Trailing-Edge
-
PDP-10 Archives
-
decuslib10-08
-
43,50515/graph1.for
There are 8 other files named graph1.for in the archive. Click here to see a list.
SUBROUTINE ADOC
C
C This really isn't a subroutine, but a device for putting comments
C in the beginning of the file.
C
C SUBROUTINE FUNCTION
C ---------- --------
C
C GRINIT Initialize the information buffer for the
C graphics routines
C calling sequence: CALL GRINIT(IBUF)
C GRREGN specify the region that a graph will
C be plotted in
C GRSCAL enter scaling factors for use by plotting
C routines when autoscale is not used, manditory
C for point mode plotting
C GRHLIN put a horizontal line at a particular vertical
C coordinate (specified in user values).
C GRVIEW turn one of the graphs on or off depending on
C the value of the argument
C
RETURN
END
SUBROUTINE GRINIT(IBUF)
C
C PURPOSE INITIALIZE THE INFORMATION BUFFER (30 WORDS)
C
DIMENSION IBUF(30)
IBUF(1)=0 !IF 0 SHOWS THAT THE SCREEN HAS NOT BEEN
C !CLEANED; OTHERWISE BIT PATTERN WILL SHOW
C !WHICH REGIONS HAVE BEEN CLEANED
IBUF(2)=0 !0=GRAPH 0 NOT SCALED 1=SCALED
IBUF(3)=0 !0= " 1 " " "
IBUF(4)="40 !FIRST CHARACTER FOR REGISTER 0
IBUF(5)="40 !SECOND CHARACTER FOR REGISTER 0
IBUF(6)="40 !FIRST CHARACTER FOR REGISTER 1
IBUF(7)="41 !SECOND CHARACTER FOR REGISTER 1
IBUF(8)=3 !REGION TO BE USED FOR GRAPH 0 (DEFAULT IS 3)
C ! =1 SIGNIFIES UPPER REGION
C ! =2 SIGNIFIES LOWER REGION
C ! =3 SIGNIFIES FULL DISPLAY
C ! =-1 IF NOT ASSIGNED
IBUF(9)=-1 !REGION TO BE USED FOR GRAPH 1
C
C 10 RESERVED FOR FUTURE USE (left over from coding change)
C 11-26 STORAGE OF SCALING FACTORS FOR GRAPHS 0 AND 1
C
C These are single precision floating point values.
C Each takes two words of PDP-11 storage, but only
C one word in VAX (one longword) and DEC10, DEC20.
C Any unused word in VAX, 10, 20 is reserved.
C
C PDP-11 VAX, 10, 20 Contents
C ------ ----------- --------
C
C 11,12 11 Graph 0 XMIN
C 13,14 12 XMAX
C 15,16 13 YMIN
C 17,18 14 YMAX
C 19,20 19 Graph 1 XMIN
C 21,22 20 XMAX
C 23,24 21 YMIN
C 25,26 22 YMAX
C
DO 10 I=10,26
10 IBUF(I)=0
IBUF(27)="52525 !PATTERN TO SHOW THAT GRINIT HAS BEEN RUN
IBUF(28)=1 !BY DEFAULT THE FULL REGION IS IN USE, 0 OTHERWISE
IBUF(29)=0 !FLAG FOR MOVE MODE IN GRPNTM, IF >0 THEN COUNTER
IBUF(30)=-1 !COUNTER USED BY GRPNTM
RETURN
END
SUBROUTINE GRREGN(IBUF,IGRAPH,IRGN)
C
C There are no defaults for this subroutine!!!
C
C Given the graph number (IGRAPH) and the region code (IRGN),
C this subroutine will modify the data tables so that the
C graph appears in the appropriate area.
C
C The values for IGRAPH are 0 and 1
C
C The values for IRGN are:
C 1 for the UPPER display area
C 2 for the LOWER display area
C 3 for the FULL display area
C
DIMENSION IBUF(30)
IF((IGRAPH.EQ.0).OR.(IGRAPH.EQ.1))GOTO 1
write (5,1000)
1000 format(' ?GRREGN - invalid graph number (0/1 required)')
CALL EXIT
C
1 IF((IRGN.GE.1).AND.(IRGN.LE.3))GOTO 2
write (5,1001)
1001 format(' ?GRREGN - invalid region designation')
CALL EXIT
C
2 IBUF(8+IGRAPH)=IRGN
RETURN
END
SUBROUTINE GRSCAL(IBUF,XMIN,XMAX,YMIN,YMAX,IGRAPH)
C
C GRSCAL is used to enter scaling factors into the IBUF array
C
C NOTE: If autoscaling is used after this subroutine for the
C same graph, this data will be lost
C
DIMENSION IBUF(30),TEMP(4),ITEMP(4)
EQUIVALENCE (TEMP(1),ITEMP(1))
IF(IBUF(27).NE."52525)CALL GRINIT(IBUF)
IF((IGRAPH.EQ.0).OR.(IGRAPH.EQ.1))GOTO 10
write (5,1000)
1000 FORMAT(' ?GRSCAL - invalid graph number')
CALL EXIT
C
10 TEMP(1)=XMIN
TEMP(2)=XMAX
TEMP(3)=YMIN
TEMP(4)=YMAX
IBASE=10
IF(IGRAPH.EQ.1)IBASE=18
DO 20 I=1,4
20 IBUF(IBASE+I)=ITEMP(I)
IBUF(2+IGRAPH)=1 !SHOW THAT THE GRAPH HAS BEEN SCALED
RETURN
END
SUBROUTINE GRHLIN(IBUF,USER,IGR)
C
C This subroutine will put a horizontal line at a particular
C location on the vertical axis. The position is specified
C in user coordinates. In order for this routine to function
C the graph must have been scaled, either thorugh a previous
C graph call, or through the use of GRSCAL.
C
C ARGUMENTS:
C
C IBUF is the information buffer described elsewhere
C
C USER is the lines position in user values (as opposed to
C absolute VT105 vertical dot positions)
C
C IGR is the graph number (0 or 1), the default is 0.
C
C
C J. LISCOUSKI DIGITAL EQUIPMENT CORPORATION
C NOV. 21, 1979
C
C NOTE: all arguments are needed, either by default or by user
C definition. If any are missing, a system error may result.
C
DIMENSION IBUF(30),TEMP(4),ITEMP(4),IRB(2,3)
INTEGER CMD(7),ENTRGR(2),EXITGR(2)
EQUIVALENCE (TEMP(1),ITEMP(1)) !THIS IS TO PROVIDE A QUICK MEANS
EQUIVALENCE (TEMP(3),YMIN) !OF GETTING SCALED VALUES FROM
EQUIVALENCE (TEMP(4),YMAX) !FROM IBUF INTO THE APPROPRIATE
C !REAL VARIABLES
DATA IRB/239,150,129,50,239,50/ !REGION BOUNDS
DATA ENTRGR/"33,'1'/
DATA EXITGR/"33,'2'/
F(Z,ZMAX,ZMIN)=(Z-ZMIN)/(ZMAX-ZMIN) !ARITH. STAT. SUBROUTINE
C
C BEGINNING OF EXECUTABLE CODE
C
IFLAG=0 !SHOW THAT WE (EXPECTED) ENTERED IN ALPHANUMERIC MODE
C CALL IDFLT(IGRAPH,0,IGR) !CHECK FOR DEFAULT ON GRAPH #
IGRAPH = IGR
C (Defaults not allowed in 10/20)
IF((IGRAPH.EQ.0).OR.(IGRAPH.EQ.1))GOTO 1 !IGRAPH OK?
write (5,1000)
1000 FORMAT(' ?GRHLIN - invalid graph number, must be 0/1')
CALL EXIT
C
1 IF(IBUF(27).EQ."52525)GOTO 4 !GRINIT CALLED?
write (5,1001)
1001 FORMAT(' ?GRHLIN - GRINIT not called')
CALL EXIT
C
4 IRGN=IBUF(8+IGRAPH)
IF(IRGN.NE.-1)GOTO 3 !FIND WHICH REGION IS BEING PLOTTED
write (5,1002)
1002 FORMAT(' ?GRHLIN - graph not assigned to region')
CALL EXIT
C
C
C GET SCALING VALUES FOR Y AXIS
C
3 IBASE=10
IF(IGRAPH.EQ.1)IBASE=18
10 IF(IBUF(2+IGRAPH).NE.0)GOTO 12 !HAVE SCALED VALUES BEEN ENTERED?
write (5,1003)
1003 FORMAT(' ?GRHLIN - scaling has not been provided for graph')
CALL EXIT
C
12 DO 15 I=1,4
15 ITEMP(I)=IBUF(IBASE+I) !GET SCALED VALUES FROM IBUF
C
C HAVE HORIZONTAL LINES BEEN ENABLED?
C
IF((IBUF(6).AND.1).NE.0)GOTO 17
IBUF(6)=IBUF(6).OR.1 !SET BIT
CMD(1)=ENTRGR(1)
CMD(2)=ENTRGR(2)
CMD(3)='I'
CMD(4)=IBUF(6)
CMD(5)=IBUF(7)
CALL OUTSTR (CMD,5)
IFLAG=1 !SHOW THAT WE ARE IN GRAPHICS MODE
C
C DISPLAY ENABLED?
C
17 IF(((IBUF(4).AND.1).NE.0).AND.(IFLAG.EQ.0))GOTO 20
IF(((IBUF(4).AND.1).NE.0).AND.(IFLAG.EQ.1))GOTO 22
IBUF(4)=IBUF(4).OR.1 !SET BIT
CMD(1)=ENTRGR(1)
CMD(2)=ENTRGR(2)
CMD(3)='A'
CMD(4)=IBUF(4)
CMD(5)=IBUF(5)
CALL OUTSTR (CMD,5)
GOTO 22
20 CALL OUTSTR (ENTRGR,2)
22 RANGE=IRB(1,IRGN)-IRB(2,IRGN) !# OF DOTS ON Y-AXIS
CMD(1)='D'
IY=INT(F(USER,YMAX,YMIN)*RANGE)+IRB(2,IRGN)
C
C CHECK FOR OUT OF REGION CONDITION
C
IF(IY.GT.IRB(1,IRGN))IY=IRB(1,IRGN)
IF(IY.LT.IRB(2,IRGN))IY=IRB(2,IRGN)
C
CMD(2)=32+("37 .AND. IY)
CMD(3)=48+(("340 .AND. IY)/32)
CALL OUTSTR (CMD,3)
CALL OUTSTR (EXITGR,2)
RETURN
END
SUBROUTINE GRVIEW(IBUF,IARG,IGRAPH)
C
C GRVIEW is used to turn a particular graph on or off.
C It is useful when two graphs occupy the same plotting region
C and the user wants to see them indivually.
C
C No defaults for this subroutine.
C
C IGRAPH may take on values of 0 or 1 depending on the
C graph involved
C
C IARG if =0 will turn the selected graph off
C if =1 will turn the selected graph on
C
C
DIMENSION IBUF(30),ION(2),IOFF(2)
INTEGER MSG(7)
DATA IOFF/"75,"73/
DATA ION/2,4/
DATA MSG /"33,'1','A',0,0,"33,'2'/
C
IF((IGRAPH.EQ.0).OR.(IGRAPH.EQ.1))GOTO 10
write (5,1000)
1000 FORMAT(' ?GRVIEW - invalid graph number, should be 0 or 1')
CALL EXIT
C
10 IF(IARG.EQ.0)GOTO 100
IF(IARG.EQ.1)GOTO 200
write (5,1001)
1001 FORMAT(' ?GRVIEW - invalid value for argument')
CALL EXIT
C
100 IBUF(4)=IBUF(4).AND.IOFF(IGRAPH+1)
IBUF(5)=IBUF(5).AND.IOFF(IGRAPH+1)
GOTO 300
200 IBUF(4)=IBUF(4).OR.ION(IGRAPH+1)
IBUF(5)=IBUF(5).OR.ION(IGRAPH+1)
300 MSG(4)=IBUF(4)
MSG(5)=IBUF(5)
CALL OUTSTR (MSG,7)
RETURN
END
SUBROUTINE BOUNDS(ITYPE,ARRAY,XMAX,XMIN,NPTS,IARRAY,MAX,MIN)
C
C This subroutine is used to determine the maximum and minimum of
C the contents of an vector. If the vector is real the value of
C ITYPE should be 1, if it is an integer vector the value should
C be 2. The default is integer.
C NPTS is the number of points in the appropriate array
C
DIMENSION ARRAY(npts),IARRAY(npts)
C CALL IDFLT(IPNT,2,ITYPE) !CHECK FOR DEFAULT VALUE
IPNT = ITYPE
C (Defaults not allowed in 10/20)
IF ((IPNT.EQ.1).OR.(IPNT.EQ.2))GOTO 5
write (5,1000)
1000 FORMAT(' ?BOUNDS - invalid array type, must be 1, 2, or defualt')
RETURN
5 GOTO (100,200),IPNT
C
C MAX AND MIN OF REAL ARRAY
C
100 XMAX=ARRAY(1)
XMIN=XMAX
DO 110 I=2,NPTS
IF(ARRAY(I).GT.XMAX)XMAX=ARRAY(I)
IF(ARRAY(I).LT.XMIN)XMIN=ARRAY(I)
110 CONTINUE
RETURN
C
C MAX AND MIN OF INTEGER ARRAY
C
200 MAX=IARRAY(1)
MIN=MAX
DO 210 I=2,NPTS
IF(IARRAY(I).GT.MAX)MAX=IARRAY(I)
IF(IARRAY(I).LT.MIN)MIN=IARRAY(I)
210 CONTINUE
RETURN
END
SUBROUTINE GRAPH(X,Y,NPTS)
C
C X IS THE REAL ARRAY FOR THE X AXIS (OPTIONAL)
C Y IS THE REAL ARRAY FOR THE Y AXIS (REQUIRED)
C NPTS IS THE NUMBER OF POINTS IN EACH ARRAY
C
DIMENSION X(npts),Y(npts)
INTEGER ENTRGR(2),EXITGR(2),CMD(6),INIT(20)
DATA ENTRGR/"33,"61/ !ENTER GRAPHICS MODE
DATA EXITGR/"33,"62/ !EXIT GRAPHICS MODE
C
C THE FOLLOWING DATA STREAM WILL SET THE ROLL AREA TO (21,24)
C MOVE THE CURSOR TO (20,80)
C AND ERASE FROM THE BEGINNING OF THE
C SCREEN TO THE CURSOR POSITION.
C
C THE EQUIVALENT CHARACTER STREAM IS $[21;24r$[20;80H$[1J
C
DATA INIT/"33,91,50,49,59,50,52,114,"33,91,50,48,59,56,48,72,
1 "33,91,49,74/
C
C NOW BEGIN PREPROCESSING DATA
C
C IF(X.EQ.0.)GOTO 10 !HAS X ARRAY BEEN DEFAULTED?
C (Defaults not allowed 10/20)
CALL BOUNDS(1,X,XMAX,XMIN,NPTS,0,0,0) !GET MAX AND MIN FOR X ARRAY
IFLAG=1 !SHOW NO DEFAULT
C GOTO 20
C10 XMIN=1. !USE NUMBER OF POINTS FOR X BOUNDS
C XMAX=NPTS
C IFLAG=0 !SHOW FLAG SET TO DEFAULT
20 CALL BOUNDS(1,Y,YMAX,YMIN,NPTS,0,0,0) !GET MAX AND MIN FOR Y ARRAY
C
C INITITALIZE SCREEN
C
CALL OUTSTR (INIT,20)
CALL OUTSTR (ENTRGR,2) !ENTER GRAPHICS MODE
C
C THE NEXT SECTION OF CODE SETS UP THE FRAME FOR THE DATA USING
C A PAIR OF HORIZONTAL LINES AND THE FIRST AND LAST X DATA POINT
C FOR THE VERTICLE PORTION OF THE FRAME
C
C FIRST, THE HORIZONTAL LINES (ONE EACH AT POINTS 52 AND 239)
C
CALL OUTSTR ('I1!A" D41D/7',-1)
C
C NOW MOVE ALL POINTS TO DOT POSITION 52
CALL OUTSTR ('H B',-1) !SET X=0 LOAD Y
DO 5 I=1,512
5 CALL OUTSTR ('41',-1) !510 DOTS AT LINE 52
C
C SET UP SCALING FOR X AND Y AXIS
C X=0 TO 511 Y=0 TO 187 (WE ARE NOT USING THE FULL DISPLAY AREA
C SINCE IT WOULD OVERLAY THE ROLL AREA)
C
C
C
C LOAD REGISTER 0
C
CALL OUTSTR('A# ',-1) !USE GRAPH 0 IN POINT MODE
C
C LOAD REGISTER 1
C
CALL OUTSTR('I%!',-1) !NO MARKERS OR LINE, SQUARE FORMAT
C
C NOW BEGIN SENDING DATA
C
DO 100 I=1,NPTS
X1=I
IF(IFLAG.EQ.1)X1=X(I) !USE ACTUAL X VALUES IF NO DEFAULT
Y1=Y(I)
IX=INT(((X1-XMIN)/(XMAX-XMIN))*511.)
CMD(1)='H'
CMD(2)=32+("37 .AND. IX)
CMD(3)=32+(("740 .AND. IX)/32)
IY=INT(((Y1-YMIN)/(YMAX-YMIN))*187.)+53 !THE 53 IS TO MOVE THE
C DISPLAY OUT OF ROLL AREA
CMD(4)='B'
CMD(5)=32+("37 .AND. IY)
CMD(6)=32+(("340 .AND. IY)/32)
CALL OUTSTR (CMD,6)
100 CONTINUE
CALL OUTSTR (EXITGR,2) !EXIT GRAPHICS MODE
RETURN
END
SUBROUTINE GRAPHM(IBUF,MODE,X,Y,NPTS,SHADE,IGR,FACTOR)
C
C
C J. LISCOUSKI DIGITAL EQUIPMENT CORPORATION
C NOV. 9, 1979
C
C This subroutine will permit graphs to be drawn given
C a few arguments.
C
C IBUF is the information buffer dimensioned by the
C user for 30 words.
C
C MODE MODE is used to enable or disable certain display
C feature of the system. Some combinations of modes
C can be effected by summing the values for the various
C types:
C
C OPTION VALUE (IF ENABLED)
C ----- -----------------
C FRAME 1
C HOR. LINES 2
C SHADING 4
C INDEX 8 (not implemented as yet)
C MOVE 16
C AUTOSCALING 32
C UNITS 64
C MARKERS 128
C
C SOME COMBINATIONS INTERACT:
C
C A) Horizontal lines can be used if frame is chosen
C B) INDEX and MOVE are mutually exclusive
C
C The default is 227 (FRAME, HORIZONTAL LINES, UNITS,
C MARKERS, and AUTOSCALING)
C
C X is the array for the horizontal axis, it may be defaulted.
C If the default is chosen, a counter from 1 to NPTS will be
C used in its place.
C
C Y is the array for the vertical axis and is manditory.
C
C NPTS is the number of points to be plotted.
C
C SHADE is the point on the vertical axis (expressed in user values)
C at which shading is to be done. The default is the bottom
C of the graph.
C
C IGR is the graph number (0/1) for plotting, the default is 0.
C
C FACTOR is a multiplier used t provide some scaling for the
C horizontal axis while in stripchart mode. The calculation
C is (number of points)*(factor)
C
C NOTE: All arguments are needed, either by default or by user
C definition. If any are missing, system failures may
C occur.
C
DIMENSION X(npts),Y(npts),IBUF(30),TEMP(4),ITEMP(4),IRB(2,3),IB(2)
INTEGER CMD(10),ENTRGR(2),EXITGR(2),IGCODE(2)
EQUIVALENCE (TEMP(1),ITEMP(1)) !THIS IS TO PROVIDE A QUICK MEANS
EQUIVALENCE (TEMP(1),XMIN) !OF GETTING SCALED VALUES FROM
EQUIVALENCE (TEMP(2),XMAX) !FROM IBUF INTO THE APPROPRIATE
EQUIVALENCE (TEMP(3),YMIN) !REAL VARIABLES
EQUIVALENCE (TEMP(4),YMAX)
DATA IRB/239,150,129,50,239,50/ !REGION BOUNDS
DATA ENTRGR/"33,'1'/
DATA EXITGR/"33,'2'/
DATA IGCODE/'B','J'/
DATA IB/10,18/
F(Z,ZMAX,ZMIN)=(Z-ZMIN)/(ZMAX-ZMIN) !ARITH. STAT. SUBROUTINE
C
C BEGINNING OF EXECUTABLE CODE
C
C CALL IDFLT(IGRAPH,0,IGR) !CHECK FOR DEFAULT ON GRAPH #
IGRAPH = IGR
C (Defaults not allowed 10/20)
IF((IGRAPH.EQ.0).OR.(IGRAPH.EQ.1))GOTO 1 !IGRAPH OK?
write (5,1000)
1000 FORMAT(' ?GRAPHM - invalid graph number, must be 0/1')
CALL EXIT
C
1 IF(IBUF(27).NE."52525)CALL GRINIT(IBUF) !GRINIT CALLED?
IRGN=IBUF(8+IGRAPH)
IF(IRGN.NE.-1)GOTO 3 !FIND WHICH REGION IS BEING PLOTTED
write (5,1001)
1001 FORMAT(' ?GRAPHM - graph not assigned to region')
CALL EXIT
C
C3 CALL IDFLT(IMODE,227,MODE) !CHECK DEFAULT ON MODE
3 IMODE = MODE
C (Defaults not allowed 10/20)
CALL GRCLN(IBUF,IGRAPH) !CLEAN PLOTTING AREA
C
C NOW, IS AUTO SCALING NECESSARY?
C
IF((IMODE.AND.32).EQ.0)GOTO 10
C
C PERFORM AUTOSCALING
C
IFLAG=0 !FLAG TO SHOW IF X HAS BEEN DEFAULTED (1=YES)
C IF(X.EQ.0.)GOTO 4 !HAS X BEEN DEFAULTED?
C (Defaults not allowed 10/20)
CALL BOUNDS(1,X,XMAX,XMIN,NPTS,0,0,0) !GET LIMITS
C GOTO 5
C4 IFLAG=1 !SHOW X DEFAULTED
C XMIN=1
C XMAX=NPTS
C5 IF(Y.NE.0.)GOTO 6 !HAS Y BEEN DEFAULTED?
C (Defaults not allowed 10/20)
C write (5,1002)
C1002 FORMAT(' ?GRAPHM - Y array cannot be defaulted')
C CALL EXIT
C
6 CALL BOUNDS(1,Y,YMAX,YMIN,NPTS,0,0,0) !GET Y LIMITS
IBASE=IB(IGRAPH+1)
DO 7 I=1,4
7 IBUF(IBASE+I)=ITEMP(I) !STORE LIMITS IN IBUF
IBUF(2+IGRAPH)=1 !SHOW THAT SCALING FACTORS EXIST
GOTO 20
10 IF(IBUF(2+IGRAPH).NE.0)GOTO 12 !HAVE SCALED VALUES BEEN ENTERED?
write (5,1003)
1003 FORMAT(' ?GRAPHM - scaling has not been provided for graph')
CALL EXIT
C
12 IBASE=IB(IGRAPH+1)
DO 15 I=1,4
15 ITEMP(I)=IBUF(IBASE+I) !GET SCALED VALUES FROM IBUF
C
C (20) NOW SEE IF FRAME IS REQUIRED
C
20 IF((IMODE.AND.1).EQ.0)GOTO 30
CALL GRFRAM(IBUF,IGRAPH,IMODE)
C
C (30) CHECK FOR SHADE MODE
C
30 NCHAR=5 !SET CHARACTER COUNT TO 5
IF((IMODE.AND.4).EQ.0)GOTO 40 !IF NOT, KEEP GOING
C CALL DFLTCK(SHADEL,YMIN,SHADE) !CKECK FOR DEFAULT ON SHADE LINE
SHADEL = SHADE
C (Defaults not allowed 10/20)
I=2
IF(IGRAPH.EQ.1)I=4 !SHADE APPROPRIATE GRAPH
IBUF(5)=((IBUF(5).OR.I).OR.IGRAPH) !SET BITS FOR SHADING
NCHAR=8 !RESET CHAR. COUNT TO 6 DUE TO SHADING
CMD(6)='@' !LOAD SHADE LINE
Y1=F(SHADEL,YMAX,YMIN)*FLOAT(IRB(1,IRGN)-IRB(2,IRGN))
IY=Y1+IRB(2,IRGN)
C
C CHECK FOR SHADE LINE OUT OF RANGE
C
IF(IY.GT.IRB(1,IRGN))IY=IRB(1,IRGN) !TOO HIGH? SHADE FROM TOP
IF(IY.LT.IRB(2,IRGN))IY=IRB(2,IRGN) !TOO LOW? SHADE FROM BOTTOM
C
CMD(7)=32+(IY.AND."37)
CMD(8)=32+((IY.AND."340)/32)
C
C (40) NOW LOAD GRAPHICS
C
40 IF((IBUF(4).AND.1).NE.0)GOTO 45 !DISPLAY GRAPHICS ENABLED?
IBUF(4)=IBUF(4).OR.1
45 I=2 !ENABLE GRAPHICS FOR APPROPRIATE GRAPH
IF(IGRAPH.EQ.1)I=4
IBUF(4)=IBUF(4).OR.I !SET BITS
C
C SET BIT IF STRIP CHART MODE IS REQUIRED
C
IF((IMODE.AND.16).NE.0)IBUF(5)=IBUF(5).OR."10 !3RD CHAR., REG. 0
CMD(1)=ENTRGR(1)
CMD(2)=ENTRGR(2)
CMD(3)='A'
CMD(4)=IBUF(4)
CMD(5)=IBUF(5)
CALL OUTSTR (CMD,NCHAR)
C
C NOW (FINALLY) PUT UP THE GRAPH
C
IF((IMODE.AND.16).NE.0)GOTO 200 !TEST FOR STRIP CHARTING
RANGE=IRB(1,IRGN)-IRB(2,IRGN) !# OF DOTS ON Y-AXIS
DO 100 I=1,NPTS
X1=I
IF(IFLAG.EQ.0)X1=X(I) !USE ACTUAL X VALUES IF NO DEFAULT
Y1=Y(I)
IX=INT(F(X1,XMAX,XMIN)*511.)
C
C CHECK FOR X OUT OF RANGE
C
IF(IX.LT.0)IX=0
IF(IX.GT.511)IX=511
C
CMD(1)='H'
CMD(2)=32+("37 .AND. IX)
CMD(3)=32+(("740 .AND. IX)/32)
IY=INT(F(Y1,YMAX,YMIN)*RANGE)
IF(((IX/128)*128) .EQ. IX)IY=0 !LEAVE TICK MARKS ALONE
IY=IY+IRB(2,IRGN) !ADD OFFSET FOR BOTTOM OF GRAPH
C
C CHECK FOR Y OUT OF RANGE
C
IF(IY.GT.IRB(1,IRGN))IY=IRB(1,IRGN)
IF(IY.LT.IRB(2,IRGN))IY=IRB(2,IRGN)
C
CMD(4)=IGCODE(IGRAPH+1)
CMD(5)=32+("37 .AND. IY)
CMD(6)=32+(("340 .AND. IY)/32)
CALL OUTSTR(CMD,6)
100 CONTINUE
GOTO 500
C
C THE FOLLOWING SECTION OF CODE IS FOR STRIP CHART MODE
C
200 CALL OUTSTR ('H ',-1) !Start at X=0
IROW=20
IF(IRGN.EQ.1)IROW=10 !SELECT ROW FOR LABLING
ICNT=-1 !INITIALIZE COUNTER
C CALL DFLTCK(FACTR,1.,FACTOR) !DEFAULT ON FACTOR IS 1
FACTR = FACTOR
C (Defaults not allowed 10/20)
IF((IMODE.AND.64).NE.0)CALL GRLM(ICNT,IROW,FACTR) !LABLE X-AXIS
RANGE=IRB(1,IRGN)-IRB(2,IRGN)
CMD(1)=IGCODE(IGRAPH+1) !DESIGNATE X VALUE
DO 300 I=1,NPTS
L=I !NEEDED TO AVOID A WARNING MESSAGE CONCERNING MODIF. TO I
Y1=Y(I)
IY=INT(F(Y1,YMAX,YMIN)*RANGE)
IF(MOD(L,128) .NE. 1)GOTO 260 !NEED TO SKIP A POINT?
IY=0 !RESET TO BASELINE
IF((IMODE.AND.64).EQ.0)GOTO 260 !UNITS SELECTED?
CALL GRLM(ICNT,IROW,FACTR)
260 IY=IY+IRB(2,IRGN)
C
C CHECK FOR Y OUT OF RANGE
C
IF(IY.GT.IRB(1,IRGN))IY=IRB(1,IRGN)
IF(IY.LT.IRB(2,IRGN))IY=IRB(2,IRGN)
C
CMD(2)=32+("37.AND.IY)
CMD(3)=32+(("340.AND.IY)/32)
CALL OUTSTR(CMD,3)
300 CONTINUE
500 CALL OUTSTR(EXITGR,2)
C
C TURN OFF STRIP CHART MODE FOR GRAPH AND THE GRAPHICS
C DISPLAY ENABLE.
C
IBUF(4)=IBUF(4).AND."177776 !DISABLE DISPLAY
IBUF(5)=IBUF(5).AND."177767 !TURN OFF STRIP CHART
RETURN
END
SUBROUTINE GRLM(ICNT,IROW,FACTOR)
C
C GRLM is a subroutine used to label the horizontal axis during
C strip chart mode.
C
C The arguments are as follows:
C
C ICNT a counter, incremented at each call. Should be set to
C -1 by the main program before the first call
C
C IROW the row used for labling
C
C FACTOR the scaling factor noted in graph (SUBROUTINE GRAPHM)
C
INTEGER CMD(11),ENTRGR(2),EXITGR(2),ICOL(4)
DATA ICOL/9,25,41,57/ !LABLING POSITIONS
DATA ENTRGR/"33,'1'/
DATA EXITGR/"33,'2'/
DATA CMD(11)/0/
C
ICNT=ICNT+1
IADJ=4
IF(ICNT.NE.0)GOTO 5
IADJ=0
GOTO 10
5 IF (ICNT.LT.5)RETURN
10 CALL OUTSTR (EXITGR,2) !LEAVE GRAPHICS MODE FOR LABELING
DO 30 J=1,4
F=FLOAT(((ICNT-IADJ)*128)+((J-1)*128))*FACTOR
ENCODE(10,20,CMD)F
20 FORMAT(1PE10.3)
CALL VTHTXT(0,IROW,ICOL(J),CMD)
30 CONTINUE
CALL OUTSTR(ENTRGR,2) !RETURN TO GRAPHICS MODE
RETURN
END
SUBROUTINE GRAPHS(IBUF,MODE,X,Y,NPTS,SHADE,IGR)
C
C
C J. LISCOUSKI DIGITAL EQUIPMENT CORPORATION
C NOV. 9, 1979
C
C This subroutine will permit graphs to be drawn given
C a few arguments.
C
C IBUF Is the information buffer dimensioned by the
C user for 30 words.
C
C MODE MODE is used to enable or disable certain display
C feature of the system. Some combinations of modes
C can be effected by summing the values for the various
C types:
C
C OPTION VALUE (IF ENABLED)
C ----- -----------------
C FRAME 1
C HOR. LINES 2
C SHADING 4
C INDEX 8 (not implemented as yet)
C MOVE 16
C AUTOSCALING 32
C UNITS 64
C MARKERS 128
C
C some combinations interact:
C
C A) horizontal lines can be used if frame is chosen
C B) index and move are mutually exclusive
C
C The default is 227 (FRAME, HORIZONTAL LINES, UNITS,
C MARKERS, and AUTOSCALING)
C
C X is the array for the horizontal axis, it may be defaulted.
C if the default is chosen, a counter from 1 to NPTS will be
C used in its place.
C
C Y is the array for the vertical axis and is manditory.
C
C NPTS is the number of points to be plotted.
C
C SHADE is the point on the vertical axis (expressed in user values)
C at which shading is to be done. The default is the bottom
C of the graph.
C
C IGR is the graph number (0/1) for plotting, the default is 0.
C
C NOTE: all arguments are needed, either by default or by user
C definition. If any are missing, system errors may occur.
C
DIMENSION X(npts),Y(npts),IBUF(30),TEMP(4),ITEMP(4),IRB(2,3),IB(2)
INTEGER CMD(10),ENTRGR(2),EXITGR(2),IGCODE(2)
EQUIVALENCE (TEMP(1),ITEMP(1)) !THIS IS TO PROVIDE A QUICK MEANS
EQUIVALENCE (TEMP(1),XMIN) !OF GETTING SCALED VALUES FROM
EQUIVALENCE (TEMP(2),XMAX) !FROM IBUF INTO THE APPROPRIATE
EQUIVALENCE (TEMP(3),YMIN) !REAL VARIABLES
EQUIVALENCE (TEMP(4),YMAX)
DATA IRB/239,150,129,50,239,50/ !REGION BOUNDS
DATA ENTRGR/"33,'1'/
DATA EXITGR/"33,'2'/
DATA IGCODE/'B','J'/
DATA IB/10,18/
F(Z,ZMAX,ZMIN)=(Z-ZMIN)/(ZMAX-ZMIN) !ARITH. STAT. SUBROUTINE
C
C BEGINNING OF EXECUTABLE CODE
C
C CALL IDFLT(IGRAPH,0,IGR) !CHECK FOR DEFAULT ON GRAPH #
IGRAPH = IGR
C (Defaults not allowed 10/20)
IF((IGRAPH.EQ.0).OR.(IGRAPH.EQ.1))GOTO 1 !IGRAPH OK?
write (5,1000)
1000 FORMAT(' ?GRAPHS - invalid graph number, must be 0/1')
CALL EXIT
C
1 IF(IBUF(27).NE."52525)CALL GRINIT(IBUF) !GRINIT CALLED?
IRGN=IBUF(8+IGRAPH)
IF(IRGN.NE.-1)GOTO 3 !FIND WHICH REGION IS BEING PLOTTED
write (5,1001)
1001 FORMAT(' ?GRAPHS - graph not assigned to region')
CALL EXIT
C
C3 CALL IDFLT(IMODE,227,MODE) !CHECK DEFAULT ON MODE
3 IMODE = MODE
C (Defaults not allowed 10/20)
CALL GRCLN(IBUF,IGRAPH) !CLEAN PLOTTING AREA
C
C NOW, IS AUTO SCALING NECESSARY?
C
IF((IMODE.AND.32).EQ.0)GOTO 10
C
C PERFORM AUTOSCALING
C
IFLAG=0 !FLAG TO SHOW IF X HAS BEEN DEFAULTED (1=YES)
CALL BOUNDS(1,X,XMAX,XMIN,NPTS,0,0,0) !GET LIMITS
6 CALL BOUNDS(1,Y,YMAX,YMIN,NPTS,0,0,0) !GET Y LIMITS
IBASE=IB(IGRAPH+1)
DO 7 I=1,4
7 IBUF(IBASE+I)=ITEMP(I) !STORE LIMITS IN IBUF
IBUF(2+IGRAPH)=1 !SHOW THAT SCALING FACTORS EXIST
GOTO 20
10 IF(IBUF(2+IGRAPH).NE.0)GOTO 12 !HAVE SCALED VALUES BEEN ENTERED?
write (5,1003)
1003 FORMAT(' ?GRAPHS - scaling has not been provided for graph')
CALL EXIT
C
12 IBASE=IB(IGRAPH+1)
DO 15 I=1,4
15 ITEMP(I)=IBUF(IBASE+I) !GET SCALED VALUES FROM IBUF
C
C (20) NOW SEE IF FRAME IS REQUIRED
C
20 IF((IMODE.AND.1).EQ.0)GOTO 30
CALL GRFRAM(IBUF,IGRAPH,IMODE)
C
C (30) CHECK FOR SHADE MODE
C
30 NCHAR=5 !AT LEAST 3 CHARACTER WILL BE SENT TO THE TERMINAL
IF((IMODE.AND.4).EQ.0)GOTO 40 !IF NOT, KEEP GOING
C CALL DFLTCK(SHADEL,YMIN,SHADE) !CKECK FOR DEFAULT ON SHADE LINE
SHADEL = SHADE
C (Defaults not allowed 10/20)
I=2
IF(IGRAPH.EQ.1)I=4 !SHADE APPROPRIATE GRAPH
IBUF(5)=((IBUF(5).OR.I).OR.IGRAPH) !SET BITS FOR SHADING
NCHAR=8 !SHADE LINE, 6 CHAR. WILL BE SENT TO THE TERMINAL
CMD(6)='@' !LOAD SHADE LINE CHARACTERS INTO CMD
IY=F(SHADEL,YMAX,YMIN)*FLOAT(IRB(1,IRGN)-IRB(2,IRGN))
IY=IY+IRB(2,IRGN)
C
C IF THE REQUESTED SHADELINE IS OUT OF THE REGION SET IT TO THE
C LIMIT OF THE REGION
C
IF(IY.GT.IRB(1,IRGN))IY=IRB(1,IRGN)
IF(IY.LT.IRB(2,IRGN))IY=IRB(2,IRGN)
C
CMD(7)=32+(IY.AND."37)
CMD(8)=32+((IY.AND."340)/32)
C
C (40) NOW LOAD GRAPHICS
C
40 IF((IBUF(4).AND.1).NE.0)GOTO 45 !DISPLAY GRAPHICS ENABLED?
IBUF(4)=IBUF(4).OR.1
45 I=2 !ENABLE GRAPHICS FOR APPROPRIATE GRAPH
IF(IGRAPH.EQ.1)I=4
IBUF(4)=IBUF(4).OR.I !SET BITS
CMD(1)=ENTRGR(1)
CMD(2)=ENTRGR(2)
CMD(3)='A'
CMD(4)=IBUF(4)
CMD(5)=IBUF(5)
CALL OUTSTR(CMD,NCHAR)
C
C NOW (FINALLY) PUT UP THE GRAPH
C
RANGE=IRB(1,IRGN)-IRB(2,IRGN) !# OF DOTS ON Y-AXIS
DO 100 I=1,NPTS
X1=I
IF(IFLAG.EQ.0)X1=X(I) !USE ACTUAL X VALUES IF NO DEFAULT
Y1=Y(I)
IX=INT(F(X1,XMAX,XMIN)*511.)
C
C CHECK FOR X OUT OF RANGE
C
IF(IX.LT.0)IX=0
IF(IX.GT.511)IX=511
C
CMD(1)='H'
CMD(2)=32+("37 .AND. IX)
CMD(3)=32+(("740 .AND. IX)/32)
IY=INT(F(Y1,YMAX,YMIN)*RANGE)
IF(((IX/128)*128) .EQ. IX)IY=0 !LEAVE TICK MARKS ALONE
IY=IY+IRB(2,IRGN) !ADD OFFSET FOR BOTTOM OF GRAPH
C
C CHECK FOR Y OUT OF RANGE
C
IF(IY.GT.IRB(1,IRGN))IY=IRB(1,IRGN)
IF(IY.LT.IRB(2,IRGN))IY=IRB(2,IRGN)
C
CMD(4)=IGCODE(IGRAPH+1)
CMD(5)=32+("37 .AND. IY)
CMD(6)=32+(("340 .AND. IY)/32)
CALL OUTSTR(CMD,6)
100 CONTINUE
CALL OUTSTR(EXITGR,2)
RETURN
END
SUBROUTINE GRCLN(IBUF,IGRAPH)
C
C CRCLN is user to clear the screen of data prior to
C using any of the graphics functions.
C for IGRAPH::
C A value of 0 will clean the section being used
C for graph 0
C A value of 1 will clean the area for graph 1
C
C If GRINIT has not been called prior to this subroutine
C it will be invoked
C
DIMENSION IBUF(30),IRB(2,3),LTXT(2,2)
INTEGER CURMRK(2),ENTRGR(2),EXITGR(2),CMD(10),INIT(30),IG(2)
INTEGER START(3,2)
DATA (START(1,I),I=1,2) /"66,"44/ !CODED DOT POSITIONS
DATA (START(2,I),I=1,2) /"62,"41/
DATA (START(3,I),I=1,2) /"62,"41/
DATA IG/'B','J'/ !PICK GRAPH 0 OR 1
DATA ENTRGR/"33,"61/ !ENTER GRAPHICS MODE
DATA EXITGR/"33,"62/ !EXIT GRAPHICS MODE
DATA IRB/239,150,129,50,239,50/ !REGION BOUNDS
DATA CURMRK/'C','K'/ !SELECT CURSOR FOR GRAPH
DATA LTXT/2,10,12,20/
C
C The following data stream will set the roll area to (21,24)
C move the cursor to (20,80)
C and erase from the beginning of the
C screen to the cursor position. It will
C also clear the graphics registers and
C memory.
C
C The equivalent character stream is $[21;24r$[20;80H$[1J$1A I0!$2
C
DATA INIT/"33,91,50,49,59,50,52,114,"33,91,50,48,59,56,48,72,
1 "33,91,49,74,"33,'1','A',32,32,'I','0',33,"33,'2'/
C
C HAS GRINIT BEEN CALLED
C
IF (IBUF(27).EQ."52525)GOTO 10
write (5,1000)
1000 FORMAT(' ?GRCLN - GRINIT has not been called prior to GRCLN')
CALL EXIT
C
10 IF ((IGRAPH.GE.0) .AND. (IGRAPH.LE.1))GOTO 20 !IGRAPH VALID?
write (5,1001)
1001 FORMAT(' ?GRCLN - invalid argument -- IGRAPH')
CALL EXIT
C
20 IRGN=IBUF(8+IGRAPH)
IF(IRGN.NE.-1)GOTO 60
write (5,1002)
1002 FORMAT(' ?GRCLN - graph not assigned to region')
CALL EXIT
C
60 IF(IBUF(1).EQ.0)GOTO 200 !HAS THE SCREEN BEEN CLEANED BEFORE?
C
C The following three lines of code permit the plotting of two graphs in
C the same display region without cleaning the section of screen a
C second time. The expression 2**IBUF(8) is simply a means of
C mapping the values 1, 2, and 3 into unique bit positions in an
C integer
C
C Should the user want to clean a section of graph after both graphs
C have been assigned to the same region he can:
C 1) Reassign one of the graphs to a different region
C 2) Use the vtclr subroutine which cleans everything
C
IF(IBUF(8).NE.IBUF(9))GOTO 70 !PLOTTING IN THE SAME REGION?
IF(((2**IBUF(8)).AND.IBUF(1)).NE.0)GOTO 300 !REGION ALREADY CLEANED
IBUF(1)=IBUF(1).OR.(2**IBUF(8)) !SET APPROPRIATE BIT
70 GOTO (100,100,200),IGRAPH+1
C
C Set up indices for erasing text lines
C
C
C If the previous graph (if any) used the full display area, and
C the current use will be using either the upper or lower
C regions, clean the entire screen
C
C NOTE: (IRGN.NE.3), in other words if IRGN (which indicate the region
C 1=UPPER, 2=LOWER, 3=FULL) is a 1 or a 2, and
C the full display was used, goto 200
C
100 IF((IBUF(28).EQ.1).AND.(IRGN.NE.3))GOTO 200
IF (IRGN.EQ.3)GOTO 200 !IF FULL REGION CLEAN ALL
110 DO 112 J=LTXT(1,IRGN),LTXT(2,IRGN)
J1=J !NEEDED TO ALLOW COMPILER OPTIMIZATIONS, WITHOUT IT A
C !COMPILE TIME WARNING RESULTS
112 CALL VTELIN(2,J1) !ERASE APPROPRIATE LINES
C
C ******** NOW CLEAN UP GRAPHICS *************
C
C BEGIN BY ELIMINATING THE HORIZONTAL LINES
C
IF((IBUF(6).AND.1).EQ.0)GOTO 120 !HAVE H-LINES BEEN ENABLED?
CMD(1)='D' !REFERENCE HORIZONTAL LINES
DO 113 J=IRB(2,IRGN),IRB(1,IRGN) !WORK WITHIN REGION BOUNDS
CMD(2)=32+("37 .AND. J) !FIRST CHARACTER
CMD(3)=32+(("340 .AND. J)/32) !SECOND CHARACTER
CALL OUTSTR(ENTRGR,2)
CALL OUTSTR (CMD,3)
113 CONTINUE
C
C ERASE GRAPHIC DATA
C
120 MASK="165 !USED TO MASK THE FIRST CHAR. OF "A" COMMAND
IF(IGRAPH.EQ.1)MASK="153
IBUF(4)=IBUF(4).AND.MASK !RESET STATUS REGISTER 0
MASK="175 !USED TO MASK THE SEC. CHAR. OF "A" COMMAND
IF(IGRAPH.EQ.1)MASK="173
IBUF(5)=IBUF(5).AND.MASK
MASK="173 !USED TO MASK THE FIRST CHARACTER OF "I" COMMAND
IF(IGRAPH.EQ.1)MASK="167
IBUF(6)=IBUF(6).AND.MASK
CMD(1)='A'
CMD(2)=IBUF(4)
CMD(3)=IBUF(5)
CMD(4)='I'
CMD(6)=IBUF(6)
CMD(7)=IBUF(7)
CALL OUTSTR (CMD,7) !RESET DISPLAY
CMD(1)=CURMRK(IGRAPH+1)
DO 130 I=1,512
J=I-1
CMD(2)=32+(J.AND."37)
CMD(3)=32+((J.AND."740)/32)
CALL OUTSTR(CMD,3) !CLEAR EXISTING MARKERS
130 CONTINUE
GOTO 310
C
C (200) SINCE THE FULL DISPLAY WILL BE USED, REINITIALIZE THE ENTIRE
C DATA AREA
C
200 CALL OUTSTR(INIT,30)
IBUF(4)="40 !MAKE SURE THAT THE DATA IN IBUF
IBUF(5)="40 !AGREES WITH THE RESULTS OF THE
IBUF(6)="40 !SCREEN INITIALIZATION
IBUF(7)="41
IBUF(1)=IBUF(1).OR.(2**IBUF(8+IGRAPH)) !SHOW WHICH REGION
C
C (300) RESET THE POSITION OF THE DOTS USED TO MAKE UP A GRAPH
C
300 CALL OUTSTR (ENTRGR,2) !ENTER GRAPHICS
310 CMD(1)='H'
CMD(2)=' '
CMD(3)=' ' !STARTING X=0
CMD(4)=IG(IGRAPH+1) !SELECT PROPER GRAPH
CALL OUTSTR (CMD,4)
CMD(1) = START(IRGN,1)
CMD(2) = START(IRGN,2)
DO 325 I=1,512
325 CALL OUTSTR (CMD,2) !POSITON DOTS USING CODED VALUES
CALL OUTSTR(EXITGR,2) !EXIT GRAPHICS MODE
RETURN
END
SUBROUTINE GRFRAM(IBUF,IGRAPH,MODE)
C
C
C J. LISCOUSKI DIGITAL EQUIPMENT CORPORATION
C NOV. 9, 1979
C
C GRFRAM function in life is to construct the frame used in a graph.
C It will construct the following items:
C
C 1) Horizontal lines at the top and bottom of the graph
C 2) The vertical bars at the sides of the graph
C 3) Place the dot for a graph on a line coincident with
C the bottom vertical line
C 4) Label the graph on the horizontal and vertical axis
C
C Arguments:
C IBUF is the FORTRAN information buffer
C IGRAPH is the graph number (0/1)
C MODE is the mode value passed to the calling routine
C
DIMENSION IBUF(30),LINE(2,3),LINEL(2,3),ICOL(4),LBLY(3,3),LINEY(3)
DIMENSION IB(2)
DIMENSION TEMP(4),ITEMP(4) !THESE WILL BE USED IN SCALING
EQUIVALENCE (TEMP(1),ITEMP(1)) !THE AXIS
INTEGER LINES(3),LINEE(3),MARKER(2)
INTEGER CMD(11),ENTRGR(2),EXITGR(2)
DATA ENTRGR/"33,'1'/ !ENTER GRAPHICS MODE
DATA EXITGR/"33,'2'/ !YOU GUESSED IT, EXIT GRAPHICS MODE
DATA LINE/150,239,50,129,50,239/ !HORIZONTAL LINE POSITIONS
DATA LINES/"33,'(','0'/ !SPECIAL GRAPHICS MODE
DATA LINEE/"33,'(','B'/ !ASCII STANDARD MODE
DATA LINEL/1,9,12,19,1,19/ !STARTING POS. AND # OF LINES
DATA ICOL/9,25,41,57/ !COLUMN POSITIONS FOR LABELING X-AXIS
DATA LBLY/9,5,1,19,15,12,19,10,1/ !ROW POS. FOR Y-AXIS
DATA LINEY/194,89,144/ !MORE HORIZONTAL LINE POSITIONS
DATA MARKER/'C','K'/ !GRAPH MARKER IDENTIFICATIONS
DATA IB/10,18/
C
IF((IGRAPH.EQ.0).OR.(IGRAPH.EQ.1))GOTO 1 !VALID GRAPH #?
write (5,1000)
1000 FORMAT(' ?GRFRAM - invalid graph #, must be 0 or 1')
CALL EXIT
C
C
1 IRGN=IBUF(8+IGRAPH)
IF(IRGN.NE.-1)GOTO 10 !WHERE IS THE GRAPH REGION?
write (5,1001)
1001 FORMAT(' ?GRFRAM - graph region not assigned')
CALL EXIT
C
C
C CHECK TO SEE IF HORIZONTAL LINES HAVE BEEN ENABLED
C
10 IF((IRGN.EQ.1).OR.(IRGN.EQ.2))IBUF(28)=0 !SHOW PARTIAL DISPLAY
IF(IRGN.EQ.3)IBUF(28)=1 !SHOW FULL REGION
CALL OUTSTR (ENTRGR,2) !ENTER GRAPHICS MODE
IF((IBUF(4).AND.1).NE.0)GOTO 12 !IF GRAPHICS HAVEN'T BEEN ENABLED
IBUF(4)=IBUF(4)+1 !ENABLE THEM
CMD(1)='A'
CMD(2)=IBUF(4)
CMD(3)=IBUF(5)
CALL OUTSTR (CMD,3)
12 IF((IBUF(6).AND.1).NE.0)GOTO 15 !IF HOR. LINE HAVEN'T BEEN ENABLED
IBUF(6)=IBUF(6)+1 !ENABLE THEM
CMD(1)='I'
CMD(2)=IBUF(6)
CMD(3)=IBUF(7)
CALL OUTSTR (CMD,3)
15 CMD(1)='D' !SET UP FOR HORIZONTAL LINES
DO 20 I=1,2
J=LINE(I,IRGN) !THIS LOOP IS USED TO PUT UP THE LINES
CMD(2)=32+(J.AND."37)
CMD(3)=48+((J.AND."340)/32)
CALL OUTSTR (CMD,3)
20 CONTINUE
CALL OUTSTR (EXITGR,2)
C
C PUT UP VERTICAL BARS
C
CALL OUTSTR (LINES,3) !INTO SPECIAL GRAPHICS MODE
DO 30 I=LINEL(1,IRGN),LINEL(2,IRGN)
I4=I !NEEDED TO AVOID A COMPILER WARNING
CALL VTHTXT(0,I4,8,'x') !ON OUTPUT THE x WILL BECOME A VERTICAL
30 CALL VTHTXT(0,I4,74,'x')!BAR SINCE ITS OCTAL CODE IS "170
CALL OUTSTR (LINEE,3) !BACK TO ASCII MODE
C
C NEXT, LABEL THE AXIS BEGINNING WITH THE HORIZONTAL AXIS
C
IF((MODE.AND.64).EQ.0)GOTO 52
IBASE=IB(IGRAPH+1) !GET READ TO COPY COORDINATES
DO 35 I=1,4
35 ITEMP(I)=IBUF(IBASE+I) !COPY VALUES FROM IBUF TO TEMP (yes, TEMP)
C
C IF STRIPCHART MODE IS GOING TO BE USED, DON'T LABEL THE
C THE X-AXIS
C
IF((MODE.AND.16).NE.0)GOTO 45 !IF STRIPCHRT, GOTO Y-AXIS
ILINE=20 !LINE VALUES ARE TO BE PRINTED ON
IF(IRGN.EQ.1)ILINE=10 !RESET FOR UPPER REGION
XINC=(TEMP(2)-TEMP(1))/4.
DO 40 I=1,4
X=TEMP(1)+XINC*FLOAT(I-1)
ENCODE(10,37,CMD)X
CMD(3) = 0
37 FORMAT(1PE10.3)
CALL VTHTXT(0,ILINE,ICOL(I),CMD)
40 CONTINUE
C
C NOW LABEL THE Y AXIS
C
45 YINC=(TEMP(4)-TEMP(3))/2.
DO 50 I=1,3
Y=TEMP(3)+YINC*FLOAT(I-1)
ENCODE(10,38,CMD)Y
38 FORMAT (1PE9.2)
CMD(3)=CMD(2)
CMD(2)=0
CALL VTMCUR(LBLY(I,IRGN),1)
CALL OUTSTR (CMD,-1) !MANTISSA
CALL VTMCUR(LBLY(I,IRGN)+1,3)
CALL OUTSTR (CMD(3),-1)
50 CONTINUE
C
C MOVING ALONG, WE NOW GET TO THE HORIZONTAL LINES IN THE
C MIDDLE OF THE SCREEN.....
C
52 IF((MODE.AND.2).EQ.0)GOTO 54
CALL OUTSTR (ENTRGR,2) !BACK INTO GRAPHICS MODE
CMD(1)='D' !SPECIFY HORIZONTAL LINE
CMD(2)=32+(LINEY(IRGN).AND."37)
CMD(3)=48+((LINEY(IRGN).AND."340)/32)
CMD(4)=EXITGR(1)
CMD(5)=EXITGR(2)
CALL OUTSTR (CMD,5)
C
C GRAPH MARKERS ARE NEXT........
C
54 IF((MODE.AND.128).EQ.0)RETURN
I4=4 !SET UP BIT PATTERN FOR ENABLING MARKERS
IF(IGRAPH.EQ.1)I4=8 !RESET IF GRAPH IS 1
IBUF(6)=IBUF(6).OR.I4 !ENABLE MARKERS
CMD(1)=ENTRGR(1)
CMD(2)=ENTRGR(2)
CMD(3)='I'
CMD(4)=IBUF(6)
CMD(5)=IBUF(7)
CALL OUTSTR (CMD,5) !SEND NEW REGISTER 1 CONFIGURATION
CMD(1)=MARKER(IGRAPH+1) !SET MARKER TYPE
DO 60 I=1,4
J=(I-1)*128 !MARKER POSITION
CMD(2)=32+(J.AND."37)
CMD(3)=48+((J.AND."740)/32)
CALL OUTSTR (CMD,3) !SEND STRING
60 CONTINUE
CALL OUTSTR (EXITGR,2) !EXIT GRAPHICS
RETURN
END
SUBROUTINE GRINDX(IBUF,X,NPTS,ARRAY,IGR)
C
C GRINDX allows the user to move a cursor along the screen
C and "remember" the cursor position for up to 10 points.
C
C The points are numbered 1-0 (0 is the tenth point) and will
C fill the real array "array" at those appropriate positions.
C
C Typing a carrige return will cause the user to exit from the
C subroutine.
C
C Cursor positioning is performed with the cursor control keys
C for left and right movement, the cursors will ride on the data
C
C Any characters not mentioned above will cause the terminal to
C beep
C
C----------------------------------------------------------------
C
C The arguments for the subroutine are as follows:
C
C IBUF THE INFORMATION BUFFER DESCRIBED IN GRDOC
C X THE DATA VECTOR FOR THE X AXIS
C NPTS THE NUMBER OF POINTS IN THE DATA
C ARRAY THE TEN ELEMENT ARRAY WHICH WILL CONTAIN THE
C CURSOR POSITIONS ON EXIT
C IGRAPH THE GRAPH NUMBER (0/1)
C
C DEFAULTS::
C
C IGRAPH ==> 0
C X ==> POINT COUNT
C
C
DIMENSION IBUF(30),TEMP(2),ITEMP(2),ARRAY(10),X(NPTS),IB(2)
INTEGER CMD(3),ENTRGR(2),EXITGR(2),IGCODE(2),CHAR(2),OKCHAR(16)
INTEGER BELL(5)
EQUIVALENCE (TEMP(1),ITEMP(1)) !THIS IS TO PROVIDE A QUICK MEANS
EQUIVALENCE (TEMP(1),XMIN) !OF GETTING SCALED VALUES FROM
EQUIVALENCE (TEMP(2),XMAX) !FROM IBUF INTO THE APPROPRIATE
DATA IB/10,18/
DATA OKCHAR/ "61,"62,"63,"64,"65,"66,"67,"70,"71,"60,"15,
1 "104,"103,"133,"33,0/
C THESE OCTAL NUMBERS ARE THE VALID KEYBOARD RESPONSES AS
C FOLLOWS: '1','2','3','4','5','6','7','8','9','0',<CR>
C PLUS THESE CURSOR ESCAPE SEQUENSES: <ESC>[D,<ESC>[C.
DATA ENTRGR/"33,'1'/
DATA BELL /"33,'2',7,"33,'1'/
DATA EXITGR/"33,'2'/
DATA IGCODE/'C','K'/ !CODES FOR ACCESSING THE GRAPH MARKERS
DATA CHAR(2)/0/
F(Z,ZMAX,ZMIN)=(Z-ZMIN)/(ZMAX-ZMIN) !ARITH. STAT. FUNCTION
C
C BEGINNING OF EXECUTABLE CODE
C
PTS=NPTS !FLOAT THE NUMBER OF POINTS
C CALL IDFLT(IGRAPH,0,IGR) !CHECK FOR DEFAULT ON GRAPH #
IGRAPH = IGR
C (Defaults not allowed 10/20)
IF((IGRAPH.EQ.0).OR.(IGRAPH.EQ.1))GOTO 1 !IGRAPH OK?
write (5,1000)
1000 FORMAT(' ?GRINDX - invalid graph number, must be 0/1')
CALL EXIT
C
1 IF(IBUF(27).EQ."52525)GOTO 4 !GRINIT CALLED?
write (5,1001)
1001 FORMAT(' ?GRINDX - GRINIT not called')
CALL EXIT
C
4 IRGN=IBUF(8+IGRAPH)
IF(IRGN.NE.-1)GOTO 3 !FIND WHICH REGION IS BEING PLOTTED
write (5,1002)
1002 FORMAT(' ?GRINDX - graph not assigned to region')
CALL EXIT
C
3 IFX=0 !INITIALIZE FLAG TO 0
C
C GET SCALING VALUES FOR X AXIS
C
IBASE=IB(IGRAPH+1)
10 IF(IBUF(2+IGRAPH).NE.0)GOTO 12 !HAVE SCALED VALUES BEEN ENTERED?
write (5,1003)
1003 FORMAT(' ?GRINDX - scaling has not been provided for graph')
CALL EXIT
C
12 DO 15 I=1,2
15 ITEMP(I)=IBUF(IBASE+I) !GET SCALED VALUES FROM IBUF
C
CALL OUTSTR (ENTRGR,2) !ENTER GRAPHICS MODE
C
C CHECK TO SEE IF GRAPH MARKERS HAVE BEEN ENABLED, IF NOT,
C ENABLE THEM.
C
MASK=4 !MASK VALUE FOR GRAPH 0
IF(IGRAPH.EQ.1)MASK=8 !MASK VALUE FOR GRAPH 1
IF((MASK.AND.IBUF(6)).NE.0)GOTO 90
IBUF(6)=IBUF(6).OR.MASK !SET BIT
CMD(1)='I'
CMD(2)=IBUF(6)
CMD(3)=IBUF(7)
CALL OUTSTR (CMD,3) !UPDATE REGISTER 1
C
C NOW PUT UP THE CURSOR SO THAT THEY WILL KNOW WE ARE READY
C ... THEN GET AND PROCESS CHARACTERS
C
90 IOLD=1
NEW=1
GOTO 150 !PUT UP CURSOR
100 ICHAR = NEREAD(1)
CALL INDX(OKCHAR,ICHAR,MPOS) !IF VALID, LOC. WILL BE IN MPOS
IF(MPOS.NE.0)GOTO 110
CALL OUTSTR (BELL,5) !RING BUZZER (BELL IF YOU ARE ASR33 ORIENTED)
GOTO 100 !TRY FOR MORE
110 GOTO (120,120,120,120,120,120,120,120,120,120,200,130,140,
1 100,100),MPOS !GOTO APPROPRIATE ROUTINE FOR PROCESSING
120 ICHAR=ICHAR-"60 !CONVERT TO SUBSCRIPT
IF(ICHAR.EQ.0)ICHAR=10 !'0' REALLY MEANS 10
IF(IFX.EQ.0)ARRAY(ICHAR)=X(IOLD)
IF(IFX.EQ.1)ARRAY(ICHAR)=IOLD
GOTO 100 !GO BACK FOR MORE
130 NEW=IOLD-1
C IF(MOD(NEW,128).EQ.1)NEW=NEW-1
IF(NEW.LT.1)NEW=IOLD
GOTO 150
140 NEW=IOLD+1
C IF(MOD(NEW,128).EQ.1)NEW=NEW+1
IF(NEW.GT.511)NEW=IOLD
150 CMD(1)=IGCODE(IGRAPH+1)
IF(IFX.EQ.1)IX=(FLOAT(IOLD)/PTS)*511.
IF(IFX.EQ.0)IX=F(X(IOLD),XMAX,XMIN)*511.
IF(MOD(IX,128).EQ.0)GOTO 155 !DON'T ERASE UNIT MARKERS
CMD(2)=32+(IX.AND."37)
CMD(3)=32+((IX.AND."740)/32)
CALL OUTSTR (CMD,3) !ERASE EXISTING CURSOR
155 IF(IFX.EQ.1)IX=(FLOAT(NEW)/PTS)*511.
IF(IFX.EQ.0)IX=F(X(NEW),XMAX,XMIN)*511.
CMD(2)=32+(IX.AND."37)
CMD(3)=48+((IX.AND."740)/32)
CALL OUTSTR (CMD,3) !PUT UP THE NEW ONE
IOLD=NEW
GOTO 100
200 CMD(1)=IGCODE(IGRAPH+1)
IF(IFX.EQ.1)IX=(FLOAT(IOLD)/PTS)*511.
IF(IFX.EQ.0)IX=F(X(IOLD),XMAX,XMIN)*511.
IF(MOD(IX,128).EQ.0)GOTO 210 !DON'T ERASE UNIT MARKERS
CMD(2)=32+(IX.AND."37)
CMD(3)=32+((IX.AND."740)/32)
CALL OUTSTR (CMD,3) !ERASE EXISTING CURSOR
210 CALL OUTSTR (EXITGR,2)
RETURN
END
C
SUBROUTINE INDX(OKCHAR,CHAR,MPOS)
C
C INDX returns the position of CHAR in OKCHAR or zero
C if it isn't found. This replaces the INDEX intrinsic
C function supplied with the PDP-11 and VAX.
C
INTEGER OKCHAR(16),CHAR
MPOS = 0
DO 10 I = 1, 16
IF (CHAR .EQ. OKCHAR(I)) MPOS = I
10 CONTINUE
RETURN
END
SUBROUTINE GRMARK(IBUF,X,MODE,IGR)
C
C GRMARK allows the user to place or erase a cursor for either
C graph given the value x in user coordinates, the MODE (0=ERASE,
C non zero = SET), and the graph
C
C
C----------------------------------------------------------------
C
C The arguments for the subroutine are as follows:
C
C IBUF the information buffer described in GRDOC
C X the x axis position of the cursor (marker)
C cursor positions on exit
C MODE =0 then erase the marker, otherwise create one
C IGR the graph number (0/1)
C
C DEFAULTS::
C
C IGRAPH ==> 0
C
C
DIMENSION IBUF(30),TEMP(2),ITEMP(2),IB(2)
INTEGER CMD(3),ENTRGR(2),EXITGR(2),IGCODE(2)
EQUIVALENCE (TEMP(1),ITEMP(1)) !THIS IS TO PROVIDE A QUICK MEANS
EQUIVALENCE (TEMP(1),XMIN) !OF GETTING SCALED VALUES FROM
EQUIVALENCE (TEMP(2),XMAX) !FROM IBUF INTO THE APPROPRIATE
DATA IB/10,18/
DATA ENTRGR/"33,'1'/
DATA EXITGR/"33,'2'/
DATA IGCODE/'C','K'/ !CODES FOR ACCESSING THE GRAPH MARKERS
F(Z,ZMAX,ZMIN)=(Z-ZMIN)/(ZMAX-ZMIN) !ARITH. STAT. FUNCTION
C
C BEGINNING OF EXECUTABLE CODE
C
C CALL IDFLT(IGRAPH,0,IGR) !CHECK FOR DEFAULT ON GRAPH #
IGRAPH = IGR
C (Defaults not allowed 10/20)
IF((IGRAPH.EQ.0).OR.(IGRAPH.EQ.1))GOTO 1 !IGRAPH OK?
write (5,1000)
1000 FORMAT(' ?GRMARK - invalid graph number, must be 0/1')
CALL EXIT
C
1 IF(IBUF(27).EQ."52525)GOTO 4 !GRINIT CALLED?
write (5,1001)
1001 FORMAT(' ?GRMARK - GRINIT not called')
CALL EXIT
C
4 IRGN=IBUF(8+IGRAPH)
IF(IRGN.NE.-1)GOTO 3 !FIND WHICH REGION IS BEING PLOTTED
write (5,1002)
1002 FORMAT(' ?GRMARK - graph not assigned to region')
CALL EXIT
C
C
C GET SCALING VALUES FOR X AXIS
C
3 IBASE=IB(IGRAPH+1)
10 IF(IBUF(2+IGRAPH).NE.0)GOTO 12 !HAVE SCALED VALUES BEEN ENTERED?
write (5,1003)
1003 FORMAT(' ?GRMARK - scaling has not been provided for graph')
CALL EXIT
C
12 DO 15 I=1,2
15 ITEMP(I)=IBUF(IBASE+I) !GET SCALED VALUES FROM IBUF
C
CALL OUTSTR (ENTRGR,2) !ENTER GRAPHICS MODE
C
C CHECK TO SEE IF GRAPH MARKERS HAVE BEEN ENABLED, IF NOT,
C ENABLE THEM.
C
MASK=4 !MASK VALUE FOR GRAPH 0
IF(IGRAPH.EQ.1)MASK=8 !MASK VALUE FOR GRAPH 1
IF((MASK.AND.IBUF(6)).NE.0)GOTO 90
IBUF(6)=IBUF(6).OR.MASK !SET BIT
CMD(1)='I'
CMD(2)=IBUF(6)
CMD(3)=IBUF(7)
CALL OUTSTR (CMD,3) !UPDATE REGISTER 1
C
90 CMD(1)=IGCODE(IGRAPH+1)
IX=F(X,XMAX,XMIN)*511.
IF(MOD(IX,128).EQ.0)GOTO 999 !DON'T ERASE UNIT MARKERS
ISET=0
IF(MODE.NE.0)ISET=16
CMD(2)=32+(IX.AND."37)
CMD(3)=32+ISET+((IX.AND."740)/32)
CALL OUTSTR (CMD,3) !ERASE/CREATE MARKER
999 CALL OUTSTR (EXITGR,2)
RETURN
END
SUBROUTINE GRPNTM(IBUF,MODE,X,Y,IGR,FACTOR)
C
C
C J. LISCOUSKI DIGITAL EQUIPMENT CORPORATION
C NOV. 9, 1979
C
C This subroutine will permit graphs to be drawn given
C a few arguments. If shading is desired, then the
C subroutine GRSHAD should be used.
C
C IBUF Is the information buffer dimensioned by the
C user for 30 integers.
C
C MODE Mode is used to enable or disable certain display
C feature of the system. Some combinations of modes
C can be effected by summing the values for the various
C types:
C
C OPTION VALUE (IF ENABLED)
C ----- -----------------
C MOVE 16
C
C
C X Is the array for the horizontal axis, it may be defaulted.
C If the default is chosen, a counter from 1 to NPTS will be
C used in its place.
C
C Y Is the array for the vertical axis and is manditory.
C
C
C IGR Is the graph number (0/1) for plotting, the default is 0.
C
C FACTOR Is a multiplier used to provide aome scaling for the
C horizontal axis while in stripchart mode. The calculation
C is (number of points)*(factor)
C
C NOTE: All arguments are needed, either by default or by user
C definition. If any are missing, a system error may occur.
C
DIMENSION IBUF(30),TEMP(4),ITEMP(4),IRB(2,3),IB(2),IROW(3)
INTEGER CMD(6),ENTRGR(2),EXITGR(2),IGCODE(2)
EQUIVALENCE (TEMP(1),ITEMP(1)) !THIS IS TO PROVIDE A QUICK MEANS
EQUIVALENCE (TEMP(1),XMIN) !OF GETTING SCALED VALUES FROM
EQUIVALENCE (TEMP(2),XMAX) !FROM IBUF INTO THE APPROPRIATE
EQUIVALENCE (TEMP(3),YMIN) !REAL VARIABLES
EQUIVALENCE (TEMP(4),YMAX)
DATA IRB/239,150,129,50,239,50/ !REGION BOUNDS
DATA ENTRGR/"33,'1'/
DATA EXITGR/"33,'2'/
DATA IGCODE/'B','J'/
DATA IB/10,18/
DATA IROW/10,20,20/ !ROW #'S FOR LABLEING X-AXIS
F(Z,ZMAX,ZMIN)=(Z-ZMIN)/(ZMAX-ZMIN) !ARITH. STAT. SUBROUTINE
C
C BEGINNING OF EXECUTABLE CODE
C
C CALL IDFLT(IGRAPH,0,IGR) !CHECK FOR DEFAULT ON GRAPH #
IGRAPH = IGR
C (Defaults not allowed 10/20)
IF((IGRAPH.EQ.0).OR.(IGRAPH.EQ.1))GOTO 1 !IGRAPH OK?
write (5,1000)
1000 FORMAT(' ?GRPNTM - invalid graph number, must be 0/1')
CALL EXIT
C
1 IF(IBUF(27).EQ."52525)GOTO 2 !GRINIT CALLED?
write (5,1001)
1001 FORMAT(' ?GRPNTM - GRINIT has not been called')
CALL EXIT
C
2 IRGN=IBUF(8+IGRAPH)
IF(IRGN.NE.-1)GOTO 4 !FIND WHICH REGION IS BEING PLOTTED
write (5,1002)
1002 FORMAT(' ?GRPNTM - graph not assigned to region')
CALL EXIT
C
C4 CALL IDFLT(IMODE,227,MODE) !CHECK DEFAULT ON MODE
4 IMODE = MODE
C (Defaults not allowed 10/20)
C
C HAS THE GRAPH BEEN SCALED?
C
IF(IBUF(2+IGRAPH).NE.0)GOTO 6
write (5,1003)
1003 FORMAT(' ?GRPNTM - scaling has not been provided for graph')
CALL EXIT
C
6 IBASE=IB(IGRAPH+1)
DO 15 I=1,4
15 ITEMP(I)=IBUF(IBASE+I) !GET SCALED VALUES FROM IBUF
C
C (40) NOW LOAD GRAPHICS
C
40 IF((IBUF(4).AND.1).NE.0)GOTO 45 !DISPLAY GRAPHICS ENABLED?
IBUF(4)=IBUF(4).OR.1
45 CALL OUTSTR (ENTRGR,2) !ENTER GRAPHICS MODE
I=2 !ENABLE GRAPHICS FOR APPROPRIATE GRAPH
IF(IGRAPH.EQ.1)I=4
IF((IBUF(4).AND.I).NE.0)GOTO 50 !SKIP OVER THE NEXT FEW LINES
C !OF CODE IF THE GRAPH IS SET
IBUF(4)=IBUF(4).OR.I !SET BITS
C
C SET BIT IF STRIP CHART MODE IS REQUIRED
C
IF((IMODE.AND.16).NE.0)IBUF(5)=IBUF(5).OR."10 !3RD CHAR., REG. 0
CMD(1)='A'
CMD(2)=IBUF(4)
CMD(3)=IBUF(5)
CALL OUTSTR (CMD,3)
C
C NOW (FINALLY) PUT UP THE GRAPH
C
50 IF((IMODE.AND.16).NE.0)GOTO 200 !TEST FOR STRIP CHARTING
RANGE=IRB(1,IRGN)-IRB(2,IRGN) !# OF DOTS ON Y-AXIS
IX=INT(F(X,XMAX,XMIN)*511.)
C
C CHECK FOR X OUT OF RANGE
C
IF(IX.LT.0)IX=0
IF(IX.GT.511)IX=511
C
CMD(1)='H'
CMD(2)=32+("37 .AND. IX)
CMD(3)=32+(("740 .AND. IX)/32)
IY=INT(F(Y,YMAX,YMIN)*RANGE)
IF(((IX/128)*128) .EQ. IX)IY=0 !LEAVE TICK MARKS ALONE
IY=IY+IRB(2,IRGN) !ADD OFFSET FOR BOTTOM OF GRAPH
C
C CHECK FOR Y OUT OF RANGE
C
IF(IY.GT.IRB(1,IRGN))IY=IRB(1,IRGN)
IF(IY.LT.IRB(2,IRGN))IY=IRB(2,IRGN)
C
CMD(4)=IGCODE(IGRAPH+1)
CMD(5)=32+("37 .AND. IY)
CMD(6)=32+(("340 .AND. IY)/32)
CALL OUTSTR (CMD,6)
GOTO 500
C
C THE FOLLOWING SECTION OF CODE IS FOR STRIP CHART MODE
C
C200 CALL DFLTCK(FACTR,1.,FACTOR) !DEFAULT FACTOR IS 1.
200 FACTR = FACTOR
C (Defaults not allowed 10/20)
IF(IBUF(29).NE.0)GOTO 210
CALL OUTSTR ('H ',-1) !MOVE X TO LOWER LEFT CORNER
C
C THE FOLLOWING IF STATEMENT AND SUBROUTINE CALL ARE
C USED TO FORM THE INITIAL LABEL ON THE X AXIS
C
IF((IMODE.AND.64).NE.0)CALL GRLM(IBUF(30),IROW(IRGN),FACTR)
210 IBUF(29)=IBUF(29)+1 !UPDATE COUNTER
RANGE=IRB(1,IRGN)-IRB(2,IRGN)
CMD(1)=IGCODE(IGRAPH+1) !DESIGNATE X VALUE
IY=INT(F(Y,YMAX,YMIN)*RANGE)
IF(MOD(IBUF(29),128) .NE. 1)GOTO 260 !NEED TO SKIP A POINT?
IY=0 !RESET TO BASELINE
IF((IMODE.AND.64).EQ.0)GOTO 260 !UNITS SELECTED?
CALL GRLM(IBUF(30),IROW(IRGN),FACTR)
260 IY=IY+IRB(2,IRGN)
C
C CHECK FOR Y OUT OF RANGE
C
IF(IY.GT.IRB(1,IRGN))IY=IRB(1,IRGN)
IF(IY.LT.IRB(2,IRGN))IY=IRB(2,IRGN)
C
CMD(2)=32+("37.AND.IY)
CMD(3)=32+(("340.AND.IY)/32)
CALL OUTSTR (CMD,3)
500 CALL OUTSTR (EXITGR,2) !EXIT GRAPHICS MODE
RETURN
END
SUBROUTINE GRPNTS(IBUF,MODE,X,Y,IGR)
C
C
C J. LISCOUSKI DIGITAL EQUIPMENT CORPORATION
C NOV. 9, 1979
C
C This subroutine will permit graphs to be drawn given
C a few arguments.
C
C NOTE: If shading is desired then the GRSHAD subroutine
C should be used
C
C IBUF Is the information buffer dimensioned by the
C user for 30 words.
C
C MODE Included for compatability with GRPNTM
C
C X Is the coordinate for the X-axis.
C
C Y Is the coordinate for the Y-axis.
C
C
C IGR Is the graph number (0/1) for plotting, the default is 0.
C
C NOTE: All arguments are needed, either by default or by user
C definition. If any are missing, a system error may occur.
C
DIMENSION IBUF(30),TEMP(4),ITEMP(4),IRB(2,3),IB(2)
INTEGER CMD(6),ENTRGR(2),EXITGR(2),IGCODE(2)
EQUIVALENCE (TEMP(1),ITEMP(1)) !THIS IS TO PROVIDE A QUICK MEANS
EQUIVALENCE (TEMP(1),XMIN) !OF GETTING SCALED VALUES FROM
EQUIVALENCE (TEMP(2),XMAX) !FROM IBUF INTO THE APPROPRIATE
EQUIVALENCE (TEMP(3),YMIN) !REAL VARIABLES
EQUIVALENCE (TEMP(4),YMAX)
DATA IRB/239,150,129,50,239,50/ !REGION BOUNDS
DATA ENTRGR/"33,'1'/
DATA EXITGR/"33,'2'/
DATA IGCODE/'B','J'/
DATA IB/10,18/
F(Z,ZMAX,ZMIN)=(Z-ZMIN)/(ZMAX-ZMIN) !ARITH. STAT. SUBROUTINE
C
C BEGINNING OF EXECUTABLE CODE
C
C CALL IDFLT(IGRAPH,0,IGR) !CHECK FOR DEFAULT ON GRAPH #
IGRAPH = IGR
C (Defaults not allowed 10/20)
IF((IGRAPH.EQ.0).OR.(IGRAPH.EQ.1))GOTO 1 !IGRAPH OK?
write (5,1000)
1000 FORMAT(' ?GRPNTS - invalid graph number, must be 0/1')
CALL EXIT
C
1 IF(IBUF(27).EQ."52525)GOTO 4 !GRINIT CALLED?
write (5,1001)
1001 FORMAT(' ?GRPNTS - GRINIT not called')
CALL EXIT
C
4 IRGN=IBUF(8+IGRAPH)
IF(IRGN.NE.-1)GOTO 3 !FIND WHICH REGION IS BEING PLOTTED
write (5,1002)
1002 FORMAT(' ?GRPNTS - graph not assigned to region')
CALL EXIT
C
C3 CALL IDFLT(IMODE,0,MODE) !CHECK DEFAULT ON MODE
3 IMODE = MODE
C (Defaults not allowed 10/20)
C
C GET SCALING VALUES FOR X AND Y AXIS
C
IBASE=IB(IGRAPH+1)
10 IF(IBUF(2+IGRAPH).NE.0)GOTO 12 !HAVE SCALED VALUES BEEN ENTERED?
write (5,1003)
1003 FORMAT(' ?GRPNTS - scaling has not been provided for graph')
CALL EXIT
C
12 DO 15 I=1,4
15 ITEMP(I)=IBUF(IBASE+I) !GET SCALED VALUES FROM IBUF
C
C (40) NOW LOAD GRAPHICS
C
40 IF((IBUF(4).AND.1).NE.0)GOTO 45 !DISPLAY GRAPHICS ENABLED?
IBUF(4)=IBUF(4).OR.1
45 CALL OUTSTR (ENTRGR,2) !ENTER GRAPHICS MODE
I=2 !ENABLE GRAPHICS FOR APPROPRIATE GRAPH
IF(IGRAPH.EQ.1)I=4
IF((IBUF(4).AND.I).NE.0)GOTO 50 !SKIP OVER THE NEXT FEW LINES
C !IF THE GRAPH ENABLE IS DONE
IBUF(4)=IBUF(4).OR.I !SET BITS
CMD(1)='A'
CMD(2)=IBUF(4)
CMD(3)=IBUF(5)
CALL OUTSTR (CMD,3) !SET UP REGISTER IN VT105
C
C NOW (FINALLY) PUT UP THE POINT
C
50 RANGE=IRB(1,IRGN)-IRB(2,IRGN) !# OF DOTS ON Y-AXIS
IX=INT(F(X,XMAX,XMIN)*511.)
C
C CHECK FOR X OUT OF RANGE
C
IF(IX.LT.0)IX=0
IF(IX.GT.511)IX=511
C
CMD(1)='H'
CMD(2)=32+("37 .AND. IX)
CMD(3)=32+(("740 .AND. IX)/32)
IY=F(Y,YMAX,YMIN)*RANGE
IF(((IX/128)*128) .EQ. IX)IY=0 !LEAVE TICK MARKS ALONE
IY=IY+IRB(2,IRGN) !ADD OFFSET FOR BOTTOM OF GRAPH
C
C CHECK FOR Y OUT OF RANGE
C
IF(IY.GT.IRB(1,IRGN))IY=IRB(1,IRGN)
IF(IY.LT.IRB(2,IRGN))IY=IRB(2,IRGN)
C
CMD(4)=IGCODE(IGRAPH+1)
CMD(5)=32+("37 .AND. IY)
CMD(6)=32+(("340 .AND. IY)/32)
CALL OUTSTR (CMD,6)
CALL OUTSTR (EXITGR,2) !EXIT GRAPHICS MODE
RETURN
END
SUBROUTINE GRSHAD(IBUF,SHADE,IGR)
C
C
C J. LISCOUSKI DIGITAL EQUIPMENT CORPORATION
C NOV. 9, 1979
C
C GRSHAD permits the user to set the shade line, or change it for
C any of the graph modes. It must be used if shading in
C point plot mode is desired.
C
C SHADE Is the point on the vertical axis (expressed in user values)
C at which shading is to be done. The default is the bottom
C of the graph.
C
C IGR Is the graph number (0/1) for plotting, the default is 0.
C
C NOTE: All arguments are needed, either by default or by user
C definition. If any are missing, a system error may occur.
C
DIMENSION IBUF(30),TEMP(4),ITEMP(4),IRB(2,3),IB(2)
INTEGER CMD(10)
EQUIVALENCE (TEMP(1),ITEMP(1)) !THIS IS TO PROVIDE A QUICK MEANS
EQUIVALENCE (TEMP(1),XMIN) !OF GETTING SCALED VALUES FROM
EQUIVALENCE (TEMP(2),XMAX) !FROM IBUF INTO THE APPROPRIATE
EQUIVALENCE (TEMP(3),YMIN) !REAL VARIABLES
EQUIVALENCE (TEMP(4),YMAX)
DATA IRB/239,150,129,50,239,50/ !REGION BOUNDS
DATA CMD/"33,'1','A',0,0,'@',0,0,"33,'2'/
DATA IB/10,18/
F(Z,ZMAX,ZMIN)=(Z-ZMIN)/(ZMAX-ZMIN) !ARITH. STAT. SUBROUTINE
C
C BEGINNING OF EXECUTABLE CODE
C
C CALL IDFLT(IGRAPH,0,IGR) !CHECK FOR DEFAULT ON GRAPH #
IGRAPH = IGR
C (Defaults not allowed 10/20)
IF((IGRAPH.EQ.0).OR.(IGRAPH.EQ.1))GOTO 1 !IGRAPH OK?
write (5,1000)
1000 FORMAT(' ?GRSHAD - invalid graph number, must be 0/1')
CALL EXIT
C
1 IF(IBUF(27).EQ."52525)GOTO 4 !GRINIT CALLED?
write (5,1001)
1001 FORMAT(' ?GRSHAD - GRINIT not called')
CALL EXIT
C
4 IRGN=IBUF(8+IGRAPH)
IF(IRGN.NE.-1)GOTO 3 !FIND WHICH REGION IS BEING PLOTTED
write (5,1002)
1002 FORMAT(' ?GRSHAD - graph not assigned to region')
CALL EXIT
C
C3 CALL IDFLT(IMODE,0,MODE) !CHECK DEFAULT ON MODE
3 IMODE = MODE
C (Defaults not allowed 10/20)
C
C GET SCALING VALUES FOR X AND Y AXIS
C
IBASE=IB(IGRAPH+1)
10 IF(IBUF(2+IGRAPH).NE.0)GOTO 12 !HAVE SCALED VALUES BEEN ENTERED?
write (5,1003)
1003 FORMAT(' ?GRSHAD - scaling has not been provided for graph')
CALL EXIT
C
12 DO 15 I=1,4
15 ITEMP(I)=IBUF(IBASE+I) !GET SCALED VALUES FROM IBUF
C30 CALL DFLTCK(SHADEL,YMIN,SHADE) !CKECK FOR DEFAULT ON SHADE LINE
30 SHADEL = SHADE
C (Defaults not allowed 10/20)
I=2
IF(IGRAPH.EQ.1)I=4 !SHADE APPROPRIATE GRAPH
IBUF(5)=((IBUF(5).OR.I).OR.IGRAPH) !SET BITS FOR SHADING
Y1=F(SHADEL,YMAX,YMIN)*FLOAT(IRB(1,IRGN)-IRB(2,IRGN))
IY=Y1+IRB(2,IRGN)
C
C CHECK FOR SHADELINE OUT OF RANGE OF REGION BOUNDS, IF OUT OF
C RANGE SET IT TO THE LIMITS OF THE REGION
C
IF(IY.GT.IRB(1,IRGN))IY=IRB(1,IRGN)
IF(IY.LT.IRB(2,IRGN))IY=IRB(2,IRGN)
C
CMD(7)=32+(IY.AND."37)
CMD(8)=32+((IY.AND."340)/32)
CMD(4)=IBUF(4) !LOAD REGISTER INFORMATION
CMD(5)=IBUF(5)
CALL OUTSTR (CMD,10) !SEND SHADING INFORMATION
RETURN
END
SUBROUTINE VTROLL(ITOP,IBOT)
C
C FUNCTION: sets the VT100 scroll area
C ARGUMENTS: ITOP is the top of the roll area
C IBOT is the bottom of the roll area
C If IBOT <= ITOP the routine will return with no action
C
INTEGER CHAR(8)
DATA CHAR/27,'[',0,0,';',0,0,'r'/
IF (IBOT .LE. ITOP)RETURN
ENCODE(2,10,CHAR(3))ITOP
10 FORMAT(I2)
ENCODE(2,10,CHAR(6))IBOT
IF (CHAR(3).EQ.' ')CHAR(3)=0
IF (CHAR(6).EQ.' ')CHAR(6)=0
CALL OUTSTR(CHAR,8)
RETURN
END
SUBROUTINE VTERAS(IARG)
C
C FUNTION: erase all or a portion of the screen
C ARGUMENTS: IARG =0 erase from cursor to end of screen
C =1 erase from start of screen to cursor
C =2 erase entire screen and reset to single width
C
INTEGER CHAR(4)
DATA CHAR/27,'[',0,'J'/
IF ((IARG .LT. 0).OR.(IARG .GT. 2))RETURN
CHAR(3)=IARG+"60
CALL OUTSTR(CHAR,4)
RETURN
END
SUBROUTINE VTMCUR(IROW,ICOL)
C
C FUNCTION: position the cursor to a particular row and column
C ARGRUMENTS: IROW the row position
C ICOL the column position
C the validity of the position is not checked
C
INTEGER CHAR(9)
DATA CHAR/27,'[',0,0,';',0,0,0,'H'/
IR=IROW/10
ENCODE(1,10,CHAR(3))IR
IR=IROW-(IR*10)
ENCODE (1,10,CHAR(4)) IR
10 FORMAT(1I1)
IC100=ICOL/100
IC10=(ICOL-(IC100*100))/10
IC1=ICOL-(IC100*100)-(IC10*10)
ENCODE(1,10,CHAR(6))IC100
ENCODE(1,10,CHAR(7))IC10
ENCODE(1,10,CHAR(8))IC1
20 CALL OUTSTR (CHAR,9)
RETURN
END
SUBROUTINE VTHOME
C
C moves the cursor to the home position
C
INTEGER CHAR(4)
DATA CHAR/27,'[',';','H'/
CALL OUTSTR(CHAR,4)
RETURN
END
SUBROUTINE VTHTXT(IDSPLY,IROW,ICOL,ITEXT)
C
C FUNCTION:: Prints the string contained in ITEXT with
C the first character at IROW,ICOL in a
C display mode governed by IDSPLY
C ARGUMENTS::
C IDSPLY (in order to invoke combination of options
C use the sum of the codes)
C 0 NO EFFECT
C 1 BOLD
C 2 UNDERSCORE
C 4 BLINK
C 8 REVERSE
C
C IROW and ICOL are the row and column for the first character
C ITEXT is a byte array containing the data (which must be
C terminated by a null character), or a quoted literal
C
INTEGER CHAR(4), C(8), ITEXT(1)
DATA CHAR/27,'[',"60,'m'/
CALL VTMCUR(IROW,ICOL)
I=0
IFLAG=0
IF (IDSPLY .EQ. 0)GOTO 5
CALL OUTSTR (CHAR,2)
IF ((IDSPLY.AND.1) .EQ. 0)GOTO 1
IFLAG=1
C(1)="61
I=2
1 IF ((IDSPLY.AND.2) .EQ. 0)GOTO 2
IF (IFLAG.EQ.1) C(I) = ';'
IFLAG=1
C(I+1) = "64
I = I + 2
2 IF ((IDSPLY.AND.4) .EQ. 0)GOTO 3
IF(IFLAG.EQ.1) C(I) = ';'
IFLAG=1
C(1+1) = "65
I = I + 2
3 IF ((IDSPLY.AND.8) .EQ. 0)GOTO 4
IF(IFLAG.EQ.1) C(I) = ';'
C(I+1) = "67
I = I + 2
4 C(I) = 'm' !TERMINATE LIST
CALL OUTSTR (C,I)
5 CALL OUTSTR (ITEXT, -1)
CALL OUTSTR (CHAR,4)
RETURN
END
SUBROUTINE VTLED(IARG)
C
C FUNCTION: Allow the user to control the led display on the
C keyboard
C ARGUMENTS: A single integer argument is used, and, depending
C
C on the value of the argument can cause the following
C IARG FUNCTION
C 0 ALL LEDS OFF
C 1 LED #1 ON
C 2 LED #2 ON
C 3 LED #3 ON
C 4 LED #4 ON
C
C ANY OTHER VALUES WILL BE IGNORED
C
INTEGER CHAR(6)
DATA CHAR/27,'[',0,'q',0,0/
IF((IARG.LT.0) .OR. (IARG.GT.4))RETURN
CHAR(3)="60+IARG
CALL OUTSTR(CHAR,6)
RETURN
END
SUBROUTINE VTDBLW(IROW,IARG)
C
C FUNCTION: switches a line to double width/single width depending
C on iarg
C ARGUMENTS: IARG: if =0 single width
C if =1 double width
C
INTEGER C0(5),C1(5)
DATA C0/27,'#','5',27,'8'/
DATA C1/27,'#','6',27,'8'/
IF ((IARG .LT. 0) .OR. (IARG .GT. 1))RETURN
CALL VTSAVC
CALL VTMCUR(IROW,1)
IF (IARG .EQ. 1)GOTO 1
CALL OUTSTR(C0,5)
GOTO 2
1 CALL OUTSTR(C1,5)
2 RETURN
END
SUBROUTINE VT80C
C
C subroutine to set VT100 to 80 column mode
C
C calling sequence: CALL VT80C
C
C
INTEGER CHAR(5)
DATA CHAR/27,'[','?','3','l'/
CALL OUTSTR(CHAR,5)
RETURN
END
SUBROUTINE VT132C
C
C subroutine to set VT100 to 132 column mode
C
C calling sequence: CALL VT132C
C
INTEGER CHAR(5)
DATA CHAR/27,'[','?','3','h'/
CALL OUTSTR(CHAR,5)
RETURN
END
SUBROUTINE VTJUMP
C
C subroutine to set VT100 to jump mode
C
C calling sequence: CALL VTJUMP
C
INTEGER CHAR(5)
DATA CHAR/27,'[','?','4','l'/
CALL OUTSTR(CHAR,5)
RETURN
END
SUBROUTINE VTSCRL
C
C subroutine to set VT100 to jump mode
C
C calling sequence: CALL VTSCRL
C
INTEGER CHAR(5)
DATA CHAR/27,'[','?','4','h'/
CALL OUTSTR(CHAR,5)
RETURN
END
SUBROUTINE VTBRIT
C
C subroutine to give the terminal a light background
C
C calling sequence: CALL VTBRIT
C
INTEGER CHAR(5)
DATA CHAR/27,'[','?','5','h'/
CALL OUTSTR(CHAR,5)
RETURN
END
SUBROUTINE VTDARK
C
C subroutine to give the terminal a dark background
C
C calling sequence: CALL VTDARK
C
INTEGER CHAR(5)
DATA CHAR/27,'[','?','5','l'/
CALL OUTSTR(CHAR,5)
RETURN
END
SUBROUTINE VTELIN(IARG,LINE)
C
C FUNCTION: Erase all or part of a line depending on the value of
C IARG:
C
C IARG FUNCTION
C
C 0 erase form the active postion to the
C end of the line, inclusive
C 1 erase from start of the line to the
C active position, inclusive
C 2 erase all of the line inclusive
C
C NOTE: 1) The argument line (indicating the line to be cleared) is valid
C only for IARG=2, the cursor will remain in the original
C position
C 2) The routine will effect the line that the cursor is on when
C the VTELIN call was made for IARG of 0 or 1.
C
INTEGER CHAR(4),CHAR1(6)
EQUIVALENCE (CHAR(1),CHAR1(1))
DATA CHAR1/27,'[',0,'K',27,'8'/
IF ((IARG.LT.0) .OR. (IARG.GT.2))RETURN
IF (IARG .EQ. 2)GOTO 100
CHAR(3)=IARG+"60
CALL OUTSTR(CHAR,4)
RETURN
100 CALL VTSAVC
CALL VTMCUR(LINE,1)
CHAR(3)='2'
CALL OUTSTR(CHAR1,6)
END
SUBROUTINE VT52
C
C The purpose of the is routine is to put the scope in VT52 mode
C
INTEGER CHAR(5)
DATA CHAR/27,'[','?','2','l'/
CALL OUTSTR(CHAR,5)
RETURN
END
SUBROUTINE VT100
C
C Set the scope in VT100 ANSI mode
C
INTEGER CHAR(2)
DATA CHAR/27,'<'/
CALL OUTSTR(CHAR,2)
RETURN
END
SUBROUTINE VTMODE(IDSPLY)
C
C FUNCTION:: prints text with in a
C display mode governed by IDSPLY
C ARGUMENTS::
C IDSPLY (in order to invoke combination of options
C use the sum of the codes)
C
C 0 RESETS TO NORMAL
C 1 BOLD
C 2 UNDERSCORE
C 4 BLINK
C 8 REVERSE
C
C
INTEGER C(10), C0(4)
EQUIVALENCE (C,C0)
DATA C0/27,'[','0','m'/
CALL OUTSTR(C0,4)
IFLAG=0
IF (IDSPLY .EQ. 0)GOTO 100
I = 3
IF ((IDSPLY.AND.1) .EQ. 0)GOTO 1
IFLAG=1
C(3)="61
I = 4
1 IF ((IDSPLY.AND.2) .EQ. 0)GOTO 2
IF (IFLAG.EQ.1) C(I) = ';'
IFLAG=1
C(I+1) = "64
I = I + 2
2 IF ((IDSPLY.AND.4) .EQ. 0)GOTO 3
IF(IFLAG.EQ.1) C(I) = ';'
IFLAG=1
C(I+1)="65
I = I + 2
3 IF ((IDSPLY.AND.8) .EQ. 0)GOTO 4
IF(IFLAG.EQ.1) C(I) = ';'
C(I+1)="67
I = I + 2
4 C(I) = 'm' !TERMINATE LIST
CALL OUTSTR(C,I)
100 RETURN
END
SUBROUTINE SPLPLT(IBUF, N, X, Y, NUMB, IPLOT, YMIN, YMAX,
1 XINC, MODE, IGRAPH)
C
C SPLPLT - SPLINE PLOT - IS A COMBINATION OF MAX/MIN ROUTINE
C AND PLOTTING ROUTINE
C IBUF - THE INFORMATION BUFFER FOR PLOTTING
C N - THE NUMBER OF POINT IN THE X AND Y DATA ARRAYS
C X - THE DATA FOR THE INDEPENDENT VARIABLE IN ASCENDING ORDER
C Y - THE CORRESPONDING DATA FOR THE DEPENDENT VARIABLE
C NUMB - THE SIZE OF THE WINDOW FOR THE SPLINE FIT
C MUST BE LESS THAN OR EQUAL TO 20 AND > 3
C IPLOT- IF EQUAL TO 0 THEN NO PLOTTING, OTHERWISE PLOT DATA
C YMIN - MIN OF SPLINED DATA ->>>>>> RETURNED BY SUBROUTINE <<<<<<<
C YMAX - MAX OF SPLINED DATA ->>>>>> RETURNED BY SUBROUTINE <<<<<<<
C XINC - THE STEP SIZE TO BE USED FOR THE X AXIS
C
DIMENSION IBUF(30),X(1),Y(1),SC(20),EL(20),A(20),B(20),C(20)
IF(NUMB .LE. 20)GOTO 5
WRITE(5,1)
1 FORMAT(' ** SPLSCL -- NUMB TOO BIG **')
RETURN
5 IFLAG=0
IBASE=0 !BEGINNING OF MOVING WINDOW FOR SPLINE FIT
NPTS=NUMB !SIZE OF MOVING WINDOW
INTVAL=(NPTS/2) !BIGIN INTERPOLATION INTERVAL
C
C THE FOLLOWING CODE DOES A MOVING WINDOW (NPTS WIDE) SPLINE FIT TO
C THE DATA AND PLOTS THE RESULTS OVER EACH DATA INTERVAL.
C THE DATA IS EVALUATED OV THE MIDDLE INTERVAL OF EACH WINDOW
C
32 IBASE=IBASE+1 !INCREMENT START OF WINDOW
IF(IBASE .GT. 1)GOTO 38
C
C THIS SECTION OF CODE EVALUATES THE DATA OVER THE INITIAL SECTION OF
C THE DATA. THAT REGION FROM THE FIRST DATA POINT TO THE END OF THE
C X(INTVAL+1) DATA ELEMENT
C
CALL SPFIT(NPTS,X(IBASE),Y(IBASE),SC,EL,A,B,C)
XPOS=X(IBASE)-XINC
33 XPOS=XPOS+XINC
IF(XPOS .GE. X(IBASE+INTVAL+1))GOTO 32
CALL SPGET(NPTS,X(IBASE),Y(IBASE),SC,EL,XPOS,YY,YP,YDP)
IF(IFLAG .NE. 0) GOTO 34
YMIN=YY
YMAX=YY
IFLAG=1
34 IF(YY .GT. YMAX)YMAX=YY
IF(YY .LT. YMIN)YMIN=YY
IF(IPLOT .NE. 0)CALL GRPNTS(IBUF,MODE,XPOS,YY,IGRAPH)
GOTO 33
C
C THIS SECTION OF CODE EVALUATES THE DATA BETWEEN THE
C END POINTS, BUT NOT INCLUDING THE END POINTS
C
38 IF((IBASE+(NPTS-1)).LE. N)GOTO 50 !ENOUGH DATA FOR WINDOW
NPTS=N-IBASE+1
CALL SPFIT(NPTS,X(IBASE),Y(IBASE),SC,EL,A,B,C) !SPLINE FIT
XPOS=X(IBASE+INTVAL)-XINC
39 XPOS=XPOS+XINC
IF(XPOS .GT. X(N))GOTO 100 !END OF DATA
CALL SPGET(NPTS,X(IBASE),Y(IBASE),SC,EL,XPOS,YY,YP,YDP)
IF(IFLAG .NE. 0)GOTO 40
YMIN=YY
YMAX=YY
IFLAG=1
40 IF(YY .GT. YMAX)YMAX=YY
IF(YY .LT. YMIN)YMIN=YY
IF(IPLOT .NE. 0)CALL GRPNTS(IBUF,MODE,XPOS,YY,IGRAPH)
GOTO 39
C
C THIS LAST SECTION OF CODE TAKES CARE OF THE END OF THE DATA
C
50 CALL SPFIT(NPTS,X(IBASE),Y(IBASE),SC,EL,A,B,C)
XPOS=X(IBASE+INTVAL)-XINC
55 XPOS=XPOS+XINC
IF(XPOS .GT. X(IBASE+INTVAL+1))GOTO 32 !DONE WITH THIS WINDOW
CALL SPGET(NPTS,X(IBASE),Y(IBASE),SC,EL,XPOS,YY,YP,YDP)
IF(IFLAG .NE. 0)GOTO 60
YMIN=YY
YMAX=YY
IFLAG=1
60 IF(YY .GT. YMAX)YMAX=YY
IF(YY .LT. YMIN)YMIN=YY
IF(IPLOT .NE. 0)CALL GRPNTS(IBUF,MODE,XPOS,YY,IGRAPH)
GOTO 55
100 RETURN
END
SUBROUTINE SPGET(N,X,F,Y,EL,AX,AF,APR,ADPF)
C
C THE SUBROUTINES IN THIS FILE ARE TAKEN FROM
C A PAPER BY R.F. DAVIS, "SPLINE CURVE FIT FUNCTIONS,
C THEIR DERIVATION AND USE"
C JULY 23, 1968
C
DIMENSION X(1),Y(1),F(1),EL(1)
K=2
84 IF(AX-X(K))83,83,85
85 IF(AX-X(N))87,87,88
87 K=K+1
GOTO 84
88 K=N
83 KK=K-1
FF=Y(KK)*(X(K)-AX)**3/(6.*EL(K))+Y(K)*(AX-X(KK))**3/(6.*EL(K))
AF=FF+(F(K)/EL(K)-Y(K)*EL(K)/6.0)*(AX-X(KK))
BF=(F(KK)/EL(K)-Y(KK)*EL(K)/6.0)*(X(K)-AX)
AF=AF+BF
BF=Y(K)*(AX-X(KK))**2/(2.*EL(K))-Y(KK)*(X(K)-AX)**2/(2.*EL(K))
BF=BF+(F(K)-F(KK))/EL(K)-EL(K)*(Y(K)-Y(KK))/6.0
APF=BF
BF=Y(KK)*(X(K)-AX)/EL(K)+Y(K)*(AX-X(KK))/EL(K)
ADPF=BF
RETURN
END
SUBROUTINE SPFIT(N,X,F,Y,EL,A,B,C)
DIMENSION X(1),Y(1),F(1),EL(1),A(1),B(1),C(1)
JJ=N-1
MM=N-2
KK=N-3
DO 1 I=1,JJ
K=I+1
1 EL(K)=X(K)-X(I)
DO 2 I=1,MM
Y(I)=(F(I+2)-F(I+1))/EL(I+2)-(F(I+1)-F(I))/EL(I+1)
B(I)=(EL(I+1)+EL(I+2))/3.0
A(I)=EL(I+1)/6.0
2 C(I)=EL(I+2)/6.0
C(1)=C(1)/B(1)
DO 3 I=2,MM
B(I)=B(I)-A(I)*C(I-1)
3 C(I)=C(I)/B(I)
B(1)=Y(1)/B(1)
DO 4 I=2,MM
4 B(I)=(Y(I)-A(I)*B(I-1))/B(I)
Y(MM)=B(MM)
K=KK
DO 5 I=2,MM
Y(K)=B(K)-C(K)*Y(K+1)
5 K=K-1
K=JJ
DO 6 I=1,MM
Y(K)=Y(K-1)
6 K=K-1
Y(1)=0.0
Y(N)=0.0
RETURN
END
SUBROUTINE VTSAVC
INTEGER SAVE(2)
DATA SAVE/27,'7'/
CALL OUTSTR(SAVE,2)
RETURN
END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
SUBROUTINE VTCLR
INTEGER MSG(27)
DATA MSG/27,'1','A',' ',' ','I','0',' ',27,'2',27,
1'[','1',';','2','4','r',27,'[','1',';','1','H',27,
2'[','2','J'/
CALL OUTSTR(MSG,27)
RETURN
END