Trailing-Edge
-
PDP-10 Archives
-
decus_20tap4_198111
-
decus/20-0118/book.for
There is 1 other file named book.for in the archive. Click here to see a list.
00100 C LIBRARY OF PICTURE BOOK'S FORTRAN LANGUAGE SUBROUTINES
00200 C
00300 C
00400 C DEC-11-GPBAA-B-LA
00500 C
00600 C COPYRIGHT (C) 1974
00700 C DIGITAL EQUIPMENT CORPORATION
00800 C MAYNARD, MASSACHUSETTS 01754
00900
01000 C THE INFORMATION IN THIS SOURCE LISTING IS SUBJECT TO
01100 C CHANGE WITHOUT NOTICE AND SHOULD NOT BE CONSTRUED AS A
01200 C COMMITTMENT BY DIGITAL EQUIPMENT CORPORATION.
01300 C DIGITAL EQUIPTMENT CORPORATION ASSUMES NO RESPONSIBILITY
01400 C FOR ANY ERRORS THAT MAY APPEAR IN THIS LISTING.
01500
01600 C THIS SOFTWARE IS FURNISHED TO THE PURCHASER
01700 C UNDER A LICENSE FOR USE ON A SINGLE COMPUTER
01800 C SYSTEM AND CAN BE COPIED (WITH INCLUSION OF DIGITAL'S
01900 C COPYRIGHT NOTICE) ONLY FOR USE IN SUCH SYSTEM, EXCEPT AS
02000 C MAY OTHERWISE BE PROVIDED IN WRITING BY DIGITAL.
02100
02200 C DIGITAL EQUIPMENT CORPORATION ASSUMES NO RESPONSIBILITY
02300 C FOR THE USE OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT
02400 C THAT IS NOT SUPPLIED BY DIGITAL.
02500 C
02600 C
02700 C
02800 C
02900 C
03000 C R. FRIEDENTHAL
03100 C
03200 C EDIT 1, 3/7/73
03300 C
03400 C
03500 C TO ASSEMBLE THESE SUBROUTINES UNDER A MONITOR THAT CANNOT
03600 C ASSEMBLE THEM AS ONE FILE,
03700 C BREAK THIS FILE UP AT END STATEMENTS
03800 C
03900 C
04000 C SCALE SETS THE SCALING, GIVEN THE COORDINATES OF THE LOWER LEFT
04100 C AND UPPER RIGHT CORNERS OF THE SCREEN
04200 SUBROUTINE SCALE(G1,G2,G3,G4)
04300 COMMON/BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
04400 F1=G2-G1
04500 C SET LENGTH OF X AXIS
04600 F2=G4-G3
04700 C AND LENGTH OF Y AXIS
04800 F3=G1
04900 C ALSO SAVE COORDINATES OF LOWER LEFT CORNER
05000 F4=G3
05100 RETURN
05200 END
00100 C VX CALCULATES A SCALED, DOT COORDINATE FROM THE GIVEN SCREEN X COORDINATE
00200 FUNCTION VX(J2)
00300 COMMON/BOOK/ I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 VX=FLOAT(J2)*F1/1023.
00500 RETURN
00600 END
00100 C VY CALCULATES A SCALED, VECTOR COORDINATE FROM THE GIVEN SCREEN Y COORDINATE
00200 FUNCTION VY(J2)
00300 COMMON/BOOK/ I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 VY=FLOAT(J2)*F1/1023.
00500 RETURN
00600 END
00100 C DX CALCULATES A SCALED, DOT COORDINATE FROM THE GIVEN SCREEN X COORDINATE
00200 FUNCTION DX(J2)
00300 COMMON/BOOK/ I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 DX=FLOAT(J2)*F1/1023.+F3
00500 RETURN
00600 END
00100 C DY CALCULATES A SCALED, DOT COORDINATE FROM THE GIVEN SCREEN Y COORDINATE
00200 FUNCTION DY(J2)
00300 COMMON/BOOK/ I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 DY=FLOAT(J2)*F1/1023.+F3
00500 RETURN
00600 END
00100 C CURSOR CONTROL THE CURSOR. FIRST ARGUMENT -1,0,1 FOR DOWN,
00200 C NOTHING, UP. 2ND ARGUMENT -1,0,1 FOR LEFT, NOTHING RIGHT.
00300 SUBROUTINE CURSOR(J2,J3)
00400 COMMON/BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00500 GOTO(3,2,1),J2+2
00600 GOTO 2
00700 C DISPATCH UP-DOWN
00800 1 N=26
00900 C UP
01000 GOTO 4
01100 3 N=10
01200 C DOWN
01300 4 CALL OUTCH(N)
01400 C OUTPUT THE COMMAND
01500 2 GOTO(8,7,6),J3+2
01600 GOTO 7
01700 6 N=24
01800 C RIGHT
01900 GOTO 9
02000 8 N=25
02100 C LEFT
02200 9 CALL OUTCH(N)
02300 7 RETURN
02400 END
00100 C ARC DRAWS A ARC OF DIAMETER D, WITH SIDES SIDES, OF AN
00200 C ARC THETA, AN AN ANGLE PHEE, WITH Y DIAMETER ELIP
00300 C OF X DIAMETER
00400
00500 SUBROUTINE ARC(D,IS,TH,PH,ELIP)
00600 INTEGER SIDES
00700 COMMON/BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00800 DI=D
00900 SIDES=IS
01000 THETA=TH
01100 PHE=PH
01200 ELIP=ELIP
01300 DI=DI/2.
01400 IF(SIDES.EQ.0)RETURN
01500 IF(THETA.EQ.0.)RETURN
01600 C RETURN OF A NON-CIRCLE
01700 SECT=THETA/FLOAT(SIDES)
01800 C CALCULATE ANGLE INCREMENT
01900 X0=DI*COS(PHE)
02000 C LOCATES CENTER
02100 Y0=DI*SIN(PHE)
02200 X1=0
02300 Y1=0
02400 ANGL=-3.1415926-SECT
02500 C SET ANGLE TO FIRST POINT ON FIGURE
02600 DO 155 IS=1,IABS(SIDES)
02700 C CALCULATE COORDS WITH CENTER AT 0,0
02800 X=DI*COS(ANGL)
02900 Y=DI*SIN(ANGL)*ELIP*F1/F2
03000 C ROTATE THE FIGURE AND SHIFT ITS CENTER
03100 R1=SQRT(X**2+Y**2)
03200 PHI=ATAN2(Y,X)
03300 X2=R1*COS(PHE+PHI)+X0
03400 Y2=R1*SIN(PHE+PHI)+Y0
03500 XI=X2-X1
03600 YJ=Y2-Y1
03700 C1151 IF(PUNCT.NE.'&')GOTO 151
03800 C CALL RMOVE(I,J)
03900 C GOTO 152
04000 C151 CALL RVECT(I,J,INV)
04100 C THE ABOVE MIGHT MOVE THE SCREEN BY
04200 C CHANGING THE LENGTH OF PICTURE 0, LINE 0
04300 151 CALL JOT(XI,YJ)
04400 C DRAW THE CIRCLE IN THE CURRENT FIGURE
04500 152 X1=X2
04600 Y1=Y2
04700 ANGL=ANGL-SECT
04800 C GO IN CLOCKWISE DIRETION FOR SECT POSITIVE
04900 155 CONTINUE
05000 RETURN
05100 END
00100
00200 C LAYOUT LAYS OUT THE BOOK ACCORDING TO ITS ARGUMENT LIST
00300 C THE ARGUMENTS HAVE THE FOLLOWING MEANINGS:
00400 C (SCROLL,CHARS,PICTURES,SIZE,FIGURES,SIZE,TABLES,SIZE,GRAPHS,SIZE,GREEK)
00500 FUNCTION LAYOUT(J2,J3,J4,J5,J6,J7,J8,J9,J10,J11,J12)
00600 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00700 I1=79
00800 C ID LETTER O
00900 I2=J2
01000 I3=J3/2
01100 I4=J4
01200 I5=J5
01300 I6=J6
01400 I7=J7
01500 I8=J8
01600 I9=J9
01700 I10=J10
01800 I11=J11
01900 I12=J12
02000 CALL ARGOUT(12)
02100 CALL INNUM(LAYOUT)
02200 RETURN
02300 END
00100 C OPENP OPENS A PICTURE
00200 SUBROUTINE OPENP(J2)
00300 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 I1=80
00500 C ID LETTER P
00600 I2=J2
00700 CALL ARGOUT(2)
00800 RETURN
00900 END
00100 C OPENF OPENS A FIGURE
00200 SUBROUTINE OPENF(J2)
00300 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 I1=70
00500 C ID LETTER F
00600 I2=J2
00700 CALL ARGOUT(2)
00800 RETURN
00900 END
00100 C OPENG OPENS A GRAPH
00200 SUBROUTINE OPENG(J2)
00300 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 I1=71
00500 C ID LETTER G
00600 I2=J2
00700 CALL ARGOUT(2)
00800 RETURN
00900 END
00100 C OPENT OPENS A TABLE
00200 SUBROUTINE OPENT(J2)
00300 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 I1=84
00500 C ID LETTER T
00600 I2=J2
00700 CALL ARGOUT(2)
00800 RETURN
00900 END
00100 C MARKP OPENS A LINE IN THE OPEN PICTURE
00200 SUBROUTINE MARKP(J2)
00300 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 COMMON /MARKS/MP,MF,MG,MT
00500 I1=76
00600 C ID LETTER L
00700 I2=J2
00800 CALL ARGOUT(2)
00900 MP=J2
01000 C RESET THE PICTURE MARKER
01100 RETURN
01200 END
01300 C MARKF OPENS AN INCH IN THE OPEN FIGURE
01400 SUBROUTINE MARKF(J2)
01500 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
01600 COMMON /MARKS/MP,MF,MG,MT
01700 I1=73
01800 C ID LETTER I
01900 I2=J2
02000 CALL ARGOUT(2)
02100 MF=J2
02200 C RESET THE FIGURE MARKER
02300 RETURN
02400 END
02500 C MARKG OPENS AN INCH IN THE OPEN GRAPH
02600 SUBROUTINE MARKG(J2)
02700 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
02800 COMMON /MARKS/MMP,MF,MG,MT
02900 I1=65
03000 C ID LETTER A
03100 I2=J2
03200 CALL ARGOUT(2)
03300 MG=J2
03400 C RESET THE GRAPH MARKER
03500 RETURN
03600 END
00100 C MARKT OPENS AN INCH IN THE OPEN TABLE
00200 SUBROUTINE MARKT(J2)
00300 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 COMMON /MARKS/MP,MF,MG,MT
00500 I1=75
00600 C ID LETTER K
00700 I2=J2
00800 CALL ARGOUT(2)
00900 MT=J2*2
01000 C RESET THE CHARACTER MARKER (2*TABLE MARKER)
01100 RETURN
01200 END
00100 C ERASEP ERASES THE OPEN PICTURE STARTING AT THE OPEN LINE
00200 SUBROUTINE ERASEP
00300 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 I1=69
00500 C ID LETTER E
00600 I2=80
00700 C ID LETTER P
00800 CALL ARGOUT(2)
00900 RETURN
01000 END
00100 C ERASEF ERASES THE OPEN FIGURE STARTING AT THE OPEN INCH
00200 SUBROUTINE ERASEF
00300 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 I1=69
00500 C ID LETTER E
00600 I2=70
00700 C ID LETTER F
00800 CALL ARGOUT(2)
00900 RETURN
01000 END
00100 C ERASEG ERASES THE OPEN GRAPH STARTING AT THE OPEN INCH
00200 SUBROUTINE ERASEG
00300 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 I1=69
00500 C ID LETTER E
00600 I2=71
00700 C ID LETTER G
00800 CALL ARGOUT(2)
00900 RETURN
01000 END
00100 C ERASET ERASES THE OPEN TABLE STARTING AT THE OPEN INCH
00200 SUBROUTINE ERASET
00300 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 I1=69
00500 C ID LETTER E
00600 I2=84
00700 C ID LETTER T
00800 CALL ARGOUT(2)
00900 RETURN
01000 END
00100 C BITS SPECIFIES THE MODE OF THE NEXT DATUM TO ENTER A PICTURE
00200 C ITS ARGUMENTS HAVE THE FOLLOWING SIGNIFICANCE
00300 C (BLINK[0-1],INTENSITY[0-7],TYPE[0-3],LIGHT SENSITIVITY[0-1])
00400 C 0 IS LOWEST INTENSITY, 7 HIGHEST
00500 C LINE TYPES ARE SOLID, LONGDASH, SHORTDASH, DOTDASH IN THAT ORDER
00600 SUBROUTINE BITS(J2,J3,J4,J5)
00700 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00800 I1=66
00900 C ID LETTER B
01000 I2=J2
01100 I3=J3
01200 I4=J4
01300 I5=J5
01400 CALL ARGOUT(5)
01500 RETURN
01600 END
00100 C PICTURE EXECUTES A SUBPAGE CALL TO A PICTURE
00200 SUBROUTINE PICTUR(J3,J4)
00300 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 COMMON /MARKS/MP,MF,MG,MT
00500 I1=67
00600 C ID LETTER C
00700 I2=80
00800 C ID LETTER P
00900 I3=J3
01000 I4=J4
01100 CALL ARGOUT(4)
01200 MP=MP+1
01300 C POP PICTURE MARKER
01400 RETURN
01500 END
00100 C VECFIG CALLS A FIGURE AS A SERIES OF SHORT VECTORS
00200 SUBROUTINE VECFIG(J3,J4)
00300 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 COMMON /MARKS/MP,MF,MG,MT
00500 I1=67
00600 C ID LETTER C
00700 I2=86
00800 C ID LETTER V
00900 I3=J3
01000 I4=J4
01100 CALL ARGOUT(4)
01200 MP=MP+1
01300 C POP PICTURE MARKER
01400 RETURN
01500 END
00100 C DOTFIG CALLS A FIGURE AS A SERIES OF RELATIVE POINTS
00200 SUBROUTINE DOTFIG(J3,J4)
00300 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 COMMON /MARKS/MP,MF,MG,MT
00500 I1=67
00600 C ID LETTER C
00700 I2=68
00800 C ID LETTER D
00900 I3=J3
01000 I4=J4
01100 CALL ARGOUT(4)
01200 MP=MP+1
01300 C POP PICTURE MARKER
01400 RETURN
01500 END
00100 C XGRAPH CALLS A GRAPH AS A SERIES OF Y VALUES ALONG AN X AXIS
00200 SUBROUTINE XGRAPH(J3,J4)
00300 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 COMMON /MARKS/MP,MF,MG,MT
00500 I1=67
00600 C ID LETTER C
00700 I2=88
00800 C ID LETTER X
00900 I3=J3
01000 I4=J4
01100 CALL ARGOUT(4)
01200 MP=MP+1
01300 C POP PICTURE MARKER
01400 RETURN
01500 END
00100 C YGRAPH CALLS A GRAPH AS SERIES OF X VALUES ALONG THE Y AXIS
00200 SUBROUTINE YGRAPH(J3,J4)
00300 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 COMMON /MARKS/MP,MF,MG,MT
00500 I1=67
00600 C ID LETTER C
00700 I2=89
00800 C ID LETTER Y
00900 I3=J3
01000 I4=J4
01100 CALL ARGOUT(4)
01200 MP=MP+1
01300 C POP PICTURE MARKER
01400 RETURN
01500 END
00100 C TABLE CALLS A TABLE
00200 SUBROUTINE TABLE(J3,J4)
00300 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 COMMON /MARKS/MP,MF,MG,MT
00500 I1=67
00600 C ID LETTER C
00700 I2=84
00800 C ID LETTER T
00900 I3=J3
01000 I4=J4
01100 CALL ARGOUT(4)
01200 MP=MP+1
01300 C POP PICTURE MARKER
01400 RETURN
01500 END
00100 C VECTOR DRAWS A VECTOR
00200 SUBROUTINE VECTOR(G1,G2)
00300 COMMON /BOOK/ I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 COMMON /MARKS/MP,MF,MG,MT
00500 I1=86
00600 C ID LETTER V
00700 I2=IFIX(1023.*G1/F1)
00800 I3=IFIX(1023.*G2/F2)
00900 CALL NUMOUT(3)
01000 MP=MP+1
01100 C POP PICTURE MARKER
01200 RETURN
01300 END
00100 C MOVE DRAWS AN INVIBLE VECTOR IN A PICTURE
00200 SUBROUTINE MOVE(G1,G2)
00300 COMMON /BOOK/ I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 COMMON /MARKS/MP,MF,MG,MT
00500 I1=77
00600 C ID LETTER M
00700 I2=IFIX(1023.*G1/F1)
00800 I3=IFIX(1023.*G2/F2)
00900 CALL NUMOUT(3)
01000 MP=MP+1
01100 C POP PICTURE MARKER
01200 RETURN
01300 END
00100 C DOT DRAWS AN ABSOLUTE POINT IN A PICTURE
00200 SUBROUTINE DOT(G1,G2)
00300 COMMON /BOOK/ I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 COMMON /MARKS/MP,MF,MG,MT
00500 I1=68
00600 C ID LETTER D
00700 I2=IFIX(1023.*(G1-F3)/F1)
00800 I3=IFIX(1023.*(G2-F4)/F2)
00900 CALL NUMOUT(3)
01000 MP=MP+1
01100 C POP PICTURE MARKER
01200 RETURN
01300 END
00100 C SET DRAWS AN INVIBLE ABSOLUTE POINT IN A PICTURE
00200 SUBROUTINE SET(G1,G2)
00300 COMMON /BOOK/ I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 COMMON /MARKS/MP,MF,MG,MT
00500 I1=83
00600 C ID LETTER S
00700 I2=IFIX(1023.*(G1-F3)/F1)
00800 I3=IFIX(1023.*(G2-F4)/F2)
00900 CALL NUMOUT(3)
01000 MP=MP+1
01100 C POP PICTURE MARKER
01200 RETURN
01300 END
00100 C JOT ADDS DATA TO FIGURES
00200 SUBROUTINE JOT(G1,G2)
00300 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 COMMON /MARKS/MP,MF,MG,MT
00500 I1=74
00600 C SET ID LETTER, J
00700 I2=IFIX(1023.*G1/F1)
00800 I3=IFIX(1023.*G2/F2)
00900 CALL ARGOUT(3)
01000 C AND OUTPUT ARGUMENTS AS SINGLE BYTES
01100 MF=MF+1
01200 C POP FIGURE MARKER
01300 RETURN
01400 END
00100 C NOJOT ADDS INVISIBLE DATA TO FIGURES
00200 SUBROUTINE NOJOT(G1,G2)
00300 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 COMMON /MARKS/MP,MF,MG,MT
00500 I1=78
00600 C SET ID LETTER, J
00700 I2=IFIX(1023.*G1/F1)
00800 I3=IFIX(1023.*G2/F2)
00900 CALL ARGOUT(3)
01000 C AND OUTPUT ARGUMENTS AS SINGLE BYTES
01100 MF=MF+1
01200 C POP FIGURE MARKER
01300 RETURN
01400 END
00100 C PLOT PLOTS A POINT IN A GRAPH
00200 SUBROUTINE PLOT(J2)
00300 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 COMMON /MARKS/MP,MF,MG,MT
00500 I1=90
00600 C I1 HOLDS ID LETTER, Z
00700 C I2 HOLDS DATA
00800 I2=J2
00900 CALL NUMOUT(2)
01000 C SEND OUT THE INFORMATION
01100 IF(J2.GE.0)MG=MG+1
01200 C POP GRAPH MARKER ON NON-NEGATIVE ARGUMENT
01300 RETURN
01400 END
00100 C TEXT WILL OUTPUT WITHIN QUOTES THE FIRST N CHARACTERS IN THE
00200 C ARGUMENT ARRAY
00300
00400 SUBROUTINE TEXT(N,IARRAY)
00500 DIMENSION IARRAY(1)
00600 COMMON/BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00700 COMMON /MARKS/MP,MF,MG,MT
00800 CALL OUTCH(4)
00900 C CONTROL D
01000 CALL OUTCH(81)
01100 C Q
01200 CALL OUTCH(N)
01300 C NUMBER OF CHARS TO FOLLOW
01400 WRITE(5,1)(IARRAY(I),I=1,N)
01500 C OUTPUT THE CHARACTERS
01600 1 FORMAT('+',100A1)
01700 MT=MT+N
01800 C POP CHARACTER MARKER BY NUMBER OF CHARACTERS
01900 RETURN
02000 END
00100 C LINEX RETURNS THE X COORDINATE OF THE PICTURE AND LINE SPECIFIED
00200 FUNCTION LINEX(J2,J3)
00300 COMMON/BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 I1=88
00500 C X
00600 I2=J2
00700 I3=J3
00800 CALL ARGOUT(3)
00900 CALL INNUM(LINEX)
01000 C READ THE COORDINATE
01100 RETURN
01200 END
00100 C LINEY RETURNS THE Y COORDINATE OF THE PICTURE AND LINE SPECIFIED
00200 FUNCTION LINEY(J2,J3)
00300 COMMON/BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 I1=89
00500 C Y
00600 I2=J2
00700 I3=J3
00800 CALL ARGOUT(3)
00900 CALL INNUM(LINEY)
01000 C READ THE COORDINATE
01100 RETURN
01200 END
00100 C HIT RETURNS THE PICTURE AND LINE LAST HIT BY THE LIGHT PEN
00200 SUBROUTINE HIT(J2,J3)
00300 COMMON/BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 CALL OUTCH(4)
00500 CALL OUTCH(72)
00600 C H
00700 CALL INNUM(J2)
00800 CALL INNUM(J3)
00900 RETURN
01000 END
00100 C UNHIT WAITS FOR THE NEXT LIGHT PEN HIT, THEN
00200 C RETURNS THE PICTURE AND LINE HIT
00300 SUBROUTINE UNHIT(J2,J3)
00400 COMMON/BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00500 CALL OUTCH(4)
00600 CALL OUTCH(85)
00700 C U
00800 CALL INNUM(J2)
00900 CALL INNUM(J3)
01000 RETURN
01100 END
00100 C IOTA STARTS THE CLOCK FOR ARG>0, READS THE CLOCK
00200 C AS A POSITIVE VALUE, MOD 4096 FOR ARG=0, OR STOPS
00300 C THE CLOCK FOR ARG<0
00400 FUNCTION IOTA(J2)
00500 COMMON/BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00600 I1=64
00700 C ID LETTER @
00800 I2=J2
00900 CALL ARGOUT(2)
01000 C OUTPUT THE ARGUMENTS
01100 IF(J2.EQ.0)CALL INNUM(IOTA)
01200 C ON 0 ARG, READ THE CLOCK
01300 RETURN
01400 END
00100 C WAIT WAITS FOR ITS OWN EXECUTION BEFORE RETURNING TO CALLER
00200 SUBROUTINE WAIT
00300 COMMON/BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 CALL OUTCH(4)
00500 CALL OUTCH(87)
00600 C W
00700 CALL INNUM(J2)
00800 C GET THE DUMMY RETURN
00900 RETURN
01000 END
00100 C THEEND RESET THE BOOK TO 32 LINES OF TEXT AND ALL PICTURES, 100 LINES LONG
00200 SUBROUTINE THEEND
00300 COMMON /BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 I1=82
00500 C ID LETTER R
00600 CALL ARGOUT(1)
00700 RETURN
00800 END
00100 C BELL RINGS THE GT40'S BELL
00200 SUBROUTINE BELL
00300 COMMON/BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00400 CALL OUTCH(7)
00500 STOP
00600 END
00100 C NUMOUT HANDLES THE OUTPUT FOR ROUTINES THAT OUT@PUT VALUES
00200 C IN EXCESS OF 128, I.E. VALUE THAT REQUIRE 2 BYTES
00300 C IT OUTPUTS CONTROL G, FOLLOWED BY THE ID CHARACTER FOLLOWED
00400 C BY THE VALUES.
00500 C ITS ARGUMENT SPECIFIES THE TOTAL NUMBER OF DATUM TO OUTPUT BESIDES
00600 C THE CONTROL G
00700 SUBROUTINE NUMOUT(N)
00800 DIMENSION IARGS(3)
00900 COMMON /BOOK/ I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
01000 EQUIVALENCE (IARGS(1),I1)
01100 CALL OUTCH(4)
01200 C OUTPUT CONTROL G
01300 CALL OUTCH(I1)
01400 C OUTPUT ID CHARACTER
01500 DO 1 I=2,N
01600 CALL OUTNUM(IARGS(I))
01700 C OUTPUT NUMERIC ARGUMENTS, 2 BYTES EACH
01800 1 CONTINUE
01900 RETURN
02000 END
00100 C ARGOUT OUTPUTS A STRING OF GRAPHIC DATA .
00200 C THE STRING STARTS WITH A CONTROL D (4)
00300 C THE ARGUMENTS FROM THE COMMON ARGUMENT LIST
00400 C THEIR NUMBER SPECIFIED IN ARGOUT'S ARGUMENT
00500 C FOLLOW THIS CONTROL CHARACTER
00600 C THE CALLING ROUTINE SETS UP THE COMMON ARGUMENTS
00700 C JUST AS PICTURE BOOK NEEDS TO RECEIVE THEM
00800 SUBROUTINE ARGOUT(N)
00900 DIMENSION IARGS(10)
01000 COMMON /BOOK/ I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
01100 EQUIVALENCE (IARGS(1),I1)
01200 CALL OUTCH(4)
01300 C OUTPUT CONTROL D
01400 DO 1 I=1,N
01500 CALL OUTCH(IARGS(I))
01600 C NOW OUTPUT ARGUMENTS
01700 1 CONTINUE
01800 RETURN
01900 END
00100 C INNUM READS AN OCTAL NUMBER CONSISTING OF A MAXIMUM OF 4
00200 C DIGITS SOMETIMES PRECEDED BY A MINUS SIGN AND FOLLOWED BY A CRLF
00300 SUBROUTINE INNUM(K)
00400 COMMON/BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00500 DATA MINUS/45/,LINEF/10/
00600 NUM=0
00700 ISIGN=1
00800 1 CALL INCH(I)
00900 IF(I.EQ.MINUS)ISIGN=-1
01000 IF(I.GE.48.AND.I.LT.56)NUM=NUM*8+I-48
01100 C ADD ON AN OCTAL NUMBER
01200 IF(I.NE.LINEF)GOTO 1
01300 C KEEP READING TILL LINE FEED
01400 K=NUM*ISIGN
01500 RETURN
01600 END
00100 C OUTNUM OUTPUTS THE VALUE IN ITS ARGUMENT AS A HIGH AND LOW BYTE,
00200 C FIRST CONVERTING TO A 14 BIT NUMBER
00300
00400 FUNCTION OUTNUM(IVAL)
00500 COMMON/BOOK/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,F1,F2,F3,F4
00600 IVAL=IVAL-(IVAL/8192)*8192
00700 C MAKE MODULO 8192
00800 IF(IVAL.LT.0)IVAL=16384+IVAL
00900 C THEN MAKE A NEGATIVE IVAL >8192
01000 IHI=IVAL/128
01100 C GET THE HI BYTE
01200 ILO=IVAL-IHI*128
01300 C AND THE LOW
01400 CALL OUTCH(IHI)
01500 C AND OUTPUT THEM
01600 CALL OUTCH(ILO)
01700 OUTNUM=0
01800 RETURN
01900 END