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