SUBROUTINE AXIS(BLOW,BHIGH,MAXTKS,LSHORT,LRAGGD,BMIN,BMAX, 1 BTMIN,BTMAX,BTICK,IPWR) LOGICAL*1 LSHORT, LRAGGD C C THIS SUBROUTINE IS MAINLY FOR INTERNAL USE, C ITS FUNCTION IS TO DETERMINE A SUITABLE C "TICK" DISTANCE OVER THE RANGE SPECIFIED BETWEEN C ALOW AND AHIGH. IT OUTPUTS THE AXIS RANGE BMIN,BMAX C AND THE TICK DISTANCE BTICK STRIPPED OF THEIR POWER OF C TEN. THE POWER OF TEN IS RETURNED IN THE VAR. IPWR. C DIMENSION JTICKS(6) LOGICAL LDIVDS LOGICAL*1 LISNEG C C IF A RAGGED AXIS IS "TOO CLOSE" TO THE NEXT TICK, THEN EXTEND IT. C THE "TOO CLOSE" PARAMETER IS THE VARIABLE TOOCLS C DATA TOOCLS /0.8/ C DATA FUZZ /0.001/ DATA JTICKS /1,2,5,4,3,10/ C C MAXTKS = MAX0(1,MAXTKS) MINTKS = MAX0(1,MAXTKS/2) BMAX = BHIGH BMIN = BLOW LISNEG = .FALSE. IF (BMAX .GE. BMIN) GO TO 30 BMAX = BLOW BMIN = BHIGH LISNEG = .TRUE. C C MAKE SURE WE HAVE ENOUGH RANGE, IF NOT, INCREASE AHIGH C 30 RANGE = BMAX - BMIN TEMP = AMAX1(ABS(BMIN),ABS(BMAX)) IF (TEMP .EQ. 0.0) TEMP = 10.0 IF (RANGE/TEMP .GE. 5.0E-3) GO TO 40 BMIN = BMIN - 5.0E-3*TEMP BMAX = BMAX + 5.0E-3*TEMP 40 CONTINUE C C STRIP THE RANGE OF ITS POWER OF TEN C IPWR=ALOG10(BMAX-BMIN)-2 50 TENX = 10.0**IPWR ASTRT = AINT(BMIN/TENX) AFIN = AINT(BMAX/TENX+0.999) IF (AFIN*TENX .LT. BMAX) AFIN = AFIN + 1 RANGE = AFIN - ASTRT IF (RANGE .LE. 10*MAXTKS) GO TO 75 IPWR = IPWR + 1 GO TO 50 75 CONTINUE C C SEARCH FOR A SUITABLE TICK C D TYPE 9999, BMIN, ASTRT, BMAX, AFIN, TENX D9999 FORMAT(/' AXIS DEBUG'/' DATA STRIPPED'/ D 1 2(1X,G14.7,2X,G14.7/)/' POWER = ',G14.7) BTICK = 0 DO 100 I=1,6 TICK = JTICKS(I) NTICK = RANGE/TICK+0.999 IF (NTICK .LT. MINTKS .OR. NTICK .GT. MAXTKS) GO TO 100 IF (LDIVDS(ASTRT,TICK) .AND. LDIVDS(AFIN,TICK)) GO TO 150 IF (BTICK .EQ. 0) BTICK = TICK 100 CONTINUE C C USE BEST NON-PERFECT TICK C GO TO 160 C C FOUND A GOOD TICK C 150 BTICK=JTICKS(I) 160 CONTINUE IF (BTICK .NE. 10.0) GO TO 165 BTICK = 1.0 IPWR = IPWR + 1 TENX = 10.0*TENX 165 TICK = BTICK*TENX C C FIGURE OUT TICK LIMITS C BTMIN = BTICK*AINT(BMIN/TICK) IF (BTMIN*TENX .LT. BMIN) BTMIN = BTMIN + BTICK BTMAX = BTICK*AINT(BMAX/TICK) IF (BTMAX*TENX .GT. BMAX) BTMAX = BTMAX - BTICK NINTVL = (BTMAX-BTMIN)/BTICK C C IF USER ABSOLUTELY MUST HAVE RAGGED AXIS, THEN FORCE IT. C IF (LSHORT .AND. LRAGGD) GO TO 180 C C CHECK INDIVIDUALLY C IF (LSHORT .AND. (NINTVL .GT. 0) .AND. 1 ((BTMIN-BMIN/TENX)/BTICK .LE. TOOCLS) ) GO TO 170 IF ((BTMIN-BMIN/TENX) .GT. FUZZ) BTMIN = BTMIN - BTICK BMIN = BTMIN*TENX 170 CONTINUE IF (LSHORT .AND. (NINTVL .GT. 0) .AND. 1 ((BMAX/TENX-BTMAX)/BTICK .LE. TOOCLS) ) GO TO 180 IF ((BMAX/TENX-BTMAX) .GT. FUZZ) BTMAX = BTMAX + BTICK BMAX = BTMAX*TENX 180 CONTINUE IF (.NOT. LISNEG) GO TO 200 C SWITCH BACK TO BACKWARDS BTICK = -BTICK TEMP = BMIN BMIN = BMAX BMAX = TEMP TEMP = BTMIN BTMIN = BTMAX BTMAX = TEMP 200 RETURN END FUNCTION LDIVDS(ANUMER,ADENOM) LOGICAL LDIVDS IF (ANUMER/ADENOM .EQ. AINT(ANUMER/ADENOM)) GO TO 10 LDIVDS = .FALSE. RETURN 10 LDIVDS = .TRUE. RETURN END SUBROUTINE BARGRA(XLOW,XHIGH,NOBARS,IMXPTS,X, 1 SXLAB,SYLAB,STITLE,TYPE) C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C PROJECT NAME: GRAPHICS UTILITY C FILE NAME : BARGRA.FOR C ROUTINE NAME: BARGRA C ROUTINE TYPE: SUBROUTINE C LANGUAGE : COMPATIBLE FORTRAN C C VERSION : 1 C C ORIGINAL AUTHOR: JOE P GARBARINI JR C DATE : 02-JUL-82 C C MAINTAINER : HAL R BRAND L126 X26313 (DIGLIB V2 VERSION) C C REVISION: 0 C REVISION AUTHOR: C REVISION DATE : C REVISION NOTES : C C SUMMARY: C C This routine makes a bar graph (frequency graph) C from an array of real data. C C INPUT VARIABLES: C C XLOW : REAL*4 CONSTANT OR VARIABLE. C THE LOW LIMIT FOR THE X-AXIS. C MUST HAVE XLOW <= X(I) FOR ALL I. C XHIGH : REAL*4 CONSTANT OR VARIABLE. C THE HIGH LIMIT FOR THE X-AXIS. C MUST HAVE X(I) <= XHIGH FOR ALL I. C NOBARS: INTEGER CONSTANT OR VARIABLE. C THE NUMBER OF BARS TO DRAW. C 1 <= *NOBARS* <= 200 C SEE LOCAL VARIABLE *IMXC*. C IMXPTS: INTEGER CONSTANT OR VARIABLE. C THE DIMESION OF ARRAY *X*. C X : REAL*4 VARIABLE. C THE ARRAY OF REAL DATA TO GRAPH. C SXLAB : LOGICAL*1 CONSTANT OR VARIABLE. C THE X-AXIS LABLE. C SYLAB : LOGICAL*1 CONSTANT OR VARIABLE. C THE Y-AXIS LABLE. C STITLE: LOGICAL*1 CONSTANT OR VARIABLE. C THE TITLE. C TYPE : INTEGER CONSTANT OR VARIABLE. C THE AXIS FLAG. SEE *DIGLIB* DOCUMENTATION. C C OUTPUT VARIABLES: NONE C C INOUT VARIABLES: NONE C C COMMON VARIABLES: NONE C C LOCAL VARIABLES: SEE CODE. C C EXCEPTION HANDLING: NONE C C SIDE EFFECTS: NONE C C PROGRAMMING NOTES: C C This routine does all the calls to DIGLIB necessary C to do the plot EXCEPT for a call to DEVSEL. This C way the calling program can choose the device. C C DIGLIB's MAPIT routine uses its own rules for the C actual lowest and highest values on the axes. They C always include the users values. If you wish to move C the bar graph away from the left and/or (imaginary) right C y axis do the following: C C Let S = (XH - XL) / NOBARS where XH = max X(i) C and XL = min X(i). Now set XLOW = XL - N * S C XHIGH = XH + M * S where N,M are chosen at your discretion. C C MAKE SURE THAT XLOW <= X(I) <= XHIGH FOR ALL I. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C INTEGER IMXPTS,NOBARS,TYPE REAL*4 XLOW,XHIGH REAL*4 X DIMENSION X(IMXPTS) LOGICAL*1 SXLAB(20),SYLAB(20),STITLE(20) C INTEGER I,J,IMXC REAL*4 COUNT(200),STEP,FBAR,YLOW,YHIGH,X0,Y0,VX0,VX1 REAL*4 VY0,VY1,FIMX C IMXC = 200 YLOW = 0.0 YHIGH = 1.0 FBAR = FLOAT(NOBARS) C IF (XLOW .GE. XHIGH) GOTO 9999 IF (NOBARS .GT. IMXC) GOTO 9999 C STEP = (XHIGH - XLOW) / FBAR C DO 100 I = 1,NOBARS C COUNT(I) = 0.0 C 100 CONTINUE C DO 200 I = 1,IMXPTS C J = INT((X(I)-XLOW)/STEP)+1 IF (J .GT. NOBARS) J = NOBARS COUNT(J) = COUNT(J) + 1.0 C 200 CONTINUE C FIMX = FLOAT(IMXPTS) * STEP C DO 300 I = 1,NOBARS C COUNT(I) = COUNT(I) / FIMX C 300 CONTINUE C CALL MINMAX(COUNT,NOBARS,YLOW,YHIGH) YLOW = 0.0 YHIGH = YHIGH + 0.1 * YHIGH C CALL BGNPLT CALL MAPSIZ(0.0,100.0,0.0,100.0,0.0) CALL MAPIT(XLOW,XHIGH,YLOW,YHIGH,SXLAB,SYLAB,STITLE,TYPE) C X0 = XLOW Y0 = 0.0 CALL SCALE(X0,Y0,VX0,VY0) CALL GSMOVE(VX0,VY0) C DO 400 I = 1,NOBARS C X0 = XLOW + I * STEP Y0 = COUNT(I) CALL SCALE(X0,Y0,VX1,VY1) CALL GSDRAW(VX0,VY1) CALL GSDRAW(VX1,VY1) CALL GSDRAW(VX1,VY0) C VX0 = VX1 C 400 CONTINUE C CALL ENDPLT C 9999 CONTINUE C C BYE C RETURN END SUBROUTINE BGNPLT C C CALL GSDRVR(2,X,Y) RETURN END SUBROUTINE CLLINE(X1,Y1,X2,Y2) C C THIS SUBROUTINE DRAWS THE LINE FROM X1,Y1 TO X2,Y2 WITH C THE APPROPIATE CLIPPING C INCLUDE 'PLTSIZ.PRM' C DIMENSION AREA(4) C CALL GSSCLP(XVSTRT,XVSTRT+XVLEN,YVSTRT,YVSTRT+YVLEN,AREA) CALL SCALE(X1,Y1,VX,VY) CALL GSMOVE(VX,VY) CALL SCALE(X2,Y2,VX,VY) CALL GSDRAW(VX,VY) CALL GSRCLP(AREA) RETURN END SUBROUTINE CONTOR(Z,NZ,IZ,MX,MY,X1,XMX,Y1,YMY,NL,CL) C C THIS SUBROUTINE WILL PRODUCE A CONTOUR PLOT OF THE FUNCTION C DEFINED BY Z(I,J) = F(X(I),Y(J)). IT IS ASSUMED THAT C A CALL TO "MAPIT" HAS ALREADY BEEN MADE TO ESTABLISH THE C COORDINATE AXIS (X,Y), WITH X LIMITS COVERING THE RANGE C X1 TO XMX, AND Y LIMITS COVERING THE RANGE Y1 TO YMY. C CArguments: C C Input C C Z * Type: real array. C * The values of the function to contour: C Z(I,J) = F(Xi,Yj) where: C Xi = X1 + (i-1)*(XMX-X1)/(MX-1) C Yj = Y1 + (j-1)*(YMX-Y1)/(MY-1) C C MX * Type: integer constant or variable. C * The number of X grid points. C C X1 * Type: real constant or variable. C * The minimum X value. C C XMX * Type: real constant or variable. C * The maximum X value. C C MY * Type: integer constant or variable. C * The number of Y grid points. C C Y1 * Type: real constant or variable. C * The minimum Y value. C C YMY * Type: real constant or variable. C * The maximum Y value. C C NL * Type: integer constant or variable. C * The number of contour levels. C C CL * Type: real array. C * The coutour levels to draw. (Same units as C F() or Z().) C C IZ * Type: byte array. C * Used internally for working storage. C C NZ * Type: integer constant or variable. C * The first dimension of the array Z - not necessarily C equal to MX, but MX <= NZ. C C Output C C None. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DIMENSION Z(NZ,MY) DIMENSION CL(NL) BYTE IZ(MX,MY) COMMON /CONTR/ CLEVEL,IOLD,JOLD,IN,JN, 1 NX,NY,XL,DX,YL,DY C C INITIALIZE ROUTINE C XL = X1 YL = Y1 DX = XMX-X1 DY = YMY-Y1 NX=MX NY=MY NLOOP=MIN1(FLOAT(NX)/2.0+.5,FLOAT(NY)/2.0+.5) C START SEARCHING FOR PLUS-MINUS TRANSITIONS C TO START A CONTOR ON. DO 50 NC=1,NL C ZERO ARRAY SHOWING WHERE WE HAVE BEEN DO 1 I=1,NX DO 1 J=1,NY 1 IZ(I,J)=0 CLEVEL=CL(NC) DO 50 ICIR=1,NLOOP IU=NX+1-ICIR JU=NY+1-ICIR DO 10 J=ICIR,JU-1 10 CALL LOOK(Z,ICIR,J,1,IZ,NZ,NX) DO 20 I=ICIR,IU-1 20 CALL LOOK(Z,I,JU,2,IZ,NZ,NX) DO 30 J=JU,ICIR+1,-1 30 CALL LOOK(Z,IU,J,3,IZ,NZ,NX) DO 40 I=IU,ICIR+1,-1 40 CALL LOOK(Z,I,ICIR,4,IZ,NZ,NX) 50 CONTINUE RETURN END C C C SUBROUTINE LOOK(Z,II,JJ,M,IZ,NZ,IZDIM) BYTE IZ(IZDIM,2) DIMENSION Z(NZ,2) COMMON /CONTR/ CLEVEL,IOLD,JOLD,IN,JN, 1 NX,NY,XL,DX,YL,DY DIMENSION IDMODE(3,4) DATA IDMODE/4,1,2, 1,2,3, 2,3,4, 3,4,1/ IOLD=II JOLD=JJ MODE=M CALL NEWP(1,MODE) C LOOK FOR CONTOR STARTING HERE IF (Z(IOLD,JOLD) .GT. CLEVEL .AND. Z(IN,JN) .LE. CLEVEL) GOTO 20 100 RETURN C CHECK FOR CONTOR PREVIOUSLY THRU HERE 20 CALL SEGMNT(ICI,ICJ,ISEG) IF ((IZ(ICI,ICJ) .AND. ISEG) .NE. 0) RETURN CALL ZPNT(XX,YY,Z,NZ) CALL SCALE(XX,YY,VX,VY) CALL GSMOVE(VX,VY) IOLD=IN JOLD=JN 30 DO 50 N=2,4 CALL NEWP(N,MODE) IF (IN .LT. 1 .OR. IN .GT. NX) GO TO 100 IF (JN .LT. 1 .OR. JN .GT. NY) GO TO 100 IF (SIGN(1.0,Z(IOLD,JOLD)-CLEVEL) .NE. 1 SIGN(1.0,Z(IN,JN)-CLEVEL)) GO TO 60 IOLD=IN JOLD=JN 50 CONTINUE 60 CALL SEGMNT(ICI,ICJ,ISEG) IF ((IZ(ICI,ICJ) .AND. ISEG) .NE. 0) RETURN IZ(ICI,ICJ)=IZ(ICI,ICJ) .OR. ISEG CALL ZPNT(XX,YY,Z,NZ) CALL SCALE(XX,YY,VX,VY) CALL GSDRAW(VX,VY) MODE=IDMODE(N-1,MODE) GO TO 30 END C C C SUBROUTINE SEGMNT(ICI,ICJ,ISEG) COMMON /CONTR/ CLEVEL,IOLD,JOLD,IN,JN, 1 NX,NY,XL,DX,YL,DY ICI=MIN0(IOLD,IN) ICJ=MIN0(JOLD,JN) ISEG=1 IF (IOLD .EQ. IN) ISEG=2 RETURN END C C C SUBROUTINE NEWP(I,M) COMMON /CONTR/ CLEVEL,IOLD,JOLD,IN,JN, 1 NX,NY,XL,DX,YL,DY DIMENSION IDELI(4),JDELJ(4) DATA IDELI,JDELJ / 0,1,0,-1, 1,0,-1,0/ INDEX=MOD(2+I+M,4)+1 IN=IOLD+IDELI(INDEX) JN=JOLD+JDELJ(INDEX) RETURN END C C C SUBROUTINE ZPNT(X,Y,Z,NZ) DIMENSION Z(NZ,2) COMMON /CONTR/ CLEVEL,IOLD,JOLD,IN,JN, 1 NX,NY,XL,DX,YL,DY A=Z(IN,JN)-Z(IOLD,JOLD) C IF NO CHANGE IN Z'S, PICK OLD POINT SO AS TO STAY TO RIGHT IF (A .EQ. 0.0) GO TO 10 A=(CLEVEL-Z(IOLD,JOLD))/A 10 X=A*(IN-IOLD)+IOLD Y=A*(JN-JOLD)+JOLD C NOW CONVERT INDEXS TO X,Y VALUES X=(X-1.0)*DX/(NX-1)+XL Y=(Y-1.0)*DY/(NY-1)+YL RETURN END PROGRAM CONVERT C C This program converts a ASCII font file into the DIGLIB compressed C binary format. The default file type for input is .FNT and on C output, a .FON file is created. This utility is distributed with C DIGLIB for all those crazies who want to mess with the font files C and have sense enough to want to do it in ASCII. However, Hal makes C absolutely no guarentees about the usefully-ness or working condition C of this code. Also be pre-warned that if you increase the number C of strokes in the font files, you may soon have to fix GCFONT.CMN to C increase the size of the stroke table. C Finally, this thing uses some stuff that I don't distribute with C DIGLIB. You will have to fake it. Basically, SREPLY simple prompts C the user for a string, and supplies a default answer. It could be C simply replaced with appropiate TYPE and ACCEPT statements. C INTEGER IPTR(129) INTEGER BX(9),BY(9) BYTE BWIDTH(127) BYTE COORDS(10000) BYTE FILNAM(40) EXTERNAL INDEX C CALL SREPLY('Enter font file','BSCRPT.FNT',39,FILNAM,LL) IF (INDEX(FILNAM,'.') .EQ. 0) CALL CONCAT(FILNAM,'.FNT',FILNAM) OPEN (UNIT=1,NAME=FILNAM,TYPE='OLD',READONLY) MINCHAR = 9999 MAXCHAR = -9999 NEXT = 1 DO 5 I=1,129 BWIDTH(I) = -1 5 CONTINUE C C LOOP READING IN ALL CHARACTERS C 10 CONTINUE READ (1,11,END=900) JCHAR,NSTROKES,ILEFT,IRIGHT,(BX(I),BY(I), I=1,7) 11 FORMAT(18I4) IF (JCHAR .EQ. 0) GOTO 10 D TYPE *,'JCHAR IS ',JCHAR D IF (JCHAR .LE. 0 .OR. JCHAR .GT. 128) STOP 'CHARACTER OUT OF RANGE' MAXCHAR = MAX(JCHAR,MAXCHAR) MINCHAR = MIN(JCHAR,MINCHAR) IPTR(JCHAR) = NEXT IF (NSTROKES .LE. 0) GO TO 10 BWIDTH(JCHAR) = IRIGHT-ILEFT NSTROKES = (NSTROKES-2)/2 I = 1 MAXI = 7 100 CONTINUE IF (I .GT. MAXI) THEN READ (1,11) (BX(I),BY(I), I=1,9) I = 1 MAXI = 9 ENDIF IF (NSTROKES .GT. 1) THEN IF (BX(I) .EQ. -999) THEN D IF (BY(I) .EQ. -999) STOP 'ERROR - DOUBLE -999' COORDS(NEXT) = -64 ELSE COORDS(NEXT) = BX(I) - ILEFT NEXT = NEXT + 1 COORDS(NEXT) = BY(I) + 9 ENDIF NEXT = NEXT + 1 ENDIF I = I + 1 NSTROKES = NSTROKES-1 IF (NSTROKES .GT. 0) GO TO 100 GO TO 10 900 CONTINUE CLOSE (UNIT=1) IPTR(128) = NEXT I = IPTR(65)-1 905 CONTINUE I = I + 1 IF (I .GE. IPTR(66)) GO TO 907 IF (COORDS(I) .EQ. -64) GO TO 905 I = I + 1 J = COORDS(I) MAXHEIGHT = MAX(MAXHEIGHT,J) GO TO 905 907 CONTINUE ITOTAL_BYTES = NEXT -1 TYPE 901, MINCHAR,MAXCHAR,MAXHEIGHT,ITOTAL_BYTES 901 FORMAT(//' MINIMUM CHARACTER CODE WAS ',I5, 1 /' MAXIMUM CHARACTER CODE WAS ',I3, 2 /' HEIGHT OF "A" IS ',I3, 3 /' TOTAL NUMBER OF BYTES IN STROKE TABLE IS ',I5//) I = INDEX(FILNAM,'.') FILNAM(I) = 0 CALL CONCAT(FILNAM,'.FON',FILNAM) IBLOCKS = 1+(ITOTAL_BYTES+511)/512 OPEN (UNIT=2,NAME=FILNAM,TYPE='NEW',ACCESS='DIRECT', 1 FORM='UNFORMATTED',RECORDTYPE='FIXED',RECORDSIZE=128, 2 INITIALSIZE=IBLOCKS) WRITE (2'1) ITOTAL_BYTES, MAXHEIGHT, (IPTR(I), I=33,128), 1 (BWIDTH(I), I=33,127) DO 910 I=1,IBLOCKS-1 WRITE (2'I+1) (COORDS(J), J=1+512*(I-1),512*I) 910 CONTINUE CLOSE (UNIT=2) STOP END FUNCTION CSZMAP() INCLUDE 'PLTPRM.PRM' C C RETURN CHARACTER SIZE MAP USED/WILL USE C CSZMAP = CYSIZE RETURN END SUBROUTINE CURSOR(X,Y,KEY) BYTE KEY C C DISPLAY AND READ THE GRAPHICS CURSOR AND RETURN ITS POSITION C IN USER COORDINATES. C INCLUDE 'PLTCOM.PRM' INCLUDE 'PLTSIZ.PRM' C C GET CURSOR POSITION IN VIRTUAL COORDINATES. C CALL GSGIN(X,Y,KEY,IERR) IF (IERR .GE. 0) GO TO 50 X = XVSTRT Y = YVSTRT 50 X = (X-XVSTRT)*UDX/XVLEN + UX0 IF (LOGX) X = 10.0**X Y = (Y-YVSTRT)*UDY/YVLEN + UY0 IF (LOGY) Y = 10.0**Y RETURN END SUBROUTINE CURVE(X,Y,NPTS,ISYMNO,SYMSIZ,NPBSYM) DIMENSION X(NPTS), Y(NPTS) C C THIS SUBROUTINE TRACES THE LINE FROM X(1),Y(1) TO C X(NPTS),Y(NPTS) WITH APPROPIATE CLIPPING. C IT THEN ADDS THE DESIRED SYMBOL (ISYMNO) TO THE PLOT SPACED C "NPBSYM" POINTS APART. C DIMENSION AREA(4) C INCLUDE 'GCLTYP.PRM' INCLUDE 'PLTSIZ.PRM' C CALL GSSCLP(XVSTRT,XVSTRT+XVLEN,YVSTRT,YVSTRT+YVLEN,AREA) CALL SCALE(X(1),Y(1),VX,VY) CALL GSMOVE(VX,VY) IF (NPTS .LE. 1) GO TO 110 10 DO 100 I=2,NPTS CALL SCALE(X(I),Y(I),VX,VY) CALL GSDRAW(VX,VY) 100 CONTINUE C C NOW ADD SYMBOLS IF DESIRED C 110 CONTINUE IF (ISYMNO .LE. 0) GO TO 800 C C SAVE LINE TYPE, AND DO SYMBOLS IN SOLID LINES C IOLDLT = ILNTYP ILNTYP = 1 DO 200 I=1, NPTS, NPBSYM CALL SCALE(X(I),Y(I),VX,VY) CALL GSMOVE(VX,VY) CALL SYMBOL(ISYMNO,SYMSIZ) 200 CONTINUE C C RESTORE LINE TYPE C ILNTYP = IOLDLT 800 CONTINUE CALL GSRCLP(AREA) RETURN END SUBROUTINE CURVEY(XMIN,XMAX,Y,NPTS,ISYMNO,SYMSIZ,NPBSYM) DIMENSION Y(NPTS) C C THIS SUBROUTINE TRACES THE LINE FROM X(1),Y(1) TO C X(NPTS),Y(NPTS) WITH APPROPIATE CLIPPING. C USE THIS ROUTINE WHEN CLIPPING IS DESIRED AND THE C INDEPENDANT VARIABLE IS IMPLIED BY THE SUBSCRIPT C USING EQUAL INTERVALS FROM XMIN TO XMAX. C IT THEN ADDS THE DESIRED SYMBOL IN THE REQUIRED SIZE SPACED C EVERY "NPBSYM" POINTS APART. C DIMENSION AREA(4) C INCLUDE 'GCLTYP.PRM' INCLUDE 'PLTSIZ.PRM' C CALL GSSCLP(XVSTRT,XVSTRT+XVLEN,YVSTRT,YVSTRT+YVLEN,AREA) CALL SCALE(XMIN,Y(1),VX,VY) CALL GSMOVE(VX,VY) 10 DX = (XMAX-XMIN)/(NPTS-1) XNEW = XMIN DO 100 I=2,NPTS XNEW = XMIN + (I-1)*DX CALL SCALE(XNEW,Y(I),VX,VY) 100 CALL GSDRAW(VX,VY) C C NOW ADD SYMBOLS IF DESIRED C IF (ISYMNO .LE. 0) GO TO 800 IOLDLT = ILNTYP ILNTYP = 1 DO 200 I=1,NPTS,NPBSYM XNEW = XMIN + (I-1)*DX CALL SCALE(XNEW,Y(I),VX,VY) CALL GSMOVE(VX,VY) CALL SYMBOL(ISYMNO,SYMSIZ) 200 CONTINUE ILNTYP = IOLDLT 800 CONTINUE CALL GSRCLP(AREA) RETURN END PROGRAM DEMO BYTE BNAME(40) DIMENSION Y1(101), Y2(101) C EXTERNAL LEN C DO 100 I=1,101 X = 9.0*(I-1)/10.0 + 1.0 Y1(I) = X**2 Y2(I) = X**3 100 CONTINUE XMIN = 1.0 XMAX = X CALL MINMAX(Y1,101,YMIN,YMAX1) CALL MINMAX(Y2,101,YMIN,YMAX2) C IDEV = 1 110 CALL GSDNAM(IDEV,BNAME) L = LEN(BNAME) IF (L .EQ. 0) GO TO 120 TYPE 111, IDEV, (BNAME(I), I=1,L) 111 FORMAT(' Device ',I1,' is ',40A1) IDEV = IDEV + 1 GO TO 110 120 CONTINUE 5 TYPE 121 121 FORMAT('$Number of the graphics device to use? ') ACCEPT 122, IDEV 122 FORMAT(I5) CALL DEVSEL(IDEV,4,IERR) IF (IERR .EQ. 0) GO TO 10 TYPE *,'THAT DEVICE DOES NOT EXIST' GO TO 5 10 CALL BGNPLT C CALL MAPSIZ(0.0,48.5,52.5,100.0,0.0) CALL MAPIT(XMIN,XMAX,YMIN,YMAX1,'X AXIS','Y AXIS','PLOT 1',0) CALL GSCOLR(8,IERR) CALL CURVEY(XMIN,XMAX,Y1,101,1,0.3,10) C CALL GSCOLR(1,IERR) CALL MAPSIZ(51.5,100.0,52.5,100.0,0.0) CALL MAPIT(XMIN,XMAX,YMIN,YMAX2,'X AXIS','Y AXIS','PLOT 2',0) CALL GSCOLR(3,IERR) CALL CURVEY(XMIN,XMAX,Y2,101,2,0.3,5) CALL GSCOLR(1,IERR) CALL MAPSIZ(0.0,100.0,0.0,47.5,0.0) CALL MAPIT(XMIN,XMAX,YMIN,YMAX2,'X AXIS','Y AXIS','PLOT 3',2) CALL GSCOLR(2,IERR) CALL CURVEY(XMIN,XMAX,Y1,101,1,0.3,10) CALL GSCOLR(3,IERR) CALL CURVEY(XMIN,XMAX,Y2,101,2,0.3,5) CALL ENDPLT CALL RLSDEV STOP END SUBROUTINE DEVSEL(NEWDEV,LUN,IERR) C C INCLUDE 'GCDSEL.PRM' INCLUDE 'GCDPRM.PRM' INCLUDE 'GCCPAR.PRM' INCLUDE 'GCVPOS.PRM' INCLUDE 'GCAPOS.PRM' INCLUDE 'GCCLIP.PRM' INCLUDE 'GCDCHR.PRM' INCLUDE 'GCLTYP.PRM' DIMENSION DEVCHR(8), GDCOMN(5) DIMENSION DFDIST(4,3) C C DEFINE DEFAULT LINE STYLES C EQUIVALENCE (DEVID,GDCOMN(1)) DATA DFDIST / 1 0.5, 0.5, 0.5, 0.5, 2 0.25, 0.25, 0.25, 0.25, 3 0.5, 0.25, 0.25, 0.25/ C C RELEASE CURRENT DEVICE C IF (IDEV .NE. 0) CALL GSDRVR(6,DUMMY,DUMMY) C C NOW INIT. THE NEW DEVICE C IF (NEWDEV .LE. 0) GO TO 900 IDEV = NEWDEV C C GET THE DEVICE CHARACTERISTICS (AND SEE IF DEVICE THERE) C DEVCHR(8) = 1.0 CALL GSDRVR(7,DEVCHR,DUMMY) IF (DEVCHR(1) .EQ. 0.0) GO TO 900 C C INITIALIZE THE DEVICE FOR DIGLIB GRAPHICS C CALL GSDRVR(1,FLOAT(LUN),DUMMY) IERR = DUMMY IF (IERR .NE. 0) GO TO 910 C C SET DEVICE CHARACTERISTICS FOR LATER USE C DO 100 I=1,5 100 GDCOMN(I) = DEVCHR(I) NDCLRS = DEVCHR(6) IDVBTS = DEVCHR(7) NFLINE = DEVCHR(8) XCLIPD = XLENCM + 0.499/DEVCHR(4) YCLIPD = YLENCM + 0.499/DEVCHR(5) C C NOW INIT THE PARAMETERS C XS = 1.0 YS = 1.0 XT = 0.0 YT = 0.0 RCOS = 1.0 RSIN = 0.0 CSIZE = GOODCS(0.3) CCOS = 1.0 CSIN = 0.0 XCUR = 0.0 YCUR = 0.0 IVIS = 0 XCM0 = 0.0 YCM0 = 0.0 XCM1 = XCLIPD YCM1 = YCLIPD ILNTYP = 1 DO 120 I=1,3 DO 110 J=1,4 DIST(J,I) = DFDIST(J,I) 110 CONTINUE 120 CONTINUE LCURNT = .FALSE. RETURN C C NON-EXISTANT DEVICE SELECTED, REPORT ERROR AND DESELECT DEVICE C 900 IERR = -1 C C DEVICE INITIALIZATION FAILED, DESELCT DEVICE C 910 IDEV = 0 RETURN END SUBROUTINE ENDPLT C C CALL GSDRVR(5,X,Y) RETURN END SUBROUTINE CONTOR(Z,NZ,IZ,MX,MY,X1,XMX,Y1,YMY,NL,CL) C C THIS SUBROUTINE WILL PRODUCE A CONTOUR PLOT OF THE FUNCTION C DEFINED BY Z(I,J) = F(X(I),Y(J)). IT IS ASSUMED THAT C A CALL TO "MAPIT" HAS ALREADY BEEN MADE TO ESTABLISH THE C COORDINATE AXIS (X,Y), WITH X LIMITS COVERING THE RANGE C X1 TO XMX, AND Y LIMITS COVERING THE RANGE Y1 TO YMY. C C FAST VERSION FOR USE WITH CRTS ONLY C C Modified 21 May 1985 to add pre-tests. Allyn Saroyan C CArguments: C C Input C C Z * Type: real array. C * The values of the function to contour: C Z(I,J) = F(Xi,Yj) where: C Xi = X1 + (i-1)*(XMX-X1)/(MX-1) C Yj = Y1 + (j-1)*(YMX-Y1)/(MY-1) C C NZ * Type: integer constant or variable. C * The first dimension of the array Z - not necessarily C equal to MX, but MX <= NZ. C C IZ * Type: Anything - a dummy for compatibility C * Not used!!! C C MX * Type: integer constant or variable. C * The number of X grid points. C C MY * Type: integer constant or variable. C * The number of Y grid points. C C X1 * Type: real constant or variable. C * The minimum X value. C C XMX * Type: real constant or variable. C * The maximum X value. C C Y1 * Type: real constant or variable. C * The minimum Y value. C C YMY * Type: real constant or variable. C * The maximum Y value. C C NL * Type: integer constant or variable. C * The number of contour levels. C C CL * Type: real array. C * The coutour levels to draw. (Same units as C F() or Z().) C C Output C C None. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC DIMENSION Z(NZ,MY) DIMENSION CL(NL) C COMMON /CONTR/ X0,Y0,DX,DY DIMENSION ZB(4) REAL min, max C C CALC. SOME SCALING CONSTANTS NEEDED C DX = (XMX-X1)/(MX-1) DY = (YMY-Y1)/(MY-1) X0 = X1-DX Y0 = Y1-DY C C MOVE THRU ARRAY LOOKING FOR CONTOUR SEGMENTS IN EACH BOX. C DO 100 J=1,MY-1 J2 = J+1 ZB(3) = Z(1,J2) ZB(4) = Z(1,J) DO 90 I=1,MX-1 I2 = I+1 ZB(1) = ZB(4) ZB(2) = ZB(3) ZB(3) = Z(I2,J2) ZB(4) = Z(I2,J) C Test for all points equal -- skip if true IF ( zb(1) .eq. zb(2) .and. zb(1) .eq. zb(3) 1 .and. zb(1) .eq. zb(4) ) goto 90 C Find extremes of box min = 1.0E30 max = -min DO l=1, 4 if ( zb(l) .lt. min ) min = zb(l) if ( zb(l) .gt. max ) max = zb(l) enddo C If a contour falls within the box, plot it. DO 50 K=1,NL IF ( cl(k) .ge. min .and. cl(k) .le. max ) 1 CALL SEGMNT(I,J,ZB,CL(K)) 50 CONTINUE 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE SEGMNT(IX,JY,ZB,CLEVEL) DIMENSION ZB(4) C C This subroutine looks for a contour segment in the box defined by C the points (IX,JY,ZB1), (IX,JY+1,ZB2), (IX+1,JY+1,ZB3) C and (IX+1,JY,ZB4). If found, the segment is drawn. C COMMON /CONTR/ X0,Y0,DX,DY DIMENSION IOFF(4), JOFF(4) LOGICAL LFIRST DATA IOFF /0,0,1,1/ DATA JOFF /0,1,1,0/ C LFIRST = .TRUE. IPREVS = 4 ZOLD = ZB(IPREVS) ZDIFF = CLEVEL - ZOLD DO 100 I=1,4 ZNEW = ZB(I) DIFF = CLEVEL - ZNEW IF (SIGN(1.0,ZDIFF) .EQ. SIGN(1.0,DIFF)) GO TO 90 TEMP = ZNEW-ZOLD IF (TEMP .NE. 0.0) GO TO 30 PCTCHG = 0.0 GO TO 40 30 CONTINUE PCTCHG = ZDIFF/TEMP 40 CONTINUE X = IX + IOFF(IPREVS) + (IOFF(I)-IOFF(IPREVS))*PCTCHG Y = JY + JOFF(IPREVS) + (JOFF(I)-JOFF(IPREVS))*PCTCHG CALL SCALE(X*DX+X0,Y*DY+Y0,VX,VY) IF (LFIRST) GOTO 50 CALL GSDRAW(VX,VY) LFIRST = .TRUE. GO TO 90 50 CONTINUE CALL GSMOVE(VX,VY) LFIRST = .FALSE. 90 CONTINUE ZDIFF = DIFF ZOLD = ZNEW IPREVS = I 100 CONTINUE RETURN END SUBROUTINE FULMAP C INCLUDE 'GCDCHR.PRM' C C DEFINE BORDER SIZE C DATA BORDER /0.15/ C C SET THE PLOTING AREA TO THE WHOLE SCREEN C CALL PLTBOX(BORDER,XLENCM-BORDER,BORDER,YLENCM-BORDER) RETURN END SUBROUTINE GD(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C TEK 4115B DRIVER FOR DIGLIB/VAX C VERSION 2.1 - CURSOR POSITIONING AND HARDWARE POLYGONS C BYTE ESC, CSUB, GS, CR, FF, US PARAMETER (ESC=27, CSUB=26, GS=29, CR=13, FF=12, US=31) CHARACTER*(*) TERMINAL PARAMETER (TERMINAL='TT') C C DEFINITIONS FOR DEVICE CONTROL C BYTE STR_END(2), STR_INIT_DEV(26), STR_WINDOW(4) BYTE STR_BEGIN_PLOT(4) INTEGER*2 STR_COLOR_SET(6) BYTE STR_END_PLOT(2), STR_RLS_DEV(6) BYTE STR_BEGIN_POLY(4), STR_END_POLY(6) DATA STR_END /US,0/ DATA STR_INIT_DEV/ 1 ESC,'%','!','0', !CODE TEK 2 ESC,'K','A','1', !DAENABLE YES 3 ESC,'L','M','0', !DAMODE REPLACE 4 ESC,'M','L','1', !LINEINDEX 1 (COLOR 1) 5 ESC,'N','U',':', !BYPASS CANCEL CHARACTER (LF) 6 ESC,'N','T','1','=',0/ !EOL STRING DATA STR_WINDOW / ESC,'R','W',0/ DATA STR_BEGIN_PLOT/ 1 ESC,FF,0,0/ !ERASE SCREEN DATA STR_COLOR_SET / 1 ESC,'M','L','1',0,0/ !LINEINDEX 1 (COLOR N) DATA STR_END_PLOT /0,0/ DATA STR_RLS_DEV / 1 ESC,'%','!','1',0,0/ !CODE ANSI DATA STR_BEGIN_POLY / ESC,'L','P',0/ DATA STR_END_POLY / US,ESC,'L','E',2*0/ C C DEFINITIONS FOR GIN C BYTE GINBUFR(8), PROMPT(4), STR_END_GIN(2), STR_MOVE_GIN_CURSOR(6) DATA PROMPT /ESC, CSUB, 0, 0/ DATA IGIN_IN_CHARS /6/ DATA STR_END_GIN /10,0/ DATA STR_MOVE_GIN_CURSOR / ESC, 'S', 'X', '0', 0,0/ DATA IX_GIN_CURSOR, IY_GIN_CURSOR / 240, 180 / C C DECLARE BUFFERING FUNCTION C LOGICAL GB_TEST_FLUSH C C DECLARE VARS NEED FOR DRIVER OPERATION C LOGICAL LVECTOR_GOING, LDUMMY DIMENSION DCHAR(8) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /4115.0, 34.778, 27.817, 36.776, 36.776, 255.0, 389.0, 1.0/ C DATA DCHAR /4107.0, 24.577, 18.423, 26.0, 26.0, 7.0, 389.0, 1.0/ C C***************** C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .GT. 1026) GOTO 20000 IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIRST, INITIALIZE THE BUFFER SUBROUTINES C CALL GB_INITIALIZE(0,STR_END,TERMINAL,IERR) YA(1) = IERR IF (IERR .NE. 0) RETURN C C INITIALIZE THE 4107 C CALL GB_IN_STRING(STR_INIT_DEV) CALL GB_IN_STRING(STR_WINDOW) CALL GD_4010_CONVERT(0,0) IX = INT(DCHAR(2)*XGUPCM+0.5) IY = INT(DCHAR(3)*YGUPCM+0.5) CALL GD_4010_CONVERT(IX,IY) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_NEW_BUFFER CALL GB_IN_STRING(STR_BEGIN_PLOT) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C **** C MOVE C **** C 300 CONTINUE C CONVERT CM. TO GRAPHICS UNITS ROUNDED IXPOSN = XGUPCM*XA(1)+0.5 IYPOSN = YGUPCM*YA(1)+0.5 LVECTOR_GOING = .FALSE. RETURN C C **** C DRAW C **** C 400 CONTINUE IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4)) IF (LVECTOR_GOING) GO TO 410 LDUMMY = GB_TEST_FLUSH(9) LVECTOR_GOING = .TRUE. CALL GB_INSERT(GS) CALL GD_4010_CONVERT(IXPOSN,IYPOSN) 410 CALL GD_4010_CONVERT(IX,IY) IXPOSN = IX IYPOSN = IY RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GB_EMPTY CALL GB_IN_STRING(STR_END_PLOT) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C DE-ASSIGN THE CHANNAL C CALL GB_EMPTY CALL GB_IN_STRING(STR_WINDOW) CALL GD_4010_CONVERT(0,0) CALL GD_4010_CONVERT(1023,767) CALL GB_FINISH(STR_RLS_DEV) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE LDUMMY = GB_TEST_FLUSH(6) ICOLOR = XA(1) IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 255) RETURN STR_COLOR_SET(4) = 48+ICOLOR !MAKE ASCII CHARACTER CALL GB_IN_STRING(STR_COLOR_SET) LVECTOR_GOING = .FALSE. RETURN C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE C C POSITION CURSOR TO ITS LAST GIN POSITION (ELSE MIDDLE OF SCREEN) C CALL GB_TEST_FLUSH(10) CALL GB_IN_STRING(STR_MOVE_GIN_CURSOR) CALL GD_4010_CONVERT(IX_GIN_CURSOR,IY_GIN_CURSOR) CALL GB_EMPTY C CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR) C ICHAR = GINBUFR(1) IX1 = GINBUFR(2) IX2 = GINBUFR(3) IY1 = GINBUFR(4) IY2 = GINBUFR(5) C XA(1) = IAND(ICHAR,127) !PICK CHARACTER IX_GIN_CURSOR = 32*IAND(IX1,31)+IAND(IX2,31) XA(2) = IX_GIN_CURSOR/XGUPCM IY_GIN_CURSOR = 32*IAND(IY1,31)+IAND(IY2,31) XA(3) = IY_GIN_CURSOR/YGUPCM C CALL GB_IN_STRING(STR_END_GIN) CALL GB_EMPTY RETURN C C ******************* C DRAW FILLED POLYGON C ******************* C 20000 CONTINUE NPTS = IFXN - 1024 IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(20)) IF (LVECTOR_GOING) THEN CALL GB_INSERT(US) LVECTOR_GOING = .FALSE. ENDIF CALL GB_IN_STRING(STR_BEGIN_POLY) CALL GD_4010_CONVERT(IX,IY) C C DO VERTICES 2 THRU N. NOTE: WE START WITH A SINCE C LVECTOR_GOING IS "FALSE" C DO 20010 I = 2, NPTS C MAKE SURE 10 CHARS (4 FOR X,Y AND 6 FOR END POLYGON) LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(10)) IF (.NOT. LVECTOR_GOING) CALL GB_INSERT(GS) CALL GD_4010_CONVERT(INT(XGUPCM*XA(I)+0.5), 1 INT(YGUPCM*YA(I)+0.5)) 20010 CONTINUE CALL GB_IN_STRING(STR_END_POLY) LVECTOR_GOING = .FALSE. RETURN END SUBROUTINE GD1012_LONG(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C CalComp 1012 plotter driver for VMS C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C PLOTTER COMMANDS, ETC. C C INTEGER CMD_INIT_PLOTTER_SIZE, CMD_PEN_UP_SIZE, 1 CMD_INDEX_PLOTTER_SIZE, CMD_PEN_DOWN_SIZE, CMD_SELECT_PEN_SIZE, 2 CMD_MAX_DELTA_SIZE PARAMETER (CMD_INIT_PLOTTER_SIZE = 32) PARAMETER (CMD_PEN_UP_SIZE = 1) PARAMETER (CMD_INDEX_PLOTTER_SIZE = 3) PARAMETER (CMD_PEN_DOWN_SIZE = 1) PARAMETER (CMD_SELECT_PEN_SIZE = 2) PARAMETER (IPEN_NUMBER_POSITION = 2) PARAMETER (CMD_MAX_DELTA_SIZE = 7) BYTE RESPONSE_CHARACTER, RC1, RC2 PARAMETER (RESPONSE_CHARACTER = '&') PARAMETER (RC1 = RESPONSE_CHARACTER/16) PARAMETER (RC2 = RESPONSE_CHARACTER-16*RC1) BYTE CMD_INIT_PLOTTER(CMD_INIT_PLOTTER_SIZE+1), 1 CMD_PEN_UP(CMD_PEN_UP_SIZE+1), 2 CMD_INDEX_PLOTTER(CMD_INDEX_PLOTTER_SIZE+1), 3 CMD_PEN_DOWN(CMD_PEN_DOWN_SIZE+1), 4 CMD_SELECT_PEN(CMD_SELECT_PEN_SIZE+1) DATA CMD_INIT_PLOTTER / 1 7,63, !RADIX 64 2 8,1, !ENABLE DOUBLE BUFFERING IN PLOTTER 3 8,2,0, !RESPONSE SUFFIX LENGTH IS 0 4 8,3,0, !TURN-AROUND DELAY IS 0 5 8,4,1,3,0, !PACKET ACCEPTED RESPONSE IS '0' 6 8,5,1,3,1, !PACKET REJECTED RESPONSE IS '1' 7 8,6,1,RC1,RC2, !RESPONSE REQUEST CHARACTER 9 4,1, !SELECT PEN 1 1 9,1, !SCALE FACTOR IS 1 2 11,0,6,-1/ !INDEX THE PLOTTER DATA CMD_PEN_UP / 3,-1/ !PEN UP COMMAND DATA CMD_INDEX_PLOTTER / 1 11,0,6,-1/ !INDEX THE PLOTTER DATA CMD_PEN_DOWN / 1 2,-1/ !PEN UP COMANND DATA CMD_SELECT_PEN / 1 4, 1,-1/ !SELECT PEN COMMAND C LOGICAL LONG, LFRESH_PAGE C C STANDARD DEVICE DRIVER STUFF C DIMENSION DCHAR(8) EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) C Note: Table is set up for TALL mode. DATA DCHAR /1012.0, 21.0, 27.3, 200.0, 200.0, 4.0, 24.0, 40.0/ C C DECLARE BUFFERING FUNCTION C LOGICAL GH_TEST_FLUSH C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C LONG = .TRUE. GO TO 10 ENTRY GD1012_TALL(IFXN,XA,YA) LONG = .FALSE. 10 CONTINUE C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 8) RETURN GO TO (100,200,300,400,500,600,700,800) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIRST, INITIALIZE THE BUFFER SUBROUTINES C CALL GH_INITIALIZE(IERR) YA(1) = IERR IF (IERR .NE. 0) RETURN CALL GH_TIMED CALL GH_IN_BIASED(CMD_INIT_PLOTTER) CALL GH_EMPTY CALL GH_NO_TIMED GO TO 280 C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GH_NEW_BUFFER CMD_SELECT_PEN(IPEN_NUMBER_POSITION) = 1 CALL GH_IN_BIASED(CMD_SELECT_PEN) IF (.NOT. LFRESH_PAGE) THEN CALL GD1012_CONVERT(4200-IXPOSN,0-IYPOSN) ENDIF LFRESH_PAGE = .TRUE. CALL GH_IN_BIASED(CMD_INDEX_PLOTTER) 280 CONTINUE LFRESH_PAGE = .TRUE. LPEN_DOWN = .FALSE. !RAISED BY SELECT PEN IXPOSN = 25 IYPOSN = -25 IPEN = 1 CALL GH_EMPTY RETURN C C **** C MOVE C **** C 300 CONTINUE CALL GH_TEST_FLUSH(CMD_MAX_DELTA_SIZE+CMD_PEN_UP_SIZE) IF (LPEN_DOWN) THEN CALL GH_IN_BIASED(CMD_PEN_UP) LPEN_DOWN = .FALSE. ENDIF GO TO 420 C C **** C DRAW C **** C 400 CONTINUE CALL GH_TEST_FLUSH(CMD_MAX_DELTA_SIZE+CMD_PEN_DOWN_SIZE) IF (.NOT. LPEN_DOWN) THEN CALL GH_IN_BIASED(CMD_PEN_DOWN) LPEN_DOWN = .TRUE. ENDIF LFRESH_PAGE = .FALSE. 420 CONTINUE IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 IF (LONG) THEN ITEMP = IX IX = IY IY = 5462-ITEMP ENDIF CALL GD1012_CONVERT(IX-IXPOSN,IY-IYPOSN) IXPOSN = IX IYPOSN = IY RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GH_EMPTY RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE CMD_SELECT_PEN(IPEN_NUMBER_POSITION) = 1 CALL GH_IN_BIASED(CMD_SELECT_PEN) CALL GD1012_CONVERT(4200-IXPOSN,0-IYPOSN) CALL GH_IN_BIASED(CMD_INDEX_PLOTTER) CALL GH_EMPTY CALL GH_FINISH RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE IF (LONG) THEN XA(2) = DCHAR(3) XA(3) = DCHAR(2) XA(1) = XA(1) + 0.5 ENDIF RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE CALL GH_TEST_FLUSH(CMD_SELECT_PEN_SIZE) ICOLOR = XA(1) IF (ICOLOR .LE. 0 .OR. ICOLOR .GT. 4) RETURN IF (ICOLOR .NE. IPEN) THEN CMD_SELECT_PEN(IPEN_NUMBER_POSITION) = ICOLOR CALL GH_IN_BIASED(CMD_SELECT_PEN) IPEN = ICOLOR ENDIF RETURN END SUBROUTINE GD1012_CONVERT(IDX,IDY) C C THIS SUBROUTINE CONVERTS AND INSERTS THE DELTA WITH THE C PROPER DELTA CODE. C PARAMETER (IRADIX = 64) BYTE RBUFR(8), BDELTAS(7,7) DATA RBUFR(8) /-1/ DATA BDELTAS / 19,43,47,31,46,42,18, 2 51,23,59,35,58,22,50, 3 55,63,27,39,26,62,54, 4 29,33,37,-1,38,34,30, 5 53,61,25,36,24,60,52, 6 49,21,57,32,56,20,48, 7 17,41,45,28,44,40,16/ C IF (IDX .EQ. 0 .AND. IDY .EQ. 0) RETURN I = 7 ICOORD = IABS(IDY) DO 200 J=1,2 ISTART = I 100 CONTINUE IF (ICOORD .EQ. 0) GO TO 190 RBUFR(I) = ICOORD .AND. (IRADIX-1) I = I-1 ICOORD = ICOORD/IRADIX GO TO 100 190 CONTINUE IF (J .EQ. 1) THEN NY = 4 + ISIGN(1,IDY)*(ISTART-I) ICOORD = IABS(IDX) ENDIF 200 CONTINUE RBUFR(I) = BDELTAS(4+ISIGN(1,IDX)*(ISTART-I),NY) D type 9999, idx,idy, (rbufr(j), j=i,8) D9999 format(' The delta command for (',i5,',',i5,') is:'/2x,8i8) D type 9998 D9998 format(/) CALL GH_IN_BIASED(RBUFR(I)) RETURN END SUBROUTINE GH_INITIALIZE(IERR) C BYTE BIAS, STMSG, RESPONSE_CHARACTER, PACKET_ACCEPTED_CHAR PARAMETER (BIAS = 32) PARAMETER (STMSG = 2) PARAMETER (RESPONSE_CHARACTER = '&') PARAMETER (PACKET_ACCEPTED_CHAR = '0') C INCLUDE '($SSDEF)' INCLUDE 'GD1012.CMN' C CHARACTER*(*) DEVICE_NAME PARAMETER (DEVICE_NAME='CALCOMP_TERM') INTEGER*4 SYS$ASSIGN C C ASSIGN A CHANNEL TO THE DEVICE OUTPUT DEVICE C 10 continue ISTAT = SYS$ASSIGN(DEVICE_NAME,IOCHAN,,) if (istat .eq. ss$_devalloc) then type 11 11 format(' Waiting 10 seconds for plotter to become free.') call lib$wait(10.0) goto 10 endif IF (.NOT. ISTAT) THEN IERR = 1 RETURN ELSE IERR = 0 ENDIF type 21 21 format( 1' Please make sure the CalComp is connected to the "BLACK BOX".'/ 2'$Hit "Return" when the connection is made:') accept 22, istat 22 format(a1) C C PLACED FIXED START OF PACKET FOR PLOTTER C BIASCHAR = BIAS RESPCHAR = RESPONSE_CHARACTER GOODCHAR = PACKET_ACCEPTED_CHAR BUFFER(1) = STMSG BUFFER(2) = BIASCHAR CALL GH_NEW_BUFFER RETURN END SUBROUTINE GH_NEW_BUFFER C C SUBROUTINE TO INITIALIZE THE GRAPHIC COMMAND BUFFER C C INCLUDE 'GD1012.CMN' C C IBUFPTR = 3 ICHECK_SUM = 0 RETURN END FUNCTION GH_TEST_FLUSH(NUMCHR) LOGICAL GH_TEST_FLUSH C C THIS SUBROUTINE CHECKS TO MAKE SURE THERE IS ENOUGH ROOM IN C THE BUFFER FOR "NUMCHR" MORE CHARACTERS, IF NOT, IF MAKES ROOM BY C EMPTYING THE BUFFER. C PARAMETER (IEND_LENGTH = 3) C C INCLUDE 'GD1012.CMN' C C IF (IBUFPTR+NUMCHR+IEND_LENGTH .GE. IBUFSIZ) THEN CALL GH_EMPTY GH_TEST_FLUSH = .TRUE. ELSE GH_TEST_FLUSH = .FALSE. ENDIF RETURN END SUBROUTINE GH_EMPTY C C THIS SUBROUTINE EMPTYS THE BUFFER IF IT HAS ANYTHING C BYTE EOMSG, CR PARAMETER (EOMSG = 3) PARAMETER (CR = 13) C C INCLUDE 'GD1012.CMN' C C IF (IBUFPTR .LE. 3) GO TO 900 CALL GH_INSERT(96-(ICHECK_SUM .AND. 31)) CALL GH_INSERT(EOMSG) CALL GH_INSERT(CR) IF (IBUFPTR .GT. IBUFSIZ+1) STOP 'BUFFERING ERROR - BUFFER OVERFLOWED' C C SEND TO PLOTTER C CALL GH_SEND 900 CALL GH_NEW_BUFFER RETURN END SUBROUTINE GH_SEND C C *** VMS SPECIFIC *** C INCLUDE '($IODEF)' INCLUDE '($SSDEF)' C INCLUDE 'GD1012.CMN' C INTEGER*4 CR_CONTROL PARAMETER (CR_CONTROL = 0) C INTEGER*4 SYS$QIOW INTEGER*2 IOSB(4) BYTE INBUF C C DO THE QIOW TO THE OUTPUT DEVICE C 10 CONTINUE ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN), 1 %VAL(IO$_WRITEVBLK+IO$M_NOFORMAT),IOSB, , , 2 BUFFER,%VAL(IBUFPTR-1),5,%VAL(CR_CONTROL), , ) IF (.NOT. ISTAT) then type 999, istat 999 format(' Write QIOW to CalComp failed, status was ',i9) stop ENDIF IFXN = IO$_READPROMPT+IO$M_NOECHO+IO$M_PURGE IF (LTIMED) IFXN = IFXN + IO$M_TIMED ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN), 1 %VAL(IFXN),IOSB, , , 2 INBUF,%VAL(1),%VAL(2), ,RESPCHAR,%VAL(1)) IF (ISTAT .EQ. SS$_TIMEOUT) THEN TYPE 901 901 FORMAT(/'$Please make the CalComp ready, then hit RETURN') ACCEPT 902, I 902 FORMAT(A1) GO TO 10 ENDIF IF (.NOT. ISTAT) then type 998, istat 998 format(' ReadPrompt QIOW to CalComp failed, status was ',i9) call lib$stop(%val(istat)) ENDIF IF (INBUF .NE. GOODCHAR) THEN type 997 997 format(' DIGLIB - informative: CalComp transmission error') D type 9999, INBUF D9999 format(' The bad character is decimal ',I4/ D 1 '$Hit return to try again') D ACCEPT 9998, INBUF D9998 FORMAT(A1) GO TO 10 ENDIF RETURN END SUBROUTINE GH_TIMED C INCLUDE 'GD1012.CMN' C LTIMED = .TRUE. RETURN END SUBROUTINE GH_NO_TIMED C INCLUDE 'GD1012.CMN' C LTIMED = .FALSE. RETURN END SUBROUTINE GH_INSERT(BCHAR) BYTE BCHAR C C THIS SUBROUTINE INSERTS A CHARACTER INTO THE BUFFER C C INCLUDE 'GD1012.CMN' C C BUFFER(IBUFPTR) = BCHAR ICHECK_SUM = ICHECK_SUM + BCHAR IBUFPTR = IBUFPTR + 1 RETURN END SUBROUTINE GH_IN_BIASED(STRING) BYTE STRING(2) C C THIS SUBROUTINE INSERTS THE STRING INTO THE GRAPHICS BUFFER C C INCLUDE 'GD1012.CMN' C I = 1 100 CONTINUE IF (STRING(I) .EQ. -1) RETURN CALL GH_INSERT(STRING(I)+BIASCHAR) I = I + 1 GO TO 100 END SUBROUTINE GH_FINISH() C C *** VMS SPECIFIC *** C C THIS SUBROUTINE RELEASES THE I/O CHANNAL TO THE PLOTTER C C INCLUDE 'GD1012.CMN' C C INTEGER*4 SYS$DASSGN C ISTAT = SYS$DASSGN(%VAL(IOCHAN)) RETURN END SUBROUTINE GD2623(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C HP 2623 DRIVER FOR DIGLIB/VAX C C----------------------------------------------------------------------- C BYTE ESC, DC1, BPENUP PARAMETER (ESC=27) PARAMETER (DC1=17) PARAMETER (BPENUP = 97) CHARACTER*(*) TERMINAL PARAMETER (TERMINAL='TT') C C DEVICE CONTROL DEFINITIONS C BYTE CHAR_TERM, STR_END(2), STR_BEGIN_PLOT(24) BYTE STR_END_PLOT(6), STR_COLOR_SET(6) BYTE STR_START_VEC(6), STR_RLS_DEV(6) BYTE BDUMMY, BINTERLOCK(2) DATA BINTERLOCK /5,0/ !ENQUIRE FOR 2648 HANDSHAKE DATA CHAR_TERM /'Z'/ DATA STR_END /13,0/ DATA STR_BEGIN_PLOT / 1 ESC,'H', !HOME ALPHA CURSOR 2 ESC,'J', !ERASE TO END OF ALPHA MEMORY 3 ESC,'*','d','A', !CLEAR GRAPHICS MEMORY 4 ESC,'*','d','C', !GRAPHICS DISPLAY ON 5 ESC,'*','m','2','A', !SET FOREGROUND TO DOTS ON 6 ESC,'*','m','1','B',2*0/ !SET SOLID LINES DATA STR_END_PLOT / 1 ESC,'H', !HOME ALPHA CURSOR 2 ESC,'J',2*0/ !ERASE TO END OF ALPHA MEMORY DATA STR_COLOR_SET / 1 ESC,'*','m','1','A',0/ !1 ==> DOTS ON, 2 ==> DOTS OFF DATA STR_START_VEC / 1 ESC,'*','p','i',2*0/ !START VECTOR DATA STR_RLS_DEV / 1 ESC,'*','d','D',2*0/ !TURN GRAPHICS OFF C C GIN DEFINITIONS C BYTE GINBUFR(28), PROMPT(8), PLUS_SIGN DATA PROMPT /ESC,'*','s','4','^',DC1,2*0/ DATA PLUS_SIGN /'+'/ C C DECLARE BUFFERING FUNCTION TO BE LOGICAL C LOGICAL GB_TEST_FLUSH C C DELCARE VARS NEEDED FOR DRIVER OPERATION C LOGICAL LVECTOR_GOING C DIMENSION DCHAR(8) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /2623.0, 21.689, 16.511, 23.56, 23.56, 1.0, 133.0, 1.0/ C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE CALL GB_INITIALIZE(CHAR_TERM,STR_END,TERMINAL,IERR) YA(1) =IERR GO TO 290 C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_NEW_BUFFER CALL GB_IN_STRING(STR_BEGIN_PLOT) CALL GB_EMPTY 290 LVECTOR_GOING = .FALSE. RETURN C C **** C MOVE C **** C 300 CONTINUE C MAKE DECISION ON MOVE/DRAW LATER C C **** C DRAW C **** C 400 CONTINUE IXPOSN = XGUPCM*XA(1)+0.5 IYPOSN = YGUPCM*YA(1)+0.5 IF (.NOT. LVECTOR_GOING) THEN CALL GB_INTERLOCK(BINTERLOCK,BDUMMY,1) LDUMMY = GB_TEST_FLUSH(18) CALL GB_IN_STRING(STR_START_VEC) CALL GB_USE_TERMINATOR LVECTOR_GOING = .TRUE. ENDIF IF (IFXN .EQ. 3) CALL GB_INSERT(BPENUP) !IF MOVE, DO PEN-UP FIRST CALL GD26CONVERT(IXPOSN,IYPOSN) LVECTOR_GOING = .NOT. GB_TEST_FLUSH(6) RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GB_EMPTY CALL GB_IN_STRING(STR_END_PLOT) CALL GB_EMPTY GO TO 290 C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE CALL GB_FINISH(STR_RLS_DEV) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE CALL GB_EMPTY ICOLOR = XA(1) IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 1) RETURN IF (ICOLOR .EQ. 0) THEN STR_COLOR_SET(4) = '1' ELSE STR_COLOR_SET(4) = '2' ENDIF CALL GB_IN_STRING(STR_COLOR_SET) GO TO 290 C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE CALL GB_EMPTY C C ASK FOR 1 GIN INPUT C C CALL GB_GIN(PROMPT,27,.FALSE.,GINBUFR) C C GET THE KEY, X POSITION, AND Y POSITION C C IPTR = 0 910 IPTR = IPTR + 1 IF (GINBUFR(IPTR) .NE. PLUS_SIGN) GO TO 910 DECODE (17,911,GINBUFR(IPTR)) IX, IY, ICHAR 911 FORMAT(I6,1X,I6,1X,I3) XA(1) = ICHAR !PICK CHARACTER XA(2) = FLOAT(IX)/XGUPCM !X IN CM. XA(3) = FLOAT(IY)/YGUPCM !Y IN CM. GO TO 290 END SUBROUTINE GD2648(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C HP 2648 DRIVER FOR DIGLIB/VAX C C----------------------------------------------------------------------- C BYTE ESC, DC1, BPENUP PARAMETER (ESC=27) PARAMETER (DC1=17) PARAMETER (BPENUP = 97) CHARACTER*(*) TERMINAL PARAMETER (TERMINAL='TT') C C DEVICE CONTROL DEFINITIONS C BYTE CHAR_TERM, STR_END(2), STR_BEGIN_PLOT(24) BYTE STR_END_PLOT(6), STR_COLOR_SET(6) BYTE STR_START_VEC(6), STR_RLS_DEV(6) BYTE BDUMMY, BINTERLOCK(2) DATA BINTERLOCK /5,0/ !ENQUIRE FOR 2648 HANDSHAKE DATA CHAR_TERM /'Z'/ DATA STR_END /13,0/ DATA STR_BEGIN_PLOT / 1 ESC,'H', !HOME ALPHA CURSOR 2 ESC,'J', !ERASE TO END OF ALPHA MEMORY 3 ESC,'*','d','A', !CLEAR GRAPHICS MEMORY 4 ESC,'*','d','C', !GRAPHICS DISPLAY ON 5 ESC,'*','m','2','A', !SET FOREGROUND TO DOTS ON 6 ESC,'*','m','1','B',2*0/ !SET SOLID LINES DATA STR_END_PLOT / 1 ESC,'H', !HOME ALPHA CURSOR 2 ESC,'J',2*0/ !ERASE TO END OF ALPHA MEMORY DATA STR_COLOR_SET / 1 ESC,'*','m','1','A',0/ !1 ==> DOTS ON, 2 ==> DOTS OFF DATA STR_START_VEC / 1 ESC,'*','p','i',2*0/ !START VECTOR DATA STR_RLS_DEV / 1 ESC,'*','d','D',2*0/ !TURN GRAPHICS OFF C C GIN DEFINITIONS C BYTE GINBUFR(28), PROMPT(8), PLUS_SIGN DATA PROMPT /ESC,'*','s','4','^',DC1,2*0/ DATA PLUS_SIGN /'+'/ C C DECLARE BUFFERING FUNCTION TO BE LOGICAL C LOGICAL GB_TEST_FLUSH C C DELCARE VARS NEEDED FOR DRIVER OPERATION C LOGICAL LVECTOR_GOING C DIMENSION DCHAR(8) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /2648.0, 23.967, 11.967, 30.0, 30.0, 1.0, 133.0, 1.0/ C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE CALL GB_INITIALIZE(CHAR_TERM,STR_END,TERMINAL,IERR) YA(1) = IERR GO TO 290 C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_NEW_BUFFER CALL GB_IN_STRING(STR_BEGIN_PLOT) CALL GB_EMPTY 290 LVECTOR_GOING = .FALSE. RETURN C C **** C MOVE C **** C 300 CONTINUE C MAKE DECISION ON MOVE/DRAW LATER C C **** C DRAW C **** C 400 CONTINUE IXPOSN = XGUPCM*XA(1)+0.5 IYPOSN = YGUPCM*YA(1)+0.5 IF (.NOT. LVECTOR_GOING) THEN CALL GB_INTERLOCK(BINTERLOCK,BDUMMY,1) LDUMMY = GB_TEST_FLUSH(18) CALL GB_IN_STRING(STR_START_VEC) CALL GB_USE_TERMINATOR LVECTOR_GOING = .TRUE. ENDIF IF (IFXN .EQ. 3) CALL GB_INSERT(BPENUP) !IF MOVE, DO PEN-UP FIRST CALL GD26CONVERT(IXPOSN,IYPOSN) LVECTOR_GOING = .NOT. GB_TEST_FLUSH(6) RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GB_EMPTY CALL GB_IN_STRING(STR_END_PLOT) CALL GB_EMPTY GO TO 290 C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE CALL GB_FINISH(STR_RLS_DEV) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE CALL GB_EMPTY ICOLOR = XA(1) IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 1) RETURN IF (ICOLOR .EQ. 0) THEN STR_COLOR_SET(4) = '1' ELSE STR_COLOR_SET(4) = '2' ENDIF CALL GB_IN_STRING(STR_COLOR_SET) GO TO 290 C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE CALL GB_EMPTY C C ASK FOR 1 GIN INPUT C C CALL GB_GIN(PROMPT,27,.FALSE.,GINBUFR) C C GET THE KEY, X POSITION, AND Y POSITION C C IPTR = 0 910 IPTR = IPTR + 1 IF (GINBUFR(IPTR) .NE. PLUS_SIGN) GO TO 910 DECODE (17,911,GINBUFR(IPTR)) IX, IY, ICHAR 911 FORMAT(I6,1X,I6,1X,I3) XA(1) = ICHAR !PICK CHARACTER XA(2) = FLOAT(IX)/XGUPCM !X IN CM. XA(3) = FLOAT(IY)/YGUPCM !Y IN CM. GO TO 290 END SUBROUTINE GD26CONVERT(IX,IY) C C THIS SUBROUTINE CONVERTS THE POINT (IX,IY) INTO THE 4010 SCHEME C OF ENCODING COORDINATES C CALL GB_INSERT(32+IX/32) CALL GB_INSERT(32+IAND(IX,31)) CALL GB_INSERT(32+IY/32) CALL GB_INSERT(32+IAND(IY,31)) RETURN END SUBROUTINE GD4010(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C TEK 4010 DRIVER FOR DIGLIB/VAX C C----------------------------------------------------------------------- C BYTE ESC, CSUB, GS, US, CR, FF PARAMETER (ESC=27, CSUB=26, GS=29, US=31, CR=13, FF=12) CHARACTER*(*) TERMINAL PARAMETER (TERMINAL='TT') C C DEFINITIONS FOR DEVICE CONTROL C BYTE STR_END(2) BYTE STR_BEGIN_PLOT(4) DATA STR_END /US,0/ DATA STR_BEGIN_PLOT /ESC,FF,2*0/ C DEFINITIONS FOR GIN C BYTE GINBUFR(8), PROMPT(4) DATA PROMPT /ESC, CSUB, 2*0/ DATA IGIN_IN_CHARS /5/ C C DECLARE BUFFERING FUNCTION C LOGICAL GB_TEST_FLUSH C C DECLARE VARS NEED FOR DRIVER OPERATION C LOGICAL LVECTOR_GOING, LDUMMY DIMENSION DCHAR(8) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /4010.0, 21.492, 16.114, 47.6, 47.6, 1.0, 130.0, 1.0/ C C***************** C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIRST, INITIALIZE THE BUFFER SUBROUTINES C CALL GB_INITIALIZE(0,STR_END,TERMINAL,IERR) YA(1) = IERR LVECTOR_GOING = .FALSE. RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_NEW_BUFFER CALL GB_IN_STRING(STR_BEGIN_PLOT) CALL GB_EMPTY CALL GDWAIT(2000) LVECTOR_GOING = .FALSE. RETURN C C **** C MOVE C **** C 300 CONTINUE C CONVERT CM. TO GRAPHICS UNITS ROUNDED IXPOSN = XGUPCM*XA(1)+0.5 IYPOSN = YGUPCM*YA(1)+0.5 LVECTOR_GOING = .FALSE. RETURN C C **** C DRAW C **** C 400 CONTINUE IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4)) IF (LVECTOR_GOING) GO TO 410 LDUMMY = GB_TEST_FLUSH(9) LVECTOR_GOING = .TRUE. CALL GB_INSERT(GS) CALL GD_4010_CONVERT(IXPOSN,IYPOSN) 410 CALL GD_4010_CONVERT(IX,IY) IXPOSN = IX IYPOSN = IY RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GB_EMPTY CALL GB_INSERT(GS) CALL GD_4010_CONVERT(0,1020) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C DE-ASSIGN THE CHANNAL C CALL GB_FINISH(0) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE RETURN C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE CALL GB_EMPTY LVECTOR_GOING = .FALSE. C C ASK FOR 1 GIN INPUT C C CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR) C ICHAR = GINBUFR(1) IX1 = GINBUFR(2) IX2 = GINBUFR(3) IY1 = GINBUFR(4) IY2 = GINBUFR(5) C XA(1) = IAND(ICHAR,127) !PICK CHARACTER XA(2) = (32*IAND(IX1,31)+IAND(IX2,31))/XGUPCM XA(3) = (32*IAND(IY1,31)+IAND(IY2,31))/YGUPCM C RETURN END SUBROUTINE GD_4010_CONVERT(IX,IY) C C THIS SUBROUTINE CONVERTS THE POINT (IX,IY) INTO THE 4010 SCHEME C OF ENCODING COORDINATES C CALL GB_INSERT(32+IY/32) CALL GB_INSERT(96+IAND(IY,31)) CALL GB_INSERT(32+IX/32) CALL GB_INSERT(64+IAND(IX,31)) RETURN END SUBROUTINE GD_4010_CONVERT(IX,IY) C C THIS SUBROUTINE CONVERTS THE POINT (IX,IY) INTO THE 4010 SCHEME C OF ENCODING COORDINATES C CALL GB_INSERT(32+IY/32) CALL GB_INSERT(96+IAND(IY,31)) CALL GB_INSERT(32+IX/32) CALL GB_INSERT(64+IAND(IX,31)) RETURN END SUBROUTINE GD4012(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C TEK 4012 DRIVER FOR DIGLIB/VAX C C----------------------------------------------------------------------- C BYTE ESC, CSUB, GS, US, CR, FF PARAMETER (ESC=27, CSUB=26, GS=29, US=31, CR=13, FF=12) CHARACTER*(*) TERMINAL PARAMETER (TERMINAL='TT') C C DEFINITIONS FOR DEVICE CONTROL C BYTE STR_END(2) BYTE STR_BEGIN_PLOT(4) DATA STR_END /US,0/ DATA STR_BEGIN_PLOT /ESC,FF,2*0/ C DEFINITIONS FOR GIN C BYTE GINBUFR(8), PROMPT(4) DATA PROMPT /ESC, CSUB, 2*0/ DATA IGIN_IN_CHARS /5/ C C DECLARE BUFFERING FUNCTION C LOGICAL GB_TEST_FLUSH C C DECLARE VARS NEED FOR DRIVER OPERATION C LOGICAL LVECTOR_GOING, LDUMMY DIMENSION DCHAR(8) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /4012.0, 20.02, 15.01, 51.1, 51.1, 1.0, 130.0, 1.0/ C C***************** C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIRST, INITIALIZE THE BUFFER SUBROUTINES C CALL GB_INITIALIZE(0,STR_END,TERMINAL,IERR) YA(1) = IERR LVECTOR_GOING = .FALSE. RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_NEW_BUFFER CALL GB_IN_STRING(STR_BEGIN_PLOT) CALL GB_EMPTY CALL GDWAIT(2000) LVECTOR_GOING = .FALSE. RETURN C C **** C MOVE C **** C 300 CONTINUE C CONVERT CM. TO GRAPHICS UNITS ROUNDED IXPOSN = XGUPCM*XA(1)+0.5 IYPOSN = YGUPCM*YA(1)+0.5 LVECTOR_GOING = .FALSE. RETURN C C **** C DRAW C **** C 400 CONTINUE IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4)) IF (LVECTOR_GOING) GO TO 410 LDUMMY = GB_TEST_FLUSH(9) LVECTOR_GOING = .TRUE. CALL GB_INSERT(GS) CALL GD_4010_CONVERT(IXPOSN,IYPOSN) 410 CALL GD_4010_CONVERT(IX,IY) IXPOSN = IX IYPOSN = IY RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GB_EMPTY CALL GB_INSERT(GS) CALL GD_4010_CONVERT(0,1020) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C DE-ASSIGN THE CHANNAL C CALL GB_FINISH(0) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE RETURN C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE CALL GB_EMPTY LVECTOR_GOING = .FALSE. C C ASK FOR 1 GIN INPUT C C CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR) C ICHAR = GINBUFR(1) IX1 = GINBUFR(2) IX2 = GINBUFR(3) IY1 = GINBUFR(4) IY2 = GINBUFR(5) C XA(1) = IAND(ICHAR,127) !PICK CHARACTER XA(2) = (32*IAND(IX1,31)+IAND(IX2,31))/XGUPCM XA(3) = (32*IAND(IY1,31)+IAND(IY2,31))/YGUPCM C RETURN END SUBROUTINE GD4014(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C TEK 4014 DRIVER FOR DIGLIB/VAX C C----------------------------------------------------------------------- C BYTE ESC, CSUB, GS, US, CR, FF PARAMETER (ESC=27, CSUB=26, GS=29, US=31, CR=13, FF=12) CHARACTER*(*) TERMINAL PARAMETER (TERMINAL='TT') C C DEFINITIONS FOR DEVICE CONTROL C BYTE STR_END(2) BYTE STR_BEGIN_PLOT(4) DATA STR_END /US,0/ DATA STR_BEGIN_PLOT /ESC,FF,2*0/ C DEFINITIONS FOR GIN C BYTE GINBUFR(8), PROMPT(4) DATA PROMPT /ESC, CSUB, 2*0/ DATA IGIN_IN_CHARS /5/ C C DECLARE BUFFERING FUNCTION C LOGICAL GB_TEST_FLUSH C C DECLARE VARS NEED FOR DRIVER OPERATION C LOGICAL LVECTOR_GOING, LDUMMY DIMENSION DCHAR(8) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /4014.0, 36.212, 27.15, 28.25, 28.25, 1.0, 130.0, 1.0/ C C***************** C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIRST, INITIALIZE THE BUFFER SUBROUTINES C CALL GB_INITIALIZE(0,STR_END,TERMINAL,IERR) LVECTOR_GOING = .FALSE. YA(1) = IERR RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_NEW_BUFFER CALL GB_IN_STRING(STR_BEGIN_PLOT) CALL GB_EMPTY CALL GDWAIT(2000) LVECTOR_GOING = .FALSE. RETURN C C **** C MOVE C **** C 300 CONTINUE C CONVERT CM. TO GRAPHICS UNITS ROUNDED IXPOSN = XGUPCM*XA(1)+0.5 IYPOSN = YGUPCM*YA(1)+0.5 LVECTOR_GOING = .FALSE. RETURN C C **** C DRAW C **** C 400 CONTINUE IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4)) IF (LVECTOR_GOING) GO TO 410 LDUMMY = GB_TEST_FLUSH(9) LVECTOR_GOING = .TRUE. CALL GB_INSERT(GS) CALL GD_4010_CONVERT(IXPOSN,IYPOSN) 410 CALL GD_4010_CONVERT(IX,IY) IXPOSN = IX IYPOSN = IY RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GB_EMPTY CALL GB_INSERT(GS) CALL GD_4010_CONVERT(0,1020) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C DE-ASSIGN THE CHANNAL C CALL GB_FINISH(0) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE RETURN C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE CALL GB_EMPTY LVECTOR_GOING = .FALSE. C C ASK FOR 1 GIN INPUT C C CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR) C ICHAR = GINBUFR(1) IX1 = GINBUFR(2) IX2 = GINBUFR(3) IY1 = GINBUFR(4) IY2 = GINBUFR(5) C XA(1) = IAND(ICHAR,127) !PICK CHARACTER XA(2) = (32*IAND(IX1,31)+IAND(IX2,31))/XGUPCM XA(3) = (32*IAND(IY1,31)+IAND(IY2,31))/YGUPCM C RETURN END SUBROUTINE GD_4014_CONVERT(IX,IY) C C CONVERTS (IX,IY) TO THE 4014 12-BIT FORMAT AND PLACES THE C CHARACTERS INTO THE BUFFER. OPTIMIZED FOR MINIMUM CHARS TO BE C TRANSMITTED. C COMMON /GD_4014_STATE_MEM/ IOLD_HIY, IOLD_EX, IOLD_LOY, IOLD_HIX DATA IOLD_HIY, IOLD_EX, IOLD_LOY, IOLD_HIX /4*-1/ IHIY = 32+IY/128 IEX = 96+4*IAND(IY,3)+IAND(IX,3) ILOY = 96+IAND(IY/4,31) IHIX = 32+IX/128 C C HI-Y ONLY NEEDS BE SENT WHEN IT CHANGES C IF (IHIY .NE. IOLD_HIY) THEN IOLD_HIY = IHIY CALL GB_INSERT(IHIY) ENDIF C C EXTRA-BITS ONLY NEEDS BE SENT WHEN IT CHANGES, BUT IF SENT, THEN C LO-Y MUST BE SENT EVEN IF IT DIDN'T CHANGE. C IF (IEX .NE. IOLD_EX) THEN IOLD_EX = IEX CALL GB_INSERT(IEX) CALL GB_INSERT(ILOY) IOLD_LOY = ILOY ELSE C C SEND LO-Y IF IT CHANGED OR IF WE NEED TO SEND A HI-X C IF (ILOY .NE. IOLD_LOY .OR. 1 IHIX .NE. IOLD_HIX) THEN IOLD_LOY = ILOY CALL GB_INSERT(ILOY) ENDIF ENDIF C C HI-X CAN ONLY BE SENT IF PRECEEDED BY LO-Y --> THIS IS HANDLED C PREVIOUSLY. C IF (IHIX .NE. IOLD_HIX) THEN IOLD_HIX = IHIX CALL GB_INSERT(IHIX) ENDIF C C LO-X MUST ALWAYS BE SENT C CALL GB_INSERT(64+IAND(IX/4,31)) RETURN END SUBROUTINE GD_4014_ZORCH COMMON /GD_4014_STATE_MEM/ IOLD_HIY, IOLD_EX, IOLD_LOY, IOLD_HIX IOLD_HIY = -1 IOLD_EX = -1 IOLD_LOY = -1 IOLD_HIX = -1 RETURN END SUBROUTINE GD4014REM(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C REMOTE (OTHER TT LINE) TEK 4014 DRIVER FOR DIGLIB/VAX C C----------------------------------------------------------------------- C BYTE ESC, CSUB, GS, US, CR, FF PARAMETER (ESC=27, CSUB=26, GS=29, US=31, CR=13, FF=12) CHARACTER*(*) TERMINAL PARAMETER (TERMINAL='DIG_4014_TTY') C C DEFINITIONS FOR DEVICE CONTROL C BYTE STR_END(2) BYTE STR_BEGIN_PLOT(4) DATA STR_END /US,0/ DATA STR_BEGIN_PLOT /ESC,FF,2*0/ C DEFINITIONS FOR GIN C BYTE GINBUFR(8), PROMPT(4) DATA PROMPT /ESC, CSUB, 2*0/ DATA IGIN_IN_CHARS /5/ C C DECLARE BUFFERING FUNCTION C LOGICAL GB_TEST_FLUSH C C DECLARE VARS NEED FOR DRIVER OPERATION C LOGICAL LVECTOR_GOING, LDUMMY DIMENSION DCHAR(8) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /4014.0, 36.212, 27.15, 28.25, 28.25, 1.0, 146.0, 1.0/ C C***************** C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIRST, INITIALIZE THE BUFFER SUBROUTINES C CALL GB_INITIALIZE(0,STR_END,TERMINAL,IERR) YA(1) = IERR LVECTOR_GOING = .FALSE. RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_NEW_BUFFER CALL GB_IN_STRING(STR_BEGIN_PLOT) CALL GB_EMPTY CALL GDWAIT(2000) LVECTOR_GOING = .FALSE. RETURN C C **** C MOVE C **** C 300 CONTINUE C CONVERT CM. TO GRAPHICS UNITS ROUNDED IXPOSN = XGUPCM*XA(1)+0.5 IYPOSN = YGUPCM*YA(1)+0.5 LVECTOR_GOING = .FALSE. RETURN C C **** C DRAW C **** C 400 CONTINUE IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4)) IF (LVECTOR_GOING) GO TO 410 LDUMMY = GB_TEST_FLUSH(9) LVECTOR_GOING = .TRUE. CALL GB_INSERT(GS) CALL GD_4010_CONVERT(IXPOSN,IYPOSN) 410 CALL GD_4010_CONVERT(IX,IY) IXPOSN = IX IYPOSN = IY RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GB_EMPTY CALL GB_INSERT(GS) CALL GD_4010_CONVERT(0,50) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C DE-ASSIGN THE CHANNAL C CALL GB_FINISH(0) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE RETURN C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE CALL GB_EMPTY LVECTOR_GOING = .FALSE. C C ASK FOR 1 GIN INPUT C C CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR) C ICHAR = GINBUFR(1) IX1 = GINBUFR(2) IX2 = GINBUFR(3) IY1 = GINBUFR(4) IY2 = GINBUFR(5) C XA(1) = IAND(ICHAR,127) !PICK CHARACTER XA(2) = (32*IAND(IX1,31)+IAND(IX2,31))/XGUPCM XA(3) = (32*IAND(IY1,31)+IAND(IY2,31))/YGUPCM C RETURN END SUBROUTINE GD4025(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C TEKTRONIX 4025 DRIVER FOR DIGLIB/VAX C C----------------------------------------------------------------------- C BYTE CMD, CSUB, US, GS, CR, FF PARAMETER (CMD=33, CSUB=26, US=31, GS=29, CR=13, FF=12) CHARACTER*(*) TERMINAL PARAMETER (TERMINAL='TT') C C DEFINITIONS FOR DEVICE CONTROL C BYTE STR_END(2), STR_BEGIN_PLOT(14), STR_COLOR_SET(8) BYTE STR_INIT_4025(32) BYTE ASCIID, ASCIIA, ASCIIT C DATA ASCIID, ASCIIA, ASCIIT /'D','A','T'/ DATA STR_END /13,0/ DATA STR_INIT_4025 / 1 CMD,'W','O','R',' ','3','0', 2 CMD,'G','R','A',' ','1',',','3','0', 3 CMD,'J','U','M',' ','1',',','1', 4 CMD,'L','I','N',' ','1',2*0/ DATA STR_BEGIN_PLOT / 1 CMD,'E','R','A',' ','G', 2 CMD,'L','I','N',' ','1',2*0/ DATA STR_COLOR_SET / 1 CMD,'L','I','N',' ','1',2*0/ C C DEFINITIONS FOR GIN C BYTE GINBUFR(28), PROMPT(8) C DATA PROMPT / 1 CMD,'E','N','A',' ','1',CR,0/ DATA IGIN_IN_CHARS /27/ C C DECLARE BUFFERING FUNCTION C LOGICAL GB_TEST_FLUSH C C DECLARE VARS NEED FOR DRIVER OPERATION C LOGICAL LVECTOR_GOING, LDUMMY DIMENSION DCHAR(8) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /4025.0, 21.69, 14.223, 29.46, 29.46, 1.0, 133.0, 1.0/ C C***************** C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIRST, INITIALIZE THE BUFFER SUBROUTINES C CALL GB_INITIALIZE(US,STR_END,TERMINAL,IERR) YA(1) = IERR IF (IERR .NE. 0) RETURN LVECTOR_GOING = .FALSE. C C CREATE WORKSPACE AND GRAPHICS AREA C CALL GB_IN_STRING(STR_INIT_4025) CALL GB_EMPTY RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_NEW_BUFFER CALL GB_IN_STRING(STR_BEGIN_PLOT) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C **** C MOVE C **** C 300 CONTINUE C CONVERT CM. TO GRAPHICS UNITS ROUNDED IXPOSN = XGUPCM*XA(1)+0.5 IYPOSN = YGUPCM*YA(1)+0.5 LVECTOR_GOING = .FALSE. RETURN C C **** C DRAW C **** C 400 CONTINUE IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4)) IF (LVECTOR_GOING) GO TO 410 LDUMMY = GB_TEST_FLUSH(9) LVECTOR_GOING = .TRUE. CALL GB_INSERT(GS) CALL GB_USE_TERMINATOR CALL GD_4010_CONVERT(IXPOSN,IYPOSN) 410 CALL GD_4010_CONVERT(IX,IY) IXPOSN = IX IYPOSN = IY RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C DO NOTHING - LET USER KILL PICTURE C CALL GB_EMPTY RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE CALL GB_EMPTY ICOLOR = XA(1) IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 1) RETURN IF (ICOLOR .EQ. 1) THEN STR_COLOR_SET(6) = 49 ELSE STR_COLOR_SET(6) = 69 ENDIF CALL GB_IN_STRING(STR_COLOR_SET) LVECTOR_GOING = .FALSE. RETURN C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE CALL GB_EMPTY LVECTOR_GOING = .FALSE. C C ASK FOR 1 GIN INPUT C C 920 CONTINUE CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.FALSE.,GINBUFR) IF ((GINBUFR(2) .NE. ASCIID) .OR. (GINBUFR(3) .NE. ASCIIA) .OR. 1 (GINBUFR(4) .NE. ASCIIT)) GOTO 920 C C GET KEY PRESSED, X AND Y C C KEY IS AT 9, X IS AT 13, AND Y IS AT 17 C DECODE (11,911,GINBUFR(9)) XA(1), XA(2), XA(3) 911 FORMAT(F3.0,1X,F3.0,1X,F3.0) XA(2) = XA(2)/XGUPCM XA(3) = XA(3)/YGUPCM RETURN END SUBROUTINE GD4027(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C TEKTRONIX 4027 DRIVER FOR DIGLIB/VAX C UNTESTED but derived from the 4025 driver, so it should C mostly work C C----------------------------------------------------------------------- C BYTE CSUB, US, GS, CR, FF, ESC PARAMETER (CSUB=26, US=31, GS=29, CR=13, FF=12, ESC=27) CHARACTER*(*) TERMINAL, LOG_CC, LOG_COM PARAMETER (TERMINAL='TT') PARAMETER (LOG_CC='TEK_4025CC') PARAMETER (LOG_COM = 'TEK_4025COM') C C DEFINITIONS FOR DEVICE CONTROL C CHARACTER*1 NEW_CC CHARACTER*80 NEW_COM BYTE CMD, BCHAR BYTE STR_END(2) BYTE ASCIID, ASCIIA, ASCIIT BYTE BCOLOR_MAP(8) C DATA CMD /33/ DATA ASCIID, ASCIIA, ASCIIT /'D','A','T'/ DATA STR_END /13,0/ DATA BCOLOR_MAP / '7', '0', '1', '2', '3', '4', '5', '6' / C C DEFINITIONS FOR GIN C BYTE GINBUFR(28), PROMPT(8) C DATA PROMPT / 1 0,'E','N','A',' ','1',CR,0/ DATA IGIN_IN_CHARS /27/ C C DECLARE BUFFERING FUNCTION C LOGICAL GB_TEST_FLUSH C C DECLARE VARS NEED FOR DRIVER OPERATION C INTEGER*4 SYS$TRNLOG, STR$UPCASE LOGICAL LVECTOR_GOING, LDUMMY DIMENSION DCHAR(8) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /4027.0, 24.706, 16.2, 25.864, 25.864, 7.0, 229.0, 1.0/ C C***************** C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 11) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900,1000,1100) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIRST, INITIALIZE THE BUFFER SUBROUTINES C CALL GB_INITIALIZE(US,STR_END,TERMINAL,IERR) YA(1) = IERR IF (IERR .NE. 0) RETURN LVECTOR_GOING = .FALSE. C C SEE IF USER DEFINED COMMAND CHARACTER C ISTATUS = SYS$TRNLOG(LOG_CC,ILENCC,NEW_CC, , , ) IF (ISTATUS) THEN CMD = ICHAR(NEW_CC) ENDIF C C EXIT ANSI MODE (JUST INCASE TERMINAL IS IN ANSI MODE) C CALL GB_INSERT(ESC) CALL GB_IN_STRING('[~') C C CREATE WORKSPACE AND GRAPHICS AREA C CALL GB_INSERT(CMD) CALL GB_IN_STRING('WOR 30') CALL GB_INSERT(CMD) CALL GB_IN_STRING('GRA 1,30') CALL GB_INSERT(CMD) CALL GB_IN_STRING('JUM 1,1') CALL GB_INSERT(CMD) CALL GB_IN_STRING('LIN 1') CALL GB_INSERT(CMD) CALL GB_IN_STRING('COL C0') CALL GB_EMPTY RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_EMPTY CALL GB_INSERT(CMD) CALL GB_IN_STRING('ERA G') CALL GB_INSERT(CMD) CALL GB_IN_STRING('COL C0') CALL GB_EMPTY C C COMMENT OUT THE FOLLOWING IF YOU DON'T WANT YOUR 4027s COLORS C CHANGED TO "NORMAL" BY DIGLIB C CALL GD4027_MIX(CMD,0,0,0,0) CALL GD4027_MIX(CMD,1,100,100,100) CALL GD4027_MIX(CMD,2,100,0,0) CALL GD4027_MIX(CMD,3,0,100,0) CALL GB_EMPTY CALL GD4027_MIX(CMD,4,0,0,100) CALL GD4027_MIX(CMD,5,100,100,0) CALL GD4027_MIX(CMD,6,100,0,100) CALL GD4027_MIX(CMD,7,0,100,100) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C **** C MOVE C **** C 300 CONTINUE C CONVERT CM. TO GRAPHICS UNITS ROUNDED IXPOSN = XGUPCM*XA(1)+0.5 IYPOSN = YGUPCM*YA(1)+0.5 LVECTOR_GOING = .FALSE. RETURN C C **** C DRAW C **** C 400 CONTINUE IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4)) IF (LVECTOR_GOING) GO TO 410 LDUMMY = GB_TEST_FLUSH(9) LVECTOR_GOING = .TRUE. CALL GB_INSERT(GS) CALL GB_USE_TERMINATOR CALL GD_4010_CONVERT(IXPOSN,IYPOSN) 410 IF (IX .NE. IXPOSN .OR. IY .NE. IYPOSN) THEN CALL GD_4010_CONVERT(IX,IY) IXPOSN = IX IYPOSN = IY ENDIF RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C SEE IF USER WANTS ANYTHING DONE, IF SO, DO IT C ISTATUS = SYS$TRNLOG(LOG_COM,ILENCOM,NEW_COM, , , ) IF (ISTATUS) THEN ISTATUS = STR$UPCASE(NEW_COM,NEW_COM) IF (NEW_COM(1:4) .EQ. 'ANSI') THEN TYPE 601 601 FORMAT('$Hit return to return terminal to ANSI mode.') ACCEPT 602, ISTATUS 602 FORMAT(A1) ENDIF CALL GB_EMPTY CALL GB_INSERT(CMD) DO 610 I=1,ILENCOM BCHAR = ICHAR(NEW_COM(I:I)) CALL GB_INSERT(BCHAR) 610 CONTINUE ENDIF CALL GB_EMPTY RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE CALL GB_EMPTY ICOLOR = XA(1) IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 7) RETURN CALL GB_INSERT(CMD) CALL GB_IN_STRING('COL C') CALL GB_INSERT(BCOLOR_MAP(ICOLOR+1)) LVECTOR_GOING = .FALSE. RETURN C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE CALL GB_EMPTY LVECTOR_GOING = .FALSE. C C ASK FOR 1 GIN INPUT C 920 CONTINUE PROMPT(1) = CMD CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.FALSE.,GINBUFR) IF ((GINBUFR(2) .NE. ASCIID) .OR. (GINBUFR(3) .NE. ASCIIA) .OR. 1 (GINBUFR(4) .NE. ASCIIT)) GOTO 920 C C GET KEY PRESSED, X AND Y C C KEY IS AT 9, X IS AT 13, AND Y IS AT 17 C DECODE (11,911,GINBUFR(9)) XA(1), XA(2), XA(3) 911 FORMAT(F3.0,1X,F3.0,1X,F3.0) XA(2) = XA(2)/XGUPCM XA(3) = XA(3)/YGUPCM RETURN C C DEFINE COLOR VIA RGB C 1000 CONTINUE CALL GB_EMPTY LVECTOR_GOING = .FALSE. CALL GD4027_MIX(CMD,INT(XA(1)),INT(YA(1)),INT(YA(2)),INT(YA(3))) RETURN C C DEFINE COLOR VIA HLS C 1100 CONTINUE CALL GB_EMPTY LVECTOR_GOING = .FALSE. CALL GD4027_MAP(CMD,INT(XA(1)),INT(YA(1)),INT(YA(2)),INT(YA(3))) RETURN END SUBROUTINE GD4027_MAP(CC,ICOLOR,IHUE,ILIGHTNESS,ISATURATION) C C THIS SUBROUTINE DOES A 4027 "MAP" COMMAND C BYTE STR_MAP(20) c ENCODE (19,11,STR_MAP) CC, ICOLOR, IHUE, ILIGHTNESS, ISATURATION 11 FORMAT(A1,'MAP C',I1,',',I3,',',I3,',',I3) STR_MAP(20) = 0 CALL GB_IN_STRING(STR_MAP) RETURN END SUBROUTINE GD4027_MIX(CC,ICOLOR,IRED,IGREEN,IBLUE) C C THIS SUBROUTINE DOES A 4027 "MIX" COMMAND C BYTE STR_MIX(20) C ENCODE (19,11,STR_MIX) CC,ICOLOR, IRED, IGREEN, IBLUE 11 FORMAT(A1,'MIX C',I1,',',I3,',',I3,',',I3) STR_MIX(20) = 0 CALL GB_IN_STRING(STR_MIX) RETURN END SUBROUTINE GD4105(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C TEK 4105 DRIVER FOR DIGLIB/VAX C VERSION 2.1A - CURSOR POSITIONING AND HARDWARE POLYGONS (fixed) C CCCCCCCCCCCCCCCCC C C PARAMETERS TO MAKE THIS A 4105 DRIVER C PARAMETER (TERM_NUMBER = 4105.0) PARAMETER (SCREEN_WIDTH_CM = 24.564) PARAMETER (SCREEN_HEIGHT_CM = 18.41) PARAMETER (X_DOTS = 480.0) PARAMETER (Y_DOTS = 360.0) PARAMETER (NUMBER_FG_COLORS = 7) C C AND NOW, THE GENERIC 410X STUFF C INCLUDE 'GD410X.FOR' END SUBROUTINE GD4107(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C TEK 4107 DRIVER FOR DIGLIB/VAX C VERSION 2.1 - CURSOR POSITIONING AND HARDWARE POLYGONS C BYTE ESC, CSUB, GS, CR, FF, US PARAMETER (ESC=27, CSUB=26, GS=29, CR=13, FF=12, US=31) CHARACTER*(*) TERMINAL PARAMETER (TERMINAL='TT') C C DEFINITIONS FOR DEVICE CONTROL C BYTE STR_END(2), STR_INIT_DEV(26), STR_WINDOW(4) BYTE STR_BEGIN_PLOT(4), STR_COLOR_SET(6) BYTE STR_END_PLOT(2), STR_RLS_DEV(6) BYTE STR_BEGIN_POLY(4), STR_END_POLY(6) DATA STR_END /US,0/ DATA STR_INIT_DEV/ 1 ESC,'%','!','0', !CODE TEK 2 ESC,'K','A','1', !DAENABLE YES 3 ESC,'L','M','0', !DAMODE REPLACE 4 ESC,'M','L','1', !LINEINDEX 1 (COLOR 1) 5 ESC,'N','U',':', !BYPASS CANCEL CHARACTER (LF) 6 ESC,'N','T','1','=',0/ !EOL STRING DATA STR_WINDOW / ESC,'R','W',0/ DATA STR_BEGIN_PLOT/ 1 ESC,FF,0,0/ !ERASE SCREEN DATA STR_COLOR_SET / 1 ESC,'M','L','1',0,0/ !LINEINDEX 1 (COLOR N) DATA STR_END_PLOT /0,0/ DATA STR_RLS_DEV / 1 ESC,'%','!','1',0,0/ !CODE ANSI DATA STR_BEGIN_POLY / ESC,'L','P',0/ DATA STR_END_POLY / US,ESC,'L','E',2*0/ C C DEFINITIONS FOR GIN C BYTE GINBUFR(8), PROMPT(4), STR_END_GIN(2), STR_MOVE_GIN_CURSOR(6) DATA PROMPT /ESC, CSUB, 0, 0/ DATA IGIN_IN_CHARS /6/ DATA STR_END_GIN /10,0/ DATA STR_MOVE_GIN_CURSOR / ESC, 'S', 'X', '0', 0,0/ DATA IX_GIN_CURSOR, IY_GIN_CURSOR / 240, 180 / C C DECLARE BUFFERING FUNCTION C LOGICAL GB_TEST_FLUSH C C DECLARE VARS NEED FOR DRIVER OPERATION C LOGICAL LVECTOR_GOING, LDUMMY DIMENSION DCHAR(8) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /4107.0, 24.577, 18.423, 26.0, 26.0, 7.0, 389.0, 1.0/ C C***************** C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .GT. 1026) GOTO 20000 IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIRST, INITIALIZE THE BUFFER SUBROUTINES C CALL GB_INITIALIZE(0,STR_END,TERMINAL,IERR) YA(1) = IERR IF (IERR .NE. 0) RETURN C C INITIALIZE THE 4107 C CALL GB_IN_STRING(STR_INIT_DEV) CALL GB_IN_STRING(STR_WINDOW) CALL GD_4010_CONVERT(0,0) IX = INT(DCHAR(2)*XGUPCM+0.5) IY = INT(DCHAR(3)*YGUPCM+0.5) CALL GD_4010_CONVERT(IX,IY) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_NEW_BUFFER CALL GB_IN_STRING(STR_BEGIN_PLOT) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C **** C MOVE C **** C 300 CONTINUE C CONVERT CM. TO GRAPHICS UNITS ROUNDED IXPOSN = XGUPCM*XA(1)+0.5 IYPOSN = YGUPCM*YA(1)+0.5 LVECTOR_GOING = .FALSE. RETURN C C **** C DRAW C **** C 400 CONTINUE IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4)) IF (LVECTOR_GOING) GO TO 410 LDUMMY = GB_TEST_FLUSH(9) LVECTOR_GOING = .TRUE. CALL GB_INSERT(GS) CALL GD_4010_CONVERT(IXPOSN,IYPOSN) 410 CALL GD_4010_CONVERT(IX,IY) IXPOSN = IX IYPOSN = IY RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GB_EMPTY CALL GB_IN_STRING(STR_END_PLOT) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C DE-ASSIGN THE CHANNAL C CALL GB_EMPTY CALL GB_IN_STRING(STR_WINDOW) CALL GD_4010_CONVERT(0,0) CALL GD_4010_CONVERT(1023,767) CALL GB_FINISH(STR_RLS_DEV) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE LDUMMY = GB_TEST_FLUSH(6) ICOLOR = XA(1) IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 7) RETURN STR_COLOR_SET(4) = 48+ICOLOR !MAKE ASCII CHARACTER CALL GB_IN_STRING(STR_COLOR_SET) LVECTOR_GOING = .FALSE. RETURN C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE C C POSITION CURSOR TO ITS LAST GIN POSITION (ELSE MIDDLE OF SCREEN) C CALL GB_TEST_FLUSH(10) CALL GB_IN_STRING(STR_MOVE_GIN_CURSOR) CALL GD_4010_CONVERT(IX_GIN_CURSOR,IY_GIN_CURSOR) CALL GB_EMPTY C CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR) C ICHAR = GINBUFR(1) IX1 = GINBUFR(2) IX2 = GINBUFR(3) IY1 = GINBUFR(4) IY2 = GINBUFR(5) C XA(1) = IAND(ICHAR,127) !PICK CHARACTER IX_GIN_CURSOR = 32*IAND(IX1,31)+IAND(IX2,31) XA(2) = IX_GIN_CURSOR/XGUPCM IY_GIN_CURSOR = 32*IAND(IY1,31)+IAND(IY2,31) XA(3) = IY_GIN_CURSOR/YGUPCM C CALL GB_IN_STRING(STR_END_GIN) CALL GB_EMPTY RETURN C C ******************* C DRAW FILLED POLYGON C ******************* C 20000 CONTINUE NPTS = IFXN - 1024 IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(20)) IF (LVECTOR_GOING) THEN CALL GB_INSERT(US) LVECTOR_GOING = .FALSE. ENDIF CALL GB_IN_STRING(STR_BEGIN_POLY) CALL GD_4010_CONVERT(IX,IY) C C DO VERTICES 2 THRU N. NOTE: WE START WITH A SINCE C LVECTOR_GOING IS "FALSE" C DO 20010 I = 2, NPTS C MAKE SURE 10 CHARS (4 FOR X,Y AND 6 FOR END POLYGON) LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(10)) IF (.NOT. LVECTOR_GOING) CALL GB_INSERT(GS) CALL GD_4010_CONVERT(INT(XGUPCM*XA(I)+0.5), 1 INT(YGUPCM*YA(I)+0.5)) 20010 CONTINUE CALL GB_IN_STRING(STR_END_POLY) LVECTOR_GOING = .FALSE. RETURN END PARAMETER (X_RES = (X_DOTS-1.0)/SCREEN_WIDTH_CM) PARAMETER (Y_RES = (Y_DOTS-1.0)/SCREEN_HEIGHT_CM) PARAMETER (RESOLUTION = (X_RES+Y_RES)/2.0) PARAMETER (XLENGTH = (X_DOTS-1.0)/RESOLUTION) PARAMETER (YLENGTH = (Y_DOTS-1.0)/RESOLUTION) PARAMETER (COLORS_FG = NUMBER_FG_COLORS) PARAMETER (IX_CENTER = RESOLUTION*XLENGTH/2.0) PARAMETER (IY_CENTER = RESOLUTION*YLENGTH/2.0) BYTE ESC,CSUB,GS,CR,FF,US PARAMETER (ESC=27, CSUB=26, GS=29, CR=13, FF=12, US=31) CHARACTER*(*) TERMINAL PARAMETER (TERMINAL='TT') C C DEFINITIONS FOR DEVICE CONTROL C BYTE STR_END(2), STR_INIT_DEV(26), STR_WINDOW(4) BYTE STR_BEGIN_PLOT(4), STR_COLOR_SET(6) BYTE STR_END_PLOT(2), STR_RLS_DEV(6) BYTE STR_BEGIN_POLY(4), STR_END_POLY(6) BYTE STR_FILL_PATRN(6) DATA STR_END /US,0/ DATA STR_INIT_DEV/ 1 ESC,'%','!','0', !CODE TEK 2 ESC,'K','A','1', !DAENABLE YES 3 ESC,'L','M','0', !DAMODE REPLACE 4 ESC,'M','L','1', !LINEINDEX 1 (COLOR 1) 5 ESC,'N','U',':', !BYPASS CANCEL CHARACTER (LF) 6 ESC,'N','T','1','=',0/ !EOL STRING DATA STR_WINDOW / ESC,'R','W',0/ DATA STR_BEGIN_PLOT/ 1 ESC,FF,0,0/ !ERASE SCREEN DATA STR_COLOR_SET / 1 ESC,'M','L','1',0,0/ !LINEINDEX 1 (COLOR N) DATA STR_END_PLOT /0,0/ DATA STR_RLS_DEV / 1 ESC,'%','!','1',0,0/ !CODE ANSI DATA STR_BEGIN_POLY / ESC,'L','P',0/ DATA STR_END_POLY / US,ESC,'L','E',2*0/ DATA STR_FILL_PATRN /ESC,'M','P',' ',2*0/ C C DEFINITIONS FOR GIN C BYTE GINBUFR(8), PROMPT(4), STR_END_GIN(2), STR_MOVE_GIN_CURSOR(6) DATA PROMPT /ESC, CSUB, 0, 0/ DATA IGIN_IN_CHARS /6/ DATA STR_END_GIN /10,0/ DATA STR_MOVE_GIN_CURSOR / ESC, 'S', 'X', '0', 0,0/ DATA IX_GIN_CURSOR, IY_GIN_CURSOR / IX_CENTER, IY_CENTER / C C DECLARE BUFFERING FUNCTION C LOGICAL GB_TEST_FLUSH C C DECLARE VARS NEED FOR DRIVER OPERATION C LOGICAL LVECTOR_GOING, LDUMMY DIMENSION DCHAR(8) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR / TERM_NUMBER, XLENGTH, YLENGTH, RESOLUTION, 1 RESOLUTION, COLORS_FG, 389.0, 1.0/ C C***************** C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .GT. 1026) GOTO 20000 IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIRST, INITIALIZE THE BUFFER SUBROUTINES C CALL GB_INITIALIZE(0,STR_END,TERMINAL,IERR) YA(1) = IERR IF (IERR .NE. 0) RETURN C C INITIALIZE THE 4105 C CALL GB_IN_STRING(STR_INIT_DEV) CALL GB_IN_STRING(STR_WINDOW) CALL GD_4010_CONVERT(0,0) IX = INT(DCHAR(2)*XGUPCM+0.5) IY = INT(DCHAR(3)*YGUPCM+0.5) CALL GD_4010_CONVERT(IX,IY) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_EMPTY CALL GB_IN_STRING(STR_BEGIN_PLOT) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C **** C MOVE C **** C 300 CONTINUE C CONVERT CM. TO GRAPHICS UNITS ROUNDED IXPOSN = XGUPCM*XA(1)+0.5 IYPOSN = YGUPCM*YA(1)+0.5 LVECTOR_GOING = .FALSE. RETURN C C **** C DRAW C **** C 400 CONTINUE IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4)) IF (LVECTOR_GOING) GO TO 410 LDUMMY = GB_TEST_FLUSH(9) LVECTOR_GOING = .TRUE. CALL GB_INSERT(GS) CALL GD_4010_CONVERT(IXPOSN,IYPOSN) 410 CALL GD_4010_CONVERT(IX,IY) IXPOSN = IX IYPOSN = IY RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GB_EMPTY CALL GB_IN_STRING(STR_END_PLOT) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C DE-ASSIGN THE CHANNAL C CALL GB_EMPTY CALL GB_IN_STRING(STR_WINDOW) CALL GD_4010_CONVERT(0,0) CALL GD_4010_CONVERT(1023,767) CALL GB_FINISH(STR_RLS_DEV) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE LDUMMY = GB_TEST_FLUSH(6) ICOLOR = XA(1) IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. NUMBER_FG_COLORS) RETURN STR_COLOR_SET(4) = 48+ICOLOR !MAKE ASCII CHARACTER CALL GB_IN_STRING(STR_COLOR_SET) LVECTOR_GOING = .FALSE. RETURN C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE C C POSITION CURSOR TO ITS LAST GIN POSITION (ELSE MIDDLE OF SCREEN) C CALL GB_TEST_FLUSH(10) CALL GB_IN_STRING(STR_MOVE_GIN_CURSOR) CALL GD_4010_CONVERT(IX_GIN_CURSOR,IY_GIN_CURSOR) CALL GB_EMPTY C CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR) C ICHAR = GINBUFR(1) IX1 = GINBUFR(2) IX2 = GINBUFR(3) IY1 = GINBUFR(4) IY2 = GINBUFR(5) C XA(1) = IAND(ICHAR,127) !PICK CHARACTER IX_GIN_CURSOR = 32*IAND(IX1,31)+IAND(IX2,31) XA(2) = IX_GIN_CURSOR/XGUPCM IY_GIN_CURSOR = 32*IAND(IY1,31)+IAND(IY2,31) XA(3) = IY_GIN_CURSOR/YGUPCM C CALL GB_IN_STRING(STR_END_GIN) CALL GB_EMPTY RETURN C C ******************* C DRAW FILLED POLYGON C ******************* C 20000 CONTINUE NPTS = IFXN - 1024 IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(26)) IF (LVECTOR_GOING) THEN CALL GB_INSERT(US) LVECTOR_GOING = .FALSE. ENDIF STR_FILL_PATRN(4) = 32 + ICOLOR IF (ICOLOR .EQ. 0) STR_FILL_PATRN(4) = 80 CALL GB_IN_STRING(STR_FILL_PATRN) CALL GB_IN_STRING(STR_BEGIN_POLY) CALL GD_4010_CONVERT(IX,IY) C C DO VERTICES 2 THRU N. NOTE: WE START WITH A SINCE C LVECTOR_GOING IS "FALSE" C DO 20010 I = 2, NPTS C MAKE SURE 10 CHARS (4 FOR X,Y AND 6 FOR END POLYGON) LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(10)) IF (.NOT. LVECTOR_GOING) CALL GB_INSERT(GS) CALL GD_4010_CONVERT(INT(XGUPCM*XA(I)+0.5), 1 INT(YGUPCM*YA(I)+0.5)) 20010 CONTINUE CALL GB_IN_STRING(STR_END_POLY) LVECTOR_GOING = .FALSE. RETURN SUBROUTINE GD4115B(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C TEK 4115B DRIVER FOR DIGLIB/VAX C VERSION 1.0 - CURSOR POSITIONING AND HARDWARE POLYGONS C BYTE ESC, CSUB, GS, CR, FF, US, LF PARAMETER (ESC=27, CSUB=26, GS=29, CR=13, FF=12, US=31, LF=10) CHARACTER*(*) TERMINAL PARAMETER (TERMINAL='TEK4115B_TERM') C C DEFINITIONS FOR DEVICE CONTROL C BYTE STR_END(2), STR_INIT_DEV(48), STR_WINDOW(4) BYTE STR_BEGIN_PLOT(6), STR_COLOR_SET(4) BYTE STR_END_PLOT(2), STR_RLS_DEV(6) BYTE STR_BEGIN_POLY(4), STR_END_POLY(6) BYTE STR_FILL_PATRN(4), STR_SET_GIN_WINDOW(4) BYTE STR_SET_GIN_AREA(6) DATA STR_END /US,0/ DATA STR_INIT_DEV/ 1 ESC,'%','!','0', !CODE TEK 2 ESC,'K','A','1', !DAENABLE YES 3 ESC,'L','M','0', !DAMODE REPLACE 4 ESC,'M','L','1', !LINEINDEX 1 (COLOR 1) 5 ESC,'N','U',':', !BYPASS CANCEL CHARACTER (LF) 6 ESC,'N','T','1','=', !EOL STRING 7 ESC,'N','F','3', !FLAGGING IN/OUT (XON/XOFF IN USE) 8 ESC,'I','C','0','0', !USE CROSS HAIR CURSOR 9 ESC,'I','G','0','0','0', !NO GIN GRIDDING 1 ESC,'T','M','4','1','1',2*0/!SET_COLOR_MODE (MACHINE/OPAQUE/COLOR) DATA STR_WINDOW / ESC,'R','W',0/ DATA STR_SET_GIN_WINDOW / ESC,'I','W',0/ DATA STR_SET_GIN_AREA / ESC,'I','V','0',33,0/ DATA STR_BEGIN_PLOT/ 1 ESC,'R','D','1','4',0/ !1 DISPLAY SURFACE OF 4 BIT PLANES DATA STR_COLOR_SET / 1 ESC,'M','L',0/ !LINEINDEX 1 (COLOR N) DATA STR_END_PLOT /0,0/ DATA STR_RLS_DEV / 1 ESC,'%','!','1',0,0/ !CODE ANSI DATA STR_BEGIN_POLY / ESC,'L','P',0/ DATA STR_END_POLY / US,ESC,'L','E',2*0/ DATA STR_FILL_PATRN /ESC,'M','P',0/ C C DEFINITIONS FOR GIN C BYTE GINBUFR(10), PROMPT(6), STR_MOVE_GIN_CURSOR(6) DATA PROMPT /ESC, 'I','E','0','1', 0/ DATA IGIN_IN_CHARS /8/ DATA STR_MOVE_GIN_CURSOR / ESC, 'S', 'X', '0', 0,0/ DATA IX_GIN_CURSOR, IY_GIN_CURSOR / 640, 512 / C C DECLARE BUFFERING FUNCTION C LOGICAL GB_TEST_FLUSH C C DECLARE VARS NEED FOR DRIVER OPERATION C LOGICAL LVECTOR_GOING, LDUMMY DIMENSION DCHAR(8) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /4115.0, 34.778, 27.817, 36.776, 36.776, 15.0, 389.0, 1.0/ C C***************** C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .GT. 1026) GOTO 20000 IF (IFXN .LE. 0 .OR. IFXN .GT. 10) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900,1000) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIRST, INITIALIZE THE BUFFER SUBROUTINES C CALL GB_INITIALIZE(0,STR_END,TERMINAL,IERR) YA(1) = IERR IF (IERR .NE. 0) RETURN C C INITIALIZE THE 4115 C CALL GB_IN_STRING(STR_INIT_DEV) CALL GB_IN_STRING(STR_WINDOW) CALL GD_4014_CONVERT(0,0) IX = INT(DCHAR(2)*XGUPCM+0.5) IY = INT(DCHAR(3)*YGUPCM+0.5) CALL GD_4014_CONVERT(IX,IY) CALL GB_IN_STRING(STR_SET_GIN_WINDOW) CALL GD_4014_CONVERT(0,0) CALL GD_4014_CONVERT(4095,4095) CALL GB_IN_STRING(STR_SET_GIN_AREA) CALL GD_4014_CONVERT(0,0) CALL GD_4014_CONVERT(4095,4095) CALL GB_EMPTY LVECTOR_GOING = .FALSE. ICOLOR = 1 RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_EMPTY CALL GB_IN_STRING(STR_BEGIN_PLOT) CALL GD4115_CMAP(1,100.0,100.0,100.0) CALL GD4115_CMAP(2,100.0,0.0,0.0) CALL GD4115_CMAP(3,0.0,100.0,0.0) CALL GD4115_CMAP(4,0.0,0.0,100.0) CALL GD4115_CMAP(5,100.0,100.0,0.0) CALL GD4115_CMAP(6,100.0,0.0,100.0) CALL GD4115_CMAP(7,0.0,100.0,100.0) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C **** C MOVE C **** C 300 CONTINUE C CONVERT CM. TO GRAPHICS UNITS ROUNDED IXPOSN = XGUPCM*XA(1)+0.5 IYPOSN = YGUPCM*YA(1)+0.5 LVECTOR_GOING = .FALSE. RETURN C C **** C DRAW C **** C 400 CONTINUE IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(5)) IF (LVECTOR_GOING) GO TO 410 LDUMMY = GB_TEST_FLUSH(11) LVECTOR_GOING = .TRUE. CALL GB_INSERT(GS) CALL GD_4014_CONVERT(IXPOSN,IYPOSN) 410 IF (IX .NE. IXPOSN .OR. IY .NE. IYPOSN) THEN CALL GD_4014_CONVERT(IX,IY) IXPOSN = IX IYPOSN = IY ENDIF RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GB_EMPTY CALL GB_IN_STRING(STR_END_PLOT) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C DE-ASSIGN THE CHANNAL C CALL GB_EMPTY CALL GB_IN_STRING(STR_WINDOW) CALL GD_4014_CONVERT(0,0) CALL GD_4014_CONVERT(4095,4095) CALL GB_FINISH(STR_RLS_DEV) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE LDUMMY = GB_TEST_FLUSH(10) ICOLOR = XA(1) IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. INT(DCHAR(6))) RETURN CALL GB_IN_STRING(STR_COLOR_SET) CALL GD_4110_INT(ICOLOR) LVECTOR_GOING = .FALSE. RETURN C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE C C POSITION CURSOR TO ITS LAST GIN POSITION (ELSE MIDDLE OF SCREEN) C CALL GB_TEST_FLUSH(12) CALL GB_IN_STRING(STR_MOVE_GIN_CURSOR) CALL GD_4014_CONVERT(IX_GIN_CURSOR,IY_GIN_CURSOR) CALL GB_EMPTY C CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR) C CALL GB_INSERT(LF) !SEND BYPASS CANCEL CHARACTER CALL GB_EMPTY C IF (GINBUFR(7) .EQ. CR .AND. GINBUFR(8) .EQ. CR) GO TO 960 CALL GB_IN_STRING('Error reading cursor, try again.') CALL GB_INSERT(CR) CALL GB_EMPTY D TYPE 9999, (I,GINBUFR(I), I=1,IGIN_IN_CHARS) D9999 FORMAT(' Character ',I2,' is ',I4,' decimal.') GO TO 900 C 960 CONTINUE ICHAR = GINBUFR(1) IY1 = GINBUFR(2) IEX = GINBUFR(3) IY2 = GINBUFR(4) IX1 = GINBUFR(5) IX2 = GINBUFR(6) C XA(1) = IAND(ICHAR,127) !PICK CHARACTER IX_GIN_CURSOR = 128*IAND(IX1,31)+4*IAND(IX2,31)+IAND(IEX,3) XA(2) = IX_GIN_CURSOR/XGUPCM IY_GIN_CURSOR = 128*IAND(IY1,31)+4*IAND(IY2,31)+IAND(IEX/4,3) XA(3) = IY_GIN_CURSOR/YGUPCM RETURN C C ********************* C DEFINE COLOR WITH RGB C ********************* C 1000 CONTINUE CALL GB_TEST_FLUSH(14) CALL GD4115_CMAP(INT(XA(1)),YA(1),YA(2),YA(3)) LVECTOR_GOING = .FALSE. RETURN C C ******************* C DRAW FILLED POLYGON C ******************* C 20000 CONTINUE NPTS = IFXN - 1024 IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(40)) IF (LVECTOR_GOING) THEN CALL GB_INSERT(US) LVECTOR_GOING = .FALSE. ENDIF CALL GB_IN_STRING(STR_FILL_PATRN) CALL GD_4110_INT(-ICOLOR) CALL GB_IN_STRING(STR_BEGIN_POLY) CALL GD_4014_CONVERT(IX,IY) C C DO VERTICES 2 THRU N. NOTE: WE START WITH A SINCE C LVECTOR_GOING IS "FALSE" C DO 20010 I = 2, NPTS C MAKE SURE 11 CHARS (5 FOR X,Y AND 6 FOR END POLYGON) LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(11)) IF (.NOT. LVECTOR_GOING) CALL GB_INSERT(GS) CALL GD_4014_CONVERT(INT(XGUPCM*XA(I)+0.5), 1 INT(YGUPCM*YA(I)+0.5)) 20010 CONTINUE CALL GB_IN_STRING(STR_END_POLY) LVECTOR_GOING = .FALSE. RETURN END SUBROUTINE GD_4110_INT(INT) C C CONVERT AN INTEGER INTO THE 4110 32-BIT INTEGER FORMAT AND PLACES C IT IN THE OUTPUT BUFFER C BYTE STRING(6) DATA STRING(6) /0/ C INTABS = IABS(INT) STRING(5) = 48 + IAND(INTABS,15) IF (INT .LT. 0) STRING(5) = STRING(5) - 16 I = 5 INTABS = INTABS/16 100 CONTINUE IF (INTABS .EQ. 0) GO TO 120 I = I-1 STRING(I) = 64 + IAND(INTABS,63) INTABS = INTABS/64 GO TO 100 120 CONTINUE CALL GB_IN_STRING(STRING(I)) RETURN END SUBROUTINE GD4115_CMAP(ICOLOR,RED,GRN,BLU) C C THIS SUBROUTINE SETS THE SPECIFIED COLOR INTO THE LOOK-UP TABLE. C IT ASSUMES THE CALLER HAS MADE SURE THERE ARE ATLEAST 12 BYTES C AVAILABLE IN THE BUFFER. C BYTE ESC PARAMETER (ESC=27) PARAMETER (COLORS = 2.55) PARAMETER (MAXCOL = 255) C BYTE SET_SURFACE_COLOR_MAP(6) DATA SET_SURFACE_COLOR_MAP /ESC, 'T', 'G', '1', '4', 0/ C CALL GB_TEST_FLUSH(20) CALL GB_IN_STRING(SET_SURFACE_COLOR_MAP) CALL GD_4110_INT(ICOLOR) CALL GD_4110_INT(MIN(MAXCOL,INT(COLORS*RED+0.5))) CALL GD_4110_INT(MIN(MAXCOL,INT(COLORS*GRN+0.5))) CALL GD_4110_INT(MIN(MAXCOL,INT(COLORS*BLU+0.5))) RETURN END SUBROUTINE GD4692 (IFXN,XA,YA) c TEKtronix 4692 DRIVER FOR DIGLIB/VAX c Author believed to be Giles Peterson. c Slightly modified by Hal Brand: c * Logical name TEK4692_TTY for terminal port DIMENSION XA(8), YA(3) PARAMETER (TERM_NUMBER = 4692.0) PARAMETER (SCREEN_WIDTH_CM = 24.564) PARAMETER (SCREEN_HEIGHT_CM = 18.41) PARAMETER (X_DOTS = 4096.0) PARAMETER (Y_DOTS = 3133.0) PARAMETER (NUMBER_FG_COLORS = 255) parameter (xdm1 = x_dots-1.) parameter (ydm1 = y_dots-1.) PARAMETER (X_RES = xdm1/SCREEN_WIDTH_CM) PARAMETER (Y_RES = ydm1/SCREEN_HEIGHT_CM) PARAMETER (RESOLUTION = (X_RES+Y_RES)/2.0) parameter (tallx = resolution*x_dots/y_dots) parameter (tally = resolution*y_dots/x_dots) PARAMETER (XLENGTH = xdm1/RESOLUTION) PARAMETER (YLENGTH = ydm1/RESOLUTION) PARAMETER (COLORS_FG = NUMBER_FG_COLORS) PARAMETER (IX_CENTER = RESOLUTION*XLENGTH/2.0) PARAMETER (IY_CENTER = RESOLUTION*YLENGTH/2.0) BYTE eb,ESC,CSUB,GS,CR,FF,US PARAMETER (eb=23,ESC=27, CSUB=26, GS=29, CR=13, FF=12, US=31) CHARACTER*(*) TERMINAL PARAMETER (TERMINAL='TEK4692_TTY') C DEFINITIONS FOR DEVICE CONTROL byte fillpattern(4),lineindex(4),textindex(4) BYTE STR_END(2), STR_INIT_DEV(25), STR_WINDOW(4) BYTE STR_BEGIN_PLOT(3) BYTE STR_END_PLOT(3), unreserve(5) BYTE beginpanel(4),endpanel(4) logical tall data beginpanel /ESC,'L','P',0/, * fillpattern/esc,'M','P',0/, * lineindex/esc,'M','L',0/, * textindex/esc,'M','T',0/ DATA STR_END /US,0/ DATA STR_INIT_DEV/esc,'K','C', * esc,'Q','O','0', * ESC,'K','A','1', !ENABLE dialog area * ESC,'M','L','1', !COLOR 1 * ESC,'N','U',':', !BYPASS CANCEL CHARACTER (LF) * ESC,'N','T','1','=',0/ !EOL STRING DATA STR_WINDOW / ESC,'R','W',0/ DATA STR_BEGIN_PLOT/ESC,FF,0/ DATA STR_END_PLOT /esc,eb,0/ DATA unreserve /ESC,'Q','R','0',0/ DATA endpanel /ESC,'L','E',0/ C DEFINITIONS FOR GIN BYTE GINBUFR(8), PROMPT(4), STR_END_GIN(2), STR_MOVE_GIN_CURSOR(6) DATA PROMPT /ESC, CSUB, 0, 0/ DATA IGIN_IN_CHARS /6/ DATA STR_END_GIN /10,0/ DATA STR_MOVE_GIN_CURSOR / ESC, 'S', 'X', '0', 0,0/ DATA IX_GIN_CURSOR, IY_GIN_CURSOR / IX_CENTER, IY_CENTER / C DECLARE BUFFERING FUNCTION LOGICAL GB_TEST_FLUSH C DECLARE VARS NEED FOR DRIVER OPERATION LOGICAL LVECTOR_GOING, LDUMMY DIMENSION DCHAR(8) c "GUPCM" IS GRAPHICS UNITS PER CENTIMETER EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR / TERM_NUMBER, XLENGTH, YLENGTH, RESOLUTION, * RESOLUTION, COLORS_FG, 389.0, 1.0/ C***************** tall = .false. 10 IF (IFXN .GT. 1026) GOTO 1000 IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN GO TO (100,200,300,400,500,600,700,800,900) IFXN c ********************* c INITIALIZE 100 CALL GB_INITIALIZE (0,STR_END,TERMINAL,IERR) YA(1) = IERR IF (IERR .NE. 0) RETURN CALL GB_IN_STRING (STR_INIT_DEV) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C ************************** C GET FRESH PLOTTING SURFACE 200 CONTINUE CALL GB_NEW_BUFFER CALL GB_IN_STRING (STR_BEGIN_PLOT) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C **** C MOVE 300 CONTINUE C CONVERT CM. TO GRAPHICS UNITS ROUNDED if (tall) then IxPOSN = xdm1 -tallx*YA(1)+0.5 IyPOSN = tally*XA(1)+0.5 else IXPOSN = XGUPCM*XA(1)+0.5 IYPOSN = YGUPCM*YA(1)+0.5 endif LVECTOR_GOING = .FALSE. RETURN C **** C DRAW 400 CONTINUE if (tall) then Ix = xdm1 -tallx*YA(1)+0.5 Iy = tally*XA(1)+0.5 else IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 endif LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4)) IF (.not.LVECTOR_GOING) then LDUMMY = GB_TEST_FLUSH(9) LVECTOR_GOING = .TRUE. CALL GB_INSERT (GS) CALL xyto4692 (IXPOSN,IYPOSN) endif CALL xyto4692 (IX,IY) IXPOSN = IX IYPOSN = IY RETURN C ***************************** C FLUSH GRAPHICS COMMAND BUFFER 500 CONTINUE CALL GB_EMPTY CALL GB_IN_STRING (STR_END_PLOT) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C ****************** C RELEASE THE DEVICE 600 CONTINUE C DE-ASSIGN THE CHANNAL CALL GB_EMPTY CALL GB_FINISH (unreserve) CALL GB_EMPTY call sys$dalloc (namdev) RETURN C ***************************** C RETURN DEVICE CHARACTERISTICS 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C **************************** C SELECT CURRENT DRAWING COLOR 800 LDUMMY = GB_TEST_FLUSH(24) call gb_in_string (lineindex) call intto4692 (xa(1)) call gb_in_string (textindex) call intto4692 (xa(1)) call gb_in_string (fillpattern) call intto4692 (xa(1)) LVECTOR_GOING = .FALSE. RETURN c ********************** c PERFORM GRAPHICS INPUT 900 RETURN c ******************* c DRAW FILLED POLYGON 1000 ldummy = gb_test_flush (11) CALL GB_IN_STRING (beginpanel) if (tall) then Ix = xdm1 -tallx*YA(1)+0.5 Iy = tally*XA(1)+0.5 else IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 endif call xyto4692 (ix,iy) call gb_insert ('0') call gb_insert (gs) LVECTOR_GOING = .FALSE. NPTS = IFXN - 1024 DO 1010 I = 2, NPTS LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(5)) IF (.NOT. LVECTOR_GOING) then ldummy = gb_test_flush (11) lvector_going = .true. CALL GB_INSERT(GS) endif if (tall) then Ix = xdm1 -tallx*YA(i)+0.5 Iy = tally*XA(i)+0.5 else IX = XGUPCM*XA(i)+0.5 IY = YGUPCM*YA(i)+0.5 endif 1010 call xyto4692 (ix,iy) CALL GB_IN_STRING (endpanel) LVECTOR_GOING = .FALSE. RETURN c****************************************************************************** entry GD4692n (IFXN,XA,YA) c Tektronix 4692 narrow driver. tall = .true. go to 10 END c****************************************************************************** c****************************************************************************** subroutine intto4692 (f) c insert char(f) into buffer. byte ic(5) i = abs(f) ic(4) = mod(i,2**4) +2**5 if (f.ge..0) ic(4) = ic(4) +2**4 ic(3) = mod(i/(2**4),2**6) +64 ic(2) = mod(i/(2**10),2**6) +64 ic(1) = mod(i/(2**16),2**6) +64 n = 4 if (ic(3).ne.64) n = 3 if (ic(2).ne.64) n = 2 if (ic(1).ne.64) n = 1 call gb_in_string (ic(n)) return end c****************************************************************************** c****************************************************************************** subroutine xyto4692 (ix,iy) c convert (ix,iy) to Tektronix 4692 code. call gb_insert (32 +iy/128) call gb_insert (96 +mod(ix,4) +4*mod(iy,4)) call gb_insert (96 +mod(iy/4,32)) call gb_insert (32 +ix/128) call gb_insert (64 +mod(ix/4,32)) return end SUBROUTINE GD550(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C Visual 550 DRIVER FOR DIGLIB/VAX V3. C Modified so a scrolling window is set at the top of the C screen for user interaction. C Joe P. Garbarini Jr. 30-May-1984 C C--------------------------------------------------------------------------- C BYTE ESC, CSUB, GS, US, CR, FF BYTE CAN PARAMETER (ESC=27, CSUB=26, GS=29, US=31, CR=13, FF=12) PARAMETER (CAN=24) CHARACTER*(*) TERMINAL PARAMETER (TERMINAL='TT') C C DEFINITIONS FOR DEVICE CONTROL C BYTE STR_END(2) DATA STR_END /CAN,0/ C BYTE STR_BEGIN_PLOT(8) DATA STR_BEGIN_PLOT /ESC,FF,ESC,'/','1','h',2*0/ C BYTE STR_COLOR_SET(6) DATA STR_COLOR_SET /ESC,'/','0','d',2*0/ C LOGICAL*1 V_300(6) LOGICAL*1 V_CAN(2),V_BOTH(6),V_ERA(6),V_SCR(10),V_1TO1(6) DATA V_300 /ESC,'[','?','2','h',0/ DATA V_CAN /CAN, 0/ DATA V_BOTH /ESC,'[','?','5','v',0/ DATA V_ERA /ESC,'[','2','J',0, 0/ DATA V_SCR /ESC,'[','1',';','4','r',4*0/ C C DEFINITIONS FOR GIN C BYTE GINBUFR(8), PROMPT(4) DATA PROMPT /ESC, CSUB, 2*0/ DATA IGIN_IN_CHARS /5/ C C DECLARE BUFFERING FUNCTION C LOGICAL GB_TEST_FLUSH C C DECLARE VARS NEED FOR DRIVER OPERATION C LOGICAL LVECTOR_GOING, LDUMMY DIMENSION DCHAR(8) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) CC C FULL SCREEN C C DATA DCHAR /550.0,23.36,17.79,32.88,32.88,1.0,133.0,1.0/ CC C SPLIT SCREEN C DATA DCHAR /550.0,23.36,15.69,32.88,32.88,1.0,133.0,1.0/ CC C C***************** C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIRST, INITIALIZE THE BUFFER SUBROUTINES C CALL GB_INITIALIZE(0,STR_END,TERMINAL,IERR) YA(1) = IERR IF (IERR .NE. 0) RETURN LVECTOR_GOING = .FALSE. C C SET UP THE SPLIT SCREEN C CALL GB_IN_STRING(V_CAN) CALL GB_IN_STRING(V_300) CALL GB_IN_STRING(V_BOTH) CALL GB_IN_STRING(V_ERA) CALL GB_IN_STRING(V_SCR) CALL GB_EMPTY C RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_EMPTY CALL GB_IN_STRING(STR_BEGIN_PLOT) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C **** C MOVE C **** C 300 CONTINUE C CONVERT CM. TO GRAPHICS UNITS ROUNDED IXPOSN = XGUPCM*XA(1)+0.5 IYPOSN = YGUPCM*YA(1)+0.5 LVECTOR_GOING = .FALSE. RETURN C C **** C DRAW C **** C 400 CONTINUE IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4)) IF (LVECTOR_GOING) GO TO 410 LDUMMY = GB_TEST_FLUSH(9) LVECTOR_GOING = .TRUE. CALL GB_INSERT(GS) CALL GD_4010_CONVERT(IXPOSN,IYPOSN) 410 CALL GD_4010_CONVERT(IX,IY) IXPOSN = IX IYPOSN = IY RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GB_EMPTY CALL GB_INSERT(GS) CALL GD_4010_CONVERT(0,584) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C DE-ASSIGN THE CHANNAL C CALL GB_FINISH(0) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE CALL GB_EMPTY ICOLOR = XA(1) IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 1) RETURN IF (ICOLOR .EQ. 1) THEN STR_COLOR_SET(3) = 48 ELSE STR_COLOR_SET(3) = 49 ENDIF CALL GB_INSERT(GS) CALL GB_IN_STRING(STR_COLOR_SET) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE CALL GB_EMPTY LVECTOR_GOING = .FALSE. C C ASK FOR 1 GIN INPUT C C CALL GB_SEND_CHARS(GS,1) CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR) C ICHAR = GINBUFR(1) IX1 = GINBUFR(2) IX2 = GINBUFR(3) IY1 = GINBUFR(4) IY2 = GINBUFR(5) C XA(1) = IAND(ICHAR,127) !PICK CHARACTER XA(2) = (32*IAND(IX1,31)+IAND(IX2,31))/XGUPCM XA(3) = (32*IAND(IY1,31)+IAND(IY2,31))/YGUPCM C CALL GB_SEND_CHARS(CAN,1) C RETURN END SUBROUTINE GD9400(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C RAMTEK 9400 (WITHOUT LUT) DRIVER FOR DIGLIB/VAX C CURRENTLY CONFIGURED FOR 640X512 C C----------------------------------------------------------------------- C PARAMETER (MAXY=511) PARAMETER (IBUFFER_SIZE=256) CHARACTER*(*) DEVICE_NAME PARAMETER (DEVICE_NAME='_RAM0:') INTEGER*2 IWVL_AND_OP1, IWVL_PLAIN, ICOP_AND_FOREGROUND PARAMETER (IWVL_AND_OP1 = '0E03'X) PARAMETER (IWVL_PLAIN = '0E01'X) PARAMETER (ICOP_AND_FOREGROUND = '8002'X) DIMENSION DCHAR(8) INTEGER*4 SYS$ASSIGN, SYS$QIOW, SYS$DASSGN INTEGER*2 IOCHANTT, IX, IY, ICURRENT_COLOR, ICOLOR_MAP(0:7) INTEGER*2 BUFFER(IBUFFER_SIZE), IOCHAN INTEGER*2 INIT_RAMTEK(4), IERASE_RAMTEK INTEGER*2 IWRITE_CURSOR(3), IREAD_CURSOR LOGICAL*2 LMOVED BYTE CHARBUFR SAVE DCHAR, IOREADNOECHO SAVE IOCHAN, IOCHANTT, BUFFER, IBUFFER_POINTER, INITIAL_POINTER SAVE ICOLOR_MAP, ICURRENT_COLOR, IXPOSN, IYPOSN, LMOVED SAVE INIT_RAMTEK, INIT_BYTES, IERASE_RAMTEK, IERASE_BYTES SAVE IWRITE_CURSOR, IREAD_CURSOR, IOREADLBLK C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) C C DATA WE WILL NEED C DATA DCHAR /9400.0, 32.803, 26.232, 19.48, 19.48, 15.0, 149.0, 1.0/ DATA ICOLOR_MAP / 0, 7, 1, 2, 4, 3, 5, 6 / DATA IOREADNOECHO /'00000071'X/ DATA INIT_RAMTEK /'0600'X, '3300'X, 1, '3400'X/ DATA INIT_BYTES /8/ DATA IERASE_RAMTEK /'0900'X/ DATA IERASE_BYTES /2/ DATA IWRITE_CURSOR /'2C00'X, 320, 256/ DATA IREAD_CURSOR /'2E00'X/ DATA IWRITE_BYTES, IREAD_BYTES / 6, 2/ DATA IOREADLBLK /'00000021'X/ C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIND THE I/O CHANNAL ASSICIATED WITH THE TERMINAL FOR DOING GINS C ISTAT = SYS$ASSIGN(DEVICE_NAME,IOCHAN,,) D TYPE *,'DEVICE NAME ASSIGNMENT STATUS IS ',ISTAT IF (.NOT. ISTAT) THEN YA(1) = 1.0 RETURN ENDIF ISTAT = SYS$ASSIGN('TT',IOCHANTT,,) D TYPE *,'ASSIGN STATUS IS ',ISTAT IF (.NOT. ISTAT) THEN YA(1) = 2.0 RETURN ELSE YA(1) = 0.0 ENDIF C C INITIALIZE THE RAMTEK C CALL GD94WRITE(INIT_RAMTEK,INIT_BYTES,IOCHAN) 190 ICURRENT_COLOR = ICOLOR_MAP(1) LMOVED = .TRUE. IBUFFER_POINTER = 1 RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE C C ERASE THE RAMTEK SCREEN AND RETURN TO NORMAL C CALL GD94WRITE(IERASE_RAMTEK, IERASE_BYTES, IOCHAN) GO TO 190 C C **** C MOVE C **** C 300 CONTINUE C CONVERT CM. TO GRAPHICS UNITS ROUNDED IXPOSN = XGUPCM*XA(1)+0.5 IYPOSN = MAXY - INT(YGUPCM*YA(1)+0.5) LMOVED = .TRUE. RETURN C C **** C DRAW C **** C 400 CONTINUE IX = XGUPCM*XA(1)+0.5 IY = MAXY - INT(YGUPCM*YA(1)+0.5) IF (.NOT. LMOVED) GO TO 450 IF (IBUFFER_POINTER .LT. (IBUFFER_SIZE-10)) GO TO 420 CALL GD94WRITE(BUFFER,2*(IBUFFER_POINTER-1),IOCHAN) IBUFFER_POINTER = 1 420 BUFFER(IBUFFER_POINTER) = IWVL_AND_OP1 BUFFER(IBUFFER_POINTER+1) = ICOP_AND_FOREGROUND BUFFER(IBUFFER_POINTER+2) = ICURRENT_COLOR BUFFER(IBUFFER_POINTER+3) = IXPOSN BUFFER(IBUFFER_POINTER+4) = IYPOSN BUFFER(IBUFFER_POINTER+5) = 0 INDEX_NBYTES = IBUFFER_POINTER + 5 IBUFFER_POINTER = IBUFFER_POINTER + 6 LMOVED = .FALSE. GO TO 460 450 IF (IBUFFER_POINTER .LE. (IBUFFER_SIZE-2)) GO TO 460 CALL GD94WRITE(BUFFER,2*(IBUFFER_POINTER-1),IOCHAN) IBUFFER_POINTER = 3 BUFFER(1) = IWVL_PLAIN BUFFER(2) = 0 INDEX_NBYTES = 2 460 BUFFER(IBUFFER_POINTER) = IX BUFFER(IBUFFER_POINTER+1) = IY IBUFFER_POINTER = IBUFFER_POINTER+2 IXPOSN = IX IYPOSN = IY C C COUNT BYTES OF DATA C BUFFER(INDEX_NBYTES) = BUFFER(INDEX_NBYTES) + 4 RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE IF (IBUFFER_POINTER .EQ. 1) RETURN CALL GD94WRITE(BUFFER,2*(IBUFFER_POINTER-1),IOCHAN) IBUFFER_POINTER = 1 LMOVED = .TRUE. RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C DE-ASSIGN THE CHANNALS C ISTAT = SYS$DASSGN(%VAL(IOCHAN)) ISTAT = SYS$DASSGN(%VAL(IOCHANTT)) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE ICOLOR = ICOLOR_MAP(INT(XA(1))) IF (ICOLOR .EQ. ICURRENT_COLOR) RETURN ICURRENT_COLOR = ICOLOR LMOVED = .TRUE. RETURN C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE IF (IBUFFER_POINTER .EQ. 1) GO TO 910 CALL GD94WRITE(BUFFER,2*(IBUFFER_POINTER-1),IOCHAN) IBUFFER_POINTER = 1 LMOVED = .TRUE. C C SET VISIBLE BIT TO MAKE CURSOR VISIBLE C 910 IWRITE_CURSOR(3) = IOR(IWRITE_CURSOR(3),'0400'X) C C BRING UP CURSOR AT LAST KNOWN LOCATION C CALL GD94WRITE(IWRITE_CURSOR, IWRITE_BYTES, IOCHAN) C C ASK FOR 1 CHARACTER FROM THE TERMINAL C ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHANTT),%VAL(IOREADNOECHO), 1 IOSB, , ,CHARBUFR,%VAL(1), , , , ) IF (.NOT. ISTAT) STOP 'GD9400 - GIN FAILURE' C C TELL 9400 WE WANT TO READ THE CURSOR C CALL GD94WRITE(IREAD_CURSOR, IREAD_BYTES, IOCHAN) C C READ THE CURSOR LOCATION INTO THE "WRITE CURSOR" AREA SO THE NEXT C "WRITE CURSOR" WILL PLACE THE CURSOR AT THIS NEW LOCATION. C ISTAT = SYS$QIOW(%VAL(0), %VAL(IOCHAN), %VAL(IOREADLBLK), 1 IOSB, , ,IWRITE_CURSOR(2), %VAL(4), , , , ) IF (.NOT. ISTAT) STOP 'GD9400 - RAMTEK READ ERROR' D TYPE *,'CURSOR LOCATION ',IWRITE_CURSOR(2), IWRITE_CURSOR(3) C C GET THE KEY, X POSITION, AND Y POSITION C XA(1) = CHARBUFR !PICK CHARACTER IWRITE_CURSOR(2) = IAND(IWRITE_CURSOR(2), '07FF'X) IWRITE_CURSOR(3) = IAND(IWRITE_CURSOR(3), '03FF'X) XA(2) = FLOAT(IWRITE_CURSOR(2))/XGUPCM !X IN CENTIMETERS. XA(3) = FLOAT(MAXY-IWRITE_CURSOR(3))/YGUPCM !Y IN CM. C C MAKE THE CURSOR INVISIBLE C CALL GD94WRITE(IWRITE_CURSOR, IWRITE_BYTES, IOCHAN) RETURN END SUBROUTINE GD94WRITE(BUFFER,NBYTES,IOCHAN) C C THIS SUBROUTINE EMPTYS THE BUFFER IF IT HAS ANYTHING C INTEGER*2 BUFFER(NBYTES/2) INTEGER*2 IOSB(4) INTEGER*4 SYS$QIOW SAVE IOWRITE DATA IOWRITE /'00000020'X/ D TYPE 9999, NBYTES, (BUFFER(I), BUFFER(I), I=1,NBYTES/2) D9999 FORMAT(' GD9400WRITE'/' BYTE COUNT IS ',I6/ D 1 128(1X,Z4,'H',4X,O6/)) ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN),%VAL(IOWRITE), 1 IOSB, , ,BUFFER,%VAL(NBYTES), , , , ) D TYPE *,'GD9400 WRITE STATUS IS ',ISTAT IF (.NOT. ISTAT) STOP 'GD9400 - WRITE ERROR' RETURN END SUBROUTINE GD9400LUT(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C RAMTEK 9400 WITH LUT DRIVER FOR DIGLIB/VAX C CURRENTLY CONFIGURED FOR 1280x1024 AND TYPE 7A LUT C C----------------------------------------------------------------------- C PARAMETER (MAXY=1023) CHARACTER*(*) DEVICE_NAME PARAMETER (DEVICE_NAME='RAA0:') C ********** INTEGER*2 IOCHAN COMMON /GD9400_IO/ IOCHAN C ********** DIMENSION DCHAR(8) INTEGER*4 SYS$ASSIGN, SYS$QIOW, SYS$DASSGN INTEGER*2 IOCHANTT INTEGER*2 INIT_RAMTEK(19), IERASE_RAMTEK INTEGER*2 IWRITE_CURSOR(3), IREAD_CURSOR INTEGER*2 LOAD_LUT(7) BYTE CHARBUFR C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) C C DATA WE WILL NEED C DATA DCHAR /9400.9, 32.8285, 26.258, 38.96, 38.96, 255.0, 213.0, 1.0/ DATA IOREADNOECHO /'00000071'X/ DATA INIT_RAMTEK /'0600'X, '2700'X, '3300'X, 1, '3400'X, '0300'X, 0, 1 16, 0, 4095, 3840, 240, 15, 4080, 3855, 255, '0300'X, 0, 0/ DATA INIT_BYTES /38/ DATA IERASE_RAMTEK /'2B00'X/ DATA IERASE_BYTES /2/ DATA IWRITE_CURSOR /'2C01'X, 320, 256/ DATA IREAD_CURSOR /'2E01'X/ DATA IWRITE_BYTES, IREAD_BYTES / 6, 2/ DATA IOREADLBLK /'00000021'X/ DATA LOAD_LUT /'0300'X, 0, 0, 0, '0300'X, 0, 0/ DATA LOAD_LUT_BYTES /14/ C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 10) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,300,500,600,700,800,900,1000) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIND THE I/O CHANNAL ASSICIATED WITH THE TERMINAL FOR DOING GINS C ISTAT = SYS$ASSIGN(DEVICE_NAME,IOCHAN,,) D TYPE *,'DEVICE NAME ASSIGNMENT STATUS IS ',ISTAT IF (.NOT. ISTAT) THEN YA(1) = 1.0 RETURN ENDIF ISTAT = SYS$ASSIGN('TT',IOCHANTT,,) D TYPE *,'ASSIGN STATUS IS ',ISTAT IF (.NOT. ISTAT) THEN YA(1) = 2.0 RETURN ELSE YA(1) = 0.0 ENDIF C C INITIALIZE THE RAMTEK C CALL GD94WRITE(INIT_RAMTEK,INIT_BYTES) 190 CALL GD9400_BUFRINIT RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE C C ERASE THE RAMTEK SCREEN AND RETURN TO NORMAL C CALL GD94WRITE(IERASE_RAMTEK, IERASE_BYTES) GO TO 190 C C ************* C MOVE AND DRAW C ************* C 300 CONTINUE C C CONVERT CM. TO GRAPHICS UNITS ROUNDED C IX = XGUPCM*XA(1) + 0.5 IY = MAXY - INT(YGUPCM*YA(1) + 0.5) IF (IFXN .EQ. 3) THEN CALL GD9400_MOVE(IX,IY) ELSE CALL GD9400_DRAW(IX,IY) ENDIF RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GD9400_FLUSH RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C DE-ASSIGN THE CHANNALS C ISTAT = SYS$DASSGN(%VAL(IOCHAN)) ISTAT = SYS$DASSGN(%VAL(IOCHANTT)) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE CALL GD9400_COLOR_SET(INT(XA(1))) RETURN C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE CALL GD9400_FLUSH C C SET VISIBLE BIT TO MAKE CURSOR VISIBLE C 910 IWRITE_CURSOR(3) = IOR(IWRITE_CURSOR(3),'0400'X) C C BRING UP CURSOR AT LAST KNOWN LOCATION C CALL GD94WRITE(IWRITE_CURSOR, IWRITE_BYTES) C C ASK FOR 1 CHARACTER FROM THE TERMINAL C ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHANTT),%VAL(IOREADNOECHO), 1 IOSB, , ,CHARBUFR,%VAL(1), , , , ) IF (.NOT. ISTAT) STOP 'GD9400 - GIN FAILURE' C C TELL 9400 WE WANT TO READ THE CURSOR C CALL GD94WRITE(IREAD_CURSOR, IREAD_BYTES) C C READ THE CURSOR LOCATION INTO THE "WRITE CURSOR" AREA SO THE NEXT C "WRITE CURSOR" WILL PLACE THE CURSOR AT THIS NEW LOCATION. C ISTAT = SYS$QIOW(%VAL(0), %VAL(IOCHAN), %VAL(IOREADLBLK), 1 IOSB, , ,IWRITE_CURSOR(2), %VAL(4), , , , ) IF (.NOT. ISTAT) STOP 'GD9400 - RAMTEK READ ERROR' D TYPE *,'CURSOR LOCATION ',IWRITE_CURSOR(2), IWRITE_CURSOR(3) C C GET THE KEY, X POSITION, AND Y POSITION C XA(1) = CHARBUFR !PICK CHARACTER IWRITE_CURSOR(2) = IAND(IWRITE_CURSOR(2), '07FF'X) IWRITE_CURSOR(3) = IAND(IWRITE_CURSOR(3), '03FF'X) XA(2) = FLOAT(IWRITE_CURSOR(2))/XGUPCM !X IN CENTIMETERS. XA(3) = FLOAT(MAXY-IWRITE_CURSOR(3))/YGUPCM !Y IN CM. C C MAKE THE CURSOR INVISIBLE C CALL GD94WRITE(IWRITE_CURSOR, IWRITE_BYTES) RETURN C C ************************** C SET COLOR USING RGB VALUES C ************************** C 1000 LOAD_LUT(2) = XA(1) !DIGLIB COLOR IS LUT ADDRESS LOAD_LUT(3) = 2 !2 BYTES TO SET A SINGLE COLOR LOAD_LUT(4) = 256*INT(0.15*YA(1)) 1 + 16*INT(0.15*YA(2)) + INT(0.15*YA(3)) CALL GD94WRITE(LOAD_LUT,LOAD_LUT_BYTES) RETURN END SUBROUTINE GD9400_MOVE(IX,IY) C C ********** PARAMETER (IBUFFER_SIZE = 512) INTEGER*2 IBUFFER LOGICAL LMOVED, LCOLOR_CHANGED COMMON /GD9400_MD/ IBUFFER(IBUFFER_SIZE), ICURRENT_COLOR, 1 IXPOSN, IYPOSN, IBUFFER_POINTER, LMOVED, LCOLOR_CHANGED C ********** C LMOVED = .TRUE. IXPOSN = IX IYPOSN = IY RETURN END SUBROUTINE GD9400_DRAW(IX,IY) C C ********** PARAMETER (IBUFFER_SIZE = 512) INTEGER*2 IBUFFER LOGICAL LMOVED, LCOLOR_CHANGED COMMON /GD9400_MD/ IBUFFER(IBUFFER_SIZE), ICURRENT_COLOR, 1 IXPOSN, IYPOSN, IBUFFER_POINTER, LMOVED, LCOLOR_CHANGED C ********** C INTEGER*2 IWVL_AND_OP1, ICOP, ICOP_AND_FOREGROUND PARAMETER (IWVL_AND_OP1 = '0E03'X) PARAMETER (ICOP = '8000'X) PARAMETER (ICOP_AND_FOREGROUND = '8002'X) LOGICAL GD9400_FLUSHIF, LDUMMY C D TYPE *,'GD9400_DRAW: IBUFFER_POINTER = ',IBUFFER_POINTER IF (LCOLOR_CHANGED .OR. LMOVED .OR. GD9400_FLUSHIF(2)) THEN LDUMMY = GD9400_FLUSHIF(9) IBUFFER(IBUFFER_POINTER) = IWVL_AND_OP1 IBUFFER(IBUFFER_POINTER+1) = ICOP_AND_FOREGROUND IBUFFER(IBUFFER_POINTER+2) = ICURRENT_COLOR IBUFFER(IBUFFER_POINTER+3) = IXPOSN IBUFFER(IBUFFER_POINTER+4) = IYPOSN IBUFFER(IBUFFER_POINTER+5) = 0 INDEX_NBYTES = IBUFFER_POINTER + 5 IBUFFER_POINTER = IBUFFER_POINTER + 6 LCOLOR_CHANGED = .FALSE. LMOVED = .FALSE. ENDIF IBUFFER(IBUFFER_POINTER) = IX IBUFFER(IBUFFER_POINTER+1) = IY IBUFFER_POINTER = IBUFFER_POINTER+2 IXPOSN = IX IYPOSN = IY C C COUNT BYTES OF DATA C IBUFFER(INDEX_NBYTES) = IBUFFER(INDEX_NBYTES) + 4 RETURN END SUBROUTINE GD9400_COLOR_SET(ICOLOR) C C ********** PARAMETER (IBUFFER_SIZE = 512) INTEGER*2 IBUFFER LOGICAL LMOVED, LCOLOR_CHANGED COMMON /GD9400_MD/ IBUFFER(IBUFFER_SIZE), ICURRENT_COLOR, 1 IXPOSN, IYPOSN, IBUFFER_POINTER, LMOVED, LCOLOR_CHANGED C ********** C IF (ICOLOR .NE. ICURRENT_COLOR) THEN ICURRENT_COLOR = ICOLOR LCOLOR_CHANGED = .TRUE. ENDIF RETURN END FUNCTION GD9400_FLUSHIF(NWORDS) LOGICAL GD9400_FLUSHIF C C ********** PARAMETER (IBUFFER_SIZE = 512) INTEGER*2 IBUFFER LOGICAL LMOVED, LCOLOR_CHANGED COMMON /GD9400_MD/ IBUFFER(IBUFFER_SIZE), ICURRENT_COLOR, 1 IXPOSN, IYPOSN, IBUFFER_POINTER, LMOVED, LCOLOR_CHANGED C ********** C D TYPE *,'GD9400_FLUSHIF(',NWORDS,') : IBUFFER_POINTER = ', 1 IBUFFER_POINTER IF ((IBUFFER_SIZE+1-IBUFFER_POINTER) .GE. NWORDS) THEN GD9400_FLUSHIF = .FALSE. ELSE CALL GD9400_FLUSH GD9400_FLUSHIF = .TRUE. ENDIF RETURN END SUBROUTINE GD9400_FLUSH C C ********** PARAMETER (IBUFFER_SIZE = 512) INTEGER*2 IBUFFER LOGICAL LMOVED, LCOLOR_CHANGED COMMON /GD9400_MD/ IBUFFER(IBUFFER_SIZE), ICURRENT_COLOR, 1 IXPOSN, IYPOSN, IBUFFER_POINTER, LMOVED, LCOLOR_CHANGED C ********** C IF (IBUFFER_POINTER .GT. 1) THEN CALL GD94WRITE(IBUFFER,2*(IBUFFER_POINTER-1)) IBUFFER_POINTER = 1 LMOVED = .TRUE. ENDIF RETURN END SUBROUTINE GD9400_BUFRINIT C C ********** PARAMETER (IBUFFER_SIZE = 512) INTEGER*2 IBUFFER LOGICAL LMOVED, LCOLOR_CHANGED COMMON /GD9400_MD/ IBUFFER(IBUFFER_SIZE), ICURRENT_COLOR, 1 IXPOSN, IYPOSN, IBUFFER_POINTER, LMOVED, LCOLOR_CHANGED C ********** C IBUFFER_POINTER = 1 LCOLOR_CHANGED = .TRUE. ICURRENT_COLOR = 1 IXPOSN = 0 IYPOSN = 0 RETURN END SUBROUTINE GD94WRITE(BUFFER,NBYTES) INTEGER*2 BUFFER(NBYTES/2) C C THIS SUBROUTINE WRITES A BUFFER TO THE RAMTEK. C C ********** INTEGER*2 IOCHAN COMMON /GD9400_IO/ IOCHAN C ********** C PARAMETER (IOWRITE = '00000020'X) INTEGER*2 IOSB(4) INTEGER*4 SYS$QIOW D TYPE 9999, NBYTES, (BUFFER(I), BUFFER(I), I=1,NBYTES/2) D9999 FORMAT(' GD9400 WRITE'/' BYTE COUNT IS ',I6/ D 1 128(1X,Z4,'H',4X,O6/)) ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN),%VAL(IOWRITE), 1 IOSB, , ,BUFFER,%VAL(NBYTES), , , , ) D TYPE *,'GD9400 WRITE STATUS IS ',ISTAT IF (.NOT. ISTAT) STOP 'GD9400 - WRITE ERROR' RETURN END SUBROUTINE GDAID(X,Y,XGUPCM,YGUPCM,IX,IY) C IX = XGUPCM*X + 0.5 IY = YGUPCM*Y + 0.5 RETURN END SUBROUTINE GDGAID(IX,IY,XGUPCM,YGUPCM,X,Y) C X = FLOAT(IX)/XGUPCM Y = FLOAT(IY)/YGUPCM RETURN END SUBROUTINE GDDM800(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C DATA MEDIA WITH DM800 RETRO-GRAPHICS UPGRADE C This driver assumes the terminal is normally in the VT100 mode C of operation. Thus, on device initialization, the DM800 is set C to 4027 emulation from VT100 emulation. On device release, the C DM800 is returned to VT100 emulation. C C----------------------------------------------------------------------- C C DEFINE DATA MEDIA 4027 EMULATION COMMAND CHARACTER C BYTE CMD PARAMETER (CMD=33) C BYTE CSUB, US, GS, CR, FF PARAMETER (ESC=27, CSUB=26, US=31, GS=29, CR=13, FF=12) CHARACTER*(*) TERMINAL PARAMETER (TERMINAL='TT') C C DEFINITIONS FOR DEVICE CONTROL C BYTE STR_END(2), STR_BEGIN_PLOT(14), STR_COLOR_SET(8) BYTE STR_INIT_DM800(49), STR_RELEASE(6) BYTE COLOR_MAP(8) C DATA STR_END /13,0/ DATA STR_INIT_DM800 / 1 GS, ESC, '"', '6', 'g', 2 CMD,'W','O','R',' ','3','0', 3 CMD,'G','R','A',' ','1',',','3','0', 4 CMD,'J','U','M',' ','1',',','1', 5 CMD,'L','I','N',' ','1', 6 CMD,'S','H','R',' ','N', 7 CMD,'C','O','L',' ','0',2*0/ DATA STR_BEGIN_PLOT / 1 CMD,'E','R','A',' ','G', 2 CMD,'C','O','L',' ','C','0',0/ DATA STR_COLOR_SET / 1 CMD,'C','O','L',' ','C','0',0/ DATA STR_RELEASE / 1 ESC,'"','0','g',2*0/ DATA COLOR_MAP / 0, 1, 2, 3, 4, 5, 6, 7 / C C DEFINITIONS FOR GIN C BYTE GINBUFR(28), PROMPT(8) C DATA PROMPT / 1 CMD,'E','N','A',' ','1',CR,0/ DATA IGIN_IN_CHARS /27/ C C DECLARE BUFFERING FUNCTION C LOGICAL GB_TEST_FLUSH C C DECLARE VARS NEED FOR DRIVER OPERATION C LOGICAL LVECTOR_GOING, LDUMMY DIMENSION DCHAR(8) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /800.0, 21.69, 14.223, 29.46, 29.46, 7.0, 229.0, 1.0/ C C***************** C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 11) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900,1000,1100) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIRST, INITIALIZE THE BUFFER SUBROUTINES C CALL GB_INITIALIZE(US,STR_END,TERMINAL,IERR) YA(1) = IERR IF (IERR .NE. 0) RETURN CALL GB_IN_STRING(STR_INIT_DM800) 190 CONTINUE CALL GD4027_MAP(CC,0,0,100,100) CALL GD4027_MAP(CC,1,120,50,100) CALL GD4027_MAP(CC,2,240,50,100) CALL GD4027_MAP(CC,3,0,50,100) CALL GD4027_MAP(CC,4,180,50,100) CALL GD4027_MAP(CC,5,60,50,100) CALL GD4027_MAP(CC,6,300,50,100) CALL GD4027_MAP(CC,7,0,0,0) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_NEW_BUFFER CALL GB_IN_STRING(STR_BEGIN_PLOT) GO TO 190 C C **** C MOVE C **** C 300 CONTINUE C CONVERT CM. TO GRAPHICS UNITS ROUNDED IXPOSN = XGUPCM*XA(1)+0.5 IYPOSN = YGUPCM*YA(1)+0.5 LVECTOR_GOING = .FALSE. RETURN C C **** C DRAW C **** C 400 CONTINUE IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4)) IF (LVECTOR_GOING) GO TO 410 LDUMMY = GB_TEST_FLUSH(9) LVECTOR_GOING = .TRUE. CALL GB_INSERT(GS) CALL GB_USE_TERMINATOR CALL GD_4010_CONVERT(IXPOSN,IYPOSN) 410 CALL GD_4010_CONVERT(IX,IY) IXPOSN = IX IYPOSN = IY RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C RETURN TO VT100 MODE C CALL GB_EMPTY CALL GB_IN_STRING(STR_RELEASE) CALL GB_EMPTY RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE CALL GB_EMPTY ICOLOR = XA(1) IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 7) RETURN STR_COLOR_SET(7) = 48 + COLOR_MAP(ICOLOR) CALL GB_IN_STRING(STR_COLOR_SET) LVECTOR_GOING = .FALSE. RETURN C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE CALL GB_EMPTY LVECTOR_GOING = .FALSE. C C ASK FOR 1 GIN INPUT C C CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.FALSE.,GINBUFR) C C GET KEY PRESSED, X AND Y C C KEY IS AT 9, X IS AT 13, AND Y IS AT 17 C DECODE (11,911,GINBUFR(9)) XA(1), XA(2), XA(3) 911 FORMAT(F3.0,1X,F3.0,1X,F3.0) XA(2) = XA(2)/XGUPCM XA(3) = XA(3)/YGUPCM RETURN C C ******************* C SET COLOR USING RGB C ******************* C 1000 CONTINUE ICOLOR = COLOR_MAP(INT(XA(1))) CALL GD4027_MIX(CC,ICOLOR,INT(YA(1)+0.5),INT(YA(2)+0.5),INT(YA(3)+0.5)) RETURN C C ******************* C SET COLOR USING HLS C ******************* C 1100 CONTINUE ICOLOR = COLOR_MAP(INT(XA(1))) CALL GD4027_MAP(CC,ICOLOR,INT(YA(1)+0.5),INT(YA(2)+0.5),INT(YA(3)+0.5)) RETURN END SUBROUTINE GDDQ650(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C VT100 WITH DQ650 RETRO-GRAPHICS UPGRADE C This driver assumes the terminal is normally in the VT100 mode C of operation. Thus, on device initialization, the DQ650 is set C to 4027 emulation from VT100 emulation. On device release, the C DQ650 is returned to VT100 emulation. C C----------------------------------------------------------------------- C BYTE CMD, CSUB, US, GS, CR, FF PARAMETER (esc=27, CMD=33, CSUB=26, US=31, GS=29, CR=13, FF=12) CHARACTER*(*) TERMINAL PARAMETER (TERMINAL='TT') C C DEFINITIONS FOR DEVICE CONTROL C BYTE STR_END(2), STR_BEGIN_PLOT(14), STR_COLOR_SET(8) BYTE STR_INIT_DQ650(49), STR_RELEASE(6) C DATA STR_END /13,0/ DATA STR_INIT_DQ650 / 1 GS, ESC, '"', '6', 'g', 2 CMD,'W','O','R',' ','3','0', 3 CMD,'G','R','A',' ','1',',','3','0', 4 CMD,'J','U','M',' ','1',',','1', 5 CMD,'L','I','N',' ','1', 6 CMD,'S','H','R',' ','N', 7 CMD,'C','O','L',' ','0',2*0/ DATA STR_BEGIN_PLOT / 1 CMD,'E','R','A',' ','G', 2 CMD,'C','O','L',' ','C','0',0/ DATA STR_COLOR_SET / 1 CMD,'C','O','L',' ','C','0',0/ DATA STR_RELEASE / 1 ESC,'"','0','g',2*0/ C C DEFINITIONS FOR GIN C BYTE GINBUFR(28), PROMPT(8) C DATA PROMPT / 1 CMD,'E','N','A',' ','1',CR,0/ DATA IGIN_IN_CHARS /27/ C C DECLARE BUFFERING FUNCTION C LOGICAL GB_TEST_FLUSH C C DECLARE VARS NEED FOR DRIVER OPERATION C LOGICAL LVECTOR_GOING, LDUMMY DIMENSION DCHAR(8) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /650.0, 21.69, 14.223, 29.46, 29.46, 1.0, 133.0, 1.0/ C C***************** C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIRST, INITIALIZE THE BUFFER SUBROUTINES C CALL GB_INITIALIZE(US,STR_END,TERMINAL,IERR) YA(1) = IERR IF (IERR .NE. 0) RETURN CALL GB_IN_STRING(STR_INIT_DQ650) CALL GD4027_MAP(CC,0,0,100,100) CALL GD4027_MAP(CC,7,0,0,0) 190 CONTINUE CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_NEW_BUFFER CALL GB_IN_STRING(STR_BEGIN_PLOT) GO TO 190 C C **** C MOVE C **** C 300 CONTINUE C CONVERT CM. TO GRAPHICS UNITS ROUNDED IXPOSN = XGUPCM*XA(1)+0.5 IYPOSN = YGUPCM*YA(1)+0.5 LVECTOR_GOING = .FALSE. RETURN C C **** C DRAW C **** C 400 CONTINUE IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4)) IF (LVECTOR_GOING) GO TO 410 LDUMMY = GB_TEST_FLUSH(9) LVECTOR_GOING = .TRUE. CALL GB_INSERT(GS) CALL GB_USE_TERMINATOR CALL GD_4010_CONVERT(IXPOSN,IYPOSN) 410 CALL GD_4010_CONVERT(IX,IY) IXPOSN = IX IYPOSN = IY RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C RETURN TO VT100 MODE C CALL GB_EMPTY CALL GB_IN_STRING(STR_RELEASE) CALL GB_EMPTY RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE CALL GB_EMPTY ICOLOR = XA(1) IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 1) RETURN IF (ICOLOR .EQ. 0) THEN STR_COLOR_SET(7) = 48+7 ELSE STR_COLOR_SET(7) = 48 ENDIF CALL GB_IN_STRING(STR_COLOR_SET) LVECTOR_GOING = .FALSE. RETURN C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE CALL GB_EMPTY LVECTOR_GOING = .FALSE. C C ASK FOR 1 GIN INPUT C C CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.FALSE.,GINBUFR) C C GET KEY PRESSED, X AND Y C C KEY IS AT 9, X IS AT 13, AND Y IS AT 17 C DECODE (11,911,GINBUFR(9)) XA(1), XA(2), XA(3) 911 FORMAT(F3.0,1X,F3.0,1X,F3.0) XA(2) = XA(2)/XGUPCM XA(3) = XA(3)/YGUPCM RETURN END SUBROUTINE GDGX1000(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C MODGRAPH GX-1000 DRIVER FOR DIGLIB/VAX C C----------------------------------------------------------------------- C EXTERNAL LEN BYTE ESC, CSUB, TMODE, GS, CR, FF PARAMETER (ESC=27, CSUB=26, TMODE=24, GS=29, CR=13, FF=12) CHARACTER*(*) TERMINAL PARAMETER (TERMINAL='TT') C C DEFINITIONS FOR DEVICE CONTROL C BYTE STR_BEGIN_PLOT(10), STR_COLOR_SET(6), STR_INIT_DEV(22) DATA STR_INIT_DEV /ESC,'^','2','2','4','f', !STATUS LINE OFF 1 ESC,'^','1','9',';','0','s', !TEXT OVER GRAPHICS 2 ESC,'^','4','2',';','1','s',0,0/ !MANUAL SCREEN CONTROL DATA STR_BEGIN_PLOT /GS,ESC,FF, 1 ESC,'/','0','d',ESC,'`',0/ DATA STR_COLOR_SET /GS,ESC,'/','0','d',0/ C C DEFINITIONS FOR GIN C BYTE GINBUFR(8), PROMPT(4) DATA PROMPT /GS, ESC, CSUB, 0/ DATA IGIN_IN_CHARS /6/ !5 FROM 4010 GIN, PLUS CR C C DECLARE BUFFERING FUNCTION C LOGICAL GB_TEST_FLUSH C C DECLARE VARS NEED FOR DRIVER OPERATION C LOGICAL LVECTOR_GOING, LDUMMY DIMENSION DCHAR(8) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /1000.0, 25.5, 19.417, 40.12, 40.12, 1.0, 133.0, 1.0/ C C***************** C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIRST, INITIALIZE THE BUFFER SUBROUTINES C CALL GB_INITIALIZE(TMODE,0,TERMINAL,IERR) YA(1) = IERR LVECTOR_GOING = .FALSE. CALL GB_NEW_BUFFER CALL GB_IN_STRING(STR_INIT_DEV) CALL GB_EMPTY RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_EMPTY CALL GB_IN_STRING(STR_BEGIN_PLOT) CALL GB_USE_TERMINATOR LVECTOR_GOING = .FALSE. RETURN C C **** C MOVE C **** C 300 CONTINUE C CONVERT CM. TO GRAPHICS UNITS ROUNDED IXPOSN = XGUPCM*XA(1)+0.5 IYPOSN = YGUPCM*YA(1)+0.5 LVECTOR_GOING = .FALSE. RETURN C C **** C DRAW C **** C 400 CONTINUE IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4)) IF (LVECTOR_GOING) GO TO 410 LDUMMY = GB_TEST_FLUSH(9) LVECTOR_GOING = .TRUE. CALL GB_INSERT(GS) CALL GB_USE_TERMINATOR CALL GD_4010_CONVERT(IXPOSN,IYPOSN) 410 CALL GD_4010_CONVERT(IX,IY) IXPOSN = IX IYPOSN = IY RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C DE-ASSIGN THE CHANNAL C CALL GB_FINISH(0) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE LDUMMY = GB_TEST_FLUSH(8) ICOLOR = XA(1) IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 1) RETURN ICOLOR = 1-ICOLOR !CONVERT 1 TO 0 AND 0 INTO 1 STR_COLOR_SET(4) = 48+ICOLOR !MAKE ASCII CHARACTER 0 OR 1 CALL GB_IN_STRING(STR_COLOR_SET) CALL GB_USE_TERMINATOR LVECTOR_GOING = .FALSE. RETURN C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE CALL GB_EMPTY LVECTOR_GOING = .FALSE. C CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR) C ICHAR = GINBUFR(1) IX1 = GINBUFR(2) IX2 = GINBUFR(3) IY1 = GINBUFR(4) IY2 = GINBUFR(5) C XA(1) = IAND(ICHAR,127) !PICK CHARACTER XA(2) = (32*IAND(IX1,31)+IAND(IX2,31))/XGUPCM XA(3) = (32*IAND(IY1,31)+IAND(IY2,31))/YGUPCM C CALL GB_SEND_CHARS(TMODE,1) RETURN END SUBROUTINE GDHIREZ(IFXN,XA,YA) DIMENSION XA(8), YA(3) CC C SELANAR HIREZ 100 (1024x768) DRIVER FOR DIGLIB/VAX C This driver almost works, but doesn't. It is distributed only C as a time saver for those who have this device. I (Hal) no longer C have access to this terminal, so I can not debug this driver. C Please call me about it ONLY AS A VERY LAST RESORT!!!!! C C----------------------------------------------------------------------- C EXTERNAL LEN BYTE ESC, CSUB, TMODE, GS, CR, FF PARAMETER (ESC=27, CSUB=26, GS=29, CR=13, FF=12) CHARACTER*(*) TERMINAL PARAMETER (TERMINAL='TT') C C DEFINITIONS FOR DEVICE CONTROL C BYTE STR_BEGIN_PLOT(18), STR_COLOR_SET(6), STR_INIT_DEV(54) BYTE STR_END_PLOT(2), STR_ANSI(4) DATA STR_INIT_DEV /GS,ESC,'\',ESC,'O','D',32,96,32,64,64, 1 ESC,'O','V',32,96,32,64,55,127,63,95, 2 ESC,'O','O',32,96,32,64,64, 3 ESC,'O','X',32,97,32,68,32,96,32,64, 4 ESC,'O','Y',32,97,32,68,32,96,32,64,2*0/ DATA STR_BEGIN_PLOT /ESC,'[','H',ESC,'[','J',GS,ESC,FF, 1 ESC,'O','W',32,96,32,64,64,0/ DATA STR_COLOR_SET /GS,ESC,'O','W',2*0/ DATA STR_END_PLOT /0,0/ DATA STR_ANSI /ESC,'2',2*0/ C C DEFINITIONS FOR GIN C BYTE GINBUFR(8), PROMPT(4) DATA PROMPT /GS, ESC, CSUB, 0/ DATA IGIN_IN_CHARS /6/ !5 FROM 4010 GIN, PLUS CR C C DECLARE BUFFERING FUNCTION C LOGICAL GB_TEST_FLUSH C C DECLARE VARS NEED FOR DRIVER OPERATION C LOGICAL LVECTOR_GOING, LDUMMY DIMENSION DCHAR(8) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /100.0, 20.46, 15.34, 50.0, 50.0, 1.0, 133.0, 1.0/ C C***************** C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIRST, INITIALIZE THE BUFFER SUBROUTINES C CALL GB_INITIALIZE(CR,STR_ANSI,TERMINAL,IERR) YA(1) = IERR CALL GB_IN_STRING(STR_INIT_DEV) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_EMPTY CALL GB_IN_STRING(STR_BEGIN_PLOT) CALL GD_4010_CAN LVECTOR_GOING = .FALSE. RETURN C C **** C MOVE C **** C 300 CONTINUE C CONVERT CM. TO GRAPHICS UNITS ROUNDED IXPOSN = XGUPCM*XA(1)+0.5 IYPOSN = YGUPCM*YA(1)+0.5 LVECTOR_GOING = .FALSE. RETURN C C **** C DRAW C **** C 400 CONTINUE IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4)) IF (.NOT. LVECTOR_GOING) THEN LDUMMY = GB_TEST_FLUSH(9) LVECTOR_GOING = .TRUE. CALL GB_INSERT(GS) CALL GB_USE_TERMINATOR CALL GD_4010_CONVERT(IXPOSN,IYPOSN) ENDIF CALL GD_4010_CONVERT(IX,IY) IXPOSN = IX IYPOSN = IY RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C DE-ASSIGN THE CHANNAL C CALL GB_FINISH(0) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE LDUMMY = GB_TEST_FLUSH(8) ICOLOR = XA(1) IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 1) RETURN IF (ICOLOR .EQ. 0) ICOLOR = 2 CALL GB_IN_STRING(STR_COLOR_SET) CALL GD_4010_CONVERT(ICOLOR,0) CALL GD_4010_CONVERT(0,0) LVECTOR_GOING = .FALSE. RETURN C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE CALL GB_EMPTY LVECTOR_GOING = .FALSE. C CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR) C ICHAR = GINBUFR(1) IX1 = GINBUFR(2) IX2 = GINBUFR(3) IY1 = GINBUFR(4) IY2 = GINBUFR(5) C XA(1) = IAND(ICHAR,127) !PICK CHARACTER XA(2) = (32*IAND(IX1,31)+IAND(IX2,31))/XGUPCM XA(3) = (32*IAND(IY1,31)+IAND(IY2,31))/YGUPCM C CALL GB_IN_STRING(STR_ANSI) CALL GB_EMPTY RETURN END SUBROUTINE GDHPGLCONVERT(IX,IY) C C THIS SUBROUTINE CONVERTS THE (X,Y) PAIR INTO THE PROPER HPGL C STRING, AND PLACES IT INTO THE BUFFER. IT IS ASSUMED THAT C THERE IS ROOM FOR THE WHOLE THING IN THE BUFFER. C BYTE STRING(12) EXTERNAL LEN C CALL NUMSTR(IX,STRING) IEND = LEN(STRING) STRING(IEND+1) = ',' CALL NUMSTR(IY,STRING(IEND+2)) CALL GB_IN_STRING(STRING) RETURN END C This subroutine has an alternate entry point given by the ENTRY statement. C You MUST remember to change that name also when configuring for a C different HPGL plotter!!!!!!! SUBROUTINE GD7475_LONG(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C GENERIC HP PLOTTER (WITH RS-232C INTERFACE) DRIVER FOR DIGLIB/VAX C THIS DRIVER SHOULD HANDLE ALL HPGL SPEAKING PLOTTERS WHEN PROPERLY C CONFIGURED. IT CAN BE USED ON A DEDICATED LINE, OR IN-LINE. C This driver has not be tested since it was modified to work in-line. C However, I have a lot of faith in it, but you all know that a C programmers faith and a buck won't even buy a cup of coffee. C C ### THIS DRIVER REQUIRES DIGLIB V3.1H OR LATER ### C C************************************************************************ C * C PLOTTER CONFIGURATION PARAMETERS * C * PARAMETER (PLOTTER_ID = 7475.0) !PLOTTER DESIGNATION * PARAMETER (X_WIDTH_CM = 25.0) !PAPER WIDTH IN CM. * PARAMETER (Y_HEIGHT_CM = 18.0) !PAPER HEIGHT IN CM. * PARAMETER (X_RESOLUTION = 400.0)!X GRAPHICS UNITS PER CM. * PARAMETER (Y_RESOLUTION = 400.0)!Y GRAPHICS UNITS PER CM. * PARAMETER (NUMBER_FOREGROUND_COLORS = 6.0) !NUMBER OF PENS * PARAMETER (PEN_WIDTH_IN_PLOTTER_UNITS = 15.0) ! * LOGICAL AUTO_PAGE_PLOTTER ! * PARAMETER (AUTO_PAGE_PLOTTER = .FALSE.) !NO PAPER ADVANCE * CHARACTER*(*) TERMINAL ! * C * C ### CONFIGURED FOR DEDICATED RS232 LINE USE ### * C TO CONFIGURE FOR IN-LINE USE, COMMENT OUT NEXT LINE * C AND UNCOMMENT OUT LINE AFTER THAT. * C * PARAMETER (TERMINAL='HP7475$TERM') !LOGICAL NAME OF RS-232 LINE * C PARAMETER (TERMINAL='TT:') !LOGICAL NAME FOR IN-LINE USE * C * C************************************************************************ C BYTE ESC, BCOMMA, BSEMICOLON PARAMETER (ESC=27, BCOMMA=',', BSEMICOLON=';') C C DEVICE CONTROL DEFINITIONS C BYTE STR_INIT_DEVICE(30), STR_BEGIN_PLOT(6) BYTE STR_COLOR_SET(6) BYTE STR_PUT_PEN_AWAY(8), STR_PLOTTER_OFF(4), STR_PLOTTER_ON(4) BYTE STR_PEN_UP(4), STR_PEN_DOWN(4) DATA STR_INIT_DEVICE / 1 ESC,'.','@',';','0',':', !NO HARDWIRED HANDSHAKE 2 ESC,'.','I','8','1',';',';','1','7',':', !XON/XOFF HANDSHAKE 3 ESC,'.','N',';','1','9',':', !XON/XOFF HANDSHAKE 4 'D','F',';', !SET PLOTTER DEFAULT VALUES 5 'S','C',2*0 / !START OF SCALING INSTRUCTION. DATA STR_BEGIN_PLOT / 1 'S','P','1',';',2*0/ !SELECT PEN 1 DATA STR_COLOR_SET / 1 'S','P','x',';',2*0 / !SELECT PEN x DATA STR_PUT_PEN_AWAY / 1 'P','U',';', !PEN PUP, THEN 1 'S','P','0',';',0/ !SELECT PEN 0 (PUT PEN AWAY) DATA STR_PLOTTER_ON / 1 ESC,'.','(',0/ !PLOTTER ON DATA STR_PLOTTER_OFF / 1 ESC,'.',')',0/ !PLOTTER OFF DATA STR_PEN_UP / 1 'P','U',';',0/ !PEN UP DATA STR_PEN_DOWN / 1 'P','D',';',0/ !PEN DOWN C C DECLARE BUFFERING FUNCTION TO BE LOGICAL C LOGICAL GB_TEST_FLUSH C C DELCARE VARS NEEDED FOR DRIVER OPERATION C LOGICAL LVECTOR_GOING, LTALL C DIMENSION DCHAR(8) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /PLOTTER_ID, X_WIDTH_CM, Y_HEIGHT_CM, 1 X_RESOLUTION, Y_RESOLUTION, NUMBER_FOREGROUND_COLORS, 2 24.0, PEN_WIDTH_IN_PLOTTER_UNITS/ C C------------------------------------------------------------------------- C C REMEMBER THAT WE ARE PLOTTER LONG IF THRU THE TOP C LTALL = .FALSE. GO TO 10 C C ######### ALTERNATE ENTRY POINT ########### C ENTRY GD7475_TALL(IFXN,XA,YA) LTALL = .TRUE. 10 CONTINUE C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE CALL GB_INITIALIZE(BSEMICOLON,0,TERMINAL,IERR) YA(1) = IERR IF (IERR .NE. 0) RETURN CALL GB_BEGIN_STRING(STR_PLOTTER_ON) C CALL GB_IN_STRING(STR_INIT_DEVICE) CALL GDHPGLCONVERT(0,INT(X_RESOLUTION*X_WIDTH_CM)) CALL GB_INSERT(BCOMMA) IY_FULL_SCALE = Y_RESOLUTION*Y_HEIGHT_CM CALL GDHPGLCONVERT(0,IY_FULL_SCALE) CALL GB_INSERT(BSEMICOLON) CALL GB_EMPTY RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_NEW_BUFFER CALL GB_IN_STRING(STR_PUT_PEN_AWAY) CALL GB_EMPTY LVECTOR_GOING = .FALSE. IF (AUTO_PAGE_PLOTTER) THEN CALL GB_IN_STRING(STR_ADVANCE_PAPER) ELSE TYPE 299 299 FORMAT( 1 '$Please place a fresh sheet of paper on the HP Plotter') ACCEPT 298, I 298 FORMAT(A1) ENDIF CALL GB_IN_STRING(STR_BEGIN_PLOT) RETURN C C **** C MOVE C **** C 300 CONTINUE LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(20)) IF (.NOT. LPEN_UP) THEN IF (LVECTOR_GOING) THEN CALL GB_INSERT(BSEMICOLON) LVECTOR_GOING = .FALSE. ENDIF CALL GB_IN_STRING(STR_PEN_UP) LPEN_UP = .TRUE. ENDIF GO TO 450 C C **** C DRAW C **** C 400 CONTINUE LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(20)) IF (LPEN_UP) THEN IF (LVECTOR_GOING) THEN CALL GB_INSERT(BSEMICOLON) LVECTOR_GOING = .FALSE. ENDIF CALL GB_IN_STRING(STR_PEN_DOWN) LPEN_UP = .FALSE. ENDIF 450 CONTINUE IXPOSN = XGUPCM*XA(1)+0.5 IYPOSN = YGUPCM*YA(1)+0.5 IF (LTALL) THEN C PLOTTER X = TALL_Y C PLOTTER Y = Y_FULL_SCALE - TALL_X ITEMP = IXPOSN IXPOSN = IYPOSN IYPOSN = IY_FULL_SCALE - ITEMP ENDIF IF (LVECTOR_GOING) THEN CALL GB_INSERT(BCOMMA) ELSE CALL GB_IN_STRING('PA') LVECTOR_GOING = .TRUE. CALL GB_USE_TERMINATOR ENDIF CALL GDHPGLCONVERT(IXPOSN,IYPOSN) RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(6)) IF (LVECTOR_GOING) THEN CALL GB_INSERT(BSEMICOLON) LVECTOR_GOING = .FALSE. CALL GB_NO_TERMINATOR ENDIF IF (.NOT. LPEN_UP) THEN CALL GB_IN_STRING(STR_PEN_UP) LPEN_UP = .TRUE. ENDIF CALL GB_EMPTY RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE CALL GB_EMPTY CALL GB_IN_STRING(STR_PUT_PEN_AWAY) CALL GB_IN_STRING('PA') CALL GDHPGLCONVERT(INT(X_RESOLUTION*X_WIDTH_CM), 1 INT(Y_RESOLUTION*Y_HEIGHT_CM)) CALL GB_INSERT(BSEMICOLON) CALL GB_EMPTY CALL GB_FINISH(STR_PLOTTER_OFF) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE IF (LTALL) THEN XA(2) = DCHAR(3) XA(3) = DCHAR(2) XA(4) = DCHAR(5) XA(5) = DCHAR(4) ENDIF RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(10)) ICOLOR = XA(1) IF (ICOLOR .LE. 0 .OR. 1 ICOLOR .GT. INT(NUMBER_FOREGROUND_COLORS)) RETURN IF (LVECTOR_GOING) THEN CALL GB_INSERT(BSEMICOLON) LVECTOR_GOING = .FALSE. CALL GB_NO_TERMINATOR ENDIF IF (.NOT. LPEN_UP) THEN CALL GB_IN_STRING(STR_PEN_UP) LPEN_UP = .TRUE. ENDIF STR_COLOR_SET(3) = 48+ICOLOR CALL GB_IN_STRING(STR_COLOR_SET) RETURN END SUBROUTINE GB_INITIALIZE(TERMIN,ENDSTR,TTNAME,IERR) CHARACTER*(*) TTNAME BYTE ENDSTR(2), TERMIN C C *** VMS SPECIFIC *** C C THIS SUBROUTINE INITIALIZES THE GRAPHICS DRIVERS BUFFERING C SUBROUTINES C INCLUDE 'GBCOMMON.CMN' C INTEGER*4 SYS$ASSIGN EXTERNAL LEN C C ASSIGN A CHANNEL TO THE DEVICE OUTPUT DEVICE C ISTAT = SYS$ASSIGN(TTNAME,IOCHAN,,) IF (.NOT. ISTAT) THEN IERR = 1 RETURN ELSE IERR = 0 ENDIF C CALL SCOPY(ENDSTR,END_STRING) IEND_LENGTH = LEN(END_STRING) C TERM_CHAR = TERMIN C CALL GB_NEW_BUFFER RETURN END SUBROUTINE GB_NEW_BUFFER C C SUBROUTINE TO INITIALIZE THE GRAPHIC COMMAND BUFFER C INCLUDE 'GBCOMMON.CMN' C IBFPTR = 1 L_USE_TERMINATOR = .FALSE. RETURN END FUNCTION GB_TEST_FLUSH(NUMCHR) LOGICAL GB_TEST_FLUSH C C THIS SUBROUTINE CHECKS TO MAKE SURE THERE IS ENOUGH ROOM IN C THE BUFFER FOR "NUMCHR" MORE CHARACTERS, IF NOT, IF MAKES ROOM BY C EMPTYING THE BUFFER. C INCLUDE 'GBCOMMON.CMN' C IF (IBFPTR+NUMCHR+IEND_LENGTH .GE. IBFSIZ) THEN CALL GB_EMPTY GB_TEST_FLUSH = .TRUE. ELSE GB_TEST_FLUSH = .FALSE. ENDIF RETURN END SUBROUTINE GB_USE_TERMINATOR C C THIS SUBROUTINE SETS THE "USE TERMINATOR" FLAG TO TRUE. C THE FLAG IS SET TO FALSE BY EMPTYING/CLEARING THE BUFFER. C INCLUDE 'GBCOMMON.CMN' C L_USE_TERMINATOR = .TRUE. RETURN END SUBROUTINE GB_EMPTY C C THIS SUBROUTINE EMPTYS THE BUFFER IF IT HAS ANYTHING C INCLUDE 'GBCOMMON.CMN' C C IF (IBFPTR .EQ. 1) GO TO 900 IF (L_USE_TERMINATOR) CALL GB_INSERT(TERM_CHAR) IF (IEND_LENGTH .NE. 0) CALL GB_IN_STRING(END_STRING) IF (IBFPTR .GT. IBFSIZ+1) STOP 'BUFFERING ERROR' C C SEND TO TTY C CALL GB_SEND_TTY(BUFFER,IBFPTR-1) 900 CALL GB_NEW_BUFFER RETURN END SUBROUTINE GB_SEND_TTY(TTY_BUFFER,IBUFR_LEN) BYTE TTY_BUFFER(IBUFR_LEN) C C *** VMS SPECIFIC *** C C THIS SUBROUTINE EMPTYS THE BUFFER IF IT HAS ANYTHING C INCLUDE 'GBCOMMON.CMN' C INTEGER*4 CR_CONTROL PARAMETER (CR_CONTROL = 0) PARAMETER (IO_WRITEV = '00000130'X) !IO$_WRITEVBLK+IO$M_NOFORMAT C INTEGER*4 SYS$QIOW INTEGER*2 IOSB(4) C C DO THE QIOW TO THE OUTPUT DEVICE C ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN),%VAL(IO_WRITEV),IOSB, , , 1 TTY_BUFFER,%VAL(IBUFR_LEN), ,%VAL(CR_CONTROL), , ) IF (.NOT. ISTAT) then type 999, istat 999 format(' QIOW to terminal failed, status was ',i9) endif RETURN END SUBROUTINE GB_INSERT(BCHAR) BYTE BCHAR C C THIS SUBROUTINE INSERTS A CHARACTER INTO THE BUFFER C INCLUDE 'GBCOMMON.CMN' C BUFFER(IBFPTR) = BCHAR IBFPTR = IBFPTR + 1 RETURN END SUBROUTINE GB_IN_STRING(STRING) BYTE STRING(2) C C THIS SUBROUTINE INSERTS THE STRING INTO THE GRAPHICS BUFFER C EXTERNAL LEN C DO 100 I=1, LEN(STRING) CALL GB_INSERT(STRING(I)) 100 CONTINUE RETURN END SUBROUTINE GB_FINISH(RELEASE_STRING) BYTE RELEASE_STRING(2) C C *** VMS SPECIFIC *** C C THIS SUBROUTINE RELEASES THE I/O CHANNAL TO THE OUTPUT DEVICE C INCLUDE 'GBCOMMON.CMN' C INTEGER*4 SYS$DASSGN EXTERNAL LEN C IF (LEN(RELEASE_STRING) .NE. 0) THEN CALL GB_EMPTY CALL GB_IN_STRING(RELEASE_STRING) CALL GB_EMPTY ENDIF ISTAT = SYS$DASSGN(%VAL(IOCHAN)) RETURN END SUBROUTINE GB_GIN(PROMPT,IGIN_CHARS_MAX,L_TERMS_OK,GINBUFR) BYTE GINBUFR(2), PROMPT(2) LOGICAL*1 L_TERMS_OK C C *** VMS SPECIFIC *** C C THIS SUBROUTINE DOES A GIN OPERATION VIA A "READ-AFTER-PROMPT" C QIOW. C INCLUDE 'GBCOMMON.CMN' C PARAMETER (IO_READ_PROMPT = '877'X) PARAMETER (IO_READ_NOECHO = '71'X) C INTEGER*4 SYS$QIOW INTEGER*2 IOSB(4) EXTERNAL LEN C IPRLEN = LEN(PROMPT) II = 1 NUMBER_TO_GET = IGIN_CHARS_MAX ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN),%VAL(IO_READ_PROMPT), 1 IOSB, , ,GINBUFR(II),%VAL(NUMBER_TO_GET),%VAL(0), , 2 PROMPT,%VAL(IPRLEN)) IF (.NOT. ISTAT) STOP 'GIN QIOW FAILED' IF (.NOT. L_TERMS_OK) GO TO 800 100 CONTINUE NUMBER_GOT = IOSB(2)+IOSB(4) D TYPE 9999, NUMBER_GOT, (GINBUFR(I), I=1,NUMBER_GOT+II-1) D9999 FORMAT(/' GB_GIN just got ',I2,' characters.' D 1 /' The characters buffered so far are:' D 2 /,20(1X,I3)) IF (NUMBER_GOT .GE. NUMBER_TO_GET) GOTO 800 NUMBER_TO_GET = NUMBER_TO_GET - NUMBER_GOT II = NUMBER_GOT + II ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN),%VAL(IO_READ_NOECHO), 1 IOSB, , ,GINBUFR(II),%VAL(NUMBER_TO_GET), , , , ) IF (.NOT. ISTAT) STOP 'GIN QIOW FAILED' GO TO 100 800 RETURN END SUBROUTINE GB_INTERLOCK(PROMPT,IN_BUFFER,IN_CHAR_COUNT) C C *** VMS SPECIFIC *** C C THIS SUBROUTINE IS USED BY THOSE DRIVERS THAT MUST USE AN INTERLOCKING C WITH THE TERMINAL SO THAT BUFFER OVERFLOW DOES NOT OCCUR IN THE C TERMINAL. MOSTLY, THIS IS CAUSED BY HP TERMINALS. IT SEEMS C THAT HP NEVER HAS UNDERSTOOD THE USEFULNESS OF XON/XOFF! C INCLUDE 'GBCOMMON.CMN' C PARAMETER (IO_READ_PROMPT = '877'X) C IO$_READPROMPT + IO$M_PURGE + IO$M_NOECHO C INTEGER*4 SYS$QIOW INTEGER*2 IOSB(4) EXTERNAL LEN C IPRLEN = LEN(PROMPT) ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN),%VAL(IO_READ_PROMPT), 1 IOSB, , ,IN_BUFFER,%VAL(IN_CHAR_COUNT),%VAL(0),%VAL(0), 2 PROMPT,%VAL(IPRLEN)) IF (.NOT. ISTAT) STOP 'GIN QIOW FAILED' RETURN END SUBROUTINE GB_INITIALIZE(TERMIN,ENDSTR,TTNAME,IERR) CHARACTER*(*) TTNAME BYTE ENDSTR(2), TERMIN C C *** VMS SPECIFIC *** C C THIS SUBROUTINE INITIALIZES THE GRAPHICS DRIVERS BUFFERING C SUBROUTINES FOR DOUBLE BUFFERING C DOUBLE BUFFERING ADDED 18-OCT-1984 C INCLUDE 'GBCOMMON2.CMN' C INTEGER*4 SYS$ASSIGN, SYS$SETEF, LIB$GET_EF EXTERNAL LEN C C ASSIGN A CHANNEL TO THE DEVICE OUTPUT DEVICE C ISTAT = SYS$ASSIGN(TTNAME,IOCHAN,,) IF (.NOT. ISTAT) THEN IERR = 1 RETURN ENDIF C C GET TWO FREE EVENT FLAGS, 1 FOR EACH BUFFER C ISTAT = LIB$GET_EF(IFLAG(1)) D TYPE *,'EVENT FLAG 1 IS ',IFLAG(1) IF (.NOT. ISTAT) THEN IERR = 1 RETURN ENDIF ISTAT = LIB$GET_EF(IFLAG(2)) D TYPE *,'EVENT FLAG 2 IS ',IFLAG(2) IF (.NOT. ISTAT) THEN IERR = 1 RETURN ELSE IERR = 0 ENDIF IACTIVE_BUFFER = 1 ISTAT = SYS$SETEF(%VAL(IFLAG(1))) D IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) ISTAT = SYS$SETEF(%VAL(IFLAG(2))) D IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) C CALL SCOPY(ENDSTR,END_STRING) IEND_LENGTH = LEN(END_STRING) BEGIN_STRING(1) = 0 IBEGIN_LENGTH = 0 C TERM_CHAR = TERMIN C CALL GB_INIT_BUFFER RETURN END SUBROUTINE GB_BEGIN_STRING(STRING) C C THIS SUBROUTINE SETS THE "BEGINNING OF EACH BUFFER STRING" C IT SHOULD BE CALLED ONCE IMMEDIATELY AFTER CALLING GB_INITIALIZE C EXTERNAL LEN C CALL SCOPY(STRING,BEGIN_STRING) IBEGIN_LENGTH = LEN(BEGIN_STRING) CALL GB_INIT_BUFFER RETURN END SUBROUTINE GB_NEW_BUFFER C C SUBROUTINE TO INITIALIZE THE GRAPHIC COMMAND BUFFER C INCLUDE 'GBCOMMON2.CMN' C INTEGER*4 SYS$WAITFR C IACTIVE_BUFFER = IACTIVE_BUFFER+1 IF (IACTIVE_BUFFER .GT. 2) IACTIVE_BUFFER = 1 D TYPE *,'IACTIVE_BUFFER IS ',IACTIVE_BUFFER D TYPE *,'THAT FLAG IS ',IFLAG(IACTIVE_BUFFER) C C MAKE SURE THIS NEW BUFFER IS EMPTY, IF NOT, WAIT FOR IT C TO EMPTY C ISTAT = SYS$WAITFR(%VAL(IFLAG(IACTIVE_BUFFER))) D IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) GO TO 100 C ENTRY GB_INIT_BUFFER() C 100 CALL SCOPY(BEGIN_STRING,BUFFER(1,IACTIVE_BUFFER)) IBFPTR = IBEGIN_LENGTH + 1 L_USE_TERMINATOR = .FALSE. RETURN END FUNCTION GB_TEST_FLUSH(NUMCHR) LOGICAL GB_TEST_FLUSH C C THIS SUBROUTINE CHECKS TO MAKE SURE THERE IS ENOUGH ROOM IN C THE BUFFER FOR "NUMCHR" MORE CHARACTERS, IF NOT, IF MAKES ROOM BY C EMPTYING THE BUFFER. C INCLUDE 'GBCOMMON2.CMN' C IF (IBFPTR+NUMCHR+IEND_LENGTH .GE. IBFSIZ) THEN CALL GB_EMPTY GB_TEST_FLUSH = .TRUE. ELSE GB_TEST_FLUSH = .FALSE. ENDIF RETURN END SUBROUTINE GB_USE_TERMINATOR C C THIS SUBROUTINE SETS THE "USE TERMINATOR" FLAG TO TRUE. C THE FLAG IS SET TO FALSE BY CALLING GB_NO_TERMINATOR OR BY C EMPTYING/CLEARING THE BUFFER. C INCLUDE 'GBCOMMON2.CMN' C L_USE_TERMINATOR = .TRUE. RETURN END SUBROUTINE GB_NO_TERMINATOR C C THIS SUBROUTINE CLEARS THE "USE TERMINATOR" FLAG TO FALSE. C INCLUDE 'GBCOMMON2.CMN' C L_USE_TERMINATOR = .FALSE. RETURN END SUBROUTINE GB_EMPTY C C THIS SUBROUTINE EMPTYS THE BUFFER IF IT HAS ANYTHING C INCLUDE 'GBCOMMON2.CMN' INTEGER*2 IOSB(4,2) C C IF (IBFPTR-1 .LE. IBEGIN_LENGTH) THEN CALL GB_INIT_BUFFER RETURN ENDIF IF (L_USE_TERMINATOR) CALL GB_INSERT(TERM_CHAR) IF (IEND_LENGTH .NE. 0) CALL GB_IN_STRING(END_STRING) IF (IBFPTR .GT. IBFSIZ+1) STOP 'BUFFERING ERROR - BUFFER OVERFLOWED' C C SEND TO TTY C CALL GB_SEND_TTY(BUFFER(1,IACTIVE_BUFFER), 1 IBFPTR-1,IFLAG(IACTIVE_BUFFER),IOSB(1,IACTIVE_BUFFER)) CALL GB_NEW_BUFFER RETURN END SUBROUTINE GB_SEND_CHARS(STRING,LENGTH) BYTE STRING(LENGTH) C INTEGER*2 IOSB(4) C CALL GB_SEND_TTY(STRING,LENGTH,0,IOSB) RETURN END SUBROUTINE GB_SEND_TTY(TTY_BUFFER,IBUFR_LEN,IEVFLAG,IOSB) BYTE TTY_BUFFER(IBUFR_LEN) INTEGER*2 IOSB(4) C C *** VMS SPECIFIC *** C NOTE: FOR INTERNAL USE ONLY. NO DRIVERS SHOULD CALL THIS ROUTINE. C DRIVERS SHOULD USE GB_SEND_CHARS INSTEAD. C C THIS SUBROUTINE EMPTYS THE BUFFER IF IT HAS ANYTHING C INCLUDE '($IODEF)' C PARAMETER (IO_WRITEV = '00000130'X) !IO$_WRITEVBLK+IO$M_NOFORMAT INCLUDE '($SSDEF)' INCLUDE 'GBCOMMON2.CMN' C INTEGER*4 CR_CONTROL PARAMETER (CR_CONTROL = 0) C INTEGER*4 SYS$QIO C C DO THE QIO TO THE OUTPUT DEVICE C 10 CONTINUE ISTAT = SYS$QIO(%VAL(IEVFLAG),%VAL(IOCHAN), 1 %VAL(IO$_WRITEVBLK+IO$M_NOFORMAT), 2 IOSB, , , 3 TTY_BUFFER,%VAL(IBUFR_LEN), ,%VAL(CR_CONTROL), , ) IF (.NOT. ISTAT) then type 999, istat 999 format(' QIOW to terminal failed, status was ',i9) ENDIF RETURN END SUBROUTINE GB_INSERT(BCHAR) BYTE BCHAR C C THIS SUBROUTINE INSERTS A CHARACTER INTO THE BUFFER C INCLUDE 'GBCOMMON2.CMN' C BUFFER(IBFPTR,IACTIVE_BUFFER) = BCHAR IBFPTR = IBFPTR + 1 RETURN END SUBROUTINE GB_IN_STRING(STRING) BYTE STRING(80) C C THIS SUBROUTINE INSERTS THE STRING INTO THE GRAPHICS BUFFER C EXTERNAL LEN C DO 100 I=1, LEN(STRING) CALL GB_INSERT(STRING(I)) 100 CONTINUE RETURN END SUBROUTINE GB_FINISH(RELEASE_STRING) BYTE RELEASE_STRING(2) C C *** VMS SPECIFIC *** C C THIS SUBROUTINE RELEASES THE I/O CHANNAL TO THE OUTPUT DEVICE C INCLUDE 'GBCOMMON2.CMN' C INTEGER*4 SYS$DASSGN, SYS$WAITFR EXTERNAL LEN C IF (LEN(RELEASE_STRING) .NE. 0) THEN CALL GB_EMPTY CALL GB_IN_STRING(RELEASE_STRING) CALL GB_EMPTY ENDIF ISTAT = SYS$WAITFR(%VAL(IFLAG(1))) D IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) ISTAT = SYS$WAITFR(%VAL(IFLAG(2))) D IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) ISTAT = SYS$DASSGN(%VAL(IOCHAN)) D IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) ISTAT = LIB$FREE_EF(IFLAG(1)) D IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) ISTAT = LIB$FREE_EF(IFLAG(2)) D IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) RETURN END SUBROUTINE GB_GIN(PROMPT,IGIN_CHARS_MAX,L_TERMS_OK,GINBUFR) BYTE GINBUFR(2), PROMPT(2) LOGICAL*1 L_TERMS_OK C C *** VMS SPECIFIC *** C C THIS SUBROUTINE DOES A GIN OPERATION VIA A "READ-AFTER-PROMPT" C QIOW. C INCLUDE 'GBCOMMON2.CMN' C C PARAMETER (IO_READ_PROMPT = '877'X) C PARAMETER (IO_READ_NOECHO = '71'X) INCLUDE '($IODEF)' C INTEGER*4 SYS$QIOW INTEGER*2 IOSB(4) EXTERNAL LEN C IPRLEN = LEN(PROMPT) IF (IPRLEN .EQ. 0) THEN IFXN = IO$_READVBLK + IO$M_NOECHO ELSE IFXN = IO$_READPROMPT + IO$M_PURGE + IO$M_NOECHO ENDIF II = 1 NUMBER_TO_GET = IGIN_CHARS_MAX ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN), 1 %VAL(IFXN), 1 IOSB, , ,GINBUFR(II),%VAL(NUMBER_TO_GET),%VAL(0), , 2 PROMPT,%VAL(IPRLEN)) IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) IF (.NOT. L_TERMS_OK) GO TO 800 100 CONTINUE NUMBER_GOT = IOSB(2)+IOSB(4) D TYPE 9999, NUMBER_GOT, (GINBUFR(I), I=1,NUMBER_GOT+II-1) D9999 FORMAT(/' GB_GIN just got ',I2,' characters.' D 1 /' The characters buffered so far are:' D 2 /,20(1X,I3)) IF (NUMBER_GOT .GE. NUMBER_TO_GET) GOTO 800 NUMBER_TO_GET = NUMBER_TO_GET - NUMBER_GOT II = NUMBER_GOT + II ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN), 1 %VAL(IO$_READVBLK+IO$M_NOECHO), 1 IOSB, , ,GINBUFR(II),%VAL(NUMBER_TO_GET), , , , ) IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) GO TO 100 800 RETURN END SUBROUTINE GB_INTERLOCK(PROMPT,IN_BUFFER,IN_CHAR_COUNT) C C *** VMS SPECIFIC *** C C THIS SUBROUTINE IS USED BY THOSE DRIVERS THAT MUST USE AN INTERLOCKING C WITH THE TERMINAL SO THAT BUFFER OVERFLOW DOES NOT OCCUR IN THE C TERMINAL. MOSTLY, THIS IS CAUSED BY HP TERMINALS. IT SEEMS C THAT HP NEVER HAS UNDERSTOOD THE USEFULNESS OF XON/XOFF! C INCLUDE 'GBCOMMON2.CMN' C INCLUDE '($IODEF)' C PARAMETER (IO_READ_PROMPT = '877'X) C IO$_READPROMPT + IO$M_PURGE + IO$M_NOECHO C INTEGER*4 SYS$QIOW INTEGER*2 IOSB(4) EXTERNAL LEN C IPRLEN = LEN(PROMPT) ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN), 1 %VAL(IO$_READPROMPT+IO$M_NOECHO+IO$M_PURGE), 2 IOSB, , ,IN_BUFFER,%VAL(IN_CHAR_COUNT),%VAL(0),%VAL(0), 3 PROMPT,%VAL(IPRLEN)) IF (.NOT. ISTAT) STOP 'INTERLOCK QIOW FAILED' RETURN END SUBROUTINE GB_OUTPUT_BUFFER(BUFFER,IBUFLEN) BYTE BUFFER(IBUFLEN) C C SUBROUTINE TO OUTPUT A BUFFER C INTEGER*2 IOSB(4) INTEGER*4 LIB$GET_EF, SYS$WAITFR C DATA IEVFLAG /-1/ C IF (IEVFLAG .LT. 0) THEN ISTAT = LIB$GET_EF(IEVFLAG) ENDIF CALL GB_SEND_TTY(BUFFER,IBUFLEN,IEVFLAG,IOSB) CCCC ISTAT = SYS$WAITFR(%VAL(IEVFLAG)) RETURN END SUBROUTINE GB_INPUT_BUFFER(PROMPT,IPRLEN, 1 IN_BUFFER,IN_CHAR_COUNT,IGOT) C C *** VMS SPECIFIC *** C C SUBROUTINE TO READ IN A BUFFER AFTER ISSUING A PROMPT C INCLUDE '($IODEF)' C PARAMETER (IO_READ_PROMPT = '877'X) C IO$_READPROMPT + IO$M_PURGE + IO$M_NOECHO C INCLUDE 'GBCOMMON2.CMN' C INTEGER*4 SYS$QIOW, IOTERMS(2) INTEGER*2 IOSB(4) C DATA IOTERMS /0,'2000'X/ ! IS ONLY TERMINATOR C ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN), 1 %VAL(IO$_READPROMPT+IO$M_NOECHO+IO$M_PURGE), 2 IOSB, , ,IN_BUFFER,%VAL(IN_CHAR_COUNT),%VAL(0),IOTERMS, 3 PROMPT,%VAL(IPRLEN)) IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)) IGOT = IOSB(2) RETURN END SUBROUTINE GDLASER_WIDE(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C QMS 1200 LASER PRINTER DRIVER - MULTIPLE COMMANDS ON A SINGLE LINE C C----------------------------------------------------------------------- C C DECLARE VARS NEED FOR DRIVER OPERATION C LOGICAL*1 L_NOTHING_PLOTTED, L_WIDE BYTE COORD(12) C DIMENSION DCHAR(8) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /1200.0, 26.67, 19.685, 118.11, 118.11, 1.0, 27.0, 3.0/ C L_WIDE = .TRUE. 10 CONTINUE C C***************** C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 7) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE LUN = XA(1) OPEN (UNIT=LUN,NAME='SYS$SCRATCH:LASER.DIG',TYPE='NEW', 1 CARRIAGECONTROL='LIST',ERR=9000) C C SHOW INITIALIZATION WORKED, I.E. WE OPENED THE FILE. C YA(1) = 0.0 WRITE (LUN,101) 101 FORMAT('^PY^-'/'^F'/'^IGV ^PW03') 190 CONTINUE CALL GDLSR_OPEN_BUFR(LUN) L_NOTHING_PLOTTED = .TRUE. L_PEN_IS_UP = .FALSE. RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE IF (L_NOTHING_PLOTTED) RETURN CALL GDLSR_DUMP_BUFR WRITE (LUN,201) 201 FORMAT('^,') GO TO 190 C C **** C MOVE C **** C 300 CONTINUE IF (L_PEN_IS_UP) GO TO 450 L_PEN_IS_UP = .TRUE. CALL GDLSR_INSERT('^U') GO TO 450 C C **** C DRAW C **** C 400 CONTINUE IF (.NOT. L_PEN_IS_UP) GO TO 450 CALL GDLSR_INSERT('^D') L_PEN_IS_UP = .FALSE. 450 CONTINUE IF (L_WIDE) THEN IX = (10.0*XGUPCM*XA(1)/3.0)+0.5 IY = (10.0*YGUPCM*(DCHAR(3)-YA(1))/3.0)+0.5 ELSE IX = (10.0*XGUPCM*YA(1)/3.0) + 0.5 IY = (10.0*YGUPCM*XA(1)/3.0) + 0.5 ENDIF ENCODE (11,451,COORD) IX,IY 451 FORMAT(I5,':',I5) DO 460 I=1,11 IF (COORD(I) .EQ. 32) COORD(I) = 48 460 CONTINUE COORD(12) = 0 CALL GDLSR_INSERT(COORD) L_NOTHING_PLOTTED = .FALSE. RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE RETURN !DONE BY BGNPLT WHEN NECESSARY. C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE CC IF (.NOT. L_NOTHING_PLOTTED) WRITE (LUN,602) CC602 FORMAT('^,') CALL GDLSR_DUMP_BUFR WRITE (LUN,601) 601 FORMAT('^IGE'/'^O'/'^PN^-') CLOSE (UNIT=LUN) ISTATUS = LIB$SPAWN('$ DIGLASEROUT SYS$SCRATCH:LASER.DIG') RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE IF (.NOT. L_WIDE) THEN XA(2) = DCHAR(3) XA(3) = DCHAR(2) ENDIF RETURN C C HANDLE FILE OPEN ERROR C 9000 CONTINUE YA(1) = 3.0 RETURN C C *********************************************************** C ENTRY GDLASER_TALL(IFXN,XA,YA) L_WIDE = .FALSE. GO TO 10 END SUBROUTINE GDLSR_OPEN_BUFR(LUN) C PARAMETER (IBUFR_SIZE = 120) BYTE BUFFER COMMON /GDLSR/ NXTCHR, LUNOUT, BUFFER(IBUFR_SIZE) C LUNOUT = LUN NXTCHR = 1 RETURN END SUBROUTINE GDLSR_INIT_BUFR C PARAMETER (IBUFR_SIZE = 120) BYTE BUFFER COMMON /GDLSR/ NXTCHR, LUNOUT, BUFFER(IBUFR_SIZE) C NXTCHR = 1 RETURN END SUBROUTINE GDLSR_INSERT(STRING) BYTE STRING(2) C PARAMETER (IBUFR_SIZE = 120) BYTE BUFFER COMMON /GDLSR/ NXTCHR, LUNOUT, BUFFER(IBUFR_SIZE) C EXTERNAL LEN C L = LEN(STRING) IF ((NXTCHR+L) .GT. IBUFR_SIZE) CALL GDLSR_DUMP_BUFR DO 100 I = 1, L BUFFER(NXTCHR) = STRING(I) NXTCHR = NXTCHR + 1 100 CONTINUE RETURN END SUBROUTINE GDLSR_DUMP_BUFR C PARAMETER (IBUFR_SIZE = 120) BYTE BUFFER COMMON /GDLSR/ NXTCHR, LUNOUT, BUFFER(IBUFR_SIZE) C IF (NXTCHR .EQ. 1) RETURN WRITE (LUNOUT,11) (BUFFER(I), I=1,NXTCHR-1) 11 FORMAT(132A1) NXTCHR = 1 RETURN END SUBROUTINE GDLEX(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C LEXIDATA 3400 DRIVER FOR VAX/VMS C C----------------------------------------------------------------------- C PARAMETER (MAXY=511) CHARACTER*(*) DEVICE_NAME PARAMETER (DEVICE_NAME='LXA0:') INTEGER LX_BUFFER_SIZE PARAMETER (LX_BUFFER_SIZE = 512) PARAMETER (LX_COMMAND_LOAD_LUT = 20) PARAMETER (LX_COMMAND_CVEC = 41) PARAMETER (LX_COMMAND_POLY = 42) C C DEFINE BUFFER STATES FOR "LX_BUFFER_STATUS" C INTEGER NO_VECTOR, VECTOR_MOVE, VECTOR_DRAW PARAMETER (NO_VECTOR = 0) PARAMETER (VECTOR_MOVE = 1) PARAMETER (VECTOR_DRAW = 2) DIMENSION DCHAR(8) INTEGER*2 BUFFER(LX_BUFFER_SIZE) INTEGER*2 LX_ERASE_INIT(55) INTEGER*2 LX_CURSOR(4), LX_READ_CURSOR(5) INTEGER*4 SYS$ASSIGN, SYS$QIOW, SYS$DASSGN INTEGER*2 IOCHANTT BYTE CHARBUFR C C FUNNY BUSINESS NEEDED TO PREVENT "INTEGER OVERFLOW" MESSAGE C INTEGER*4 IX INTEGER*2 IXEQ(2) EQUIVALENCE (IX,IXEQ(1)) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) C C DATA WE WILL NEED C DATA DCHAR /3400, 32.79, 26.23, 19.5, 19.5, 1023.0, 981.0, 1.0/ DATA IOREADNOECHO /'00000071'X/ DATA LX_ERASE_INIT / 3,4095, !ERASE ALL 12 PLANES 1 24,639,511,20, !CONFIGURE 1 10,0,0,1, !NO ZOOM OR PAN 2 2,1023,1023,1023, !ENABLE FIRST 10 BIT PLANES 3 27, !ERASE MATRIX CURSOR 4 26,2,76,32, !SELECT MATRIX CURSOR WITH OFFSETS 5 7,0,0, !ZERO LITES 6 20,1024,8,0,255,255,0,0,255,255,0, !RED PORTION LUT 0->7 7 20,2048,8,0,255,0,255,0,255,0,255, !GREEN PART 8 20,3072,8,0,255,0,0,255,0,255,255/ !BLUE PART DATA LX_ERASE_INIT_WORDS /55/ DATA LX_INIT_START /3/ DATA LX_CURSOR /26, 0, 76, 38/ !SELECT CROSS HAIR CURSOR DATA LX_CURSOR_WORDS /4/ DATA LX_READ_CURSOR /26, 2, 76, 38, !SELECT MATRIX CURSOR 1 5/ !READ X,Y,SWITCHES DATA LX_READ_CURSOR_WORDS /5/ C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .GE. 1027) GO TO 20000 !POLYGON IF (IFXN .LE. 0 .OR. IFXN .GT. 10) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,300,500,600,700,800,900,1000) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIND THE I/O CHANNAL ASSICIATED WITH THE TERMINAL FOR DOING GINS C ISTAT = LX_OPEN() IF (ISTAT .NE. 1) THEN YA(1) = 2.0 RETURN ENDIF ISTAT = SYS$ASSIGN('TT',IOCHANTT,,) IF (.NOT. ISTAT) THEN YA(1) = 2.0 RETURN ELSE YA(1) = 0.0 ENDIF C C INITIALIZE THE LEXIDATA C I = LX_INIT_START 120 CONTINUE CALL LX_WRITE(LX_ERASE_INIT(I),LX_ERASE_INIT_WORDS+1-I) NXT = 1 LX_BUFFER_STATUS = NO_VECTOR ICURRENT_COLOR = 1 IX = 0 IY = 0 RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE C C ERASE THE LEXIDATA SCREEN AND RETURN TO NORMAL C I = 1 GO TO 120 C C ************* C MOVE AND DRAW C ************* C 300 CONTINUE IF ((LX_BUFFER_STATUS .EQ. NO_VECTOR) .OR. 1 (NXT+2 .GE. LX_BUFFER_SIZE)) THEN IF (LX_BUFFER_STATUS .NE. NO_VECTOR) THEN CALL GDLEX_TERM_VECT(BUFFER,ICOUNT,NXT) ENDIF IF (NXT+32 .GE. LX_BUFFER_SIZE) THEN CALL LX_WRITE(BUFFER,NXT-1) NXT = 1 ENDIF BUFFER(NXT) = LX_COMMAND_CVEC BUFFER(NXT+1) = ICURRENT_COLOR ICOUNT = NXT+2 IX = IX .OR. "100000 BUFFER(NXT+3) = IXEQ(1) BUFFER(NXT+4) = IY NXT = NXT + 5 LX_BUFFER_STATUS = VECTOR_MOVE ENDIF C C CONVERT CM. TO GRAPHICS UNITS ROUNDED C IX = XGUPCM*XA(1) + 0.5 IY = MAXY - INT(YGUPCM*YA(1) + 0.5) IF (IFXN .EQ. 3) THEN IX = IX .OR. "100000 IF (LX_BUFFER_STATUS .EQ. VECTOR_MOVE) NXT = NXT - 2 LX_BUFFER_STATUS = VECTOR_MOVE ELSE LX_BUFFER_STATUS = VECTOR_DRAW ENDIF BUFFER(NXT) = IXEQ(1) BUFFER(NXT+1) = IY NXT = NXT + 2 RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE IF (LX_BUFFER_STATUS .NE. NO_VECTOR) THEN CALL GDLEX_TERM_VECT(BUFFER,ICOUNT,NXT) LX_BUFFER_STATUS = NO_VECTOR ENDIF IF (NXT .GT. 1) CALL LX_WRITE(BUFFER,NXT-1) RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C DE-ASSIGN THE CHANNALS C ISTAT = SYS$DASSGN(%VAL(IOCHANTT)) CALL LX_CLOSE RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE ICURRENT_COLOR = XA(1) IF (LX_BUFFER_STATUS .NE. NO_VECTOR) THEN CALL GDLEX_TERM_VECT(BUFFER,ICOUNT,NXT) LX_BUFFER_STATUS = NO_VECTOR ENDIF RETURN C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE IF (LX_BUFFER_STATUS .NE. NO_VECTOR) THEN CALL GDLEX_TERM_VECT(BUFFER,ICOUNT,NXT) ENDIF IF (NXT+LX_CURSOR_WORDS .GE. LX_BUFFER_SIZE) THEN CALL LX_WRITE(BUFFER,NXT-1) NXT = 1 ENDIF DO 910 I=1,LX_CURSOR_WORDS BUFFER(NXT) = LX_CURSOR(I) NXT = NXT + 1 910 CONTINUE CALL LX_WRITE(BUFFER,NXT-1) LX_BUFFER_STATUS = NO_VECTOR NXT = 1 C C ASK FOR 1 CHARACTER FROM THE TERMINAL C ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHANTT),%VAL(IOREADNOECHO), 1 IOSB, , ,CHARBUFR,%VAL(1), , , , ) IF (.NOT. ISTAT) STOP 'GD9400 - GIN FAILURE' C C TELL LEXIDATA TO DROP CROSS HAIR CURSOR AND TO READ C THE CURSOR POSITION C CALL LX_WRITE(LX_READ_CURSOR,LX_READ_CURSOR_WORDS) CALL LX_READ(BUFFER,3) D TYPE *,'CURSOR LOCATION ',BUFFER(1), BUFFER(2) C C GET THE KEY, X POSITION, AND Y POSITION C XA(1) = CHARBUFR !PICK CHARACTER XA(2) = FLOAT(BUFFER(1))/XGUPCM !X IN CENTIMETERS. XA(3) = FLOAT(MAXY-BUFFER(2))/YGUPCM !Y IN CM. RETURN C C ************************** C SET COLOR USING RGB VALUES C ************************** C 1000 CONTINUE IF (LX_BUFFER_STATUS .NE. NO_VECTOR) THEN CALL GDLEX_TERM_VECT(BUFFER,ICOUNT,NXT) ENDIF IF (NXT+16 .GT. LX_BUFFER_SIZE) THEN CALL LX_WRITE(BUFFER,NXT-1) NXT = 1 ENDIF LX_BUFFER_STATUS = NO_VECTOR ICOLOR = XA(1) DO 1010 I=1,3 BUFFER(NXT) = LX_COMMAND_LOAD_LUT ICOLOR = ICOLOR + 1024 BUFFER(NXT+1) = ICOLOR !LUT ADDRESS BUFFER(NXT+2) = 1 !1 LUT ADDRESS TO LOAD BUFFER(NXT+3) = 2.55*YA(I)+0.5 NXT = NXT + 4 1010 CONTINUE D TYPE 9997, ICOLOR, (BUFFER(I), I=NXT-9,NXT-1,4) D9997 FORMAT(' COLOR ',I4,' IS ',3(I4,2X)) RETURN C C *************** C CONVEX POLYGONS C *************** C 20000 CONTINUE NPTS = IFXN - 1024 IF (LX_BUFFER_STATUS .NE. NO_VECTOR) THEN CALL GDLEX_TERM_VECT(BUFFER,ICOUNT,NXT) LX_BUFFER_STATUS = NO_VECTOR ENDIF IF ((NXT+3+2*NPTS) .GE. LX_BUFFER_SIZE) THEN CALL LX_WRITE(BUFFER,NXT-1) NXT = 1 ENDIF BUFFER(NXT) = LX_COMMAND_POLY BUFFER(NXT+1) = ICURRENT_COLOR BUFFER(NXT+2) = 2*NPTS NXT = NXT + 3 DO 20010 I=1,NPTS BUFFER(NXT) = XGUPCM*XA(I) + 0.5 BUFFER(NXT+1) = MAXY - INT(YGUPCM*YA(I)+0.5) NXT = NXT + 2 20010 CONTINUE RETURN END SUBROUTINE GDLEX_TERM_VECT(BUFFER,ICOUNT,NXT) INTEGER*2 BUFFER(NXT) C C THIS SUBROUTINE PROPERLY TERMINATES A CHAINED VECTOR SEQUENCE C BY CALCULATING THE WORD COUNT AND PLACING IT INTO THE BUFFER C NWORDS = (NXT-ICOUNT) - 1 IF (NWORDS .EQ. 0) THEN NXT = NXT - 3 ELSE BUFFER(ICOUNT) = NWORDS D TYPE 9999, (BUFFER(I), I=ICOUNT-2,NXT-1) D9999 FORMAT(//' Vector buffer is:',10000(/1X,I6)) ENDIF RETURN END SUBROUTINE GDLXY11(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C DIGLIB LXY-11 GRAPHICS DEVICE DRIVER C C----------------------------------------------------------------------- C DIMENSION DCHAR(8) LOGICAL*2 LDUMPIT, LWIDE C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(2),X_FULL_SCALE) EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /302.0, 21.59, 26.67, 78.7402, 78.7402, 1.0, 3.0, 1.0/ SAVE LDUMPIT C C SHOW WE WANT wide NOT tall PLOTTING AREA C LWIDE = .TRUE. 10 CONTINUE C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 7) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE FACT = 1.0 ! ENLARGE IS = 0 ! SELEST POSTPROCESSING LU = XA(1) ! LU IS IGNORED, INCLUDED ANYWAY CALL PLOTST (1,'CM',IS) CALL FACTOR (FACT) LDUMPIT = .FALSE. YA(1) = 0.0 RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE IF (LDUMPIT) THEN CALL PLOT(0.0, 0.0, -3) C CALL FACTOR(1.0/2.54) ENDIF LDUMPIT = .FALSE. RETURN C C ****************************** C MOVE CURRENT REFERENCE POINTER C ****************************** C 300 CONTINUE IPEN = +3 GO TO 450 C C **************************** C DRAW VECTER TO POSITION X,Y C **************************** C 400 CONTINUE IPEN = +2 450 IF (LWIDE) THEN CALL PLOT(X_FULL_SCALE-YA(1), XA(1), IPEN) ELSE CALL PLOT(XA(1), YA(1), IPEN) END IF C LDUMPIT = .TRUE. RETURN C C ***************************************************************** C FLUSH GRAPHICS COMMAND BUFFER,CLOSE VECTOR FILE TO TERMINATE PLOT C ***************************************************************** C 500 CONTINUE CALL PLOTND C RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE ISTATUS = LIB$SPAWN(' $ RUN SYS$SYSTEM:PLXY') !CREATE VECTOR FILE ISTATUS = LIB$SPAWN(' $ PRINT PLTDAT.PLT/NOFEED ') !PRINT OUTPUT FILE RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE IF (.NOT. LWIDE) RETURN XA(2) = DCHAR(3) XA(3) = DCHAR(2) RETURN C C ALTERNATE ENTRY FOR WIDE PLOTTING AREA C ENTRY GDLXY11_tall(IFXN,XA,YA) LWIDE = .FALSE. GO TO 10 END SUBROUTINE GDMCRO(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C MICROTERM ERGO 301 w/4010 graphics DRIVER FOR DIGLIB/VAX C 1024 x 780 (4010 resolution) effective C hardware mapped to 768 x 245 C C Converted from Retro-Graphics driver by Andy Simmons. C Refinements by Hal R. Brand and R. A. Saroyan Jan 85 C C GB_Empty puts the terminal to VT100 mode so interactive C graphics can be done. C Must put the terminal into Plot-10 mode for each graphical C operation. C C The fast method of sending drawing coordinates to the terminal C cannot be used (probably because of the switching in and out of C plot-10 mode). The slow method of sending coordinates is included C here as the subroutine GD_4010_Convert_Slo. C C----------------------------------------------------------------------- C EXTERNAL LEN BYTE ESC, CSUB, TMODE, GS, CR, FF PARAMETER (ESC=27, CSUB=26, TMODE=24, GS=29, CR=13, FF=12) parameter (ENTNTV=49, ENTP10=42, EXP10=79, EXNTV=50, ENQ=5) CHARACTER*(*) TERMINAL PARAMETER (TERMINAL='TT') C C DEFINITIONS FOR DEVICE CONTROL C BYTE STR_BEGIN_PLOT1(6), STR_BEGIN_PLOT2(4) BYTE STR_ENTER_PLOT10(6), STR_EXIT_PLOT10(6) BYTE STR_END_PLOT(6) C DATA STR_BEGIN_PLOT1 /ESC,'[','2','J',0,0/ DATA STR_BEGIN_PLOT2 /ESC,FF,2*0/ DATA STR_ENTER_PLOT10 /ESC,ENTNTV,ESC,ENTP10,2*0/ DATA STR_EXIT_PLOT10 /ESC,EXP10,ESC,EXNTV,2*0/ DATA STR_END_PLOT /ESC,'[','2','J',0,0/ DATA LENGTH_END_PLOT /4/ C C DEFINITIONS FOR GIN C C Enter Plot-10 mode and request GIN mode. C BYTE GINBUFR(8), PROMPT(8) DATA prompt /ESC,ENTNTV,ESC,ENTP10,esc,csub,2*0/ DATA IGIN_IN_CHARS /6/ !5 FROM 4010 GIN, PLUS CR C C DECLARE BUFFERING FUNCTION C LOGICAL GB_TEST_FLUSH C C DECLARE VARS NEED FOR DRIVER OPERATION C LOGICAL LVECTOR_GOING DIMENSION DCHAR(8) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /100.0, 21.001, 15.747, 30.419, 30.419, 1.0, 133.0, 1.0/ C C***************** C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIRST, INITIALIZE THE BUFFER SUBROUTINES C CALL GB_INITIALIZE(CR,STR_EXIT_PLOT10,TERMINAL,IERR) YA(1) = IERR LVECTOR_GOING = .FALSE. RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_EMPTY CALL GB_IN_STRING(STR_BEGIN_PLOT1) CALL GB_IN_STRING(STR_ENTER_PLOT10) CALL GB_IN_STRING(STR_BEGIN_PLOT2) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C **** C MOVE C **** C 300 CONTINUE C CONVERT CM. TO GRAPHICS UNITS ROUNDED IXPOSN = XGUPCM*XA(1)+0.5 IYPOSN = YGUPCM*YA(1)+0.5 LVECTOR_GOING = .FALSE. RETURN C C **** C DRAW C **** C 400 CONTINUE IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 C C MAKE SURE BUFFER SPACE AVAILABLE AND IN GRAPHICS MODE C IF (LVECTOR_GOING) THEN IF (GB_TEST_FLUSH(4)) THEN CALL GB_IN_STRING(STR_ENTER_PLOT10) LVECTOR_GOING = .FALSE. ENDIF ELSE CALL GB_TEST_FLUSH(20) CALL GB_IN_STRING(STR_ENTER_PLOT10) LVECTOR_GOING = .FALSE. ENDIF IF (LVECTOR_GOING) GO TO 410 LVECTOR_GOING = .TRUE. CALL GB_INSERT(GS) CALL GB_USE_TERMINATOR CALL GD_4010_Convert_Slo((8*IXPOSN/5),(13*IYPOSN)/8) 410 CALL GD_4010_Convert_Slo((8*IX/5),(13*IY)/8) IXPOSN = IX IYPOSN = IY RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GB_EMPTY LVECTOR_GOING = .FALSE. CALL GB_SEND_CHARS(STR_END_PLOT,LENGTH_END_PLOT) RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C DE-ASSIGN THE CHANNAL C CALL GB_FINISH(0) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE c LDUMMY = GB_TEST_FLUSH(8) c ICOLOR = XA(1) c IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 1) RETURN c ICOLOR = 1-ICOLOR !CONVERT 1 TO 0 AND 0 INTO 1 c STR_COLOR_SET(4) = 48+ICOLOR !MAKE ASCII CHARACTER 0 OR 1 c CALL GB_IN_STRING(STR_COLOR_SET) c CALL GB_USE_TERMINATOR c LVECTOR_GOING = .FALSE. RETURN C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE CALL GB_EMPTY LVECTOR_GOING = .FALSE. C CALL GB_EMPTY CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR) CALL GB_INSERT(CR) CALL GB_EMPTY C ICHAR = GINBUFR(1) IX1 = GINBUFR(2) IX2 = GINBUFR(3) IY1 = GINBUFR(4) IY2 = GINBUFR(5) C XA(1) = IAND(ICHAR,127) !PICK CHARACTER XA(2) = (5.0*(32*IAND(IX1,31)+IAND(IX2,31))/8.0)/XGUPCM XA(3) = (8.0*(32*IAND(IY1,31)+IAND(IY2,31))/13.0)/YGUPCM C RETURN END SUBROUTINE GD_4010_Convert_SLO(IX,IY) C C THIS SUBROUTINE CONVERTS THE POINT (IX,IY) INTO THE 4010 SCHEME C OF ENCODING COORDINATES C CALL GB_INSERT(32+IY/32) CALL GB_INSERT(96+IAND(IY,31)) CALL GB_INSERT(32+IX/32) CALL GB_INSERT(64+IAND(IX,31)) RETURN END SUBROUTINE GDPOSTSCR_TALL(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C POST SCRIPT DRIVER - HARD COPY DEVICE HAS 300 DOTS/INCH PARAMETER (DOTS_PER_INCH = 300.0) C C----------------------------------------------------------------------- C C DECLARE VARS NEED FOR DRIVER OPERATION C LOGICAL*1 L_NOTHING_PLOTTED, L_WIDE BYTE COORD(20) CHARACTER*8 CTIME CHARACTER*80 FILENAME CHARACTER*120 COMMAND C DIMENSION DCHAR(8) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) C C PAPER DEFINITIONS (INCHES) C PARAMETER (PSRES = 72.0) REAL*4 LEFT_MARGIN PARAMETER (LEFT_MARGIN = 0.5) PARAMETER (RIGHT_MARGIN = 0.25) PARAMETER (TOP_MARGIN = 0.5) PARAMETER (BOTTOM_MARGIN = 0.25) PARAMETER (PAPER_HEIGHT = 11.0) PARAMETER (PAPER_WIDTH = 8.5) C DERIVED PARAMETERS PARAMETER (USEABLE_WIDTH = PAPER_WIDTH-LEFT_MARGIN-RIGHT_MARGIN) PARAMETER (USEABLE_HEIGHT = PAPER_HEIGHT-TOP_MARGIN-BOTTOM_MARGIN) PARAMETER (WIDTH_CM = 2.54*USEABLE_WIDTH) PARAMETER (HEIGHT_CM = 2.54*USEABLE_HEIGHT) PARAMETER (RESOLUTION = DOTS_PER_INCH/2.54) PARAMETER (PSRESCM = PSRES/2.54) PARAMETER (XOFF = PSRES*LEFT_MARGIN) PARAMETER (YOFF = PSRES*BOTTOM_MARGIN) C PARAMETER (MAX_POINTS_PER_PATH = 900) C C DIGLIB DEVICE CHARACTERISTICS WORDS C DATA DCHAR /910.0, WIDTH_CM, HEIGHT_CM, RESOLUTION, 1 RESOLUTION, 1.0, 27.0, 4.0/ C BYTE EOF(2) DATA EOF /4,0/ C L_WIDE = .FALSE. 10 CONTINUE C C***************** C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 7) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE LUN = XA(1) CALL IDATE(IM,ID,IY) CALL TIME(CTIME) FILENAME = 'SYS$SCRATCH:POSTSCRIPT.DIG'//CHAR(IM+64)//CHAR(ID+64) 1 //CTIME(1:2)//CTIME(4:5)//CTIME(7:8) OPEN (UNIT=LUN,NAME=FILENAME,TYPE='NEW', 1 FORM='UNFORMATTED',CARRIAGECONTROL='NONE',RECORDTYPE='VARIABLE', 2 INITIALSIZE = 50, EXTENDSIZE = 50, ERR=9000) C C SHOW INITIALIZATION WORKED, I.E. WE OPENED THE FILE. C YA(1) = 0.0 CALL GDLSR_OPEN_BUFR(LUN) CALL GDLSR_INSERT(EOF) CALL GDLSR_INSERT('erasepage initgraphics 1 setlinecap 1 setlinejoin ') CALL GDLSR_INSERT('/m {moveto} def /l {lineto} def ') CALL GDLSR_DUMP_BUFR 190 CONTINUE L_NOTHING_PLOTTED = .TRUE. N_POINTS_IN_PATH = 0 RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE IF (.NOT. L_NOTHING_PLOTTED) THEN CALL GDLSR_INSERT('stroke showpage ') ENDIF CALL GDLSR_INSERT('newpath ') GO TO 190 C C **** C MOVE C **** C 300 CONTINUE C C **** C DRAW C **** C 400 CONTINUE N_POINTS_IN_PATH = N_POINTS_IN_PATH + 1 IF (N_POINTS_IN_PATH .GT. MAX_POINTS_PER_PATH) THEN CALL GDLSR_INSERT('stroke newpath ') IF (IFXN .EQ. 4) THEN CALL GDLSR_INSERT(COORD) CALL GDLSR_INSERT('m ') ENDIF N_POINTS_IN_PATH = 1 ENDIF IF (L_WIDE) THEN X = PSRESCM*YA(1)+XOFF Y = PSRESCM*(HEIGHT_CM-XA(1))+YOFF ELSE X = PSRESCM*XA(1)+XOFF Y = PSRESCM*YA(1)+YOFF ENDIF ENCODE (14,451,COORD) X,Y 451 FORMAT(F6.1,1X,F6.1,1X) COORD(15) = 0 CALL GDLSR_INSERT(COORD) IF (IFXN .EQ. 3) THEN CALL GDLSR_INSERT('m ') ELSE CALL GDLSR_INSERT('l ') ENDIF L_NOTHING_PLOTTED = .FALSE. RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE RETURN !DONE BY BGNPLT WHEN NECESSARY. C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE IF (.NOT. L_NOTHING_PLOTTED) THEN CALL GDLSR_INSERT('stroke showpage ') CALL GDLSR_INSERT(EOF) CALL GDLSR_DUMP_BUFR ENDIF CLOSE (UNIT=LUN) COMMAND = '$ PROCESSPS '//FILENAME ISTATUS = LIB$SPAWN(COMMAND, , ,1) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE IF (L_WIDE) THEN XA(2) = DCHAR(3) XA(3) = DCHAR(2) ENDIF RETURN C C HANDLE FILE OPEN ERROR C 9000 CONTINUE YA(1) = 3.0 RETURN C C *********************************************************** C ENTRY GDPOSTSCR_WIDE(IFXN,XA,YA) L_WIDE = .TRUE. GO TO 10 END SUBROUTINE GDLSR_OPEN_BUFR(LUN) C PARAMETER (IBUFR_SIZE = 80) BYTE BUFFER COMMON /GDLSR/ NXTCHR, LUNOUT, BUFFER(IBUFR_SIZE) C LUNOUT = LUN NXTCHR = 1 RETURN END SUBROUTINE GDLSR_INIT_BUFR C PARAMETER (IBUFR_SIZE = 80) BYTE BUFFER COMMON /GDLSR/ NXTCHR, LUNOUT, BUFFER(IBUFR_SIZE) C NXTCHR = 1 RETURN END SUBROUTINE GDLSR_INSERT(STRING) BYTE STRING(2) C PARAMETER (IBUFR_SIZE = 80) BYTE BUFFER COMMON /GDLSR/ NXTCHR, LUNOUT, BUFFER(IBUFR_SIZE) C EXTERNAL LEN C L = LEN(STRING) IF ((NXTCHR+L) .GT. IBUFR_SIZE) CALL GDLSR_DUMP_BUFR DO 100 I = 1, L BUFFER(NXTCHR) = STRING(I) NXTCHR = NXTCHR + 1 100 CONTINUE RETURN END SUBROUTINE GDLSR_DUMP_BUFR C PARAMETER (IBUFR_SIZE = 80) BYTE CR PARAMETER (CR = 13) BYTE BUFFER COMMON /GDLSR/ NXTCHR, LUNOUT, BUFFER(IBUFR_SIZE) C IF (NXTCHR .EQ. 1) RETURN WRITE (LUNOUT) (BUFFER(I), I=1,NXTCHR-1), CR NXTCHR = 1 RETURN END SUBROUTINE GDRASTECH(IFXN,XA,YA) C C RASTER TECHNOLOGIES MODEL ONE DIGLIB DRIVER 9/4/85 C ( 512 X 512 RESOLUTION ) C C JOHN C PETERSON C TRW/MED INC. MS RC2/2639 C ONE RANCHO CARMEL C SAN DIEGO, CA 92128 C DIMENSION XA(1),YA(1) C C VARIABLE DECLARATIONS FOR DEVICE CONTROL C CHARACTER*(*) TERMINAL PARAMETER ( TERMINAL='TT' ) C BYTE STR_GRAPHICS_MODE(1) BYTE STR_COLD_START(1) BYTE STR_INIT_DEV(32) BYTE STR_BEGIN_PLOT(10) BYTE STR_MOVE(1) BYTE STR_DRAW(1) BYTE STR_SET_COLOR(1) BYTE STR_POLY(2) BYTE STR_XHAIR(3) BYTE STR_PROMPT(2) BYTE STR_FLUSH(1) BYTE STR_READ_BUTTON(3) BYTE STR_READ_REGISTER(2) BYTE STR_GIN_BUFFER(16) BYTE STR_ACKNOWLEDGE(1) BYTE STR_END_PLOT(1) BYTE STR_DEBUG(5) BYTE STR_END(2) C C DATA LOAD DEVICE CONTROL VARIABLES C DATA STR_GRAPHICS_MODE /'84'X / !ENTER GRAPHICS MODE DATA STR_COLD_START / 'FD'X / !COLD START DATA STR_INIT_DEV / '84'X, !ENTER GRAPHICS MODE 1 '37'X, !RESET COORDINATE ORIGIN 2 0,0,0,0, !HIX,LOX,HIY,LOY BYTES 3 '36'X, !RESET SCREEN ORIGIN 4 0,0,0,0, !HIX,LOX,HIY,LOY BYTES 5 '3A'X, !RESET WINDOW 6 0,0,0,0, !HIX,LOX,HIY,LOY BYTES 7 0,0,0,0, !HIX,LOX,HIY,LOY BYTES 8 '1F'X,1, !POLYGONS ARE FILLED 9 '8B'X,0, !DEFINE MACRO TO MAKE 1 'A1'X,5,2, ! THE CROSS HAIR FOLLOW 2 '0C'X, ! THE DIGITIZER MOUSE 3 'AA'X,0,0, !EXECUTE 1/30 SEC INT 4 'FF'X / !EXIT GRAPHICS MODE DATA STR_BEGIN_PLOT / '84'X, 1 '06'X, !SET PIXEL VALUES 2 0,0,0, !RED, GREEN, BLUE 3 '07'X, !FLOOD THE SCREEN 4 '06'X, !SET PIXEL VALUES 5 255,255,255 / !RED, GREEN, BLUE DATA STR_MOVE / '01'X / !MOVE ABSOLUTE CODE DATA STR_DRAW / '81'X / !DRAW ABSOLUTE CODE DATA STR_SET_COLOR / '06'X / !SET PIXEL VALUES DATA STR_POLY / '12'X,1 / !DRAW ONE POLYGON CODE DATA STR_XHAIR / '9C'X,0,0 / !CURSOR VISIBILITY CODE DATA STR_PROMPT / '?',0 / !PROMPT USER FOR PICK DATA STR_FLUSH / '15'X / !EMPTY BUTTON QUEUE DATA STR_READ_REGISTER /'98'X,2 / !READ TABLET REGISTER DATA STR_READ_BUTTON / '9A'X,1,1 / !READ MOUSE BUTTON VALUE DATA STR_ACKNOWLEDGE / '86'X / !ACKNOWLEDGE RECEPTION DATA STR_END_PLOT / 'FF'X / !EXIT GRAPHICS MODE DATA STR_DEBUG / '84'X,'A8'X,1,'FF'X,0 / !******DEBUG MODE****** DATA STR_END / 0,0 / C C INTEGER*2 COORDINATE VARIABLES C INTEGER*2 ICORORG,ISCRORG,IWINDOW C DATA ICORORG /-256 / !THESE VALUES DEPENDENT ON RESOLUTION DATA ISCRORG / 256 / DATA IWINDOW / 511 / C INTEGER*2 IXMOVE,IYMOVE,IXDRAW,IYDRAW INTEGER*2 IXCURP,IYCURP,IXVERT,IYVERT C BYTE STR_CORORG(2) BYTE STR_SCRORG(2) BYTE STR_WINDOW(2) BYTE STR_XMOVE(2) BYTE STR_YMOVE(2) BYTE STR_XDRAW(2) BYTE STR_YDRAW(2) BYTE STR_NVERT(2) BYTE STR_XVERT(2) BYTE STR_YVERT(2) C C COLOR MAP TABLE C BYTE COLOR_MAP(3,0:7) C DATA COLOR_MAP / 0, 0, 0, !BLACK 1 255,255,255, !WHITE 2 255, 0, 0, !RED 3 0,255, 0, !GREEN 4 0, 0,255, !BLUE 5 255,255, 0, !YELLOW 6 255, 0,255, !MAGENTA 7 0,255,255 / !CYAN C C VARIABLE TO RECIEVE USER "PICK" CHARACTER C BYTE IPICK C C DECLARE FUNCTIONS AND VARIABLES NEED FOR DRIVER OPERATION C LOGICAL GB_TEST_FLUSH,LVECTOR_DRAWING,LDUMMY C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C ("YGUPCM" IS Y GRAPHICS UNITS PER CENTIMETER) C DIMENSION DCHAR(8) C EQUIVALENCE (DCHAR(4),XGUPCM) EQUIVALENCE (DCHAR(5),YGUPCM) C DATA DCHAR / 9999.0, !DIGLIB DEVICE NUMBER 1 32.803, 26.232, !X,Y SCREEN DIMENSIONS (CM) 2 15.608, 19.518, !XGUPCM, YGUPCM 3 7.0, !NUMBER OF FOREGROUND COLORS 4 1411.0, !DEVICE CHARACTERISTICS MASK 5 1.0 / !NUMBER OF SCAN LINES TO SKIP C C ********************* C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN.GT.1024) GOTO 1300 C IF (IFXN.LE.0.OR.IFXN.GT.12) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900,1000,1100,1200) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIRST INITIALIZE THE DIGLIB BUFFER SUBROUTINES C CALL GB_INITIALIZE(0,STR_END,TERMINAL,IERR) YA(1)= IERR IF (IERR.NE.0) RETURN C C NOW COLD START THE MODEL ONE C CALL GB_INSERT(STR_GRAPHICS_MODE(1)) CALL GB_INSERT(STR_COLD_START(1)) CALL GB_EMPTY C C WAIT 10 SECONDS FOR COLD START TO COMPLETE BEFORE GOING ON C CALL GDWAIT(10000) C C FINISH WITH INITIALIZATION C CALL RASTER_TECH_CONVERT(ICORORG,STR_CORORG) STR_INIT_DEV( 3)= STR_CORORG(1) STR_INIT_DEV( 4)= STR_CORORG(2) STR_INIT_DEV( 5)= STR_CORORG(1) STR_INIT_DEV( 6)= STR_CORORG(2) C CALL RASTER_TECH_CONVERT(ISCRORG,STR_SCRORG) STR_INIT_DEV( 8)= STR_SCRORG(1) STR_INIT_DEV( 9)= STR_SCRORG(2) STR_INIT_DEV(10)= STR_SCRORG(1) STR_INIT_DEV(11)= STR_SCRORG(2) C CALL RASTER_TECH_CONVERT(IWINDOW,STR_WINDOW) STR_INIT_DEV(17)= STR_WINDOW(1) STR_INIT_DEV(18)= STR_WINDOW(2) STR_INIT_DEV(19)= STR_WINDOW(1) STR_INIT_DEV(20)= STR_WINDOW(2) C C CALL GB_IN_STRING(STR_DEBUG) !******DEBUG****** C CALL GB_EMPTY !******DEBUG****** C DO N= 1,32 CALL GB_INSERT(STR_INIT_DEV(N)) ENDDO C IXMOVE= 0 IYMOVE= 0 CALL RASTER_TECH_CONVERT(IXMOVE,STR_XMOVE) CALL RASTER_TECH_CONVERT(IYMOVE,STR_YMOVE) CALL GB_INSERT(STR_XMOVE(1)) CALL GB_INSERT(STR_XMOVE(2)) CALL GB_INSERT(STR_YMOVE(1)) CALL GB_INSERT(STR_YMOVE(2)) LVECTOR_DRAWING= .FALSE. IXCURP= IXMOVE IYCURP= IYMOVE C CALL GB_EMPTY C RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE C CALL GB_NEW_BUFFER C DO N= 1,10 CALL GB_INSERT(STR_BEGIN_PLOT(N)) ENDDO C IXMOVE= 0 IYMOVE= 0 CALL RASTER_TECH_CONVERT(IXMOVE,STR_XMOVE) CALL RASTER_TECH_CONVERT(IYMOVE,STR_YMOVE) CALL GB_INSERT(STR_XMOVE(1)) CALL GB_INSERT(STR_XMOVE(2)) CALL GB_INSERT(STR_YMOVE(1)) CALL GB_INSERT(STR_YMOVE(2)) LVECTOR_DRAWING= .FALSE. IXCURP= IXMOVE IYCURP= IYMOVE C CALL GB_EMPTY C RETURN C C **** C MOVE C **** C 300 CONTINUE IXMOVE= XGUPCM*XA(1)+0.5 IYMOVE= YGUPCM*YA(1)+0.5 LVECTOR_DRAWING= .FALSE. RETURN C C **** C DRAW C **** C 400 CONTINUE IXDRAW= XGUPCM*XA(1)+0.5 IYDRAW= YGUPCM*YA(1)+0.5 IF (LVECTOR_DRAWING) GO TO 450 LDUMMY= GB_TEST_FLUSH(5) CALL GB_INSERT(STR_MOVE) CALL RASTER_TECH_CONVERT(IXMOVE,STR_XMOVE) CALL RASTER_TECH_CONVERT(IYMOVE,STR_YMOVE) CALL GB_INSERT(STR_XMOVE(1)) CALL GB_INSERT(STR_XMOVE(2)) CALL GB_INSERT(STR_YMOVE(1)) CALL GB_INSERT(STR_YMOVE(2)) LVECTOR_DRAWING= .TRUE. C 450 CONTINUE LDUMMY= GB_TEST_FLUSH(5) CALL GB_INSERT(STR_DRAW) CALL RASTER_TECH_CONVERT(IXDRAW,STR_XDRAW) CALL RASTER_TECH_CONVERT(IYDRAW,STR_YDRAW) CALL GB_INSERT(STR_XDRAW(1)) CALL GB_INSERT(STR_XDRAW(2)) CALL GB_INSERT(STR_YDRAW(1)) CALL GB_INSERT(STR_YDRAW(2)) IXMOVE= IXDRAW IYMOVE= IYDRAW IXCURP= IXDRAW IYCURP= IYDRAW RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE LVECTOR_DRAWING= .FALSE. LDUMMY= GB_TEST_FLUSH(1) CALL GB_INSERT(STR_END_PLOT(1)) CALL GB_EMPTY RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE CALL GB_FINISH(STR_END) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 750 I= 1,8 XA(I)= DCHAR(I) 750 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE ICOLOR= IFIX( XA(1) ) IF (ICOLOR.LT.0 .OR. ICOLOR.GT.7) RETURN C LDUMMY= GB_TEST_FLUSH(4) CALL GB_INSERT(STR_SET_COLOR(1)) CALL GB_INSERT(COLOR_MAP(1,ICOLOR)) CALL GB_INSERT(COLOR_MAP(2,ICOLOR)) CALL GB_INSERT(COLOR_MAP(3,ICOLOR)) RETURN C C ****************************************** C PERFORM GRAPHICS INPUT WITH PICK CHARACTER C ****************************************** C 900 CONTINUE C STR_XHAIR(3)= 1 LDUMMY= GB_TEST_FLUSH(4) CALL GB_INSERT(STR_XHAIR(1)) !MAKE CURSOR VISIBLE CALL GB_INSERT(STR_XHAIR(2)) CALL GB_INSERT(STR_XHAIR(3)) CALL GB_INSERT(STR_END_PLOT(1)) !GET READY FOR PICK CHARACTER CALL GB_EMPTY C CALL GB_GIN(STR_PROMPT,1,.TRUE.,IPICK) C LDUMMY= GB_TEST_FLUSH(3) CALL GB_INSERT(STR_GRAPHICS_MODE(1)) CALL GB_INSERT(STR_READ_REGISTER(1)) CALL GB_INSERT(STR_READ_REGISTER(2)) CALL GB_EMPTY C CALL GB_GIN(STR_PROMPT,12,.TRUE.,STR_GIN_BUFFER)!TERMINAL IGNORES PROMPT C DECODE (12,950,STR_GIN_BUFFER) IX_GIN,IY_GIN 950 FORMAT(I6,I6) C XA(1)= IPICK XA(2)= IX_GIN/XGUPCM XA(3)= IY_GIN/YGUPCM C STR_XHAIR(3)= 0 LDUMMY= GB_TEST_FLUSH(4) CALL GB_INSERT(STR_ACKNOWLEDGE(1)) CALL GB_INSERT(STR_XHAIR(1)) !MAKE CURSOR INVISIBLE CALL GB_INSERT(STR_XHAIR(2)) CALL GB_INSERT(STR_XHAIR(3)) C RETURN C C ********************** C DEFINE COLOR USING RGB C ********************** C 1000 CONTINUE C RETURN C C ********************** C DEFINE COLOR USING HLB C ********************** C 1100 CONTINUE C RETURN C C *********************************** C PERFORM GRAPHICS INPUT WITH BUTTONS C *********************************** C 1200 CONTINUE C STR_XHAIR(3)= 1 LDUMMY= GB_TEST_FLUSH(7) CALL GB_INSERT(STR_FLUSH(1)) CALL GB_INSERT(STR_XHAIR(1)) !MAKE CROSS HAIR VISIBLE CALL GB_INSERT(STR_XHAIR(2)) CALL GB_INSERT(STR_XHAIR(3)) CALL GB_INSERT(STR_READ_BUTTON(1)) !WAIT FOR NEXT MOUSE BUTTON CALL GB_INSERT(STR_READ_BUTTON(2)) CALL GB_INSERT(STR_READ_BUTTON(3)) CALL GB_EMPTY C CALL GB_GIN(0,15,.TRUE.,STR_GIN_BUFFER) !IMPORTANT: SEND NO PROMPTS C DECODE (15,1250,STR_GIN_BUFFER) IB_GIN,IX_GIN,IY_GIN 1250 FORMAT(I3,I6,I6) C XA(1)= 2**(IB_GIN-1) XA(2)= IX_GIN/XGUPCM XA(3)= IY_GIN/YGUPCM C STR_XHAIR(3)= 0 LDUMMY= GB_TEST_FLUSH(4) CALL GB_INSERT(STR_ACKNOWLEDGE(1)) CALL GB_INSERT(STR_XHAIR(1)) !MAKE CURSOR INVISIBLE CALL GB_INSERT(STR_XHAIR(2)) CALL GB_INSERT(STR_XHAIR(3)) C RETURN C C ******************* C DRAW FILLED POLYGON C ******************* C 1300 CONTINUE NVERT= IFXN-1024 LVECTOR_DRAWING= .FALSE. IF (NVERT.LT.3) RETURN C IF (IXCURP.NE.0 .OR. IYCURP.NE.0) THEN LDUMMY= GB_TEST_FLUSH(5) CALL GB_INSERT(STR_MOVE) IXCURP= 0 IYCURP= 0 CALL RASTER_TECH_CONVERT(IXCURP,STR_XMOVE) CALL RASTER_TECH_CONVERT(IYCURP,STR_YMOVE) CALL GB_INSERT(STR_XMOVE(1)) CALL GB_INSERT(STR_XMOVE(2)) CALL GB_INSERT(STR_YMOVE(1)) CALL GB_INSERT(STR_YMOVE(2)) ENDIF C LDUMMY= GB_TEST_FLUSH(4) CALL GB_INSERT(STR_POLY(1)) CALL GB_INSERT(STR_POLY(2)) CALL RASTER_TECH_CONVERT(NVERT,STR_NVERT) CALL GB_INSERT(STR_NVERT(1)) CALL GB_INSERT(STR_NVERT(2)) C DO 1350 N= 1,NVERT LDUMMY= GB_TEST_FLUSH(4) IXVERT= XGUPCM*XA(N)+0.5 IYVERT= YGUPCM*YA(N)+0.5 CALL RASTER_TECH_CONVERT(IXVERT,STR_XVERT) CALL RASTER_TECH_CONVERT(IYVERT,STR_YVERT) CALL GB_INSERT(STR_XVERT(1)) CALL GB_INSERT(STR_XVERT(2)) CALL GB_INSERT(STR_YVERT(1)) CALL GB_INSERT(STR_YVERT(2)) 1350 CONTINUE C RETURN C END SUBROUTINE RASTER_TECH_CONVERT(N,STR_N) C C THIS ROUTINE CONVERTS INTEGER*2 TO RASTER TECHNOLOGY HI-LO BYTE C INTEGER*2 N, NPOS, HIBYTE, LOBYTE C BYTE STR_N(2), STR_BYTE(2) C EQUIVALENCE (STR_BYTE(1),HIBYTE) EQUIVALENCE (STR_BYTE(2),LOBYTE) C LOGICAL CARRY C NPOS= IABS(N) C HIBYTE= NPOS/256 LOBYTE= MOD(NPOS,256) C IF (N.GE.0) GO TO 100 C CARRY= (LOBYTE.EQ.0) HIBYTE= INOT(HIBYTE) !NEXT FOUR LINES VAX/VHS SPECIFIC LOBYTE= INOT(LOBYTE) + 1 HIBYTE= IIAND(255,HIBYTE) LOBYTE= IIAND(255,LOBYTE) C IF (CARRY) HIBYTE= HIBYTE + 1 C 100 CONTINUE STR_N(1)= STR_BYTE(1) STR_N(2)= STR_BYTE(2) C RETURN C END SUBROUTINE GDRTRO(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C VT100 WITH 640x480 RETROGRAPHICS DRIVER FOR DIGLIB/VAX C C----------------------------------------------------------------------- C EXTERNAL LEN BYTE ESC, CSUB, TMODE, GS, CR, FF PARAMETER (ESC=27, CSUB=26, TMODE=24, GS=29, CR=13, FF=12) CHARACTER*(*) TERMINAL PARAMETER (TERMINAL='TT') C C DEFINITIONS FOR DEVICE CONTROL C BYTE STR_BEGIN_PLOT(14), STR_COLOR_SET(6) BYTE STR_END_PLOT(8) DATA STR_BEGIN_PLOT /ESC,'[','H',ESC,'[','J',GS,ESC,FF, 1 ESC,'/','0','d',0/ DATA STR_COLOR_SET /GS,ESC,'/','0','d',0/ DATA STR_END_PLOT /ESC,'[','H',ESC,'[','J',0,0/ C C DEFINITIONS FOR GIN C BYTE GINBUFR(8), PROMPT(4) DATA PROMPT /GS, ESC, CSUB, 0/ DATA IGIN_IN_CHARS /6/ !5 FROM 4010 GIN, PLUS CR C C DECLARE BUFFERING FUNCTION C LOGICAL GB_TEST_FLUSH C C DECLARE VARS NEED FOR DRIVER OPERATION C LOGICAL LVECTOR_GOING, LDUMMY DIMENSION DCHAR(8) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /100.0, 21.001, 15.747, 30.419, 30.419, 1.0, 133.0, 1.0/ C C***************** C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIRST, INITIALIZE THE BUFFER SUBROUTINES C CALL GB_INITIALIZE(TMODE,0,TERMINAL,IERR) YA(1) = IERR LVECTOR_GOING = .FALSE. RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_NEW_BUFFER CALL GB_IN_STRING(STR_BEGIN_PLOT) CALL GB_USE_TERMINATOR LVECTOR_GOING = .FALSE. RETURN C C **** C MOVE C **** C 300 CONTINUE C CONVERT CM. TO GRAPHICS UNITS ROUNDED IXPOSN = XGUPCM*XA(1)+0.5 IYPOSN = YGUPCM*YA(1)+0.5 LVECTOR_GOING = .FALSE. RETURN C C **** C DRAW C **** C 400 CONTINUE IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4)) IF (LVECTOR_GOING) GO TO 410 LDUMMY = GB_TEST_FLUSH(9) LVECTOR_GOING = .TRUE. CALL GB_INSERT(GS) CALL GB_USE_TERMINATOR CALL GD_4010_CONVERT((8*IXPOSN/5),(13*IYPOSN)/8) 410 CALL GD_4010_CONVERT((8*IX/5),(13*IY)/8) IXPOSN = IX IYPOSN = IY RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GB_EMPTY CALL GB_IN_STRING(STR_END_PLOT) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C DE-ASSIGN THE CHANNAL C CALL GB_FINISH(0) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE LDUMMY = GB_TEST_FLUSH(8) ICOLOR = XA(1) IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 1) RETURN ICOLOR = 1-ICOLOR !CONVERT 1 TO 0 AND 0 INTO 1 STR_COLOR_SET(4) = 48+ICOLOR !MAKE ASCII CHARACTER 0 OR 1 CALL GB_IN_STRING(STR_COLOR_SET) CALL GB_USE_TERMINATOR LVECTOR_GOING = .FALSE. RETURN C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE CALL GB_EMPTY LVECTOR_GOING = .FALSE. C CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR) C ICHAR = GINBUFR(1) IX1 = GINBUFR(2) IX2 = GINBUFR(3) IY1 = GINBUFR(4) IY2 = GINBUFR(5) C XA(1) = IAND(ICHAR,127) !PICK CHARACTER XA(2) = (5.0*(32*IAND(IX1,31)+IAND(IX2,31))/8.0)/XGUPCM XA(3) = (8.0*(32*IAND(IY1,31)+IAND(IY2,31))/13.0)/YGUPCM C CALL GB_SEND_TTY(TMODE,1) RETURN END SUBROUTINE GDVERSTALL(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C DIGLIB VERSATEC GRAPHICS DEVICE DRIVER C C----------------------------------------------------------------------- C DIMENSION DCHAR(8) LOGICAL*2 LDUMPIT, LWIDE C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(2),X_FULL_SCALE) EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /80.0, 21.336, 26.67, 78.7402, 78.7402, 1.0, 3.0, 1.0/ SAVE LDUMPIT C C SHOW WE WANT TALL NOT WIDE PLOTTING AREA C LWIDE = .FALSE. 10 CONTINUE C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 7) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE CALL PLOTS(0,0,0) CALL FACTOR(1.0/2.54) LDUMPIT = .FALSE. YA(1) = 0.0 RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE IF (LDUMPIT) THEN CALL PLOT(0.0, 0.0, -999) CALL FACTOR(1.0/2.54) ENDIF LDUMPIT = .FALSE. RETURN C C **** C MOVE C **** C 300 CONTINUE IPEN = +3 GO TO 450 C C **** C DRAW C **** C 400 CONTINUE IPEN = +2 450 IF (LWIDE) THEN CALL PLOT(X_FULL_SCALE-YA(1), XA(1), IPEN) ELSE CALL PLOT(XA(1), YA(1), IPEN) END IF LDUMPIT = .TRUE. RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE C C NOP ON VERSATEC - BGNPLT WILL TERMINATE PREVIOUS PLOT ON START C OF NEW PLOT. C RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE CALL PLOT(0.0, 0.0, +999) CALL GDVERS_VPINIT RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE IF (.NOT. LWIDE) RETURN XA(2) = DCHAR(3) XA(3) = DCHAR(2) RETURN C C ALTERNATE ENTRY FOR WIDE PLOTTING AREA C ENTRY GDVERSWIDE(IFXN,XA,YA) LWIDE = .TRUE. GO TO 10 END SUBROUTINE GDVERS_VPINIT C C Release versatec driver C C Problem: C C The Versaplot software has no way to re-initialize itself C once and "end of plot, end of run" call has been made. C That is, once DIGLIB releases the Versatec driver C (either because of a call to RLSDEV or DEVSEL) the application C program can NOT make more plots with the Versatec driver. C C Solution: C C Call this routine before calling after releasing the VERSATEC. C Then, the next call to DEVSEL, to select the Versatec driver, will C act as if it were the first call to DEVSEL. C C COMMON /PPEP0/ LBLK, NBLK, LREC, LVEC, IUNIT, JUNIT, KUNIT, LUNIT, 1 MUNIT, IPARM, IPCTR, IPREC, IEOF, IPBUF(128) C COMMON /PPEP1/ IX1, IY1, IX2, IY2, ISCAN, NSCAN, NBAND, NIPS, NIP0, 1 NIPM1, LYNES, NIBSX, MSGLVL, XDOTS, YDOTS, PREF(2), RORG(2), 2 PORT(2,2), IEND(4), ALMT, FACT, JPEN, XOFF, XFAC, YOFF, YFAC, 3 NBITS, NBITM1, NBYTES, NBYTM1, MSK, LMSK, IOPEN, XA(13), 4 YA(13), XC, YC, XO, YO, XT, YT, THETA, ANCC, ANCS, RADCO, FNN, 5 FCTR, FACC, ISTAT, IPAT(16), NTP, JRCD, JWRD, MINREC, MAXREC, 6 MAXPLT, NPLOT, FPLOT, NCLIP, NBAD, JBUF(128) C C Make VERSAPLOT initialize itself on next call to C DEVSEL. C C PPEP0 C IPCTR = 129 IPREC = 1 C C PPEP1 C IOPEN = 0 RADCO = 0.01745329 FNN = 999.0 FCTR = 0.7 FACC = 0.0 THETA = 0.0 ANCC = 1.0 ANCS = 0.0 XC = 0.0 YC = 0.0 XT = 0.0 YT = 0.0 XO = 0.0 YO = 0.0 C DO 10 I=1,13 XA(I) = 0.0 YA(I) = 0.0 10 CONTINUE C ISTAT = 1 NTP = 1 C DO 20 I=1,16 IPAT(I) = -1 20 CONTINUE C JRCD = 1 JWRD = 1 MINREC = 999999 MAXREC = -1 MAXPLT = -1 NPLOT = 1 FPLOT = 0.0 NCLIP = 0 NBAD = 0 RETURN END SUBROUTINE GDVHR19(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C INTECOLOR VHR-19 DRIVER FOR DIGLIB/VAX C Drawing is done via the TEK 4010 compatability mode since this C provides a much more dense (and so faster) coordinate stream. C The terminal itself is placed in the ANSI mode. It is switched C temporarily to TEK mode only for the duration of a buffer (or C less) of lines. C BYTE ESC, CSUB, GS, CR, FF, US, BCOMMA PARAMETER (ESC=27, CSUB=26, GS=29, CR=13, FF=12, US=31, BCOMMA=44) CHARACTER*(*) TERMINAL PARAMETER (TERMINAL='TT') C C DEFINITIONS FOR DEVICE CONTROL C BYTE STR_END(4) BYTE STR_INIT_DEV(38) BYTE STR_BEGIN_PLOT(6), STR_COLOR_SET(8), STR_START_VECTOR(4) BYTE STR_POLYGON_START(8), STR_POLYGON_PATTERN(4) BYTE STR_COMMA_END(4), STR_END_PLOT(10) BYTE STRING(20) EXTERNAL LEN C DATA STR_END /ESC,'A',2*0/ DATA STR_INIT_DEV/ 1 ESC,'B',ESC,'T', 1 'Z',',','1',',', !ZOOM FACTOR OF 1 2 'N',',','1','0','2','3',',','7',',', !PAN TO BOTTOM LEFT 3 'I','H',',','7',',', !STD COLORS, COLOR 1 (INTECOLOR 7) 4 'T','F','F','F','F',',', !LINE STYLE SOLID 5 '#',',','7',',', !WRITE TO ALL 3 PLANES 6 'L',',','7',',','?',0/ !DISPLAY FROM ALL 3 PLANES, EXIT DATA STR_BEGIN_PLOT/ 1 ESC,'C',ESC,FF,0,0/ !ERASE SCREEN DATA STR_START_VECTOR/ 1 ESC,'C',GS,0/ !START A 4010 VECTOR DATA STR_END_PLOT / 1 ESC,'A', 2 ESC,'[','H',ESC,'[','J',2*0/!ERASE TEXT DATA STR_COLOR_SET / 1 ESC,'B',ESC,'T','H',',',2*0/!SET COLOR PARTIAL COMMAND DATA STR_POLYGON_START/ 1 ESC,'B',ESC,'T','D',',',2*0/!START POLYGON DATA STR_POLYGON_PATTERN/ 1 ',','2',',',0/ DATA STR_COMMA_END/ 1 ',','?',2*0/ !ENDS A COMMAND AND EXIT GRAPHICS MODE. C C DEFINITIONS FOR GIN C BYTE GINBUFR(8), PROMPT(6), STR_END_GIN(2) DATA PROMPT /ESC, 'C', ESC, CSUB, 0, 0/ DATA IGIN_IN_CHARS /6/ DATA STR_END_GIN /10,0/ C C COLOR MAP C DIMENSION MAP_COLOR(8) DATA MAP_COLOR /0,7,1,2,4,3,5,6/ C C DECLARE BUFFERING FUNCTION C LOGICAL GB_TEST_FLUSH C C DECLARE VARS NEED FOR DRIVER OPERATION C LOGICAL LVECTOR_GOING, LDUMMY DIMENSION DCHAR(8) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /19.0, 38.0, 28.5, 26.921, 26.921, 7.0, 389.0, 1.0/ C C***************** C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .GT. 1026) GOTO 20000 IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIRST, INITIALIZE THE BUFFER SUBROUTINES C CALL GB_INITIALIZE(0,STR_END,TERMINAL,IERR) YA(1) = IERR IF (IERR .NE. 0) RETURN C C INITIALIZE THE VHR-19 C CALL GB_IN_STRING(STR_INIT_DEV) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_EMPTY CALL GB_IN_STRING(STR_BEGIN_PLOT) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C **** C MOVE C **** C 300 CONTINUE C CONVERT CM. TO GRAPHICS UNITS ROUNDED IXPOSN = XGUPCM*XA(1)+0.5 IYPOSN = YGUPCM*YA(1)+0.5 LVECTOR_GOING = .FALSE. RETURN C C **** C DRAW C **** C 400 CONTINUE IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4)) IF (LVECTOR_GOING) GO TO 410 LDUMMY = GB_TEST_FLUSH(9) LVECTOR_GOING = .TRUE. CALL GB_IN_STRING(STR_START_VECTOR) CALL GD_4010_CONVERT(IXPOSN,IYPOSN) 410 CALL GD_4010_CONVERT(IX,IY) IXPOSN = IX IYPOSN = IY RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GB_TEST_FLUSH(LEN(STR_END_PLOT)) CALL GB_IN_STRING(STR_END_PLOT) CALL GB_EMPTY LVECTOR_GOING = .FALSE. RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C DE-ASSIGN THE CHANNAL C CALL GB_EMPTY CALL GB_FINISH(0) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE LDUMMY = GB_TEST_FLUSH(12) ICOLOR = XA(1) IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 7) RETURN CALL GB_IN_STRING(STR_COLOR_SET) CALL NUMSTR(MAP_COLOR(1+ICOLOR),STRING) CALL GB_IN_STRING(STRING) CALL GB_IN_STRING(STR_COMMA_END) LVECTOR_GOING = .FALSE. RETURN C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE C C DO A GIN C CALL GB_EMPTY C CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR) C ICHAR = GINBUFR(1) IX1 = GINBUFR(2) IX2 = GINBUFR(3) IY1 = GINBUFR(4) IY2 = GINBUFR(5) C XA(1) = IAND(ICHAR,127) !PICK CHARACTER IX_GIN_CURSOR = 32*IAND(IX1,31)+IAND(IX2,31) XA(2) = IX_GIN_CURSOR/XGUPCM IY_GIN_CURSOR = 32*IAND(IY1,31)+IAND(IY2,31) XA(3) = IY_GIN_CURSOR/YGUPCM C CALL GB_IN_STRING(STR_END_GIN) CALL GB_EMPTY RETURN C C ******************* C DRAW FILLED POLYGON C ******************* C 20000 CONTINUE NPTS = IFXN - 1024 CALL GB_EMPTY CALL GB_IN_STRING(STR_POLYGON_START) CALL NUMSTR(NPTS,STRING) CALL GB_IN_STRING(STRING) CALL GB_IN_STRING(STR_POLYGON_PATTERN) C C DO VERTICES 1 THRU N. C DO 20010 I = 1, NPTS IX = XGUPCM*XA(I)+0.5 IY = YGUPCM*YA(I)+0.5 CALL NUMSTR(IX,STRING) CALL GB_IN_STRING(STRING) CALL GB_INSERT(BCOMMA) CALL NUMSTR(IY,STRING) CALL GB_IN_STRING(STRING) CALL GB_INSERT(BCOMMA) 20010 CONTINUE CALL GB_IN_STRING(STR_COMMA_END) LVECTOR_GOING = .FALSE. RETURN END SUBROUTINE GDVT125(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C VT125 DRIVER FOR DIGLIB/VAX C Modified for DIGLIB V3 by Hal Brand 8-Feb-1985. C C Opinion of Hal Brand: C It is completely misleading to even think of VT125 as graphics C devices. DEC does not know the first thing about making C graphics terminals, and by their track record (VT240/241) C probably never will. You will probably be very disappointed C if you use this driver for two reasons: 1) The driver may not C work well (and I don't really care cause of the above), and C 2) The truth in the opinions above. C C--------------------------------------------------------------------------- C BYTE ESC PARAMETER (ESC=27) CHARACTER*(*) TERMINAL PARAMETER (TERMINAL='TT') C C DEFINITIONS FOR DEVICE CONTROL C BYTE STR_END(4) BYTE STR_INIT(39) BYTE STR_BEGIN_PLOT(16) BYTE STR_COLOR_SET(10) BYTE STR_PREFACE(4) BYTE GINBUFR(14) BYTE PROMPT(7) BYTE STR_COORD(10) BYTE BEGIN_CHAR, CHAR_P, CHAR_V DATA CHAR_LEFT_BRACKET /'['/ DATA CHAR_RIGHT_BRACKET /']'/ DATA CHAR_V /'V'/ DATA CHAR_P /'P'/ BYTE COLOR(8) DATA COLOR /'D','W','R','G','B','Y','M','C'/ C C THE VT125 DRIVER USES THE DIGLIB/VAX STANDARD TERMINAL BUFFERING C SUBROUTINES. GRAPHIC COMMANDS ARE BUFFERED BY THESE SUBROUTINES C AND SENT TO THE USERS TERMINAL UNDER PROGRAM CONTROL. C C *** C STR_END CONTAINS THE STRING WHICH IS APPENDED TO THE COMMAND BUFFER C JUST BEFORE IT IS SENT TO THE TERMINAL. THIS ELIMINATES THE NEED C TO CONSTANTLY REMEMBER TO APPEND THIS STRING JUST BEFORE FLUSHING C THE BUFFER. C *** DATA STR_END /ESC,'\',0,0/ C C *** C STR_INIT CONTAINS THE STRING TO INITIALIZE THE VT125. THIS STRING C IS ONLY SENT WHEN WHEN IFXN=1 (I.E. AT "DEVSEL" TIME). C *** DATA STR_INIT / 1 ESC,'[','H', !HOME ALPHA CURSOR 2 ESC,'[','J', !ERASE ALPHA TO END OF SCREEN 3 ESC,'P','p', !ENTER ReGIS 4 'S','(','I','D', !SET SCREEN MODE dark 5 'A','[','0',',','4','7','9',']', !SET ADDRESS TRANSLATION 6 '[','7','6','7',',','0',']',')', !so origin is lower left 5 'W','(','I','W','R','P','1',')', !SET WRITING MODE 6 0,0/ C C *** C STR_BEGIN_PLOT CONTAINS THE STRING TO "GET A FRESH PLOTTING SURFACE" C AND TO MAKE SURE THE DEVICE IS IN "NORMAL" MODE, READY TO PLOT. C *** DATA STR_BEGIN_PLOT / 1 ESC,'P','p', !ENTER ReGIS 2 'S','(','I','D','E',')', !SET BKGD DARK & ERASE SCREEN 3 'W','(','I','W','R',')',0/ !WRITE IN WHITE C C *** C STR_COLOR_SET CONTAINS THE STRING TO SELECT A NEW COLOR. C THIS STRINGS CONTAINS A DUMMY ARGUMENT THAT IS MODIFIED AT RUN TIME C TO BE THE COLOR SELECTED. C ICOLOR_BYTE IS THE SUBSCRIPT OF THE BYTE TO BE MODIFIED IN THE C SET COLOR COMMAND. C *** DATA STR_COLOR_SET / 1 ESC,'P','p', !ENTER ReGIS 2 'W','(','I','W',')',0,0/ !WRITE IN COLOR or MONO DATA ICOLOR_BYTE /7/ C C *** C STR_PREFACE CONTAINS THE ReGIS ENTRY STRING. C *** DATA STR_PREFACE / ESC,'P','p',0/ C C *** C PROMPT IS STRING SENT TO VT125 TO REQUEST IT DISPLAY THE GRAPHICS C CURSOR, WAIT TILL USER HITS A KEY, THEN RETURN THE GRAPHICS CURSOR C POSITION ALONG WITH THE KEY THE USER HIT. C *** DATA PROMPT / 1 ESC,'P','p', !ENTER ReGIS 2 'R','(','P',')'/ C C *** C IGIN_IN_CHARACTERS IS THE EXPECTED NUMBER OF CHARACTERS RETURNED C BY THE VT125 IN RESPONSE TO "PROMPT". C *** DATA IGIN_IN_CHARS /12/ C C *** C**************************************************************************** C C DECLARE BUFFERING FUNCTION C LOGICAL GB_TEST_FLUSH C C DECLARE VARS NEED FOR DRIVER OPERATION C LOGICAL L_PREFACED, LDUMMY DIMENSION DCHAR(7) C C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) C C FOR DESCRIPTION OF DCHAR, SEE "DEVICE CHARACTERISTICS" RETURNED C BY DRIVER WHEN IFXN=7 (I.E. GET DEVICE CHARACTERISTICS) C DATA DCHAR /125.0, 25.583, 15.933, 30.0, 15.0, 3.0, 5.0, 1.0/ C C***************** C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIRST, INITIALIZE THE BUFFER SUBROUTINES C CALL GB_INITIALIZE(13,STR_END,TERMINAL,IERR) YA(1) = IERR IF (IERR .NE. 0) RETURN C C THEN, INITIALIZE THE VT125 C CALL GB_IN_STRING(STR_INIT) GO TO 290 C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_NEW_BUFFER CALL GB_IN_STRING(STR_BEGIN_PLOT) 290 CALL GB_EMPTY L_PREFACED = .FALSE. RETURN C C **** C MOVE C **** C 300 CONTINUE BEGIN_CHAR = CHAR_P GO TO 420 C C **** C DRAW C **** C 400 CONTINUE BEGIN_CHAR = CHAR_V C 420 CONTINUE C C CONVERT CM TO VT125 GRAPHICS UNITS C IX = XGUPCM*XA(1)+0.5 IY = 2*INT(YGUPCM*YA(1)+0.5) C C SEE IF ENOUGH ROOM IN BUFFER FOR THIS COMMAND C WE NEED 10 CHARACTERS OF ROOM, SO BE SAFE AS MAKE SURE 12 LEFT. C L_PREFACED = L_PREFACED .AND. (.NOT. GB_TEST_FLUSH(12)) IF (.NOT. L_PREFACED) CALL GB_IN_STRING(STR_PREFACE) C C INSERT THE ReGIS COMMAND TO MOVE/DRAW CALL GB_INSERT(BEGIN_CHAR) ENCODE (9,431,STR_COORD) IX,IY 431 FORMAT('[',I3,',',I3,']') STR_COORD(10) = 0 CALL GB_IN_STRING(STR_COORD) RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GB_EMPTY L_PREFACED = .FALSE. RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C DO NOTHING - LET USER KILL PICTURE C CALL GB_EMPTY RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE CALL GB_EMPTY ICOLOR = XA(1) + 1 IF (ICOLOR .LT. 1 .OR. ICOLOR .GT. 8) RETURN STR_COLOR_SET(ICOLOR_BYTE) = COLOR(ICOLOR) CALL GB_IN_STRING(STR_COLOR_SET) L_PREFACED = .TRUE. RETURN C C ********************** C PERFORM GRAPHICS INPUT C ********************** C 900 CONTINUE CALL GB_EMPTY L_PREFACED = .FALSE. C C ASK FOR 1 GIN INPUT C CALL GB_GIN(PROMPT,-IGIN_IN_CHARS,.TRUE.,GINBUFR) TYPE 992,GINBUFR 992 FORMAT(' Ginbufr',14O4) C C GET KEY PRESSED C c I = 3 c XA(1) = GINBUFR(1) c IF (GINBUFR(1) .EQ. CHAR_LEFT_BRACKET) THEN c XA(1) = 13 c I = 2 c ENDIF C C GET X,Y C c DECODE (11,991,GINBUFR(I)) XA(2), XA(3) 991 FORMAT(F3.0,1X,F3.0) c XA(2) = XA(2)/XGUPCM c XA(3) = 0.5*XA(3)/YGUPCM RETURN END subroutine gdvt240(ifxn,xa,ya) c****************************************************************************** c c Title: GDVT240 c Version: 1.0 c Date: 5-Apr-84 c Written by: Steve Wolfe c Mini Micro Systems Group c Applications Systems Division c Computations Department C MODIFIED: HAL BRAND 14-AUG-84 c c Purpose: c c GDVT240 is the DIGLIB device driver for the DEC VT240/241 graphics c terminals. c C WARNING: THIS DRIVER MAY HAVE BUGS - IT IS NOT SUPPORTED. C It is my (Hal Brand's) opinion that 240 resolution in Y is far too C little. In addition, the VT240 doesn't separate the alphatext C from the graphics leading to numerous problems. If you have never C used a real graphics terminal before, your probably won't hate using C a VT240 for graphics, however, if you have ever used a real graphics C terminal, you will be very very disappointed. c c****************************************************************************** dimension xa(8), ya(3) c c DEC VT240 driver for diglib/vax c byte esc integer f1,f2,str_length parameter (esc=27) character*(*) terminal parameter (terminal='TT') logical cursor_moved c c definitions for device control c byte str_init_dev(66) byte str_begin_plot(14) byte str_rls_dev(6) byte str_move_pos(14) byte str_draw_vec(11) byte str_regis_mode(5) byte str_draw_point(4) BYTE STR_COLOR_SET(6) data str_init_dev/ 1 esc,'[','?','3','8','l', !4014 => VT200 mode 2 esc,'P','1','p', !VT200 => REGIS mode 3 's','(','a','[','0',',','4','9','9',']', 4 '[','7','9','9',',','0',']',')',!Origin is lower left 5 'w','(','f','3',')', !allow writing to both planes 6 'w','(','i','1',')', !select color 3 (white) 7 'S','(','M','1','(','A','W',')', 8 '2','(','A','R',')','3','(','A','G',')', 9 esc,'/',ESC,'[','H',ESC,'[','J',0,0/ !back to VT200 mode data str_begin_plot/ 1 esc,'P','1','p', !VT200 => REGIS mode 2 's','(','e',')', !erase screen 3 esc,'/', !Back to VT200 mode 4 esc,'[','H',0/ !Home the alpha cursor data str_rls_dev /esc,'/',esc,'[','H',0/ data str_move_pos/'p','[',3*'x',',',3*'y',']','V','[',']',0/ data str_draw_vec/'v','[',3*'x',',',3*'y',']',0/ data str_regis_mode/esc,'P','1','p',0/ data str_draw_point/'p','[',']',0/ DATA STR_COLOR_SET / 'w','(','i','1',')',0 / c c definitions for gin c byte ginbufr(40), prompt(8) data prompt /'r','(','p','(','i',2*')',0/ data igin_in_chars /18/ DATA ICURX /400/ DATA ICURY /240/ c c declare buffering function c logical gb_test_flush, LDUMMY c c declare vars need for driver operation c dimension dchar(8) c c make nice names for the devices resolution in x and y c ("xgupcm" is x graphics units per centimeter) c equivalence (dchar(4),xgupcm), (dchar(5),ygupcm) data dchar /240.0, 23.78, 14.88, 33.6, 16.8, 3.0, 129.0, 1.0/ DATA YFUDGE /2.0/ c c***************** c c first verify we got a graphics function we can handle c if (ifxn .le. 0 .or. ifxn .gt. 9) return c c now dispatch to the proper code to handle that function c go to (100,200,300,400,500,600,700,800,900) ifxn c c ********************* c initialize the device c ********************* c 100 continue c c first, initialize the buffer subroutines c call gb_initialize(0,0,terminal,ierr) ya(1) = ierr if (ierr .ne. 0) return c C INITIALIZE THE VT240 c call gb_in_string(str_init_dev) 190 call gb_empty lvector_going = .false. return c c ************************** c get fresh plotting surface c ************************** c 200 continue call gb_empty call gb_in_string(str_begin_plot) GO TO 190 c c **** c move c **** c 300 continue c convert cm. to graphics units rounded ixposn = xgupcm*xa(1)+0.5 iyposn = YFUDGE*ygupcm*ya(1)+0.5 lvector_going = .false. return c c **** c draw c **** c 400 continue ix = xgupcm*xa(1)+0.5 iy = YFUDGE*ygupcm*ya(1)+0.5 C if (ix .ne. ixposn .or. iy .ne. iyposn) then c c Draw a vector from the current position to the new position c c Go into graphics mode c call gb_test_flush(4) call gb_in_string(str_regis_mode) c c Move to the current position first (if necessary) c If (.not. lvector_going) then f1 = num_dig(ixposn) f2 = num_dig(iyposn) str_length = f1 + f2 + 4 encode((f1 + f2 + 2),9000,str_move_pos(3))ixposn,iyposn 9000 format(i','i']') C str_move_pos(str_length + 1) = 0 CALL SCOPY('v[]',STR_MOVE_POS(STR_LENGTH+1)) call gb_test_flush(str_length+4) call gb_in_string(str_move_pos) endif c c Now draw the vector c f1 = num_dig(ix) f2 = num_dig(iy) str_length = f1 + f2 + 4 encode((f1 + f2 + 2),9000,str_draw_vec(3))ix,iy str_draw_vec(str_length + 1) = 0 call gb_test_flush(str_length) call gb_in_string(str_draw_vec) c c update the current position c ixposn = ix iyposn = iy c c Go back to alpha mode c call gb_test_flush(5) call gb_in_string(str_rls_dev) call gb_empty lvector_going = .true. return c c ***************************** c flush graphics command buffer c ***************************** c 500 continue call gb_empty return c c ****************** c release the device c ****************** c 600 continue call gb_finish(str_rls_dev) return c c ***************************** c return device characteristics c ***************************** c 700 continue do 720 i=1,8 xa(i) = dchar(i) 720 continue return c c **************************** c select current drawing color c **************************** c 800 continue CALL GB_TEST_FLUSH(10) CALL GB_IN_STRING(STR_REGIS_MODE) ICOLOR = XA(1) IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 3) RETURN STR_COLOR_SET(4) = ICOLOR+48 CALL GB_IN_STRING(STR_COLOR_SET) LVECTOR_GOING = .FALSE. CALL GB_TEST_FLUSH(5) CALL GB_IN_STRING(STR_RLS_DEV) CALL GB_EMPTY return c c ********************** c perform graphics input c ********************** c 900 continue c c Move the cursor to previous position c lvector_going = .false. call gb_test_flush(4) call gb_in_string(str_regis_mode) if (ixposn .ne. icurx .or. iyposn .ne. icury) then f1 = num_dig(icurx) f2 = num_dig(icury) str_length = f1 + f2 + 4 encode((f1 + f2 + 2),9000,str_move_pos(3))icurx,icury str_move_pos(str_length + 1) = 0 call gb_test_flush(str_length) call gb_in_string(str_move_pos) endif call gb_empty c c Wait for graphic input c 905 continue call gb_gin(prompt,igin_in_chars,.false.,ginbufr) IF (GINBUFR(1) .EQ. 13) THEN CALL GB_GIN(0,IGIN_IN_CHARS-1,.FALSE.,GINBUFR(2)) ENDIF call gb_in_string(str_rls_dev) call gb_empty c c Parse the graphic input. It comes in the form: p[xxxxE-1,yyyyE-1], where c 'p' is the pick character, 'xxxxE-1' & 'yyyyE-1' are the X & Y coordinates. c The 'xE-1' or 'yE-1' may or may not be present in the coordinates. If the c user is fast enough (dumb enough) to type two pick characters quickly then c the graphic input will contain two pick characters (or more) and the c cursor position will be shifted to the right by the extra characters. c This routine will always return the pick character JUST BEFORE THE C LEFT BRACKET. c c Look for the left bracket c do ilbrakt = 2,40 if (ginbufr(ilbrakt) .eq. '[') goto 910 enddo goto 905 c c Look for the right bracket c 910 continue do irbrakt = ilbrakt + 1,40 if (ginbufr(irbrakt) .eq. ']') goto 920 enddo goto 905 c c Decode and return the values c 920 continue length = irbrakt - ilbrakt - 1 decode(length,9100,ginbufr(ilbrakt + 1))curx,cury 9100 format(2f10.0) xa(1) = ginbufr(ILBRAKT-1) xa(2) = curx / xgupcm xa(3) = cury / (YFUDGE*ygupcm) icurx = curx icury = cury return end integer function num_dig(integer) implicit integer (a-z) num_dig = 1 if (integer .gt. 9) num_dig = 2 if (integer .gt. 99) num_dig = 3 return end SUBROUTINE GDVECTRIX(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C VECTRIX VX128 DRIVER FOR DIGLIB/VAX (USES "HEX" FORMAT) C C--------------------------------------------------------------------------- C CHARACTER*(*) TERMINAL PARAMETER (TERMINAL='DIG_VECTRIX_TTY') C C DEFINITIONS FOR DEVICE CONTROL C BYTE STR_INIT_VECTRIX(4) DATA STR_INIT_VECTRIX /'G','K','F',0/ INTEGER*2 COLOR_MAP(0:7) DATA COLOR_MAP /0,7,1,2,4,3,5,6/ C C DECLARE ARRAY FOR DEVICE PARAMETERS C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C DIMENSION DCHAR(8) EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /128.0, 26.84, 19.16, 25.0, 25.0, 7.0, 789.0, 1.0/ C C DECLARE BUFFERING FUNCTION C LOGICAL GB_TEST_FLUSH C LOGICAL LDUMMY C C***************** C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .GT. 1026) GO TO 1200 !FILLED POLYGON IF (IFXN .LE. 0 .OR. IFXN .GT. 8) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIRST, INITIALIZE THE BUFFER SUBROUTINES C CALL GB_INITIALIZE(0,0,TERMINAL,IERR) YA(1) = IERR IF (IERR .NE. 0) RETURN CALL GB_IN_STRING(STR_INIT_VECTRIX) RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_NEW_BUFFER CALL GB_INSERT('E') CALL GD_VECTRIX_WORD(0) CALL GB_IN_STRING('REC') ICOLOR = 1 CALL GD_VECTRIX_WORD(COLOR_MAP(ICOLOR)) RETURN C C **** C MOVE C **** C 300 CONTINUE CALL GB_INSERT('M') GO TO 410 C C **** C DRAW C **** C 400 CONTINUE CALL GB_INSERT('L') 410 CONTINUE C IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 LDUMMY = GB_TEST_FLUSH(6) CALL GD_VECTRIX_WORD(IX) CALL GD_VECTRIX_WORD(IY) RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GB_EMPTY RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C DE-ASSIGN THE CHANNAL C CALL GB_FINISH(0) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE IF (XA(1) .LT. 0.0 .OR. XA(1) .GT. 7.0) RETURN ICOLOR = XA(1) CALL GB_INSERT('C') CALL GD_VECTRIX_WORD(COLOR_MAP(ICOLOR)) RETURN C C *************** C FILLED POLYGONS C *************** C 1200 CONTINUE N = IFXN-1024 CALL GB_INSERT('F') CALL GD_VECTRIX_WORD(COLOR_MAP(ICOLOR)) CALL GD_VECTRIX_WORD(N) DO 1220 I=1, N CALL GD_VECTRIX_WORD(INT(XGUPCM*XA(I)+0.5)) CALL GD_VECTRIX_WORD(INT(YGUPCM*YA(I)+0.5)) 1220 CONTINUE RETURN END SUBROUTINE GD_VECTRIX_WORD(INT) INTEGER*2 INT C CALL GB_INSERT(INT) CALL GB_INSERT(INT/256) RETURN END SUBROUTINE GDVECTRIX384(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C VECTRIX VX384 DRIVER FOR DIGLIB/VAX (USES "HEX" FORMAT) C C--------------------------------------------------------------------------- C CHARACTER*(*) TERMINAL PARAMETER (TERMINAL='DIG_VECTRIX_TTY') C C DEFINITIONS FOR DEVICE CONTROL C BYTE STR_INIT_VECTRIX(4) DATA STR_INIT_VECTRIX /'G','K','F',0/ BYTE INIT_RGB(24) DATA INIT_RGB /0,0,0, 255,255,255, 255,0,0, 0,255,0, 0,0,255, 1 255,255,0, 255,0,255, 0,255,255 / C C DECLARE ARRAY FOR DEVICE PARAMETERS C MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y C ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER) C DIMENSION DCHAR(8) EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM) DATA DCHAR /128.0, 26.84, 19.16, 25.0, 25.0, 7.0, 789.0, 1.0/ C C DECLARE BUFFERING FUNCTION C LOGICAL GB_TEST_FLUSH C LOGICAL LDUMMY C C***************** C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .GT. 1026) GO TO 1200 !FILLED POLYGON IF (IFXN .LE. 0 .OR. IFXN .GT. 10) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800,900,1000) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE C C FIRST, INITIALIZE THE BUFFER SUBROUTINES C CALL GB_INITIALIZE(0,0,TERMINAL,IERR) YA(1) = IERR IF (IERR .NE. 0) RETURN CALL GB_IN_STRING(STR_INIT_VECTRIX) RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL GB_NEW_BUFFER CALL GB_INSERT('E') CALL GD_VECTRIX_WORD(0) CALL GB_IN_STRING('REC') ICOLOR = 1 CALL GD_VECTRIX_WORD(ICOLOR) CALL GB_INSERT('Q') CALL GD_VECTRIX_WORD(0) CALL GD_VECTRIX_WORD(8) DO 220 I=1,24 CALL GB_INSERT(INIT_RGB(I)) 220 CONTINUE RETURN C C **** C MOVE C **** C 300 CONTINUE CALL GB_INSERT('M') GO TO 410 C C **** C DRAW C **** C 400 CONTINUE CALL GB_INSERT('L') 410 CONTINUE C IX = XGUPCM*XA(1)+0.5 IY = YGUPCM*YA(1)+0.5 LDUMMY = GB_TEST_FLUSH(6) CALL GD_VECTRIX_WORD(IX) CALL GD_VECTRIX_WORD(IY) RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE CALL GB_EMPTY RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE C C DE-ASSIGN THE CHANNAL C CALL GB_FINISH(0) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE RETURN C C **************************** C SELECT CURRENT DRAWING COLOR C **************************** C 800 CONTINUE IF (XA(1) .LT. 0.0 .OR. XA(1) .GT. 7.0) RETURN ICOLOR = XA(1) CALL GB_INSERT('C') CALL GD_VECTRIX_WORD(COLOR_MAP(ICOLOR)) RETURN 900 RETURN C C ********************** C DEFINE COLOR USING RGB C ********************** C 1000 CONTINUE CALL GB_INSERT('Q') CALL GD_VECTRIX_WORD(INT(XA(1)) CALL GD_VECTRIX_WORD(1) DO 1010 I=1,3 CALL GB_INSERT(INT(2.55*YA(I)+0.5)) 1010 CONTINUE RETURN C C *************** C FILLED POLYGONS C *************** C 1200 CONTINUE N = IFXN-1024 CALL GB_INSERT('F') CALL GD_VECTRIX_WORD(COLOR_MAP(ICOLOR)) CALL GD_VECTRIX_WORD(N) DO 1220 I=1, N CALL GD_VECTRIX_WORD(INT(XGUPCM*XA(I)+0.5)) CALL GD_VECTRIX_WORD(INT(YGUPCM*YA(I)+0.5)) 1220 CONTINUE RETURN END SUBROUTINE GD_VECTRIX_WORD(INT) INTEGER*2 INT C CALL GB_INSERT(INT) CALL GB_INSERT(INT/256) RETURN END SUBROUTINE GDWAIT(MILLISECONDS) C C THIS SUBROUTINE DELAYS A GIVEN NUMBER OF MILLISECONDS. C INTEGER*4 SYS$SETIMR,SYS$WAITFR C INTEGER*4 DELTIME(2) C DELTIME(1) = -MILLISECONDS*10000 !10,000 (100ns) UNITS PER MILLISEC. DELTIME(2) = -1 ISTAT = SYS$SETIMR(%VAL(1),DELTIME, , ) IF (.NOT. ISTAT) STOP 'SET TIME FAILURE' ISTAT = SYS$WAITFR(%VAL(1)) IF (.NOT. ISTAT) STOP 'WAITFOR FAILURE' RETURN END This code is completely untested!!!!! SUBROUTINE GDZETA8TALL(IFXN,XA,YA) DIMENSION XA(8), YA(3) C C DIGLIB ZETA 8 GRAPHICS DEVICE DRIVER C USES THE ZETA "FUNDAMENTAL PLOTTING SUBROUTINES" C C----------------------------------------------------------------------- C DIMENSION DCHAR(8) LOGICAL*2 LWIDE C C THE ZETA 8 IS ASSUMED TO BE SET FOR RESOLUTION OF 0.025 mm C DIGLIB ASSUMES 8.5 INCH FAN FOLD PAPER. DIGLIB USES A PLOTTING C SURFACE OF 8X10 INCHES, WITH EQUAL 0.25 INCH BORDERS IN THE X C DIRECTION, A BOTTOM BORDER OF 0.25 INCH, AND A TOP BORDER OF C 0.75 INCH. THUS THE DIGLIB PLOTTING SURFACE OF 8X10 IS PLACED C NICELY ON 8.5X11.0 INCH PAPER. C THIS DIGLIB DRIVER PROVIDES AN ALTERNATE ENTRY POINT FOR ROTATING C THE PLOT 90 DEGREES WHEN THE USER WANTS A PLOT THAT IS WIDER THAN C IT IS TALL. THE ENTRY POINT NAME IS "GDZETA8WIDE". THE SAME C BOTTOM AND LEFT BORDERS ARE USED. C PARAMETER (CM_PER_INCH = 2.54) C----------------------------------------------------------------------- C C PAPER DEFINITIONS - ALL IN INCHES C PARAMETER (PAPER_WIDTH = 8.5) !PAPER FAN FOLD WIDTH PARAMETER (PAPER_HEIGHT = 11.0) !PAPER HEIGHT PARAMETER (LEFT_BORDER = 0.25) !LEFT SIDE BORDER PARAMETER (BOTTOM_BORDER = 0.25)!BOTTOM OF PAPER BORDER PARAMETER (PLOT_WIDTH = 8.0) !WIDTH OF PAPER USED FOR PLOTTING PARAMETER (PLOT_HEIGHT = 11.0) !HEIGHT OF PAPER USE FOR PLOTTING C C PLOTTER DEFINITIONS - ALL IN CENTIMETERS C PARAMETER (RESOLUTION = 0.0025) !RESOLUTION PARAMETER (PEN_WIDTH = 0.002) !PEN LINE WIDTH C C*********************************************************************** C C CALCULATED QUANTITIES FOR PLOTTER C PARAMETER (X_WIDE = CM_PER_INCH*PLOT_WIDTH) PARAMETER (Y_HIGH = CM_PER_INCH*PLOT_HEIGHT) PARAMETER (SKIPPED_LINES = PEN_WIDTH/RESOLUTION) C C*********************************************************************** C DATA DCHAR /8.0, X_WIDE, Y_HIGH, RESOLUTION, RESOLUTION, 1 7.0, 3.0, SKIPPED_LINES/ C C SHOW WE WANT TALL NOT WIDE PLOTTING AREA C LWIDE = .FALSE. 10 CONTINUE C C FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE C IF (IFXN .LE. 0 .OR. IFXN .GT. 8) RETURN C C NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION C GO TO (100,200,300,400,500,600,700,800) IFXN C C ********************* C INITIALIZE THE DEVICE C ********************* C 100 CONTINUE ??? CALL PLOTS(53,0,4) YA(1) = 0.0 RETURN C C ************************** C GET FRESH PLOTTING SURFACE C ************************** C 200 CONTINUE CALL NEWPEN(1) CALL PLOT(PAPER_WIDTH,0.0,-3) RETURN C C **** C MOVE C **** C 300 CONTINUE IPEN = +3 GO TO 450 C C **** C DRAW C **** C 400 CONTINUE IPEN = +2 450 CONTINUE C C ZETA "PLOT" SUBROUTINE WANTS INCHES, SO CONVERT C X = XA(1)/CM_PER_INCH Y = YA(1)/CM_PER_INCH IF (LWIDE) THEN CALL PLOT(LEFT_BORDER+PLOT_WIDTH-Y,BOTTOM_BORDER+X,IPEN) ELSE CALL PLOT(LEFT_BORDER+X,BOTTOM_BORDER+Y,IPEN) END IF RETURN C C ***************************** C FLUSH GRAPHICS COMMAND BUFFER C ***************************** C 500 CONTINUE C C NOP FOR ZETA 8 CAUSE I DON'T KNOW HOW TO MAKE THE FUNDAMENTAL C PLOTTING ROUTINES DO IT C RETURN C C ****************** C RELEASE THE DEVICE C ****************** C 600 CONTINUE CALL PLOT(PAPER_WIDTH, 0.0, +999) RETURN C C ***************************** C RETURN DEVICE CHARACTERISTICS C ***************************** C 700 CONTINUE DO 720 I=1,8 XA(I) = DCHAR(I) 720 CONTINUE IF (.NOT. LWIDE) RETURN XA(2) = DCHAR(3) XA(3) = DCHAR(2) RETURN C C SELECT NEW COLOR C 800 CONTINUE CALL NEWPEN(INT(XA(1)) RETURN C C ALTERNATE ENTRY FOR WIDE PLOTTING AREA C ENTRY GDZETA8WIDE(IFXN,XA,YA) LWIDE = .TRUE. GO TO 10 END FUNCTION GOODCS(APPROX) INCLUDE 'GCDCHR.PRM' INCLUDE 'GCDPRM.PRM' DATA YCELL /8.0/ C C CALCULATE MINIMUM VIRTUAL COORD. SIZE OF CHARS THAT ARE READALBE WITH C THE DEVICES RESOLUTION. C SIZE = (YCELL/YRES)/YS C C NOW SCALE UP THIS MINIMUM SIZE SO THAT CHARACTERS ARE ABOUT C THE SIZE DESIRED. C N = APPROX/SIZE + 0.25 C C MUST BE ATLEAST N=1 C IF (N .EQ. 0) N=1 C C NOW RETURN OUR ANSWER C GOODCS = N*SIZE RETURN END SUBROUTINE GRAFIN(X,Y,LFLAG) LOGICAL LFLAG C C DISPLAY AND READ THE GRAPHICS CURSOR AND RETURN ITS POSITION C IN WORLD COORDINATES. C INCLUDE 'PLTCOM.PRM' INCLUDE 'PLTSIZ.PRM' C C GET CURSOR POSITION IN VIRTUAL COORDINATES. C CALL GSCRSR(X,Y,LFLAG,IERR) IF (IERR .NE. 0) RETURN X = (X-XVSTRT)*UDX/XVLEN + UX0 IF (LOGX) X = 10.0**X Y = (Y-YVSTRT)*UDY/YVLEN + UY0 IF (LOGY) Y = 10.0**Y RETURN END SUBROUTINE GSCCLC(X,Y,DX,DY) C C THIS SUBROUTINE DOES THE CHARACTER SIZING AND ROTATION. C INCLUDE 'GCCPAR.PRM' INCLUDE 'GCCOFF.PRM' C XS = X*CSIZE YS = Y*CSIZE DX = CCOS*XS + CSIN*YS + XOFF DY = CCOS*YS - CSIN*XS + YOFF RETURN END SUBROUTINE GSCCMP(IX,IY,XOFF,YOFF,X,Y) C C INCLUDE 'GCCPAR.PRM' INCLUDE 'GCAPOS.PRM' C C SCALE TO PROPER SIZE C XS = CSIZE*IX YS = CSIZE*IY C C ROTATE AND TRANSLATE C X = CCOS*XS + CSIN*YS + XOFF Y = CCOS*YS - CSIN*XS + YOFF D TYPE 9999, IX, IY, X,Y D9999 FORMAT(' CMOVE TO (',I2,',',I2,') GOES TO (',F9.4,',',F9.4,')') RETURN END SUBROUTINE GSCGET(IPTR,DX,DY,LMOVE) C C THIS SUBROUTINE GETS THE NEXT NODE (POINT) ON THE CHARACTER C BASED UPON "IPTR". IT THEN SCALES AND ROTATES IT. C LOGICAL LMOVE INCLUDE 'GCCTBL.PRM' C LMOVE = .FALSE. 50 IF (BX(IPTR) .NE. -64) GO TO 100 LMOVE = .TRUE. IPTR = IPTR + 1 GO TO 50 100 X=BX(IPTR) Y=BY(IPTR) CALL GSCCLC(X,Y,DX,DY) IPTR = IPTR + 1 END FUNCTION GSCHIT() C C THIS FUNCTION RETURNS THE "HEIGHT" OF A CAPITAL LETTER C IN THE CHARACTER STROKE TABLE. ALL CHARACTERS ARE STROKED C FROM POINTS (COORDINATE PAIRS) STORED IN A STROKE TABLE. C CAPITAL LETTERS ARE DEFINED ON A GRID SO THAT (0,0) IS AT THE C LOWER LEFT CORNER OF THE CHARACTER CELL, AND (GSCWID(),GSCHIT()) C IS AT THE UPPER RIGHT BOUNDARY. NOTE, GSCWID() INCLUDES THE C SPACE BETWEEN CHARACTERS, THAT IS, CHARACTERS ARE GSCWID() APART. C GSCHIT = 8.0 RETURN END SUBROUTINE GSCOLR(ICOLOR,IERR) INCLUDE 'GCDCHR.PRM' C C SELECT COLOR "ICOLOR" ON CURRENT DEVICE C LOGICAL*1 LNOBKG IERR = 0 C C LNOBKG SET TO TRUE IF NO BACKGROUND COLOR EXISTS ON THIS DEVICE C LNOBKG = IAND(IDVBTS,4) .EQ. 0 C C FIRST, ERROR IF BACKGROUND COLOR REQUESTED AND DEVICE DOES NOT C SUPPORT BACKGROUND COLOR WRITE. C IF (ICOLOR .EQ. 0 .AND. LNOBKG) GO TO 900 C C SECOND, ERROR IF COLOR REQUESTED IS LARGER THAN THE NUMBER OF C FOREGROUND COLORS AVAILABLE ON THIS DEVICE C IF (ICOLOR .GT. NDCLRS) GO TO 900 C C IF ONLY 1 FOREGROUND COLOR AND NO BACKGROUND COLOR, THEN C DRIVER WILL NOT SUPPORT SET COLOR, AND OF COURSE, THE C COLOR MUST BE COLOR 1 TO HAVE GOTTEN THIS FAR, SO JUST RETURN C IF (NDCLRS .EQ. 1 .AND. LNOBKG) RETURN C C ALL IS OK, SO SET THE REQUESTED COLOR C 100 CALL GSDRVR(8,FLOAT(ICOLOR),DUMMY) RETURN 900 IERR = -1 RETURN END SUBROUTINE GSCRSR(X,Y,IBUTN,IERR) C C THIS DIGLIB SUBROUTINE TRIES TO GET GRAPHIC INPUT FROM C THE CURRENTLY SELECTED DEVICE. IF THE DEVICE IS NOT CAPABLE C OF IT, IERR=-1, ELSE IERR=0 AND: C X = X POSITION OF CURSOR IN VIRTUAL COORDINATES C Y = Y POSITION OF CURSOR IN VIRTUAL COORDINATES C IBUTN = NEW BUTTON STATE C INCLUDE 'GCDCHR.PRM' INCLUDE 'GCDPRM.PRM' DIMENSION ARRAY(3) C C SEE IF DEVICE SUPPORTS CURSOR C IF (IAND(IDVBTS,1024) .EQ. 0) GO TO 900 C C NOW ASK FOR CURSOR FROM DEVICE DRIVER C CALL GSDRVR(12,ARRAY,DUMMY) C C CONVERT ABSOLUTE CM. COORD. TO VIRTUAL COORDINATES C CALL GSIRST(ARRAY(2),ARRAY(3),X,Y) C C GET BUTTON STATE C IBUTN = ARRAY(1) 120 CONTINUE IERR = 0 RETURN C C DEVICE DOESN'T SUPPORT GIN C 900 IERR = -1 RETURN END FUNCTION GSCWID() C C THIS FUNCTION RETURNS THE "WIDTH" OF A CAPITAL LETTER C IN THE CHARACTER STROKE TABLE. ALL CHARACTERS ARE STROKED C FROM POINTS (COORDINATE PAIRS) STORED IN A STROKE TABLE. C CAPITAL LETTERS ARE DEFINED ON A GRID SO THAT (0,0) IS AT THE C LOWER LEFT CORNER OF THE CHARACTER CELL, AND (GSCWID(),GSCHIT()) C IS AT THE UPPER RIGHT BOUNDARY. NOTE, GSCWID() INCLUDES THE C SPACE BETWEEN CHARACTERS, THAT IS, CHARACTERS ARE GSCWID() APART. C GSCWID = 9.0 RETURN END SUBROUTINE GSDLNS(ILTYPE,ON1,OFF1,ON2,OFF2) C C Define LiNe Style C INCLUDE 'GCLTYP.PRM' C IF (ILTYPE .LT. 2 .OR. ILTYPE .GT. 4) RETURN INDEX = ILTYPE-1 DIST(1,INDEX) = ON1 DIST(2,INDEX) = OFF1 DIST(3,INDEX) = ON2 DIST(4,INDEX) = OFF2 RETURN END SUBROUTINE GSDRAW(X,Y) C C INCLUDE 'GCVPOS.PRM' INCLUDE 'GCAPOS.PRM' INTEGER GSIVIS C C TRANSFORM VIRT. COOR. TO SCREEN COORD. C D TYPE *,'OLD POSITION ',XAPOS,YAPOS,IVIS XVPOS = X YVPOS = Y CALL GSRST(XVPOS,YVPOS,X1,Y1) IVIS1 = GSIVIS(X1,Y1) CALL GSDRW2(XAPOS,YAPOS,IVIS,X1,Y1,IVIS1) XAPOS = X1 YAPOS = Y1 IVIS = IVIS1 D TYPE *,'NEW POSITION ',XAPOS,YAPOS,IVIS RETURN END SUBROUTINE GSDRGB(ICOLOR,RED,GRN,BLU,IERR) INCLUDE 'GCDCHR.PRM' DIMENSION RGB(3) C C DEFINE A COLOR C IF ( IAND(IDVBTS,64) .EQ. 0 .OR. 1 (ICOLOR .GT. NDCLRS) .OR. 2 (ICOLOR .LT. 0)) GO TO 900 IERR = 0 RGB(1) = RED RGB(2) = GRN RGB(3) = BLU CALL GSDRVR(10,FLOAT(ICOLOR),RGB) RETURN 900 IERR = -1 RETURN END SUBROUTINE GSDRVR(IFXN,X,Y) C C INCLUDE 'GCDSEL.PRM' DATA MAXDEV /4/ C C SEE IF DEVICE EXISTS C IF (IDEV .GT. 0 .AND. IDEV .LE. MAXDEV) GO TO 50 C C NON-EXISTANT DEVICE, SO SEE IF USER IS JUST ENQUIRING?? C IF (IFXN .NE. 7) RETURN C C RETURN DEVICE TYPE EQUAL ZERO IF ENQUIRING ABOUT NON-EXISTANT C DEVICE. C X = 0.0 RETURN C C DISPATCH TO THE PROPER DRIVER C 50 CONTINUE GO TO (100,200,300,400) IDEV C C DEVICE 1 IS VT100 WITH RETRO-GRAPHICS C 100 CALL GDRTRO(IFXN,X,Y) RETURN C C DEVICE 2 IS CUSTOM TEK. 4115B C 200 CALL GD(IFXN,X,Y) RETURN C C DEVICE 3 IS TEK. 4115B C 300 CALL GD4115B(IFXN,X,Y) RETURN C C DEVICE 4 IS TEK 4105 C 400 CALL GD4105(IFXN,X,Y) RETURN END SUBROUTINE GSDNAM(IDEV,BNAME) BYTE BNAME(40) C C THIS SUBROUTINE RETURNS THE DEVICE NAME OF THE SPECIFIED DEVICE C *********** DEVICE NAMES ARE LIMITED TO 39 CHARACTERS ********** C DATA MAXDEV /4/ C BNAME(1) = 0 IF ((IDEV .LE. 0) .OR. (IDEV .GT. MAXDEV)) RETURN GO TO (100,200,300,400) IDEV 100 CALL SCOPY('VT100/RetroGraphics',BNAME) RETURN 200 CALL SCOPY('custom Tek. 4115B',BNAME) RETURN 300 CALL SCOPY('Tek. 4115B',BNAME) RETURN 400 CALL SCOPY('Tek. 4105',BNAME) RETURN END SUBROUTINE GSDRW2(X0,Y0,IVIS0,X1,Y1,IVIS1) C C CLIP LINE TO CLIPPING BOX. PASS ON ONLY VISIBLE LINE SEGMENTS TO C GSDRW3 TO BE DRAWN IN THE CURRENT LINE TYPE. THIS SUBROUTINE ALSO C WORRIES ABOUT WHETHER THE GRAPHICS DEVICE WILL REQUIRE A "MOVE" C BEFORE THE "DRAW" IS DONE. C INCLUDE 'GCCLIP.PRM' INCLUDE 'GCLTYP.PRM' C LOGICAL*1 LDID1 C D TYPE *,'CLIPPING (',X0,',',Y0,') IVIS=',IVIS0 D TYPE *,' TO (',X1,',',Y1,') IVIS=',IVIS1 IF (IAND(IVIS0,IVIS1) .NE. 0) RETURN IF (IVIS0 .EQ. 0) GO TO 10 LPOSND = .FALSE. LINILT = .TRUE. 10 CONTINUE C C CALCULATE THE NUMBER OF CLIPS NECESSARY C NCLIPS = 0 IF (IVIS0 .NE. 0) NCLIPS = 1 IF (IVIS1 .NE. 0) NCLIPS = NCLIPS + 1 IF (NCLIPS .NE. 0) GO TO 100 C C LINE TOTALLY VISIBLE, JUST DRAW IT C CALL GSDRW3(X0,Y0,X1,Y1) RETURN C C FIND THE INTERSECTION(S) WITH THE CLIPPING BOX EDGES C 100 CONTINUE D TYPE *,'NCLIPS=',NCLIPS LDID1 = .FALSE. IST = 1 DX = X1-X0 IF (DX .EQ. 0.0) IST = 3 IFN = 4 DY = Y1-Y0 IF (DY .EQ. 0.0) IFN = 2 IF (IST .GT. IFN) RETURN IVISC = IOR(IVIS0,IVIS1) IBIT = 2**(IST-1) D TYPE *,'IST=',IST,' IFN=',IFN DO 210 I = IST, IFN IF (IAND(IVISC,IBIT) .EQ. 0) GO TO 200 IF (I .GT. 2) GO TO 110 XI = XCM0 IF (I .EQ. 2) XI = XCM1 YI = Y0 + (XI-X0)*DY/DX IF (YI .LT. YCM0 .OR. YI .GT. YCM1) GO TO 200 GO TO 120 110 CONTINUE YI = YCM0 IF (I .EQ. 4) YI = YCM1 XI = X0 + (YI-Y0)*DX/DY D TYPE *,'Y INTERSECTION',XI,YI IF (XI .LT. XCM0 .OR. XI .GT. XCM1) GO TO 200 120 CONTINUE C C GOT AN INTERSECTION. IF IT'S THE ONLY ONE, THE DRAW THE LINE. C IF (NCLIPS .GT. 1) GO TO 140 IF (IVIS0 .EQ. 0) GO TO 130 CALL GSDRW3(XI,YI,X1,Y1) RETURN 130 CONTINUE CALL GSDRW3(X0,Y0,XI,YI) RETURN 140 CONTINUE C C TWO CLIPS NECESSARY. IF WE ALREADY HAVE ONE, DRAW THE DOUBLE CLIPPED C LINE, ELSE SAVE FIRST CLIP AND WAIT FOR LAST. C NOTE, IF DOUBLE CLIPPED, IT DOESN'T MATTER IN WHICH DIRECTION IT C IS DRAWN. C IF (.NOT. LDID1) GO TO 180 CALL GSDRW3(X2,Y2,XI,YI) RETURN 180 CONTINUE X2 = XI Y2 = YI LDID1 = .TRUE. 200 CONTINUE IBIT = 2*IBIT 210 CONTINUE C C SEGMENT IS NOT VISIBLE IF WE DROP THRU TO HERE C RETURN END SUBROUTINE GSDRW3(X0,Y0,X1,Y1) C C DRAW A LINE FROM (X0,Y0) TO (X1,Y1) IN ABSOLUTE COORDINATES. C ASSUMES THAT CLIPPING HAS ALREADY BEEN DONE. TO SUPPRESS UNNECESSARY C "MOVES", THIS IS THE ONLY ROUTINE THAT SHOULD CALL GSDRVR(3,,,). C THE LINE IS DRAWN IN THE CURRENT LINE TYPE. THIS ROUTINE DOES NOT C SET THE ABSOLUTE POSITION (XAPOS,YAPOS). IT IS UP TO THE CALLER TO C DO SO IF NECESSARY. C INCLUDE 'GCLTYP.PRM' C IF (ILNTYP .GT. 1) GO TO 50 IF (.NOT. LPOSND) CALL GSDRVR(3,X0,Y0) GO TO 220 C C SEGMENT LINE TO MAKE CURRENT LINE TYPE C 50 CONTINUE IF (.NOT. LINILT) GO TO 100 INXTL = 1 DLEFT = DIST(1,ILNTYP-1) LINILT = .FALSE. IF (.NOT. LPOSND) CALL GSDRVR(3,X0,Y0) 100 DX = X1-X0 DY = Y1-Y0 DL = SQRT(DX**2+DY**2) C C SEE IF THIS SEGMENT IS SHORTER THAT DIST. LEFT ON LINE TYPE C IF (DL .LE. DLEFT) GO TO 200 C C SEGMENT IS LONGER, SO ADVANCE TO LINE TYPE BREAK C S = DLEFT/DL X0 = S*DX+X0 Y0 = S*DY+Y0 C C SEE IF THIS PART OF THE LINE TYPE IS DRAWN OR SKIPPED C IF (IAND(INXTL,1) .NE. 0) GO TO 120 CALL GSDRVR(3,X0,Y0) GO TO 140 120 CONTINUE CALL GSDRVR(4,X0,Y0) 140 CONTINUE C C NOW GO TO NEXT PORTION OF LINE TYPE C INXTL = INXTL + 1 IF (INXTL .GT. 4) INXTL = 1 DLEFT = DIST(INXTL,ILNTYP-1) GO TO 100 C C DRAW LAST OF LINE IF DRAWN C 200 CONTINUE DLEFT = DLEFT - DL IF (IAND(INXTL,1) .NE. 0) GO TO 220 LPOSND = .FALSE. GO TO 240 220 CONTINUE CALL GSDRVR(4,X1,Y1) LPOSND = .TRUE. 240 CONTINUE RETURN END SUBROUTINE GSETDP(ANGLE,XSCALE,YSCALE,XTRAN,YTRAN) C C INCLUDE 'GCDPRM.PRM' INCLUDE 'PIODEF.PRM' C C SET SCALE AND TRANSLATION FACTORS C XS = XSCALE YS = YSCALE XT = XTRAN YT = YTRAN C C SET ROTATION FACTORS C RAD = -ANGLE*PIO180 RCOS = COS(RAD) RSIN = SIN(RAD) RETURN END SUBROUTINE GSFILL(X,Y,N,TX,TY) DIMENSION X(N),Y(N), TX(N),TY(N) C C DIGLIB POLYGON FILL SUPPORT C DERIVED FROM "HATCH" ALGORITHM BY KELLY BOOTH C INCLUDE 'GCDCHR.PRM' INCLUDE 'GCDPRM.PRM' INCLUDE 'GCLTYP.PRM' C DIMENSION XINS(40) INTEGER GSIVIS LOGICAL*1 LEFT DATA FACT /16.0/ C C ***** C DEFINE ARITHMETIC STATEMENT FUNCTION TO MAPPING VERTICES YMAP(YYY) = 2.0*AINT(YSCALE*YYY+0.5)+1.0 C ***** C IF (N .LT. 3) RETURN C C C CONVERT TO ABSOLUTE COORD. C DO 10 I=1,N CALL GSRST(X(I),Y(I),TX(I),TY(I)) 10 CONTINUE CALL MINMAX(TY,N,YMIN,YMAX) CALL MINMAX(TX,N,XMIN,XMAX) C C IF CLIPPING NEEDED OR IF NO HARDWARE POLYGON FILL, USE SOFTWARE C IF ((GSIVIS(XMIN,YMIN) .NE. 0) .OR. 1 (GSIVIS(XMAX,YMAX) .NE. 0) .OR. 2 (IAND(IDVBTS,256) .EQ. 0)) GO TO 200 C C IF CAN HANDLE CONCAVE POLYGONS, JUST CALL DRIVER C IF ((IAND(IDVBTS,512) .EQ. 0) .OR. 1 (N .EQ. 3)) GO TO 150 C C IF HERE, DRIVER CAN HANDLE CONVEX NON-INTERSECTING POLYGONS ONLY, C SO MAKE SURE THIS POLYGON IS CONVEX AND NON-SELF-INTERSECTING. C DX1 = X(1)-X(N) DY1 = Y(1)-Y(N) DY = DY1 !OLD NON-ZERO DELTA-Y NCHNGS = 0 !NUMBER OF TIMES DELTA-Y CHANGES SIGN L = 1 COSTH = 0.0 110 CONTINUE C C CONVEXITY TEST C DX2 = X(L+1)-X(L) DY2 = Y(L+1)-Y(L) A = DX1*DY2-DX2*DY1 IF (A*COSTH .LT. 0.0) GO TO 200 IF (COSTH .EQ. 0.0) COSTH = A C C SELF INTERSECTION CHECK - RELYS ON "CONVEXITY" CHECK C IF (DY .NE. 0.0) GO TO 120 DY = DY2 GO TO 130 120 CONTINUE IF (DY2*DY .GE. 0.0) GO TO 130 DY = DY2 NCHNGS = NCHNGS + 1 IF (NCHNGS .GE. 3) GO TO 200 130 CONTINUE DX1 = DX2 DY1 = DY2 L = L + 1 IF (L .LT. N) GO TO 110 150 CONTINUE CALL GSDRVR(1024+N,TX,TY) RETURN C C ********** C SOFTWARE FILL C ********** C 200 CONTINUE C C FILLING A POLYGON IS VERY SIMPLE IF AND ONLY IF THE VERTICES OF C THE POLYGON NEVER LIE ON A SCAN LINE. WE CAN FORCE THIS TO HAPPEN C BY THE FOLLOWING TRICK: MAKE ALL VERTICES LIE JUST BARELY ABOVE C THE SCAN LINE THEY SHOULD LIE ON. THIS IS DONE BY MAPPING THE C VERTICES TO A GRID THAT IS "FACT" TIMES THE DEVICE RESOLUTION, C AND THEN DOUBLING THE GRID DENSITY, AND OFFSETTING THE VERTICES C BY 1. BECAUSE WE DO THIS, WE MUST OUTLINE THE POLYGON. C C ******* C C FILL WITH SOLID LINES C LINOLD = ILNTYP ILNTYP = 1 C LEFT = .TRUE. YSCALE = AMAX1(XS,YS)*YRES*FACT DLINES = 2.0*FACT YMIN = AINT(YMAP(YMIN)/DLINES)*DLINES+DLINES YMAX = AINT(YMAP(YMAX)/DLINES)*DLINES YSCAN = YMIN 210 CONTINUE INISEC = 0 IFIRST = 0 C C DO EACH SIDE OF THE POLYGON. PUT ANY X INTERSECTIONS C WITH THE SCAN LINE Y=YSCAN IN XINS C YBEGIN = YMAP(Y(N)) XBEGIN = X(N) DO 400 L = 1, N YEND = YMAP(Y(L)) DY = YSCAN-YBEGIN IF (DY*(YSCAN-YEND) .GT. 0.0) GO TO 390 C C INSERT AN INTERSECTION C INISEC = INISEC + 1 XINS(INISEC) = DY*(X(L)-XBEGIN)/(YEND-YBEGIN)+XBEGIN C 390 CONTINUE YBEGIN = YEND XBEGIN = X(L) 400 CONTINUE C C FILL IF THERE WERE ANY INTERSECTIONS C IF (INISEC .EQ. 0) GOTO 500 C FIRST WE MUST SORT. USE BUBBLE SORT BECAUSE USUALLY ONLY 2. DO 450 I = 1, INISEC-1 XKEY = XINS(I) DO 430 J = I+1, INISEC IF (.NOT. LEFT) GOTO 420 IF (XKEY .GE. XINS(J)) GO TO 430 410 CONTINUE TEMP = XKEY XKEY = XINS(J) XINS(J) = TEMP GO TO 430 420 IF (XKEY .GT. XINS(J)) GOTO 410 430 CONTINUE XINS(I) = XKEY 450 CONTINUE C C DRAW FILL LINES NOW C YY = YSCAN/(2.0*YSCALE) DO 460 I = 1, INISEC, 2 CALL GSMOVE(XINS(I),YY) CALL GSDRAW(XINS(I+1),YY) 460 CONTINUE 500 CONTINUE YSCAN = YSCAN + DLINES LEFT = .NOT. LEFT IF (YSCAN .LE. YMAX) GO TO 210 C C FINALLY, OUTLINE THE POLYGON C CALL GSMOVE(X(N),Y(N)) DO 510 L=1,N CALL GSDRAW(X(L),Y(L)) 510 CONTINUE C C RESTORE LINE TYPE C ILNTYP = LINOLD RETURN END SUBROUTINE GSFONT(NEWFONT,IERR) C C THIS SUBROUTINE SELECTS A NEW FONT, LOADING IT IF NECESSARY C PARAMETER (LUN=91) C INCLUDE 'GCFONT.CMN' INCLUDE 'GCCPAR.PRM' C BYTE FILNAM(12) DATA FILNAM /'D','I','G','$','F','O','N','T','n','n',2*0/ C C IF (NEWFONT .LE. 0 .OR. NEWFONT .GT. MAXFNT) THEN IERR = -1 RETURN ENDIF ISLOT = 1 100 CONTINUE IF (ISLOTFONT(ISLOT) .EQ. NEWFONT) GO TO 200 ISLOT = ISLOT + 1 IF (ISLOT .LE. MAXSLOT) GO TO 100 C C ***** LOAD NEW FONT *** C MAXSLOT = ISLOT ISLOTFONT(ISLOT) = NEWFONT C IF (NEWFONT .LT. 10) THEN FILNAM(9) = 48 + NEWFONT FILNAM(10) = 0 ELSE I = NEWFONT/10 FILNAM(9) = 48 + I FILNAM(10) = 48 + (NEWFONT - 10*I) FILNAM(11) = 0 ENDIF OPEN (UNIT=LUN,NAME=FILNAM,TYPE='OLD',ACCESS='DIRECT', 1 FORM='UNFORMATTED',RECORDTYPE='FIXED',RECORDSIZE=128, 2 ERR=900,READONLY,SHARED) C C CALCULATE OFFSETS INTO TABLES C IST = 1 + 95*(ISLOT-1) IEND = IST + 95 IOFF = INDX(IST)-1 READ (LUN'1) ITOTAL_BYTES, IHEIGHT(ISLOT), (INDX(I), I=IST,IEND), 1 (BWIDTH(I), I=IST-95,IEND-96) C C MAKE SURE IT ALL FITS C IF ((IOFF+ITOTAL_BYTES) .GT. MAXSTROKES) THEN CLOSE (UNIT=LUN) IERR = -1 RETURN ENDIF C C NOW ADD OFFSET TO INDEXES C DO 180 I=IST,IEND IF (INDX(I) .GT. 0) INDX(I) = INDX(I) + IOFF 180 CONTINUE C C READ IN THE STROKES C IBLOCKS = (ITOTAL_BYTES+511)/512 JST = IOFF+1 DO 190 I=1,IBLOCKS-1 READ (LUN'I+1) (BXY(J), J=JST,JST+511) JST = JST + 512 190 CONTINUE IF (JST .LE. ITOTAL_BYTES+IOFF) THEN READ (LUN'IBLOCKS+1) (BXY(J), J=JST,ITOTAL_BYTES+IOFF) ENDIF CLOSE (UNIT=LUN) C C ***** SELECT THE NEW FONT ***** C 200 CONTINUE OLDH = GSCHIT() ICFONTSLOT = ISLOT CSIZE = OLDH*CSIZE/GSCHIT() IERR = 0 RETURN C C FONT FILE NOT FOUND C 900 CONTINUE IERR = -2 RETURN END SUBROUTINE GSGIN(X,Y,BCHAR,IERR) BYTE BCHAR C C THIS DIGLIB SUBROUTINE TRIES TO GET GRAPHIC INPUT (GIN) FROM C THE CURRENTLY SELECTED DEVICE. IF THE DEVICE IS NOT CAPABLE C OF GIN, IERR=-1. FOR GIN DEVICES, IERR=0 AND: C X = X POSITION OF CURSOR IN ABSOLUTE SCREEN CM. C Y = Y POSITION OF CURSOR IN ABSOLUTE SCREEN CM. C BCHAR = CHARACTER STUCK AT TERMINAL TO SIGNAL CURSOR HAS C BEEN POSITIONED (BYTE). C INCLUDE 'GCDCHR.PRM' INCLUDE 'GCDPRM.PRM' DIMENSION ARRAY(3) BYTE SPACE DATA SPACE /' '/ C C SEE IF DEVICE SUPPORTS GIN C IF ((IDVBTS .AND. 128) .EQ. 0) GO TO 900 C C NOW ASK FOR GIN FROM DEVICE DRIVER C CALL GSDRVR(9,ARRAY,DUMMY) C C CONVERT ABSOLUTE CM. COORD. TO VIRTUAL CM. COORDINATES C CALL GSIRST(ARRAY(2),ARRAY(3),X,Y) C C GET CHARACTER AS 7 BIT ASCII C IF (ARRAY(1) .LT. 0.0 .OR. ARRAY(1) .GT. 127.0) GOTO 110 BCHAR = ARRAY(1) GOTO 120 C ELSE 110 CONTINUE BCHAR = SPACE C ENDIF 120 CONTINUE IERR = 0 RETURN C C DEVICE DOESN'T SUPPORT GIN C 900 IERR = -1 RETURN END FUNCTION GSHGHT() C C THIS FUNCTIONS RETURNS THE CURRENT CHARACTER HEIGHT IN VIRTUAL C COORDINATES. C INCLUDE 'GCCPAR.PRM' C GSHGHT = CSIZE/GSCHIT() RETURN END SUBROUTINE GSINPT(X,Y,LFLAG,IERR) LOGICAL LFLAG C C DO A GENERIC GRAPHICS INPUT C BYTE CHAR, SPACE DATA SPACE /' '/ C CALL GSCRSR(X,Y,IBUTN,IERR) IF (IERR .NE. 0) GO TO 100 LFLAG = (IAND(IBUTN,1) .EQ. 1) RETURN 100 CONTINUE CALL GSGIN(X,Y,CHAR,IERR) IF (IERR .NE. 0) RETURN LFLAG = (CHAR .EQ. SPACE) RETURN END FUNCTION GSIVIS(X,Y) INTEGER GSIVIS C INCLUDE 'GCCLIP.PRM' C C GSIVIS = 0 IF (X .LT. XCM0) GSIVIS = 1 IF (X .GT. XCM1) GSIVIS = GSIVIS + 2 IF (Y .LT. YCM0) GSIVIS = GSIVIS + 4 IF (Y .GT. YCM1) GSIVIS = GSIVIS + 8 RETURN END FUNCTION GSLENS(BSTRNG) BYTE BSTRNG(2) C C This function returns the length in virtual coordinates of C the string BSTRNG. The current character size is assumed. C INCLUDE 'GCCPAR.PRM' C EXTERNAL LEN C GSLENS = (GSCWID()*CSIZE)*LEN(BSTRNG) RETURN END SUBROUTINE GSLTYP(ITYPE) C C INCLUDE 'GCLTYP.PRM' C C SET THE CURRENT LINE TYPE C ILNTYP = ITYPE IF (ILNTYP .LE. 0 .OR. (ILNTYP .GT. 4)) ILNTYP = 1 LINILT = .TRUE. RETURN END SUBROUTINE GSMOVE(X,Y) C C MOVE THE THE POINT (X,Y). C INCLUDE 'GCLTYP.PRM' INCLUDE 'GCVPOS.PRM' INCLUDE 'GCAPOS.PRM' INTEGER GSIVIS C C RESET LINE STYLE TO BEGINNING OF PATTERN AND SHOW MOVED C LINILT = .TRUE. LPOSND = .FALSE. C C TRANSFORM VIRTUAL COORD. TO ABSOLUTE COORD. C XVPOS = X YVPOS = Y CALL GSRST(XVPOS,YVPOS,XAPOS,YAPOS) IVIS = GSIVIS(XAPOS,YAPOS) RETURN END SUBROUTINE GSPOLY(X,Y,N) DIMENSION X(2),Y(2) C C DIGLIB POLYGON SUPPORT C CALL GSMOVE(X(N),Y(N)) DO 100 I = 1, N CALL GSDRAW(X(I),Y(I)) 100 CONTINUE RETURN END SUBROUTINE GSPSTR(BSTRNG) BYTE BSTRNG(80) C C THIS SUBROUTINE STROKES OUT THE CHARACTER STRING "BSTRNG" (A BYTE C ARRAY WITH 0 AS A TERMINATOR) AT THE CURRENT POSITION. C INCLUDE 'GCVPOS.PRM' INCLUDE 'GCCOFF.PRM' INCLUDE 'GCLTYP.PRM' C C DON'T DRAW CHARACTERS IN LINETYPES C IOLD = ILNTYP ILNTYP = 1 C NBYTE = 0 100 NBYTE = NBYTE + 1 C C SAVE THE (0,0) POSITION OF THE CHARACTER C XOFF = XVPOS YOFF = YVPOS C C GET THE CHARACTER TO STROKE C IICHAR = BSTRNG(NBYTE) IF (IICHAR .EQ. 0) GO TO 200 C C STROKE THE CHARACTER C CALL GSSTRK(IICHAR) GO TO 100 C C RETURN LINE TYPE TO THAT OF BEFORE C 200 CONTINUE ILNTYP = IOLD RETURN END SUBROUTINE GSRCLP(AREA) DIMENSION AREA(4) C C THIS SUBROUTINE RESTORES A SAVED ABSOLUTE CLIPPING WINDOW PREVIOUSLY C SAVED BY "GSSCLP". NO ERROR CHECKING IS PERFORMED HERE!!! C INCLUDE 'GCCLIP.PRM' C XCM0 = AREA(1) XCM1 = AREA(2) YCM0 = AREA(3) YCM1 = AREA(4) RETURN END SUBROUTINE GSRST(XV,YV,XA,YA) C C INCLUDE 'GCDPRM.PRM' C C ROTATE, SCALE, AND THEN TRANSLATE COORDINATES C (TAKE VIRT. COORD. INTO SCREEN COORD.) C XTEMP = XV XA = XS*(RCOS*XTEMP+RSIN*YV) + XT YA = YS*(RCOS*YV-RSIN*XTEMP) + YT RETURN END SUBROUTINE GSIRST(XA,YA,XV,YV) C C INVERSE ROTATE, SCALE, AND THEN TRANSLATE C (TAKE ABSOLUTE COORD. INTO VIRTUAL COORD.) C INCLUDE 'GCDPRM.PRM' C C CONVERT ABSOLUTE CM. COORD. TO VIRTUAL CM. COORDINATES C XTEMP = (XA-XT)/XS YV = (YA-YT)/YS XV = RCOS*XTEMP-RSIN*YV YV = RCOS*YV+RSIN*XTEMP RETURN END SUBROUTINE GSSCLP(VX0,VX1,VY0,VY1,AREA) DIMENSION AREA(4) C C THIS SUBROUTINE SAVES THE CURRENT ABSOLUTE CLIPPING WINDOW AND C SETS A NEW ABSOLUTE CLIPPING WINDOW GIVEN VIRTUAL COORDINATES. C IT MAKES SURE THAT THE CLIPPING WINDOW NEVER LIES OUTSIDE THE C PHYSICAL DEVICE. C INCLUDE 'GCCLIP.PRM' INCLUDE 'GCDCHR.PRM' C AREA(1) = XCM0 AREA(2) = XCM1 AREA(3) = YCM0 AREA(4) = YCM1 C CALL GSRST(VX0,VY0,AX0,AY0) CALL GSRST(VX1,VY1,AX1,AY1) XCM0 = AMAX1(AMIN1(AX0,AX1),0.0) YCM0 = AMAX1(AMIN1(AY0,AY1),0.0) XCM1 = AMIN1(XCLIPD,AMAX1(AX0,AX1)) YCM1 = AMIN1(YCLIPD,AMAX1(AY0,AY1)) RETURN END SUBROUTINE GSSETC(SIZE,ANGLE) C C INCLUDE 'GCCPAR.PRM' INCLUDE 'PIODEF.PRM' C C SET UP SIZE MULTIPLIER C CSIZE = SIZE/GSCHIT() C C CALCULATE THE ROTATION FACTORS C RAD = -PIO180*ANGLE CCOS = COS(RAD) CSIN = SIN(RAD) RETURN END FUNCTION GSSLEN(NCHARS) C C This function returns the length in virtual coordinates of C a string of length NCHARS. The current character size is assumed. C INCLUDE 'GCCPAR.PRM' C EXTERNAL LEN C GSSLEN = (GSCWID()*CSIZE)*NCHARS RETURN END SUBROUTINE GSSTRK(ICHAR) C C THIS SUBROUTINE STROKES OUT A CHARACTER. C LOGICAL LMOVE INCLUDE 'GCCIDX.PRM' C C SPACE FILL ALL NON-PRINTING C IF (ICHAR .LE. 32 .OR. ICHAR .GE. 128) GO TO 200 C C STROKE THIS CHARACTER C INDX = INDEXC(ICHAR-32) IDONE = INDEXC(ICHAR-31) C C GET THE SCALED AND ROTATED NEXT NODE ON THE CHARACTER C 100 CALL GSCGET(INDX,DX,DY,LMOVE) IF (LMOVE) GO TO 140 CALL GSDRAW(DX,DY) GO TO 160 140 CALL GSMOVE(DX,DY) C C SEE IF ALL DONE C 160 IF (INDX .LT. IDONE) GO TO 100 C C ALL DONE WITH THE CHARACTER, MOVE TO NEXT CHARACTER POSITION C 200 CALL GSCCLC(GSCWID(),0.0,DX,DY) CALL GSMOVE(DX,DY) RETURN END FUNCTION GSWDTH(SIZE) C C This function returns the width in virtual coordinates of C a character. If SIZE=0 then the current character size is assumed. C INCLUDE 'GCCPAR.PRM' C EXTERNAL LEN C TEMP = SIZE*GSCHIT() IF (TEMP .EQ. 0.0) TEMP = CSIZE GSWDTH = GSCWID()*TEMP RETURN END SUBROUTINE GSWNDO(UXL,UXH,UYL,UYH,XOFF,YOFF,XAWDTH,YAHIGH) C C THIS SUBROUTINE PROVIDES DIGLIB V3'S WINDOW/VIEWPORT MECHANISM. C INCLUDE 'GCCLIP.PRM' INCLUDE 'GCDCHR.PRM' INCLUDE 'GCDPRM.PRM' C C RCOS = 1.0 RSIN = 0.0 XS = XAWDTH/(UXH-UXL) YS = YAHIGH/(UYH-UYL) XT = XOFF - XS*UXL YT = YOFF - YS*UYL XCM0 = AMAX1(AMIN1(XOFF,XOFF+XAWDTH),0.0) YCM0 = AMAX1(AMIN1(YOFF,YOFF+YAHIGH),0.0) XCM1 = AMIN1(XCLIPD,AMAX1(XOFF,XOFF+XAWDTH)) YCM1 = AMIN1(YCLIPD,AMAX1(YOFF,YOFF+YAHIGH)) RETURN END FUNCTION GSXLCM() C C THIS FUNCTION RETURNS THE X AXIS LENGTH OF THE CURRENT DEVICE C IN CENTIMETERS. C INCLUDE 'GCDCHR.PRM' C GSXLCM = XLENCM RETURN END FUNCTION GSYLCM() C C THIS FUNCTION RETURNS THE Y AXIS LENGTH OF THE CURRENT DEVICE C IN CENTIMETERS. C INCLUDE 'GCDCHR.PRM' C GSYLCM = YLENCM RETURN END SUBROUTINE HATCH(XVERT, YVERT, NUMPTS, PHI, CMSPAC, IFLAGS, 1 XX, YY) DIMENSION XVERT(NUMPTS), YVERT(NUMPTS), XX(NUMPTS), YY(NUMPTS) C C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C H A T C H C by Kelly Booth and modified for DIGLIB by Hal Brand C C PROVIDE SHADING FOR A GENERAL POLYGONAL REGION. THERE IS ABSOLUTELY NO C ASSUMPTION MADE ABOUT CONVEXITY. A POLYGON IS SPECIFIED BY ITS VERTICES, C GIVEN IN EITHER A CLOCKWISE OR COUNTER-CLOCKWISE ORDER. THE DENSITY OF C THE SHADING LINES (OR POINTS) AND THE ANGLE FOR THE SHADING LINES ARE C BOTH DETERMINED BY THE PARAMETERS PASSED TO THE SUBROUTINE. C C THE INPUT PARAMETERS ARE INTERPRETED AS FOLLOWS: C C XVERT - AN ARRAY OF X COORDINATES FOR THE POLYGON VERTICES C C YVERT - AN ARRAY OF Y COORDINATES FOR THE POLYGON VERTICES C C NUMPTS - THE NUMBER OF VERTICES IN THE POLYGON C C PHI - THE ANGLE FOR THE SHADING, MEASURED COUNTER-CLOCKWISE C IN DEGREES FROM THE POSITIVE X-AXIS C C CMSPAC - THE DISTANCE IN VIRTUAL COORDINATES (CM. USUALLY) C BETWEEN SHADING LINES. THIS VALUE MAY BE ROUNDED C A BIT, SO SOME CUMMULATIVE ERROR MAY BE APPARENT. C C IFLAGS - GENERAL FLAGS CONTROLLING HATCH C 0 ==> BOUNDARY NOT DRAWN, INPUT IS VIRTUAL COORD. C 1 ==> BOUNDARY DRAWN, INPUT IS VIRTUAL COORD. C 2 ==> BOUNDARY NOT DRAWN, INPUT IS WORLD COORD. C 3 ==> BOUNDARY DRAWN, INPUT IS WORLD COORD. C C XX - A WORK ARRAY ATLEAST "NUMPTS" LONG. C C YY - A SECOND WORK ARRAY ATLEAST "NUMPTS" LONG. C C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C INCLUDE 'GCDCHR.PRM' C C THIS SUBROUTINE HAS TO MAINTAIN AN INTERNAL ARRAY OF THE TRANSFORMED C COORDINATES. THIS REQUIRES THE PASSING OF THE TWO WORKING ARRAYS C CALLED "XX" AND "YY". C THIS SUBROUTINE ALSO NEEDS TO STORE THE INTERSECTIONS OF THE HATCH C LINES WITH THE POLYGON. THIS IS DONE IN "XINTCP". C REAL XINTCP(20) LOGICAL LMOVE DATA IDIMX /20/ C C 'BIGNUM' SIGNALS THE END OF A POLYGON IN THE INPUT. C DATA BIGNUM /1E38/ DATA FACT /16.0/ DATA PI180 /0.017453292/ C C------------------------------------------------------------------------ C C CHECK FOR VALID NUMBER OF VERTICES. C IF (NUMPTS .LT. 3) RETURN C C CONVERT ALL OF THE POINTS TO INTEGER COORDINATES SO THAT THE SHADING C LINES ARE HORIZONTAL. THIS REQUIRES A ROTATION FOR THE GENERAL CASE. C THE TRANSFORMATION FROM VIRTUAL TO INTERNAL COORDINATES HAS THE TWO C OR THREE PHASES: C C (1) CONVERT WORLD TO VIRTUAL COORD. IF INPUT IN WORLD COORD. C C (2) ROTATE CLOCKWISE THROUGH THE ANGLE PHI SO SHADING IS HORIZONTAL, C C (3) SCALE TO INTEGERS IN THE RANGE C [0...2*FACT*(DEVICE_MAXY_COORDINATE)], FORCING COORDINATES C TO BE ODD INTEGERS. C C THE COORDINATES ARE ALL ODD SO THAT LATER TESTS WILL NEVER HAVE AN C OUTCOME OF "EQUAL" SINCE ALL SHADING LINES HAVE EVEN COORDINATES. C THIS GREATLY SIMPLIFIES SOME OF THE LOGIC. C C AT THE SAME TIME THE PRE-PROCESSING IS BEING DONE, THE INPUT IS CHECKED C FOR MULTIPLE POLYGONS. IF THE X-COORDINATE OF A VERTEX IS A 'BIGNUM' C THEN THE POINT IS NOT A VERTEX, BUT RATHER IT SIGNIFIES THE END OF A C PARTICULAR POLYGON. AN IMPLIED EDGE EXISTS BETWEEN THE FIRST AND LAST C VERTICES IN EACH POLYGON. A POLYGON MUST HAVE AT LEAST THREE VERTICES. C ILLEGAL POLYGONS ARE REMOVED FROM THE INTERNAL LISTS. C C C COMPUTE TRIGONOMETRIC FUNCTIONS FOR THE ANGLE OF ROTATION. C COSPHI = COS(PI180*PHI) SINPHI = SIN(PI180*PHI) C C FIRST CONVERT FROM WORLD TO VIRTUAL COORD. IF NECESSARY AND ELIMINATE C ANY POLYGONS WITH TWO OR FEWER VERTICES C ITAIL = 1 IHEAD = 0 DO 120 I = 1, NUMPTS C C ALLOCATE ANOTHER POINT IN THE VERTEX LIST. C IHEAD = IHEAD + 1 C C A 'BIGNUM' IN THE X-COORDINATE IS A SPECIAL FLAG. C IF (XVERT(I) .NE. BIGNUM) GO TO 110 XX(IHEAD) = BIGNUM IF ((IHEAD-ITAIL) .LT. 2) IHEAD = ITAIL - 1 ITAIL = IHEAD + 1 GO TO 120 110 CONTINUE C C CONVERT FROM WORLD TO VIRTUAL COORD. IF INPUT IS WORLD COORD. C IF ((IFLAG .AND. 2) .EQ. 0) GO TO 115 CALL SCALE(XVERT(I),YVERT(I),XX(IHEAD),YY(IHEAD)) GO TO 120 115 CONTINUE XX(IHEAD) = XVERT(I) YY(IHEAD) = YVERT(I) 120 CONTINUE IF ((IHEAD-ITAIL) .LT. 2) IHEAD = ITAIL - 1 NVERT = IHEAD C C DRAW BOUNDARY(S) IF DESIRED C IHEAD = 0 ITAIL = 1 LMOVE = .TRUE. 130 CONTINUE IHEAD = IHEAD + 1 IF (IHEAD .GT. NVERT) GO TO 133 IF (XX(IHEAD) .NE. BIGNUM) GO TO 135 133 CONTINUE CALL GSDRAW(XX(ITAIL),YY(ITAIL)) ITAIL = IHEAD + 1 LMOVE = .TRUE. GO TO 139 135 CONTINUE IF (LMOVE) GO TO 137 CALL GSDRAW(XX(IHEAD),YY(IHEAD)) GO TO 139 137 CONTINUE CALL GSMOVE(XX(IHEAD),YY(IHEAD)) LMOVE = .FALSE. 139 CONTINUE IF (IHEAD .LE. NVERT) GO TO 130 C C ROTATE TO MAKE SHADING LINES HORIZONTAL C YMIN = BIGNUM YMAX = -BIGNUM YSCALE = YRES*FACT YSCAL2 = 2.0*YSCALE DO 140 I = 1, NVERT IF (XX(I) .EQ. BIGNUM) GO TO 140 C C PERFORM THE ROTATION TO ACHIEVE HORIZONTAL SHADING LINES. C XV1 = XX(I) XX(I) = +COSPHI*XV1 + SINPHI*YY(I) YY(I) = -SINPHI*XV1 + COSPHI*YY(I) C C CONVERT TO INTEGERS AFTER SCALING, AND MAKE VERTICES ODD. IN Y C YY(I) = 2.0*AINT(YSCALE*YY(I)+0.5)+1.0 YMIN = AMIN1(YMIN,YY(I)) YMAX = AMAX1(YMAX,YY(I)) 140 CONTINUE C C MAKE SHADING START ON A MULTIPLE OF THE STEP SIZE. C STEP = 2.0*AINT(YRES*CMSPAC*FACT) YMIN = AINT(YMIN/STEP) * STEP YMAX = AINT(YMAX/STEP) * STEP C C AFTER ALL OF THE COORDINATES FOR THE VERTICES HAVE BEEN PRE-PROCESSED C THE APPROPRIATE SHADING LINES ARE DRAWN. THESE ARE INTERSECTED WITH C THE EDGES OF THE POLYGON AND THE VISIBLE PORTIONS ARE DRAWN. C Y = YMIN 150 CONTINUE IF (Y .GT. YMAX) GO TO 250 C C INITIALLY THERE ARE NO KNOWN INTERSECTIONS. C ICOUNT = 0 IBASE = 1 IVERT = 1 160 CONTINUE ITAIL = IVERT IVERT = IVERT + 1 IHEAD = IVERT IF (IHEAD .GT. NVERT) GO TO 165 IF (XX(IHEAD) .NE. BIGNUM) GO TO 170 C C THERE IS AN EDGE FROM VERTEX N TO VERTEX 1. C 165 IHEAD = IBASE IBASE = IVERT + 1 IVERT = IVERT + 1 170 CONTINUE C C SEE IF THE TWO ENDPOINTS LIE ON C OPPOSITE SIDES OF THE SHADING LINE. C YHEAD = Y - YY(IHEAD) YTAIL = Y - YY(ITAIL) IF (YHEAD*YTAIL .GE. 0.0) GO TO 180 C C THEY DO. THIS IS AN INTERSECTION. COMPUTE X. C ICOUNT = ICOUNT + 1 DELX = XX(IHEAD) - XX(ITAIL) DELY = YY(IHEAD) - YY(ITAIL) XINTCP(ICOUNT) = (DELX/DELY) * YHEAD + XX(IHEAD) 180 CONTINUE IF ( IVERT .LE. NVERT ) GO TO 160 C C SORT THE X INTERCEPT VALUES. USE A BUBBLESORT BECAUSE THERE C AREN'T VERY MANY OF THEM (USUALLY ONLY TWO). C IF (ICOUNT .EQ. 0) GO TO 240 DO 200 I = 2, ICOUNT XKEY = XINTCP(I) K = I - 1 DO 190 J = 1, K IF (XINTCP(J) .LE. XKEY) GO TO 190 XTEMP = XKEY XKEY = XINTCP(J) XINTCP(J) = XTEMP 190 CONTINUE XINTCP(I) = XKEY 200 CONTINUE C C ALL OF THE X COORDINATES FOR THE SHADING SEGMENTS ALONG THE C CURRENT SHADING LINE ARE NOW KNOWN AND ARE IN SORTED ORDER. C ALL THAT REMAINS IS TO DRAW THEM. PROCESS THE X COORDINATES C TWO AT A TIME. C YR = Y/YSCAL2 DO 230 I = 1, ICOUNT, 2 C C CONVERT BACK TO VIRTUAL COORDINATES. C ROTATE THROUGH AN ANGLE OF -PHI TO ORIGINAL ORIENTATION. C THEN UNSCALE FROM GRID TO VIRTUAL COORD. C XV1 = + COSPHI*XINTCP(I) - SINPHI*YR YV1 = + SINPHI*XINTCP(I) + COSPHI*YR XV2 = + COSPHI*XINTCP(I+1) - SINPHI*YR YV2 = + SINPHI*XINTCP(I+1) + COSPHI*YR D TYPE *,'LINE: (',XV1,YV1,') TO (',XV2,YV2,')' C C DRAW THE SEGMENT OF THE SHADING LINE. C CALL GSMOVE(XV1,YV1) CALL GSDRAW(XV2,YV2) 230 CONTINUE 240 CONTINUE Y = Y + STEP GO TO 150 250 CONTINUE RETURN END SUBROUTINE LAXIS(ALOW,AHIGH,MAXTCK,BMIN,BMAX,BTICK) C C THIS ROUTINE FINDS A SUITABLE TICK FOR LOG AXES C DATA SMLREL /1E-38/ C BLOW = ALOG10(AMAX1(SMLREL,AMIN1(AHIGH,ALOW))) BHIGH = ALOG10(AMAX1(ALOW,AHIGH,1E2*SMLREL)) RANGE = BHIGH-BLOW IF (RANGE .LE. 1E-2) RANGE = 1.0 !1E-2 IS FUZZ FACTOR ISTRT = 1 IMAX = 5 30 DO 50 I=ISTRT,IMAX,ISTRT NTCKS = RANGE/I + 0.999 type *,ntcks IF (NTCKS .LE. MAXTCK) GO TO 60 50 CONTINUE ISTRT = 10 IMAX = 80 GO TO 30 60 BTICK = I BMIN = BTICK*AINT(BLOW/BTICK) BMAX = BTICK*AINT(BHIGH/BTICK) IF ((BMIN-BLOW)/RANGE .GT. 0.001) BMIN = BMIN - BTICK IF ((BHIGH-BMAX)/RANGE .GT. 0.001) BMAX = BMAX + BTICK RETURN END SUBROUTINE LINLAB(NUM,IEXP,STRNG,LRMTEX) LOGICAL*1 LRMTEX BYTE STRNG(8) C BYTE BMINUS, BZERO(4) EXTERNAL LEN DATA BMINUS /'-'/ DATA BZERO /'0', '.', '0', 0/ C C LRMTEX = .TRUE. C C WORK WITH ABSOLUTE VALUE AS IT IS EASIER TO PUT SIGN IN NOW C IF (NUM .LT. 0) GO TO 10 NVAL = NUM ISTART = 1 GO TO 20 10 CONTINUE NVAL = -NUM ISTART = 2 STRNG(1) = BMINUS 20 CONTINUE IF (IEXP .GE. -2 .AND. IEXP .LE. 2) LRMTEX = .FALSE. IF (IEXP .GT. 0 .AND. (.NOT. LRMTEX)) NVAL = NVAL*10**IEXP CALL NUMSTR(NVAL,STRNG(ISTART)) IF ((NVAL .EQ. 0) .OR. LRMTEX .OR. (IEXP .GE. 0)) GOTO 800 C C NUMBER IS IN RANGE 10**-1 OR 10**-2, SO FORMAT PRETTY C N = -IEXP L = LEN(STRNG(ISTART)) IZBGN = 1 NIN = 3 IF (N .EQ. L) NIN = 2 C C IF N