//scratch exec pgm=iehprogm **scratch old data sets if they exist       ********
//itch dd disp=old,unit=2311,vol=ser=111111
//sysprint dd sysout=a
//sysin dd *
 scratch dsname=ics160.fmts,purge,vol=2311=111111
 scratch dsname=ics160.loadmod,purge,vol=2311=111111
//fmts exec pgm=iebgener **store format specification cards on disk     ********
//sysin dd dummy
//sysprint dd sysout=a
//sysut2 dd dsn=ics160.fmts,disp=(new,pass),unit=2311,
// dcb=(recfm=fb,lrecl=80,blksize=3520),space=(trk,(3,1),rlse),
// vol=ref=*.scratch.itch,label=expdt=99365
//sysut1 dd *
(' history h, continue exec c, stop w/o dump s, or stop w/ dump d? ')  1
(' ', 6a1, ': width err')  2
(' ', 6a1, ': rectangle left of picture by ', i11)  3
(' ', 6a1, ': rectangle right of picture by ', i11)  4
(' ', 6a1, ': rectangle below picture by ', i11)  5
(' ', 6a1, ': rectangle above picture by ', i11)  6
(' ', 6a1, ': probability err')  7
(' you called: cheker(', 6(i11, ','), i11, ')')  8
(' frame ', i6, ': ', 2(a4, ' '), i11, ' begins here')  9
(' frame ',i6,' = ',i2,' (mod ',i2,'): ',2(a4,' '),i11,' begins here')  10
(' print', i1, ': width err')  11
(' print', i1, ': height err')  12
(' ', 6a1, ': height err')  13
(' print', i1, ': rectangle left of picture by ', i11)  14
(' print', i1, ': rectangle right of picture by ', i11)  15
(' print', i1, ': rectangle below picture by ', i11)  16
(' print', i1, ': rectangle above picture by ', i11)  17
(' you called: print3(', 4(i11, ','), 't#1,t#2,t#3)')  18
(' you called: print2(', 4(i11, ','), 't#1,t#2)')  19
(' you called: print1(', 4(i11, ','), 't#1)')  20
(' you called: print0(', 3(i11, ','), i11, ')')  21
******************* bad cards deleted here **************
************************** 13 cards deleted *******************
(' watzin(', i11, ',', i11, '); x outside by ', i11)  30
(' watzin(', i11, ',', i11, '); y outside by ', i11)  31
(' cardin: width err; cards may be read but no storage')  32
(' cardin: width > card width; no copy into rightmost cols')  33
(' cardin: rectangle outside picture; cards may be read but no storage')  34
(' cardin: rectangle left of picture; no copy from leftmost card cols')  35
(' cardin: rectangle right of picture; no copy from rightmost card cols')  36
(' cardin: height err; no cards can be read')  37
(' cardin: rectangle below picture; last cards read & ignored')  38
(' cardin: rectangle above picture; first cards read & ignored')  39
(' you called: cardin(', 4(i11, ','), i11, ')')  40
(' cardin: too few data cards')  41
(' stash(', i11, ',', i11, '); x outside by ', i11)  42
(' stash(', i11, ',', i11, '); y outside by ', i11)  43
(' print', i1, ': only leftmost 132 cols within picture can be printed')  44
(' xlitr8: entry ', i3, ' in table is not a char')  45
(' print', i1, ': entry ', i3, ' in table1 is not a char')  46
(' print', i1, ': entry ', i3, ' in table2 is not a char')  47
(' print3: entry ', i3, ' in table3 is not a char')  48
(' you called: qgenr8(', 4(i11, ','), 'your_subrtn)')  49
(' fleck: err in fleck values; min<0, max<0, min>max, or max>', i3)  50
(' addmod: modulus < 2 or > ', i3)  51
(' you called: addmod(', 6(i11, ','), i11, ')')  52
(' you called: fleck(', 6(i11, ','), i11, ')')  53
(' locop: direction err')  54
(' locop: min # of neighbors > max # (in absolute value)')  55
(' locop: min # of neighbors > possible # (in absolute value)')  56
(' locop: max # of neighbors > possible # (in absolute value)')  57
(' locop: max # of neighbors .ge. possible # (in absolute value)')  58
(' locop: lower bound of interval > upper bound (in absolute value)')  59
(' you called: xlitr8(', 5(i11, ','), 'xlit_table)')  60
(' a big "howdy" from ucsc graphic2 system, revised 4/11/72 18:00')  61
(' nowat: 1st param < 1 or > 50')  62
(' you called: nowat(', 4(i11, ','), i11, ')')  63
(' id  consec   total    call      value      value      value      value'/
 '  #   calls   calls  number   number 1   number 2   number 3   number 4')64&65
(' ', 70(1h*))  66
(' ', i2, 3i8, 4i11/ 19(1h ), i8, 4i11)  67
(' you called: census(', 3(i11, ','), i11, ')')  68
(' punch', i1, ': rectangle below picture; fewer than "height" cards punched')69
(' punch', i1, ': width err; no cards punched')  70
(' punch', i1, ': height err; no cards punched')  71
(' punch', i1, ': rectangle left of picture; no punch in leftmost card cols') 72
(' punch',i1,': rectangle right of picture; no punch in rightmost card cols') 73
(' punch', i1, ': rectangle above picture; fewer than "height" cards punched')74
(' punch', i1, ': only leftmost 80 cols of rectangle can be punched')  75
(' you called: punch1(', 4(i11, ','), 't#1)')  76
(' you called: punch0(', 3(i11, ','), i11, ')')  77
(' random: range > 401')  78
(' punch1: entry ', i3, ' in table is not a char')  79
(' locop: lower bound of interval > ', i3, ' (in absolute value)')  80
(' locop: upper bound of interval > ', i3, ' (in absolute value)')  81
(' locop: upper bound of interval .ge. ', i3, ' (in absolute value)')  82
(' you called: locop(', 5(i11, ',')/ 13x, 5(i11, ','), 'xlit_table)')  83
(' locop: entry ', i3, ' in table is not a char')  84
(' copy: orientation err')  85
(' you called: copy(', 5(i11, ',')/ 13x, 5(i11, ','), i11, ')')  86
** last 2 cards; include enough cards to completely fill the block which
** contains the highest numbered format specification **************************
//list exec pgm=iebgener **list the format specifications just stored   ********
//sysin dd dummy
//sysprint dd sysout=a
//sysut1 dd dsn=*.fmts.sysut2,disp=(old,keep)
//sysut2 dd sysout=a,dcb=(recfm=fb,lrecl=80,blksize=3520)
//sysprog exec pgm=ieyfort,parm=map **fortran compilation               ********
//sysprint dd sysout=a
//syslin dd disp=(new,pass),unit=sysda,space=(trk,(6,3)),
// dcb=(recfm=fb,lrecl=80,blksize=800)
//sysin dd *
c                 conventions for graphics package
c
c
c
c questions concerning this code should be addressed to:
c dan ross or ken knowlton
c information and computer sciences dept.
c univ. of calif.
c santa cruz, calif.  95060
c revision date and time appear on format card number 61
c
c names:
c all names of system subroutines, variables, etc. which users can
c access, but ordinarily should not access, begin with the letter "q".
c users should avoid creating any name starting with "q", to prevent
c naming conflicts.
c
c error checking and error messages:
c subroutines whose names do not begin with "q" are callable by the
c users.  these subroutines must assume that there can be errors in
c their input parameters.  they must check their parameters, producing
c error messages as appropriate.  they must not pass on erroneous
c parameters in the calls of other subroutines.
c subroutines whose names begin with "q" are not callable by the users.
c these subroutines may assume that all their input parameters are
c correct.
c
c device assignment:
c all references to devices should be made by name rather than by
c number.  device names are assigned in the common area named "com1".
c system (unit 0):  output messages to the computer operator, to the
c    system log, to other conversational users, etc., as specified by an
c    explicit or implicit destination in the text of the message.  no
c    carriage control.
c scope (unit 1):  output display to a storage scope or equivalent
c    device.  pertinent characteristics are:  high speed; point plotting
c    capability on a raster, with one complete horizontal line produced
c    by each "write" statement; no erasure until the entire frame is
c    advanced; possibly no vector generator; possibly no gray scale;
c    possibly no character generator; no carriage control.
c ttyo (unit 2):  output to the user's typewriter-like terminal device.
c    pertinent characteristics are:  cannot operate simultaneously with
c    input from "ttyi"; low speed; hard copy; typeout interruptable by
c    the user; possibly only 72 columns per output line; possibly
c    inoperative tab, backspace, and page eject; asa carriage control
c    characters, modified as follows:
c       blank   print, then carriage return and 1 line upspace
c       0       print, then carriage return and 2 lines upspace
c       1       print, then carriage return and eject to top of next
c                  page
c       +       print, then carriage return only, no upspace
c       .       print only, no carriage return or upspace
c ttyi (unit 3):  input from the user's typewriter-like terminal device.
c    pertinent characteristics are:  cannot operate simultaneously with
c    output to "ttyo", except to send an interrupt which forces early
c    termination of output to "ttyo"; low speed; hard copy; possibly
c    inoperative tab, backspace, and page eject; possibly only full-line
c    interaction capability (instead of single character interaction),
c    so input must be terminated by eom interrupt or carriage return.
c ptapei (unit 4):  input from paper tape reader or equivalent device.
c    pertinent characteristics are:  low speed; continuous text string;
c    alphanumeric or binary; non-reversible; stoppable by program at any
c    character; no carriage control.
c cardi (unit 5):  input from card reader or equivalent device.
c    pertinent characteristics are:  high speed; non-conversational;
c    80 alphanumeric characters produced by each "read" statement;
c    non-reversible; no carriage control.
c printr (unit 6):  output to line printer or equivalent device.
c    pertinent characteristics are:  high speed; non-conversational;
c    one complete horizontal line produced by each "write" statement;
c    alphanumeric characters; no more than 132 columns per line;
c    non-reversible; asa carriage control characters, namely:
c       blank   upspace 1 line, then print
c       0       upspace 2 lines, then print
c       -       upspace 3 lines, then print
c       1       eject to top of next page, then print
c       +       print only, no upspace
c cardo (unit 7):  output to card punch or equivalent device.
c    pertinent characteristics are:  high speed; non-conversational;
c    machine readable; 80 alphanumeric characters produced by each
c    "write" statement; non-reversible; no carriage control.
c camrao (unit 8):  output to camera.  device-dependent characteristics.
c camrai (unit 9):  input from camera.  device-dependent
c    characteristics.
c fmts (unit 10):  format specifications stored in a file of 80-column
c    card images, 1 format per card image.
c (units 11 to 19):  reserved for later system use.
c (units 20 to 99):  available to users.
c
c common areas:
c the system recognizes 2 named common areas.  "qommon" is for the
c private use of the system.  "com1" contains system variables which
c users may access.  the system initializes both these areas in a "block
c data" subroutine.  users should not attempt to assign any new
c variables in "com1".  users may create other named or unnamed common
c areas, as desired.
c
c rectangles defined by subroutine parameters:
c many of the system subroutines operate on a rectangle specified by 4
c input parameters:  x and y coordinates of the center square, the
c width, and the height.  if either width or height or both are even
c numbers, there is no single square located at the center of the
c rectangle.  in this case, the user should supply an x or y coordinate
c of the square just to the left or just below the true center of the
c rectangle.
c
c neighborhood of a square:
c the neighbors of a square consist of the square itself and all squares
c accessible by a chess king's move, including squares outside the
c picture.  no characters ever are stored into squares outside the
c picture.  when accessed, squares outside the picture are assumed to
c have character value = -1.  directions relative to the square under
c consideration are transmitted as 3 binary-coded decimal (bcd) digits.
c the first digit is for the row above the center square, the second
c digit is for the row containing the center square, and the third digit
c is for the row below the center square.  each bcd digit in turn is
c formed from 3 binary digits, where a "1" means inclusion of the
c direction and a "0" means exclusion of the direction.  for example, to
c encode the pair of directions "northwest" and "southeast", the
c representation is:
c     binary 100  =  4 octal
c            000  =  0
c            001  =  1
c and the bcd number representing this set of directions is (decimal)
c 401.  names of commonly used neighborhood direction sets have been
c assigned in common area "com1".  users not wishing to remember this
c encoding scheme may perform arithmetic using the named direction sets.
c caution:  do not add in any one direction twice, or subtract a
c direction from a set which does not include the direction.  example:
c direction "king" = direction "rook" + direction "bishop" - direction
c "self".
c
c array storage:
c it is assumed throughout this code that elements of 2-dimensional
c arrays are stored row-wise.  as an illustrative example,
c        dimension array(2,2)
c would cause consecutive storage of array(1,1), array(1,2), array(2,1),
c and array(2,2).  if this assumption is false, major recoding of nearly
c all subroutines becomes necessary.
c
c conversations with users:
c in order to conserve core memory space, the format specifications are
c stored on disk for all output typed to the user.  prior to each
c "write" statement directed to the teletype, the program must call
c subroutine "getfmt" to read in the proper format specifications from
c the disk.  the program then may write to the user with:
c        write (ttyo,fmtbuf) <output list>
c subroutine "getfmt" includes a detailed description of the use of
c format specifications.
c users may type input either as a solicited response to a request from
c the program, or as an unsolicited message.  these two types of input
c must be handled differently.
c a user response is solicited as part of typing out the request
c message, by setting parameter "reply" to .true. in a call of
c subroutine "getfmt".  the next executed "write" to the teletype will
c not return control until the user's response is stored in the teletype
c input buffer "income".  the program should scan the user's response.
c if the response can be understood by the program, even though the
c response might contain errors, the program should process the
c response, typing out error messages and requesting other responses as
c necessary.  only if the response is totally incomprehensible, to the
c extent that it looks like the response was not directed to the program
c at all, should the program call subroutine "huh".  subroutine "huh"
c never returns control, but passes the user's response on to other
c programs in the system, to see if they can understand it.  after
c calling "huh", the program should pause and wait for an unsolicited
c message.
c unsolicited messages first are scanned by the graphics system program.
c if the graphics system program cannot understand the message, it will
c call a user's subroutine named "ring".  each user's program must
c include a subroutine "ring".  if "ring" can understand the message,
c it should process the message and return control normally.  if "ring"
c cannot understand the message, it should return control by calling
c subroutine "notme".  the simplest version of subroutine "ring" would
c be an immediate call of "notme".  warning:  "ring" and any
c subroutines it calls to process a message are executed asynchronously
c from the remainder of the program.  fortran code is not reentrant.
c extreme caution is required in coding subroutine "ring".
c
c
c
      block data
c variables in "qommon":
      common /qommon/ chars,mach2k,k2mach,pictx,picty,picher,buf1,
     c   ranseq,rancnt,
     c   eratio,ldist,rdist,bdist,tdist,maxmsg,wider,higher,prober,
     c   frames,frame1,frame2,frame3,frame4,frscop,frintr,frcard,
     c   prctrl,caller
c
c number of distinct characters = 1 + max. numeric value of any
c character
      integer chars/256/
c system transliteration tables from machine representation (ebcdic,
c ascii, etc.) to knowltonian and from knowltonian to machine
c representation; must be changed for every machine ********************
      logical*1 mach2k(256), k2mach(256)
c picture dimensions
      integer pictx/320/, picty/240/
c picture array
      logical*1 picher(320,240)
c buffer length should = max(pictx,picty,132)
      logical*1 buf1(352)
c random number table
      integer ranseq(192)/
     c 393,262,382,139,031,145,261,248,205,301,384,266,149,132,198,093,
     c 334,188,258,311,210,030,171,080,116,222,118,043,203,048,269,057,
     c 396,255,021,297,156,099,026,357,354,283,363,040,296,163,272,274,
     c 233,364,336,236,047,114,360,320,369,293,270,039,265,330,304,278,
     c 168,029,007,350,287,338,263,028,368,131,282,335,142,153,134,074,
     c 019,349,341,104,281,356,034,011,088,340,259,214,290,013,152,103,
     c 143,388,264,073,377,086,372,329,204,002,023,232,008,033,326,398,
     c 230,037,218,245,260,343,294,392,129,038,096,333,113,347,127,322,
     c 345,181,121,138,077,161,169,082,355,049,010,220,124,020,298,102,
     c 215,213,280,337,070,348,373,239,376,151,106,284,238,119,180,323,
     c 279,325,381,107,183,224,100,196,209,383,374,228,231,036,054,062,
     c 187,189,295,331,252,092,353,085,115,285,001,385,061,174,327,141/
      integer rancnt (209) /
     c 068,275,155,202,253,199,328,303,351,243,083,273,289,310,216,051,
     c 165,128,137,194,078,097,162,321,302,184,346,012,105,069,178,148,
     c 022,208,089,144,250,292,084,056,400,317,087,173,379,154,120,366,
     c 234,044,362,319,185,101,076,140,277,227,370,071,112,315,063,053,
     c 305,006,390,066,058,158,387,226,386,339,176,065,251,035,003,276,
     c 267,095,157,367,375,133,179,395,055,111,025,016,246,166,288,237,
     c 170,150,197,090,316,212,126,177,050,042,024,091,286,098,190,172,
     c 299,015,136,060,117,160,081,399,254,110,041,192,159,175,332,130,
     c 195,052,361,244,193,109,240,358,389,365,009,352,167,211,207,123,
     c 046,324,313,312,314,318,291,268,079,223,067,125,257,094,191,017,
     c 005,206,306,027,394,135,221,229,164,108,241,300,072,378,182,249,
     c 235,371,242,014,256,147,271,146,344,075,342,018,219,059,307,032,
     c 186,200,397,247,217,201,380,064,308,391,309,359,004,045,225,000,
     c 122/
c if an error message previously was produced when the user tried to
c operate on a square at distance d outside the picture, the next error
c message should be sent when he tries to operate at distance eratio*d
c outside the picture.
      integer eratio/4/
c distances outside the picture which last caused error messages
      integer ldist/0/, rdist/0/, bdist/0/, tdist/0/
c maxmsg = max. number of consecutive error messages produced on
c consecutive calls to a subroutine, where all the calls have the same
c error in specifying a parameter.  a different mechanism is used for
c messages caused by the error of trying to operate on a square outside
c the picture.
      integer maxmsg/3/
c counts of consecutive error messages for illegal parameters
      integer wider/1/, higher/1/, prober/1/
c frame counter
      integer frames/0/
c copies of the actual parameters to the most recent call of subroutine
c "frame"
      logical frame1,frame2
      integer frame3,frame4
c switches indicate whether the current frame identification has been
c written to the various display devices; initialized to .true. so users
c will not see a garbage identification displayed if they choose never
c to call subroutine "frame".
      logical frscop/.true./, frintr/.true./, frcard/.true./
c carriage control character for the next write to unit "printr"
      logical*1 prctrl/'1'/
c name of the subroutine calling function "qadj"
      logical*1 caller(6)
c
c
c
c variables in "com1":
      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
c
c names of digits, letters, and special characters
      integer d0/0/,d1/1/,d2/2/,d3/3/,d4/4/,d5/5/,d6/6/,d7/7/,d8/8/,
     c   d9/9/
      integer la/10/,lb/11/,lc/12/,ld/13/,le/14/,lf/15/,lg/16/,lh/17/,
     c   li/18/,lj/19/,lk/20/,ll/21/,lm/22/,ln/23/,lo/24/,lp/25/,lq/26/,
     c   lr/27/,ls/28/,lt/29/,lu/30/,lv/31/,lw/32/,lx/33/,ly/34/,lz/35/
      integer blank/36/,period/37/,lparen/38/,plus/39/,dollar/40/,
     c   aster/41/,rparen/42/,minus/43/,slash/44/,comma/45/,under/46/,
     c   equal/47/,quote/48/,less/49/,bar/50/,and/51/,semi/52/,not/53/,
     c   prcent/54/,grater/55/,questn/56/,colon/57/,pound/58/,at/59/,
     c   apost/60/
c names of commonly used neighborhood directions
      integer self/020/, west/040/, east/010/, south/002/,north/200/,
     c   swest/004/, nwest/400/, seast/001/, neast/100/, horiz/070/,
     c   vert/222/, aigu/421/, grave/124/, rook/272/, bishop/525/,
     c   king/777/
c i/o unit assignments
      integer system/0/, scope/1/, ttyo/2/, ttyi/3/, ptapei/4/,
     c   cardi/5/, printr/6/, cardo/7/, camrao/8/, camrai/9/, fmts/10/
c carriage width on teletype
      integer ttwide/72/
c number of the last filled column of the teletype input buffer;
c lastin=0 means an empty line was typed
      integer lastin
c buffer for teletype input
      logical*1 income(72)
c buffer for format specifications read from file "fmts"; 2 card images
      logical*1 fmtbuf(160)
      end
c graphics system initialization
c
c
c
      subroutine init
      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
c the first and second parameters to "define file" must be changed
c whenever the blocking factor of file "fmts" changes.  the product:
c (first parameter) * (blocking factor)    should be much greater than
c the number of card images in file "fmts".  ***************************
c
c
c     define file 10 (10,3520,e,assoc)                                  dir acc
c
c
c type "hello" message
      call qttyo(61)
c initialize system transliteration tables from card images in file
c "fmts".  this code must be changed if variable "chars" > 256. ********
      cards = chars / 64
      do 1 i=1,cards
      j = i - 1
      call q4mat(22+j,1)
      j = 64 * j
      do 1 k=1,64
 1    mach2k(j+k) = fmtbuf(k)
      do 2 i=1,cards
      j = i - 1
      call q4mat(26+j,1)
      j = 64 * j
      do 2 k=1,64
 2    k2mach(j+k) = fmtbuf(k)
      return
      end
c the first parameter is named after brigitte bardot, a character who
c lent beauty to many otherwise dull pictures.  not being a male
c chauvanist pig, i address her by her last name.
c this subroutine stores character "bardot" in square (x,y).  only one
c byte is taken out of "bardot", the rightmost.  any other bits in the
c actual parameter are ignored.  this subroutine may be called as though
c "bardot" were an integer parameter, instead of a logical parameter.
c
c
c
      subroutine stash(bardot,x,y)
c well, why not call it stash?  i could have called it "tuck".
      implicit integer (a-z)
      logical bardot
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 switch indicates whether any error messages were typed
      logical ermsg
c switch indicates whether actual parameters were inside picture
      logical inside
c
c
c
c initially no errors detected
      ermsg = .false.
      inside = .true.
      if (x .lt. 1) go to 1
      if (x .gt. pictx) go to 2
 6    if (y .lt. 1) go to 3
      if (y .gt. picty) go to 4
c ask the user what he wants to do next
 9    if (ermsg) call qnowut
      if (inside) picher(x,y) = bardot
      return
c x is to the left of the picture
 1    if (1-x .lt. ldist*eratio) go to 5
      ldist = 1 - x
      outby = ldist
 7    ermsg = .true.
      call getfmt(42,.false.)
      write (ttyo,fmtbuf) x,y,outby
 5    inside = .false.
      go to 6
c x is to the right of the picture
 2    if (x-pictx .lt. rdist*eratio) go to 5
      rdist = x - pictx
      outby = rdist
      go to 7
c y is below the picture
 3    if (1-y .lt. bdist*eratio) go to 8
      bdist = 1 - y
      outby = bdist
 10   ermsg = .true.
      call getfmt(43,.false.)
      write (ttyo,fmtbuf) x,y,outby
 8    inside = .false.
      go to 9
c y is above the picture
 4    if (y-picty .lt. tdist*eratio) go to 8
      tdist = y - picty
      outby = tdist
      go to 10
      end
c find the integer value of the character in square (x,y).  this
c function may be called as though its value were an integer instead of
c a logical value.  if (x,y) is outside the picture, the value of the
c function is -1.
c
c
c
      logical function watzin(x,y)
      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 switch indicates whether any error messages were typed
      logical ermsg
c switch indicates whether actual parameters were inside picture
      logical inside
c function value if (x,y) outside picture
      integer minus1/-1/
      logical minusl
      equivalence (minus1,minusl)
c
c
c
c initially no errors detected
      ermsg = .false.
      inside = .true.
      if (x .lt. 1) go to 1
      if (x .gt. pictx) go to 2
 6    if (y .lt. 1) go to 3
      if (y .gt. picty) go to 4
c ask the user what he wants to do next
 9    if (ermsg) call qnowut
      watzin = minusl
      if (inside) watzin = picher(x,y)
      return
c x is to the left of the picture
 1    if (1-x .lt. ldist*eratio) go to 5
      ldist = 1 - x
      outby = ldist
 7    ermsg = .true.
      call getfmt(30,.false.)
      write (ttyo,fmtbuf) x,y,outby
 5    inside = .false.
      go to 6
c x is to the right of the picture
 2    if (x-pictx .lt. rdist*eratio) go to 5
      rdist = x - pictx
      outby = rdist
      go to 7
c y is below the picture
 3    if (1-y .lt. bdist*eratio) go to 8
      bdist = 1 - y
      outby = bdist
 10   ermsg = .true.
      call getfmt(31,.false.)
      write (ttyo,fmtbuf) x,y,outby
 8    inside = .false.
      go to 9
c y is above the picture
 4    if (y-picty .lt. tdist*eratio) go to 8
      tdist = y - picty
      outby = tdist
      go to 10
      end
c read data cards and store the characters in the picture.  the first 4
c parameters define the rectangle where the characters will be stored.
c the number of cards read = the value of parameter "height".  each
c card corresponds to one row in the rectangle, with the first card
c corresponding to the top row.  data in the cards must be left-
c justified, so that card column 1 corresponds to the leftmost column of
c the rectangle.
c the fifth parameter may be any integer value, but it is of particular
c interest when it is the value of some character.  as each data
c character is read from cards, its value is compared with the fifth
c parameter.  if these values are equal, the data character is not
c stored in the picture; the original value in that square in the
c picture remains unchanged.  this feature allows data cards to overlay
c part but not all of the rectangle.  to guarantee that the data cards
c overlay the entire rectangle, supply a fifth parameter which is not a
c character value (for example, a negative number is not a character
c value).
c
c
c
      subroutine cardin(xcentr,ycentr,width,height,nocopy)
      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 boundaries of the rectangle
      integer ledge,redge,bedge,tedge
c card column corresponding to picture column "ledge"
      integer lcol
c switch determines whether to type an error message showing all the
c input parameters
      logical ermsg
c switch determines whether storage of data from the cards is possible
      logical nostor
c counts of the number of cards to be read corresponding to rows above,
c within, and below the picture
      integer above,within,below
c equivalent storage for indexing with character values
      integer chari/0/
      logical charl
      equivalence (chari,charl)
c
c
c
c initially no errors detected
      ermsg = .false.
      nostor = .false.
c compute boundaries of the rectangle
      if (width .lt. 1) go to 1
      ledge = xcentr - (width-1)/2
      redge = xcentr + width/2
c if the specified width is > card width, the right edge must be moved
c leftward, since the left edge corresponds to card column 1
      if (redge-ledge .gt. 79) go to 2
c test whether the rectangle is completely outside the picture
 15   if ((ledge .gt. pictx) .or. (redge .lt. 1)) go to 3
c assume all columns of the rectangle are within the picture, change
c value later if assumption is false
      lcol = 1
c test whether any part of the rectangle is outside the picture
      if (ledge .lt. 1) go to 4
 16   if (redge .gt. pictx) go to 5
c compute boundaries of the rectangle
 14   if (height .lt. 1) go to 6
      bedge = ycentr - (height-1)/2
      tedge = ycentr + height/2
c test whether the rectangle is completely outside the picture
      if ((bedge .gt. picty) .or. (tedge .lt. 1)) go to 7
c assume all rows of the rectangle are within the picture, change values
c later if assumption is false
      above = 0
      within = tedge - bedge + 1
      below = 0
c test whether any part of the rectangle is outside the picture
      if (bedge .lt. 1) go to 12
 18   if (tedge .gt. picty) go to 13
c if illegal parameters caused any error messages, show the user his
c actual call
      if (ermsg) go to 8
 19   if (nostor) go to 9
c read past any cards corresponding to rows above the picture
      if (above .eq. 0) go to 10
      do 11 dy=1,above
 11   read (cardi,100,end=21)
c read the cards corresponding to rows within the picture.  for
c 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.
 10   tedge = (tedge-1)*pictx + 1
      t2b = tedge - (bedge-1)*pictx
      do 23 dy=1,t2b,pictx
      read (cardi,101,end=21) (buf1(column), column=1,80)
      column = lcol
      mindex = tedge - dy + ledge
      maxdex = tedge - dy + redge
      do 23 index=mindex,maxdex
c transliterate from machine representation to knowltonian
      charl = buf1(column)
      charl = mach2k(chari+1)
c store only if this character does not match the "nocopy" parameter
      if (chari .ne. nocopy) string(index) = charl
 23   column = column + 1
c read past any cards corresponding to rows below the picture
      if (below .eq. 0) go to 22
      do 24 dy=1,below
 24   read (cardi,100,end=21)
      go to 22
c process nonpositive width parameter
 1    nostor = .true.
      ermsg = .true.
      call qttyo(32)
      go to 14
c process width parameter > card width
 2    redge = ledge + 79
      ermsg = .true.
      call qttyo(33)
      go to 15
c the specified rectangle is completely outside the picture
 3    nostor = .true.
      ermsg = .true.
      call qttyo(34)
      go to 14
c the rectangle extends to the left of the picture
 4    lcol = 2 - ledge
      ledge = 1
      ermsg = .true.
      call qttyo(35)
c test "redge" in case the picture is defined narrower than 1 card
c width
      go to 16
c the rectangle extends to the right of the picture
 5    redge = pictx
      ermsg = .true.
      call qttyo(36)
      go to 14
c process nonpositive height parameter
 6    call qttyo(37)
c no need to set error message switch; execution branches to statement 8
      above = 0
 17   within = 0
      below = 0
      nostor = .true.
      go to 8
c the specified rectangle is completely outside the picture
 7    call qttyo(34)
      above = tedge - bedge + 1
      go to 17
c the rectangle extends below the picture
 12   below = 1 - bedge
      within = within - below
      bedge = 1
      ermsg = .true.
      call qttyo(38)
      go to 18
c the rectangle extends above the picture
 13   above = tedge - picty
      within = within - above
      tedge = picty
c no need to set error message switch; execution falls through to
c statement 8
      call qttyo(39)
c at least one error message preceded this.  show the user his actual
c call.
 8    call getfmt(40,.false.)
      write (ttyo,fmtbuf) xcentr,ycentr,width,height,nocopy
c ask the user what he wants to do next
      call qnowut
      go to 19
c the actual parameters prohibited data storage.  read and ignore the
c data cards.
 9    above = above + within + below
      if (above .eq. 0) go to 22
      do 20 dy=1,above
 20   read (cardi,100,end=21)
      go to 22
c too few data cards
 21   call qttyo(41)
c show the user his actual call
      call getfmt(40,.false.)
      write (ttyo,fmtbuf) xcentr,ycentr,width,height,nocopy
c ask the user what he wants to do next
      call qnowut
 22   return
c
c
c
 100  format (1x)
 101  format (80a1)
      end
c the first 4 parameters define a rectangle.  "prob" is a percentage
c probability between 0 and 100 applied separately to each square (x,y)
c in the rectangle, determining whether any operation is to be executed
c on the square.
c for each square operated upon, if mod(x+y,2)=0 then "char0" is stored
c in the square.  if mod(x+y,2)=1 then "char1" is stored in the square.
c the rightmost byte of "char0" and "char1" are used.  any other bits in
c the actual parameters "char0" and "char1" are ignored.
c
c
c
      subroutine cheker(xcentr,ycentr,width,height,prob,char0,char1)
      implicit integer (a-z)
      logical char0,char1
c
c specifications 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 boundaries of the rectangle
      integer ledge,redge,bedge,tedge
c switch determines whether actual parameters allow subroutine execution
      logical xecute
c probability adjusted to legal value
      integer adjprb
      integer probx4,point,skip,del
