home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d4xx / d499 / diglib.lha / Diglib / diglib.lzh / plotters / digplot.txt
Encoding:
Text File  |  1991-04-13  |  213.0 KB  |  9,391 lines
  1.     SUBROUTINE GD(IFXN,XA,YA)
  2.     DIMENSION XA(8), YA(3)
  3. C
  4. C    TEK 4115B DRIVER FOR DIGLIB/VAX
  5. C        VERSION 2.1 - CURSOR POSITIONING AND HARDWARE POLYGONS
  6. C
  7.     BYTE ESC, CSUB, GS, CR, FF, US
  8.     PARAMETER (ESC=27, CSUB=26, GS=29, CR=13, FF=12, US=31)
  9.     CHARACTER*(*) TERMINAL
  10.     PARAMETER (TERMINAL='TT')
  11. C
  12. C    DEFINITIONS FOR DEVICE CONTROL
  13. C
  14.     BYTE STR_END(2), STR_INIT_DEV(26), STR_WINDOW(4)
  15.     BYTE STR_BEGIN_PLOT(4)
  16.     INTEGER*2 STR_COLOR_SET(6)
  17.     BYTE STR_END_PLOT(2), STR_RLS_DEV(6)
  18.     BYTE STR_BEGIN_POLY(4), STR_END_POLY(6)
  19.     DATA STR_END /US,0/
  20.     DATA STR_INIT_DEV/
  21.     1   ESC,'%','!','0',        !CODE TEK
  22.     2   ESC,'K','A','1',        !DAENABLE YES
  23.     3   ESC,'L','M','0',        !DAMODE REPLACE
  24.     4   ESC,'M','L','1',        !LINEINDEX 1 (COLOR 1)
  25.     5   ESC,'N','U',':',        !BYPASS CANCEL CHARACTER (LF)
  26.     6   ESC,'N','T','1','=',0/    !EOL STRING <CR> <NULL>
  27.     DATA STR_WINDOW / ESC,'R','W',0/
  28.     DATA STR_BEGIN_PLOT/
  29.     1   ESC,FF,0,0/            !ERASE SCREEN
  30.     DATA STR_COLOR_SET /
  31.     1   ESC,'M','L','1',0,0/    !LINEINDEX 1 (COLOR N)
  32.     DATA STR_END_PLOT /0,0/
  33.     DATA STR_RLS_DEV /
  34.     1   ESC,'%','!','1',0,0/    !CODE ANSI
  35.     DATA STR_BEGIN_POLY / ESC,'L','P',0/
  36.     DATA STR_END_POLY / US,ESC,'L','E',2*0/
  37. C
  38. C    DEFINITIONS FOR GIN
  39. C
  40.     BYTE GINBUFR(8), PROMPT(4), STR_END_GIN(2), STR_MOVE_GIN_CURSOR(6)
  41.     DATA PROMPT /ESC, CSUB, 0, 0/
  42.     DATA IGIN_IN_CHARS /6/
  43.     DATA STR_END_GIN /10,0/
  44.     DATA STR_MOVE_GIN_CURSOR / ESC, 'S', 'X', '0', 0,0/
  45.     DATA IX_GIN_CURSOR, IY_GIN_CURSOR / 240, 180 /
  46. C
  47. C    DECLARE BUFFERING FUNCTION
  48. C
  49.     LOGICAL GB_TEST_FLUSH
  50. C
  51. C    DECLARE VARS NEED FOR DRIVER OPERATION
  52. C
  53.     LOGICAL LVECTOR_GOING, LDUMMY
  54.     DIMENSION DCHAR(8)
  55. C
  56. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  57. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  58. C
  59.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  60.     DATA DCHAR /4115.0, 34.778, 27.817, 36.776, 36.776, 255.0, 389.0, 1.0/
  61. C    DATA DCHAR /4107.0, 24.577, 18.423, 26.0, 26.0, 7.0, 389.0, 1.0/
  62. C
  63. C*****************
  64. C
  65. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  66. C
  67.     IF (IFXN .GT. 1026) GOTO 20000
  68.     IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN
  69. C
  70. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  71. C
  72.     GO TO (100,200,300,400,500,600,700,800,900) IFXN
  73. C
  74. C    *********************
  75. C    INITIALIZE THE DEVICE
  76. C    *********************
  77. C
  78. 100    CONTINUE
  79. C
  80. C    FIRST, INITIALIZE THE BUFFER SUBROUTINES
  81. C
  82.     CALL GB_INITIALIZE(0,STR_END,TERMINAL,IERR)
  83.     YA(1) = IERR
  84.     IF (IERR .NE. 0) RETURN
  85. C
  86. C    INITIALIZE THE 4107
  87. C
  88.     CALL GB_IN_STRING(STR_INIT_DEV)
  89.     CALL GB_IN_STRING(STR_WINDOW)
  90.     CALL GD_4010_CONVERT(0,0)
  91.     IX = INT(DCHAR(2)*XGUPCM+0.5)
  92.     IY = INT(DCHAR(3)*YGUPCM+0.5)
  93.     CALL GD_4010_CONVERT(IX,IY)
  94.     CALL GB_EMPTY
  95.     LVECTOR_GOING = .FALSE.
  96.     RETURN
  97. C
  98. C    **************************
  99. C    GET FRESH PLOTTING SURFACE
  100. C    **************************
  101. C
  102. 200    CONTINUE
  103.     CALL GB_NEW_BUFFER
  104.     CALL GB_IN_STRING(STR_BEGIN_PLOT)
  105.     CALL GB_EMPTY
  106.     LVECTOR_GOING = .FALSE.
  107.     RETURN
  108. C
  109. C    ****
  110. C    MOVE
  111. C    ****
  112. C
  113. 300    CONTINUE
  114. C    CONVERT CM. TO GRAPHICS UNITS ROUNDED
  115.     IXPOSN = XGUPCM*XA(1)+0.5
  116.     IYPOSN = YGUPCM*YA(1)+0.5
  117.     LVECTOR_GOING = .FALSE.
  118.     RETURN
  119. C
  120. C    ****
  121. C    DRAW
  122. C    ****
  123. C
  124. 400    CONTINUE
  125.     IX = XGUPCM*XA(1)+0.5
  126.     IY = YGUPCM*YA(1)+0.5
  127.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4))
  128.     IF (LVECTOR_GOING) GO TO 410
  129.     LDUMMY = GB_TEST_FLUSH(9)
  130.     LVECTOR_GOING = .TRUE.
  131.     CALL GB_INSERT(GS)
  132.     CALL GD_4010_CONVERT(IXPOSN,IYPOSN)
  133. 410    CALL GD_4010_CONVERT(IX,IY)
  134.     IXPOSN = IX
  135.     IYPOSN = IY
  136.     RETURN
  137. C
  138. C    *****************************
  139. C    FLUSH GRAPHICS COMMAND BUFFER
  140. C    *****************************
  141. C
  142. 500    CONTINUE
  143.     CALL GB_EMPTY
  144.     CALL GB_IN_STRING(STR_END_PLOT)
  145.     CALL GB_EMPTY
  146.     LVECTOR_GOING = .FALSE.
  147.     RETURN
  148. C
  149. C    ******************
  150. C    RELEASE THE DEVICE
  151. C    ******************
  152. C
  153. 600    CONTINUE
  154. C
  155. C    DE-ASSIGN THE CHANNAL
  156. C
  157.     CALL GB_EMPTY
  158.     CALL GB_IN_STRING(STR_WINDOW)
  159.     CALL GD_4010_CONVERT(0,0)
  160.     CALL GD_4010_CONVERT(1023,767)
  161.     CALL GB_FINISH(STR_RLS_DEV)
  162.     RETURN
  163. C
  164. C    *****************************
  165. C    RETURN DEVICE CHARACTERISTICS
  166. C    *****************************
  167. C
  168. 700    CONTINUE
  169.     DO 720 I=1,8
  170.     XA(I) = DCHAR(I)
  171. 720    CONTINUE
  172.     RETURN
  173. C
  174. C    ****************************
  175. C    SELECT CURRENT DRAWING COLOR
  176. C    ****************************
  177. C
  178. 800    CONTINUE
  179.     LDUMMY = GB_TEST_FLUSH(6)
  180.     ICOLOR = XA(1)
  181.     IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 255) RETURN
  182.     STR_COLOR_SET(4) = 48+ICOLOR    !MAKE ASCII CHARACTER
  183.     CALL GB_IN_STRING(STR_COLOR_SET)
  184.     LVECTOR_GOING = .FALSE.
  185.     RETURN
  186. C
  187. C    **********************
  188. C    PERFORM GRAPHICS INPUT
  189. C    **********************
  190. C
  191. 900    CONTINUE
  192. C
  193. C    POSITION CURSOR TO ITS LAST GIN POSITION (ELSE MIDDLE OF SCREEN)
  194. C
  195.     CALL GB_TEST_FLUSH(10)
  196.     CALL GB_IN_STRING(STR_MOVE_GIN_CURSOR)
  197.     CALL GD_4010_CONVERT(IX_GIN_CURSOR,IY_GIN_CURSOR)
  198.     CALL GB_EMPTY
  199. C
  200.     CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR)
  201. C
  202.     ICHAR = GINBUFR(1)
  203.     IX1 = GINBUFR(2)
  204.     IX2 = GINBUFR(3)
  205.     IY1 = GINBUFR(4)
  206.     IY2 = GINBUFR(5)
  207. C
  208.     XA(1) = IAND(ICHAR,127)        !PICK CHARACTER
  209.     IX_GIN_CURSOR = 32*IAND(IX1,31)+IAND(IX2,31)
  210.     XA(2) = IX_GIN_CURSOR/XGUPCM
  211.     IY_GIN_CURSOR = 32*IAND(IY1,31)+IAND(IY2,31)
  212.     XA(3) = IY_GIN_CURSOR/YGUPCM
  213. C
  214.     CALL GB_IN_STRING(STR_END_GIN)
  215.     CALL GB_EMPTY
  216.     RETURN
  217. C
  218. C    *******************
  219. C    DRAW FILLED POLYGON
  220. C    *******************
  221. C
  222. 20000    CONTINUE
  223.     NPTS = IFXN - 1024
  224.     IX = XGUPCM*XA(1)+0.5
  225.     IY = YGUPCM*YA(1)+0.5
  226.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(20))
  227.     IF (LVECTOR_GOING) THEN
  228.         CALL GB_INSERT(US)
  229.         LVECTOR_GOING = .FALSE.
  230.     ENDIF
  231.     CALL GB_IN_STRING(STR_BEGIN_POLY)
  232.     CALL GD_4010_CONVERT(IX,IY)
  233. C
  234. C    DO VERTICES 2 THRU N.   NOTE: WE START WITH A <GS> SINCE
  235. C     LVECTOR_GOING IS "FALSE"
  236. C
  237.         DO 20010 I = 2, NPTS
  238. C        MAKE SURE 10 CHARS (4 FOR X,Y AND 6 FOR END POLYGON)
  239.         LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(10))
  240.         IF (.NOT. LVECTOR_GOING) CALL GB_INSERT(GS)
  241.         CALL GD_4010_CONVERT(INT(XGUPCM*XA(I)+0.5),
  242.     1        INT(YGUPCM*YA(I)+0.5))
  243. 20010        CONTINUE
  244.     CALL GB_IN_STRING(STR_END_POLY)
  245.     LVECTOR_GOING = .FALSE.
  246.     RETURN
  247.     END
  248.     SUBROUTINE GD1012_LONG(IFXN,XA,YA)
  249.     DIMENSION XA(8), YA(3)
  250. C
  251. C    CalComp 1012 plotter driver for VMS
  252. C
  253. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  254. C
  255. C    PLOTTER COMMANDS, ETC.
  256. C
  257. C
  258.     INTEGER CMD_INIT_PLOTTER_SIZE, CMD_PEN_UP_SIZE,
  259.     1   CMD_INDEX_PLOTTER_SIZE, CMD_PEN_DOWN_SIZE, CMD_SELECT_PEN_SIZE,
  260.     2   CMD_MAX_DELTA_SIZE
  261.     PARAMETER (CMD_INIT_PLOTTER_SIZE = 32)
  262.     PARAMETER (CMD_PEN_UP_SIZE = 1)
  263.     PARAMETER (CMD_INDEX_PLOTTER_SIZE = 3)
  264.     PARAMETER (CMD_PEN_DOWN_SIZE = 1)
  265.     PARAMETER (CMD_SELECT_PEN_SIZE = 2)
  266.     PARAMETER (IPEN_NUMBER_POSITION = 2)
  267.     PARAMETER (CMD_MAX_DELTA_SIZE = 7)
  268.     BYTE RESPONSE_CHARACTER, RC1, RC2
  269.     PARAMETER (RESPONSE_CHARACTER = '&')
  270.     PARAMETER (RC1 = RESPONSE_CHARACTER/16)
  271.     PARAMETER (RC2 = RESPONSE_CHARACTER-16*RC1)
  272.     BYTE CMD_INIT_PLOTTER(CMD_INIT_PLOTTER_SIZE+1),
  273.     1   CMD_PEN_UP(CMD_PEN_UP_SIZE+1),
  274.     2   CMD_INDEX_PLOTTER(CMD_INDEX_PLOTTER_SIZE+1),
  275.     3   CMD_PEN_DOWN(CMD_PEN_DOWN_SIZE+1),
  276.     4   CMD_SELECT_PEN(CMD_SELECT_PEN_SIZE+1)
  277.     DATA CMD_INIT_PLOTTER /
  278.     1   7,63,        !RADIX 64
  279.     2   8,1,        !ENABLE DOUBLE BUFFERING IN PLOTTER
  280.     3   8,2,0,        !RESPONSE SUFFIX LENGTH IS 0
  281.     4   8,3,0,        !TURN-AROUND DELAY IS 0
  282.     5   8,4,1,3,0,        !PACKET ACCEPTED RESPONSE IS '0'
  283.     6   8,5,1,3,1,        !PACKET REJECTED RESPONSE IS '1'
  284.     7   8,6,1,RC1,RC2,    !RESPONSE REQUEST CHARACTER
  285.     9   4,1,        !SELECT PEN 1
  286.     1   9,1,        !SCALE FACTOR IS 1
  287.     2   11,0,6,-1/        !INDEX THE PLOTTER
  288.     DATA CMD_PEN_UP / 3,-1/    !PEN UP COMMAND
  289.     DATA CMD_INDEX_PLOTTER /
  290.     1   11,0,6,-1/        !INDEX THE PLOTTER
  291.     DATA CMD_PEN_DOWN /
  292.     1   2,-1/        !PEN UP COMANND
  293.     DATA CMD_SELECT_PEN /
  294.     1   4, 1,-1/        !SELECT PEN COMMAND
  295. C
  296.     LOGICAL LONG, LFRESH_PAGE
  297. C
  298. C    STANDARD DEVICE DRIVER STUFF
  299. C
  300.     DIMENSION DCHAR(8)
  301.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  302. C    Note: Table is set up for TALL mode.
  303.     DATA DCHAR /1012.0, 21.0, 27.3, 200.0, 200.0, 4.0, 24.0, 40.0/
  304. C
  305. C    DECLARE BUFFERING FUNCTION
  306. C
  307.     LOGICAL GH_TEST_FLUSH
  308. C
  309. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  310. C
  311.     LONG = .TRUE.
  312.     GO TO 10
  313.     ENTRY GD1012_TALL(IFXN,XA,YA)
  314.     LONG = .FALSE.
  315. 10    CONTINUE
  316. C
  317. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  318. C
  319.     IF (IFXN .LE. 0 .OR. IFXN .GT. 8) RETURN
  320.     GO TO (100,200,300,400,500,600,700,800) IFXN
  321. C
  322. C    *********************
  323. C    INITIALIZE THE DEVICE
  324. C    *********************
  325. C
  326. 100    CONTINUE
  327. C
  328. C    FIRST, INITIALIZE THE BUFFER SUBROUTINES
  329. C
  330.     CALL GH_INITIALIZE(IERR)
  331.     YA(1) = IERR
  332.     IF (IERR .NE. 0) RETURN
  333.     CALL GH_TIMED
  334.     CALL GH_IN_BIASED(CMD_INIT_PLOTTER)
  335.     CALL GH_EMPTY
  336.     CALL GH_NO_TIMED
  337.     GO TO 280
  338. C
  339. C    **************************
  340. C    GET FRESH PLOTTING SURFACE
  341. C    **************************
  342. C
  343. 200    CONTINUE
  344.     CALL GH_NEW_BUFFER
  345.     CMD_SELECT_PEN(IPEN_NUMBER_POSITION) = 1
  346.     CALL GH_IN_BIASED(CMD_SELECT_PEN)
  347.     IF (.NOT. LFRESH_PAGE) THEN
  348.         CALL GD1012_CONVERT(4200-IXPOSN,0-IYPOSN)
  349.     ENDIF
  350.     LFRESH_PAGE = .TRUE.
  351.     CALL GH_IN_BIASED(CMD_INDEX_PLOTTER)
  352. 280    CONTINUE
  353.     LFRESH_PAGE = .TRUE.
  354.     LPEN_DOWN = .FALSE.    !RAISED BY SELECT PEN
  355.     IXPOSN = 25
  356.     IYPOSN = -25
  357.     IPEN = 1
  358.     CALL GH_EMPTY
  359.     RETURN
  360. C
  361. C    ****
  362. C    MOVE
  363. C    ****
  364. C
  365. 300    CONTINUE
  366.     CALL GH_TEST_FLUSH(CMD_MAX_DELTA_SIZE+CMD_PEN_UP_SIZE)
  367.     IF (LPEN_DOWN) THEN
  368.         CALL GH_IN_BIASED(CMD_PEN_UP)
  369.         LPEN_DOWN = .FALSE.
  370.     ENDIF
  371.     GO TO 420
  372. C
  373. C    ****
  374. C    DRAW
  375. C    ****
  376. C
  377. 400    CONTINUE
  378.     CALL GH_TEST_FLUSH(CMD_MAX_DELTA_SIZE+CMD_PEN_DOWN_SIZE)
  379.     IF (.NOT. LPEN_DOWN) THEN
  380.         CALL GH_IN_BIASED(CMD_PEN_DOWN)
  381.         LPEN_DOWN = .TRUE.
  382.     ENDIF
  383.     LFRESH_PAGE = .FALSE.
  384. 420    CONTINUE
  385.     IX = XGUPCM*XA(1)+0.5
  386.     IY = YGUPCM*YA(1)+0.5
  387.     IF (LONG) THEN
  388.         ITEMP = IX
  389.         IX = IY
  390.         IY = 5462-ITEMP
  391.     ENDIF
  392.     CALL GD1012_CONVERT(IX-IXPOSN,IY-IYPOSN)
  393.     IXPOSN = IX
  394.     IYPOSN = IY
  395.     RETURN
  396. C
  397. C    *****************************
  398. C    FLUSH GRAPHICS COMMAND BUFFER
  399. C    *****************************
  400. C
  401. 500    CONTINUE
  402.     CALL GH_EMPTY
  403.     RETURN
  404. C
  405. C    ******************
  406. C    RELEASE THE DEVICE
  407. C    ******************
  408. C
  409. 600    CONTINUE
  410.     CMD_SELECT_PEN(IPEN_NUMBER_POSITION) = 1
  411.     CALL GH_IN_BIASED(CMD_SELECT_PEN)
  412.     CALL GD1012_CONVERT(4200-IXPOSN,0-IYPOSN)
  413.     CALL GH_IN_BIASED(CMD_INDEX_PLOTTER)
  414.     CALL GH_EMPTY
  415.     CALL GH_FINISH
  416.     RETURN
  417. C
  418. C    *****************************
  419. C    RETURN DEVICE CHARACTERISTICS
  420. C    *****************************
  421. C
  422. 700    CONTINUE
  423.     DO 720 I=1,8
  424.     XA(I) = DCHAR(I)
  425. 720    CONTINUE
  426.     IF (LONG) THEN
  427.         XA(2) = DCHAR(3)
  428.         XA(3) = DCHAR(2)
  429.         XA(1) = XA(1) + 0.5
  430.     ENDIF
  431.     RETURN
  432. C
  433. C    ****************************
  434. C    SELECT CURRENT DRAWING COLOR
  435. C    ****************************
  436. C
  437. 800    CONTINUE
  438.     CALL GH_TEST_FLUSH(CMD_SELECT_PEN_SIZE)
  439.     ICOLOR = XA(1)
  440.     IF (ICOLOR .LE. 0 .OR. ICOLOR .GT. 4) RETURN
  441.     IF (ICOLOR .NE. IPEN) THEN
  442.         CMD_SELECT_PEN(IPEN_NUMBER_POSITION) = ICOLOR
  443.         CALL GH_IN_BIASED(CMD_SELECT_PEN)
  444.         IPEN = ICOLOR
  445.     ENDIF
  446.     RETURN
  447.     END
  448.  
  449.     SUBROUTINE GD1012_CONVERT(IDX,IDY)
  450. C
  451. C    THIS SUBROUTINE CONVERTS AND INSERTS THE DELTA WITH THE
  452. C     PROPER DELTA CODE.
  453. C
  454.     PARAMETER (IRADIX = 64)
  455.     BYTE RBUFR(8), BDELTAS(7,7)
  456.     DATA RBUFR(8) /-1/
  457.     DATA BDELTAS / 19,43,47,31,46,42,18,
  458.     2   51,23,59,35,58,22,50,
  459.     3   55,63,27,39,26,62,54,
  460.     4   29,33,37,-1,38,34,30,
  461.     5   53,61,25,36,24,60,52,
  462.     6   49,21,57,32,56,20,48,
  463.     7   17,41,45,28,44,40,16/
  464. C
  465.     IF (IDX .EQ. 0 .AND. IDY .EQ. 0) RETURN
  466.     I = 7
  467.     ICOORD = IABS(IDY)
  468.     DO 200 J=1,2
  469.         ISTART = I
  470. 100            CONTINUE
  471.             IF (ICOORD .EQ. 0) GO TO 190
  472.             RBUFR(I) = ICOORD .AND. (IRADIX-1)
  473.             I = I-1
  474.             ICOORD = ICOORD/IRADIX
  475.             GO TO 100
  476. 190        CONTINUE
  477.         IF (J .EQ. 1) THEN
  478.             NY = 4 + ISIGN(1,IDY)*(ISTART-I)
  479.             ICOORD = IABS(IDX)
  480.         ENDIF
  481. 200        CONTINUE
  482.     RBUFR(I) = BDELTAS(4+ISIGN(1,IDX)*(ISTART-I),NY)
  483. D    type 9999, idx,idy, (rbufr(j), j=i,8)
  484. D9999    format(' The delta command for (',i5,',',i5,') is:'/2x,8i8)
  485. D    type 9998
  486. D9998    format(/)
  487.     CALL GH_IN_BIASED(RBUFR(I))
  488.     RETURN
  489.     END
  490.  
  491.  
  492.     SUBROUTINE GH_INITIALIZE(IERR)
  493. C
  494.     BYTE BIAS, STMSG, RESPONSE_CHARACTER, PACKET_ACCEPTED_CHAR
  495.     PARAMETER (BIAS    = 32)
  496.     PARAMETER (STMSG = 2)
  497.     PARAMETER (RESPONSE_CHARACTER = '&')
  498.     PARAMETER (PACKET_ACCEPTED_CHAR = '0')
  499. C
  500.     INCLUDE '($SSDEF)'
  501.     INCLUDE 'GD1012.CMN'
  502. C
  503.     CHARACTER*(*) DEVICE_NAME
  504.     PARAMETER (DEVICE_NAME='CALCOMP_TERM')
  505.     INTEGER*4 SYS$ASSIGN
  506. C
  507. C    ASSIGN A CHANNEL TO THE DEVICE OUTPUT DEVICE
  508. C
  509. 10    continue
  510.     ISTAT = SYS$ASSIGN(DEVICE_NAME,IOCHAN,,)
  511.     if (istat .eq. ss$_devalloc) then
  512.         type 11
  513. 11        format(' Waiting 10 seconds for plotter to become free.')
  514.         call lib$wait(10.0)
  515.         goto 10
  516.     endif
  517.     IF (.NOT. ISTAT) THEN
  518.         IERR = 1
  519.         RETURN
  520.         ELSE
  521.         IERR = 0
  522.     ENDIF
  523.     type 21
  524. 21    format(
  525.     1' Please make sure the CalComp is connected to the "BLACK BOX".'/
  526.     2'$Hit "Return" when the connection is made:')
  527.     accept 22, istat
  528. 22    format(a1)
  529. C
  530. C    PLACED FIXED START OF PACKET FOR PLOTTER
  531. C
  532.     BIASCHAR = BIAS
  533.     RESPCHAR = RESPONSE_CHARACTER
  534.     GOODCHAR = PACKET_ACCEPTED_CHAR
  535.     BUFFER(1) = STMSG
  536.     BUFFER(2) = BIASCHAR
  537.     CALL GH_NEW_BUFFER
  538.     RETURN
  539.     END
  540.  
  541.  
  542.  
  543.     SUBROUTINE GH_NEW_BUFFER
  544. C
  545. C    SUBROUTINE TO INITIALIZE THE GRAPHIC COMMAND BUFFER
  546. C
  547. C
  548.     INCLUDE 'GD1012.CMN'
  549. C
  550. C
  551.     IBUFPTR = 3
  552.     ICHECK_SUM = 0
  553.     RETURN
  554.     END
  555.  
  556.  
  557.  
  558.     FUNCTION GH_TEST_FLUSH(NUMCHR)
  559.     LOGICAL GH_TEST_FLUSH
  560. C
  561. C    THIS SUBROUTINE CHECKS TO MAKE SURE THERE IS ENOUGH ROOM IN
  562. C    THE BUFFER FOR "NUMCHR" MORE CHARACTERS, IF NOT, IF MAKES ROOM BY
  563. C    EMPTYING THE BUFFER.
  564. C
  565.     PARAMETER (IEND_LENGTH = 3)
  566. C
  567. C
  568.     INCLUDE 'GD1012.CMN'
  569. C
  570. C
  571.     IF (IBUFPTR+NUMCHR+IEND_LENGTH .GE. IBUFSIZ) THEN
  572.         CALL GH_EMPTY
  573.         GH_TEST_FLUSH = .TRUE.
  574.         ELSE
  575.         GH_TEST_FLUSH = .FALSE.
  576.         ENDIF
  577.     RETURN
  578.     END
  579.  
  580.  
  581.  
  582.     SUBROUTINE GH_EMPTY
  583. C
  584. C    THIS SUBROUTINE EMPTYS THE BUFFER IF IT HAS ANYTHING
  585. C
  586.     BYTE EOMSG, CR
  587.     PARAMETER (EOMSG = 3)
  588.     PARAMETER (CR = 13)
  589. C
  590. C
  591.     INCLUDE 'GD1012.CMN'
  592. C
  593. C
  594.     IF (IBUFPTR .LE. 3) GO TO 900
  595.     CALL GH_INSERT(96-(ICHECK_SUM .AND. 31))
  596.     CALL GH_INSERT(EOMSG)
  597.     CALL GH_INSERT(CR)
  598.     IF (IBUFPTR .GT. IBUFSIZ+1) STOP 'BUFFERING ERROR - BUFFER OVERFLOWED'
  599. C
  600. C    SEND TO PLOTTER
  601. C
  602.     CALL GH_SEND
  603. 900    CALL GH_NEW_BUFFER
  604.     RETURN
  605.     END
  606.  
  607.  
  608.  
  609.     SUBROUTINE GH_SEND
  610. C
  611. C    *** VMS SPECIFIC ***
  612. C
  613.     INCLUDE '($IODEF)'
  614.     INCLUDE '($SSDEF)'
  615. C
  616.     INCLUDE 'GD1012.CMN'
  617. C
  618.     INTEGER*4 CR_CONTROL
  619.     PARAMETER (CR_CONTROL = 0)
  620. C
  621.     INTEGER*4 SYS$QIOW
  622.     INTEGER*2 IOSB(4)
  623.     BYTE INBUF
  624. C
  625. C    DO THE QIOW TO THE OUTPUT DEVICE
  626. C
  627. 10    CONTINUE
  628.     ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN),
  629.     1   %VAL(IO$_WRITEVBLK+IO$M_NOFORMAT),IOSB, , ,
  630.     2   BUFFER,%VAL(IBUFPTR-1),5,%VAL(CR_CONTROL), , )
  631.     IF (.NOT. ISTAT) then
  632.         type 999, istat
  633. 999        format(' Write QIOW to CalComp failed, status was ',i9)
  634.         stop
  635.     ENDIF
  636.     IFXN = IO$_READPROMPT+IO$M_NOECHO+IO$M_PURGE
  637.     IF (LTIMED) IFXN = IFXN + IO$M_TIMED
  638.     ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN),
  639.     1   %VAL(IFXN),IOSB, , ,
  640.     2   INBUF,%VAL(1),%VAL(2), ,RESPCHAR,%VAL(1))
  641.     IF (ISTAT .EQ. SS$_TIMEOUT) THEN
  642.         TYPE 901
  643. 901        FORMAT(/'$Please make the CalComp ready, then hit RETURN')
  644.         ACCEPT 902, I
  645. 902        FORMAT(A1)
  646.         GO TO 10
  647.     ENDIF
  648.     IF (.NOT. ISTAT) then
  649.         type 998, istat
  650. 998        format(' ReadPrompt QIOW to CalComp failed, status was ',i9)
  651.         call lib$stop(%val(istat))
  652.     ENDIF
  653.     IF (INBUF .NE. GOODCHAR) THEN
  654.         type 997
  655. 997        format(' DIGLIB - informative: CalComp transmission error')
  656. D        type 9999, INBUF
  657. D9999        format(' The bad character is decimal ',I4/
  658. D    1    '$Hit return to try again')
  659. D        ACCEPT 9998, INBUF
  660. D9998        FORMAT(A1)
  661.         GO TO 10
  662.     ENDIF
  663.     RETURN
  664.     END
  665.  
  666.  
  667.     SUBROUTINE GH_TIMED
  668. C
  669.     INCLUDE 'GD1012.CMN'
  670. C
  671.     LTIMED = .TRUE.
  672.     RETURN
  673.     END
  674.  
  675.  
  676.     SUBROUTINE GH_NO_TIMED
  677. C
  678.     INCLUDE 'GD1012.CMN'
  679. C
  680.     LTIMED = .FALSE.
  681.     RETURN
  682.     END
  683.  
  684.  
  685.     SUBROUTINE GH_INSERT(BCHAR)
  686.     BYTE BCHAR
  687. C
  688. C    THIS SUBROUTINE INSERTS A CHARACTER INTO THE BUFFER
  689. C
  690. C
  691.     INCLUDE 'GD1012.CMN'
  692. C
  693. C
  694.     BUFFER(IBUFPTR) = BCHAR
  695.     ICHECK_SUM = ICHECK_SUM + BCHAR
  696.     IBUFPTR = IBUFPTR + 1
  697.     RETURN
  698.     END
  699.  
  700.  
  701.     SUBROUTINE GH_IN_BIASED(STRING)
  702.     BYTE STRING(2)
  703. C
  704. C    THIS SUBROUTINE INSERTS THE STRING INTO THE GRAPHICS BUFFER
  705. C
  706. C
  707.     INCLUDE 'GD1012.CMN'
  708. C
  709.     I = 1
  710. 100        CONTINUE
  711.         IF (STRING(I) .EQ. -1) RETURN
  712.         CALL GH_INSERT(STRING(I)+BIASCHAR)
  713.         I = I + 1
  714.         GO TO 100
  715.     END
  716.  
  717.  
  718.     SUBROUTINE GH_FINISH()
  719. C
  720. C    *** VMS SPECIFIC ***
  721. C
  722. C    THIS SUBROUTINE RELEASES THE I/O CHANNAL TO THE PLOTTER
  723. C
  724. C
  725.     INCLUDE 'GD1012.CMN'
  726. C
  727. C
  728.     INTEGER*4 SYS$DASSGN
  729. C
  730.     ISTAT = SYS$DASSGN(%VAL(IOCHAN))
  731.     RETURN
  732.     END
  733.     SUBROUTINE GD2623(IFXN,XA,YA)
  734.     DIMENSION XA(8), YA(3)
  735. C
  736. C    HP 2623 DRIVER FOR DIGLIB/VAX
  737. C
  738. C-----------------------------------------------------------------------
  739. C
  740.     BYTE ESC, DC1, BPENUP
  741.     PARAMETER (ESC=27)
  742.     PARAMETER (DC1=17)
  743.     PARAMETER (BPENUP = 97)
  744.  
  745.     CHARACTER*(*) TERMINAL
  746.     PARAMETER (TERMINAL='TT')
  747. C
  748. C    DEVICE CONTROL DEFINITIONS
  749. C
  750.     BYTE CHAR_TERM, STR_END(2), STR_BEGIN_PLOT(24)
  751.     BYTE STR_END_PLOT(6), STR_COLOR_SET(6)
  752.     BYTE STR_START_VEC(6), STR_RLS_DEV(6)
  753.     BYTE BDUMMY, BINTERLOCK(2)
  754.     DATA BINTERLOCK /5,0/        !ENQUIRE FOR 2648 HANDSHAKE
  755.     DATA CHAR_TERM /'Z'/
  756.     DATA STR_END /13,0/
  757.     DATA STR_BEGIN_PLOT /
  758.     1   ESC,'H',            !HOME ALPHA CURSOR
  759.     2   ESC,'J',            !ERASE TO END OF ALPHA MEMORY
  760.     3   ESC,'*','d','A',        !CLEAR GRAPHICS MEMORY
  761.     4   ESC,'*','d','C',        !GRAPHICS DISPLAY ON
  762.     5   ESC,'*','m','2','A',    !SET FOREGROUND TO DOTS ON
  763.     6   ESC,'*','m','1','B',2*0/    !SET SOLID LINES
  764.     DATA STR_END_PLOT /
  765.     1   ESC,'H',            !HOME ALPHA CURSOR
  766.     2   ESC,'J',2*0/        !ERASE TO END OF ALPHA MEMORY
  767.     DATA STR_COLOR_SET /
  768.     1   ESC,'*','m','1','A',0/    !1 ==> DOTS ON, 2 ==> DOTS OFF
  769.     DATA STR_START_VEC /
  770.     1   ESC,'*','p','i',2*0/    !START VECTOR
  771.     DATA STR_RLS_DEV /
  772.     1   ESC,'*','d','D',2*0/    !TURN GRAPHICS OFF
  773. C
  774. C    GIN DEFINITIONS
  775. C
  776.     BYTE GINBUFR(28), PROMPT(8), PLUS_SIGN
  777.     DATA PROMPT /ESC,'*','s','4','^',DC1,2*0/
  778.     DATA PLUS_SIGN /'+'/
  779. C
  780. C    DECLARE BUFFERING FUNCTION TO BE LOGICAL
  781. C
  782.     LOGICAL GB_TEST_FLUSH
  783.  
  784. C
  785. C    DELCARE VARS NEEDED FOR DRIVER OPERATION
  786. C
  787.     LOGICAL LVECTOR_GOING
  788. C
  789.     DIMENSION DCHAR(8)
  790. C
  791. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  792. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  793. C
  794.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  795.     DATA DCHAR /2623.0, 21.689, 16.511, 23.56, 23.56, 1.0, 133.0, 1.0/
  796. C
  797. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  798. C
  799.     IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN
  800. C
  801. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  802. C
  803.     GO TO (100,200,300,400,500,600,700,800,900) IFXN
  804. C
  805. C    *********************
  806. C    INITIALIZE THE DEVICE
  807. C    *********************
  808. C
  809. 100    CONTINUE
  810.     CALL GB_INITIALIZE(CHAR_TERM,STR_END,TERMINAL,IERR)
  811.     YA(1) =IERR
  812.     GO TO 290
  813. C
  814. C    **************************
  815. C    GET FRESH PLOTTING SURFACE
  816. C    **************************
  817. C
  818. 200    CONTINUE
  819.     CALL GB_NEW_BUFFER
  820.     CALL GB_IN_STRING(STR_BEGIN_PLOT)
  821.     CALL GB_EMPTY
  822. 290    LVECTOR_GOING = .FALSE.
  823.     RETURN
  824. C
  825. C    ****
  826. C    MOVE
  827. C    ****
  828. C
  829. 300    CONTINUE
  830. C    MAKE DECISION ON MOVE/DRAW LATER
  831. C
  832. C    ****
  833. C    DRAW
  834. C    ****
  835. C
  836. 400    CONTINUE
  837.     IXPOSN = XGUPCM*XA(1)+0.5
  838.     IYPOSN = YGUPCM*YA(1)+0.5
  839.     IF (.NOT. LVECTOR_GOING) THEN
  840.         CALL GB_INTERLOCK(BINTERLOCK,BDUMMY,1)
  841.         LDUMMY = GB_TEST_FLUSH(18)
  842.         CALL GB_IN_STRING(STR_START_VEC)
  843.         CALL GB_USE_TERMINATOR
  844.         LVECTOR_GOING = .TRUE.
  845.       ENDIF
  846.     IF (IFXN .EQ. 3) CALL GB_INSERT(BPENUP)    !IF MOVE, DO PEN-UP FIRST
  847.     CALL GD26CONVERT(IXPOSN,IYPOSN)
  848.     LVECTOR_GOING = .NOT. GB_TEST_FLUSH(6)
  849.     RETURN
  850. C
  851. C    *****************************
  852. C    FLUSH GRAPHICS COMMAND BUFFER
  853. C    *****************************
  854. C
  855. 500    CONTINUE
  856.     CALL GB_EMPTY
  857.     CALL GB_IN_STRING(STR_END_PLOT)
  858.     CALL GB_EMPTY
  859.     GO TO 290
  860. C
  861. C    ******************
  862. C    RELEASE THE DEVICE
  863. C    ******************
  864. C
  865. 600    CONTINUE
  866.     CALL GB_FINISH(STR_RLS_DEV)
  867.     RETURN
  868. C
  869. C    *****************************
  870. C    RETURN DEVICE CHARACTERISTICS
  871. C    *****************************
  872. C
  873. 700    CONTINUE
  874.     DO 720 I=1,8
  875.     XA(I) = DCHAR(I)
  876. 720    CONTINUE
  877.     RETURN
  878. C
  879. C    ****************************
  880. C    SELECT CURRENT DRAWING COLOR
  881. C    ****************************
  882. C
  883. 800    CONTINUE
  884.     CALL GB_EMPTY
  885.     ICOLOR = XA(1)
  886.     IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 1) RETURN
  887.     IF (ICOLOR .EQ. 0) THEN
  888.         STR_COLOR_SET(4) = '1'
  889.       ELSE
  890.         STR_COLOR_SET(4) = '2'
  891.       ENDIF
  892.     CALL GB_IN_STRING(STR_COLOR_SET)
  893.     GO TO 290
  894. C
  895. C    **********************
  896. C    PERFORM GRAPHICS INPUT
  897. C    **********************
  898. C
  899. 900    CONTINUE
  900.     CALL GB_EMPTY
  901. C
  902. C    ASK FOR 1 GIN INPUT
  903. C
  904. C
  905.     CALL GB_GIN(PROMPT,27,.FALSE.,GINBUFR)
  906. C
  907. C    GET THE KEY, X POSITION, AND Y POSITION
  908. C
  909. C
  910.     IPTR = 0
  911. 910    IPTR = IPTR + 1
  912.     IF (GINBUFR(IPTR) .NE. PLUS_SIGN) GO TO 910
  913.     DECODE (17,911,GINBUFR(IPTR)) IX, IY, ICHAR
  914. 911    FORMAT(I6,1X,I6,1X,I3)
  915.     XA(1) = ICHAR    !PICK CHARACTER
  916.     XA(2) = FLOAT(IX)/XGUPCM    !X IN CM.
  917.     XA(3) = FLOAT(IY)/YGUPCM    !Y IN CM.
  918.     GO TO 290
  919.     END
  920.     SUBROUTINE GD2648(IFXN,XA,YA)
  921.     DIMENSION XA(8), YA(3)
  922. C
  923. C    HP 2648 DRIVER FOR DIGLIB/VAX
  924. C
  925. C-----------------------------------------------------------------------
  926. C
  927.     BYTE ESC, DC1, BPENUP
  928.     PARAMETER (ESC=27)
  929.     PARAMETER (DC1=17)
  930.     PARAMETER (BPENUP = 97)
  931.  
  932.     CHARACTER*(*) TERMINAL
  933.     PARAMETER (TERMINAL='TT')
  934. C
  935. C    DEVICE CONTROL DEFINITIONS
  936. C
  937.     BYTE CHAR_TERM, STR_END(2), STR_BEGIN_PLOT(24)
  938.     BYTE STR_END_PLOT(6), STR_COLOR_SET(6)
  939.     BYTE STR_START_VEC(6), STR_RLS_DEV(6)
  940.     BYTE BDUMMY, BINTERLOCK(2)
  941.     DATA BINTERLOCK /5,0/        !ENQUIRE FOR 2648 HANDSHAKE
  942.     DATA CHAR_TERM /'Z'/
  943.     DATA STR_END /13,0/
  944.     DATA STR_BEGIN_PLOT /
  945.     1   ESC,'H',            !HOME ALPHA CURSOR
  946.     2   ESC,'J',            !ERASE TO END OF ALPHA MEMORY
  947.     3   ESC,'*','d','A',        !CLEAR GRAPHICS MEMORY
  948.     4   ESC,'*','d','C',        !GRAPHICS DISPLAY ON
  949.     5   ESC,'*','m','2','A',    !SET FOREGROUND TO DOTS ON
  950.     6   ESC,'*','m','1','B',2*0/    !SET SOLID LINES
  951.     DATA STR_END_PLOT /
  952.     1   ESC,'H',            !HOME ALPHA CURSOR
  953.     2   ESC,'J',2*0/        !ERASE TO END OF ALPHA MEMORY
  954.     DATA STR_COLOR_SET /
  955.     1   ESC,'*','m','1','A',0/    !1 ==> DOTS ON, 2 ==> DOTS OFF
  956.     DATA STR_START_VEC /
  957.     1   ESC,'*','p','i',2*0/    !START VECTOR
  958.     DATA STR_RLS_DEV /
  959.     1   ESC,'*','d','D',2*0/    !TURN GRAPHICS OFF
  960. C
  961. C    GIN DEFINITIONS
  962. C
  963.     BYTE GINBUFR(28), PROMPT(8), PLUS_SIGN
  964.     DATA PROMPT /ESC,'*','s','4','^',DC1,2*0/
  965.     DATA PLUS_SIGN /'+'/
  966. C
  967. C    DECLARE BUFFERING FUNCTION TO BE LOGICAL
  968. C
  969.     LOGICAL GB_TEST_FLUSH
  970.  
  971. C
  972. C    DELCARE VARS NEEDED FOR DRIVER OPERATION
  973. C
  974.     LOGICAL LVECTOR_GOING
  975. C
  976.     DIMENSION DCHAR(8)
  977. C
  978. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  979. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  980. C
  981.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  982.     DATA DCHAR /2648.0, 23.967, 11.967, 30.0, 30.0, 1.0, 133.0, 1.0/
  983. C
  984. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  985. C
  986.     IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN
  987. C
  988. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  989. C
  990.     GO TO (100,200,300,400,500,600,700,800,900) IFXN
  991. C
  992. C    *********************
  993. C    INITIALIZE THE DEVICE
  994. C    *********************
  995. C
  996. 100    CONTINUE
  997.     CALL GB_INITIALIZE(CHAR_TERM,STR_END,TERMINAL,IERR)
  998.     YA(1) = IERR
  999.     GO TO 290
  1000. C
  1001. C    **************************
  1002. C    GET FRESH PLOTTING SURFACE
  1003. C    **************************
  1004. C
  1005. 200    CONTINUE
  1006.     CALL GB_NEW_BUFFER
  1007.     CALL GB_IN_STRING(STR_BEGIN_PLOT)
  1008.     CALL GB_EMPTY
  1009. 290    LVECTOR_GOING = .FALSE.
  1010.     RETURN
  1011. C
  1012. C    ****
  1013. C    MOVE
  1014. C    ****
  1015. C
  1016. 300    CONTINUE
  1017. C    MAKE DECISION ON MOVE/DRAW LATER
  1018. C
  1019. C    ****
  1020. C    DRAW
  1021. C    ****
  1022. C
  1023. 400    CONTINUE
  1024.     IXPOSN = XGUPCM*XA(1)+0.5
  1025.     IYPOSN = YGUPCM*YA(1)+0.5
  1026.     IF (.NOT. LVECTOR_GOING) THEN
  1027.         CALL GB_INTERLOCK(BINTERLOCK,BDUMMY,1)
  1028.         LDUMMY = GB_TEST_FLUSH(18)
  1029.         CALL GB_IN_STRING(STR_START_VEC)
  1030.         CALL GB_USE_TERMINATOR
  1031.         LVECTOR_GOING = .TRUE.
  1032.       ENDIF
  1033.     IF (IFXN .EQ. 3) CALL GB_INSERT(BPENUP)    !IF MOVE, DO PEN-UP FIRST
  1034.     CALL GD26CONVERT(IXPOSN,IYPOSN)
  1035.     LVECTOR_GOING = .NOT. GB_TEST_FLUSH(6)
  1036.     RETURN
  1037. C
  1038. C    *****************************
  1039. C    FLUSH GRAPHICS COMMAND BUFFER
  1040. C    *****************************
  1041. C
  1042. 500    CONTINUE
  1043.     CALL GB_EMPTY
  1044.     CALL GB_IN_STRING(STR_END_PLOT)
  1045.     CALL GB_EMPTY
  1046.     GO TO 290
  1047. C
  1048. C    ******************
  1049. C    RELEASE THE DEVICE
  1050. C    ******************
  1051. C
  1052. 600    CONTINUE
  1053.     CALL GB_FINISH(STR_RLS_DEV)
  1054.     RETURN
  1055. C
  1056. C    *****************************
  1057. C    RETURN DEVICE CHARACTERISTICS
  1058. C    *****************************
  1059. C
  1060. 700    CONTINUE
  1061.     DO 720 I=1,8
  1062.     XA(I) = DCHAR(I)
  1063. 720    CONTINUE
  1064.     RETURN
  1065. C
  1066. C    ****************************
  1067. C    SELECT CURRENT DRAWING COLOR
  1068. C    ****************************
  1069. C
  1070. 800    CONTINUE
  1071.     CALL GB_EMPTY
  1072.     ICOLOR = XA(1)
  1073.     IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 1) RETURN
  1074.     IF (ICOLOR .EQ. 0) THEN
  1075.         STR_COLOR_SET(4) = '1'
  1076.       ELSE
  1077.         STR_COLOR_SET(4) = '2'
  1078.       ENDIF
  1079.     CALL GB_IN_STRING(STR_COLOR_SET)
  1080.     GO TO 290
  1081. C
  1082. C    **********************
  1083. C    PERFORM GRAPHICS INPUT
  1084. C    **********************
  1085. C
  1086. 900    CONTINUE
  1087.     CALL GB_EMPTY
  1088. C
  1089. C    ASK FOR 1 GIN INPUT
  1090. C
  1091. C
  1092.     CALL GB_GIN(PROMPT,27,.FALSE.,GINBUFR)
  1093. C
  1094. C    GET THE KEY, X POSITION, AND Y POSITION
  1095. C
  1096. C
  1097.     IPTR = 0
  1098. 910    IPTR = IPTR + 1
  1099.     IF (GINBUFR(IPTR) .NE. PLUS_SIGN) GO TO 910
  1100.     DECODE (17,911,GINBUFR(IPTR)) IX, IY, ICHAR
  1101. 911    FORMAT(I6,1X,I6,1X,I3)
  1102.     XA(1) = ICHAR    !PICK CHARACTER
  1103.     XA(2) = FLOAT(IX)/XGUPCM    !X IN CM.
  1104.     XA(3) = FLOAT(IY)/YGUPCM    !Y IN CM.
  1105.     GO TO 290
  1106.     END
  1107.     SUBROUTINE GD26CONVERT(IX,IY)
  1108. C
  1109. C    THIS SUBROUTINE CONVERTS THE POINT (IX,IY) INTO THE 4010 SCHEME
  1110. C    OF ENCODING COORDINATES
  1111. C
  1112.     CALL GB_INSERT(32+IX/32)
  1113.     CALL GB_INSERT(32+IAND(IX,31))
  1114.     CALL GB_INSERT(32+IY/32)
  1115.     CALL GB_INSERT(32+IAND(IY,31))
  1116.     RETURN
  1117.     END
  1118.     SUBROUTINE GD4010(IFXN,XA,YA)
  1119.     DIMENSION XA(8), YA(3)
  1120. C
  1121. C    TEK 4010 DRIVER FOR DIGLIB/VAX
  1122. C
  1123. C-----------------------------------------------------------------------
  1124. C
  1125.     BYTE ESC, CSUB, GS, US, CR, FF
  1126.     PARAMETER (ESC=27, CSUB=26, GS=29, US=31, CR=13, FF=12)
  1127.     CHARACTER*(*) TERMINAL
  1128.     PARAMETER (TERMINAL='TT')
  1129. C
  1130. C    DEFINITIONS FOR DEVICE CONTROL
  1131. C
  1132.     BYTE STR_END(2)
  1133.     BYTE STR_BEGIN_PLOT(4)
  1134.     DATA STR_END /US,0/
  1135.     DATA STR_BEGIN_PLOT /ESC,FF,2*0/
  1136.  
  1137. C    DEFINITIONS FOR GIN
  1138. C
  1139.     BYTE GINBUFR(8), PROMPT(4)
  1140.     DATA PROMPT /ESC, CSUB, 2*0/
  1141.     DATA IGIN_IN_CHARS /5/
  1142. C
  1143. C    DECLARE BUFFERING FUNCTION
  1144. C
  1145.     LOGICAL GB_TEST_FLUSH
  1146. C
  1147. C    DECLARE VARS NEED FOR DRIVER OPERATION
  1148. C
  1149.     LOGICAL LVECTOR_GOING, LDUMMY
  1150.     DIMENSION DCHAR(8)
  1151. C
  1152. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  1153. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  1154. C
  1155.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  1156.     DATA DCHAR /4010.0, 21.492, 16.114, 47.6, 47.6, 1.0, 130.0, 1.0/
  1157. C
  1158. C*****************
  1159. C
  1160. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  1161. C
  1162.     IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN
  1163. C
  1164. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  1165. C
  1166.     GO TO (100,200,300,400,500,600,700,800,900) IFXN
  1167. C
  1168. C    *********************
  1169. C    INITIALIZE THE DEVICE
  1170. C    *********************
  1171. C
  1172. 100    CONTINUE
  1173. C
  1174. C    FIRST, INITIALIZE THE BUFFER SUBROUTINES
  1175. C
  1176.     CALL GB_INITIALIZE(0,STR_END,TERMINAL,IERR)
  1177.     YA(1) = IERR
  1178.     LVECTOR_GOING = .FALSE.
  1179.     RETURN
  1180. C
  1181. C    **************************
  1182. C    GET FRESH PLOTTING SURFACE
  1183. C    **************************
  1184. C
  1185. 200    CONTINUE
  1186.     CALL GB_NEW_BUFFER
  1187.     CALL GB_IN_STRING(STR_BEGIN_PLOT)
  1188.     CALL GB_EMPTY
  1189.     CALL GDWAIT(2000)
  1190.     LVECTOR_GOING = .FALSE.
  1191.     RETURN
  1192. C
  1193. C    ****
  1194. C    MOVE
  1195. C    ****
  1196. C
  1197. 300    CONTINUE
  1198. C    CONVERT CM. TO GRAPHICS UNITS ROUNDED
  1199.     IXPOSN = XGUPCM*XA(1)+0.5
  1200.     IYPOSN = YGUPCM*YA(1)+0.5
  1201.     LVECTOR_GOING = .FALSE.
  1202.     RETURN
  1203. C
  1204. C    ****
  1205. C    DRAW
  1206. C    ****
  1207. C
  1208. 400    CONTINUE
  1209.     IX = XGUPCM*XA(1)+0.5
  1210.     IY = YGUPCM*YA(1)+0.5
  1211.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4))
  1212.     IF (LVECTOR_GOING) GO TO 410
  1213.     LDUMMY = GB_TEST_FLUSH(9)
  1214.     LVECTOR_GOING = .TRUE.
  1215.     CALL GB_INSERT(GS)
  1216.     CALL GD_4010_CONVERT(IXPOSN,IYPOSN)
  1217. 410    CALL GD_4010_CONVERT(IX,IY)
  1218.     IXPOSN = IX
  1219.     IYPOSN = IY
  1220.     RETURN
  1221. C
  1222. C    *****************************
  1223. C    FLUSH GRAPHICS COMMAND BUFFER
  1224. C    *****************************
  1225. C
  1226. 500    CONTINUE
  1227.     CALL GB_EMPTY
  1228.     CALL GB_INSERT(GS)
  1229.     CALL GD_4010_CONVERT(0,1020)
  1230.     CALL GB_EMPTY
  1231.     LVECTOR_GOING = .FALSE.
  1232.     RETURN
  1233. C
  1234. C    ******************
  1235. C    RELEASE THE DEVICE
  1236. C    ******************
  1237. C
  1238. 600    CONTINUE
  1239. C
  1240. C    DE-ASSIGN THE CHANNAL
  1241. C
  1242.     CALL GB_FINISH(0)
  1243.     RETURN
  1244. C
  1245. C    *****************************
  1246. C    RETURN DEVICE CHARACTERISTICS
  1247. C    *****************************
  1248. C
  1249. 700    CONTINUE
  1250.     DO 720 I=1,8
  1251.     XA(I) = DCHAR(I)
  1252. 720    CONTINUE
  1253.     RETURN
  1254. C
  1255. C    ****************************
  1256. C    SELECT CURRENT DRAWING COLOR
  1257. C    ****************************
  1258. C
  1259. 800    CONTINUE
  1260.     RETURN
  1261. C
  1262. C    **********************
  1263. C    PERFORM GRAPHICS INPUT
  1264. C    **********************
  1265. C
  1266. 900    CONTINUE
  1267.     CALL GB_EMPTY
  1268.     LVECTOR_GOING = .FALSE.
  1269. C
  1270. C    ASK FOR 1 GIN INPUT
  1271. C
  1272. C
  1273.     CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR)
  1274. C
  1275.     ICHAR = GINBUFR(1)
  1276.     IX1 = GINBUFR(2)
  1277.     IX2 = GINBUFR(3)
  1278.     IY1 = GINBUFR(4)
  1279.     IY2 = GINBUFR(5)
  1280. C
  1281.     XA(1) = IAND(ICHAR,127)        !PICK CHARACTER
  1282.     XA(2) = (32*IAND(IX1,31)+IAND(IX2,31))/XGUPCM
  1283.     XA(3) = (32*IAND(IY1,31)+IAND(IY2,31))/YGUPCM
  1284. C
  1285.     RETURN
  1286.     END
  1287.     SUBROUTINE GD_4010_CONVERT(IX,IY)
  1288. C
  1289. C    THIS SUBROUTINE CONVERTS THE POINT (IX,IY) INTO THE 4010 SCHEME
  1290. C    OF ENCODING COORDINATES
  1291. C
  1292.     CALL GB_INSERT(32+IY/32)
  1293.     CALL GB_INSERT(96+IAND(IY,31))
  1294.     CALL GB_INSERT(32+IX/32)
  1295.     CALL GB_INSERT(64+IAND(IX,31))
  1296.     RETURN
  1297.     END
  1298.     SUBROUTINE GD_4010_CONVERT(IX,IY)
  1299. C
  1300. C    THIS SUBROUTINE CONVERTS THE POINT (IX,IY) INTO THE 4010 SCHEME
  1301. C    OF ENCODING COORDINATES
  1302. C
  1303.     CALL GB_INSERT(32+IY/32)
  1304.     CALL GB_INSERT(96+IAND(IY,31))
  1305.     CALL GB_INSERT(32+IX/32)
  1306.     CALL GB_INSERT(64+IAND(IX,31))
  1307.     RETURN
  1308.     END
  1309.     SUBROUTINE GD4012(IFXN,XA,YA)
  1310.     DIMENSION XA(8), YA(3)
  1311. C
  1312. C    TEK 4012 DRIVER FOR DIGLIB/VAX
  1313. C
  1314. C-----------------------------------------------------------------------
  1315. C
  1316.     BYTE ESC, CSUB, GS, US, CR, FF
  1317.     PARAMETER (ESC=27, CSUB=26, GS=29, US=31, CR=13, FF=12)
  1318.     CHARACTER*(*) TERMINAL
  1319.     PARAMETER (TERMINAL='TT')
  1320. C
  1321. C    DEFINITIONS FOR DEVICE CONTROL
  1322. C
  1323.     BYTE STR_END(2)
  1324.     BYTE STR_BEGIN_PLOT(4)
  1325.     DATA STR_END /US,0/
  1326.     DATA STR_BEGIN_PLOT /ESC,FF,2*0/
  1327.  
  1328. C    DEFINITIONS FOR GIN
  1329. C
  1330.     BYTE GINBUFR(8), PROMPT(4)
  1331.     DATA PROMPT /ESC, CSUB, 2*0/
  1332.     DATA IGIN_IN_CHARS /5/
  1333. C
  1334. C    DECLARE BUFFERING FUNCTION
  1335. C
  1336.     LOGICAL GB_TEST_FLUSH
  1337. C
  1338. C    DECLARE VARS NEED FOR DRIVER OPERATION
  1339. C
  1340.     LOGICAL LVECTOR_GOING, LDUMMY
  1341.     DIMENSION DCHAR(8)
  1342. C
  1343. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  1344. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  1345. C
  1346.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  1347.     DATA DCHAR /4012.0, 20.02, 15.01, 51.1, 51.1, 1.0, 130.0, 1.0/
  1348. C
  1349. C*****************
  1350. C
  1351. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  1352. C
  1353.     IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN
  1354. C
  1355. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  1356. C
  1357.     GO TO (100,200,300,400,500,600,700,800,900) IFXN
  1358. C
  1359. C    *********************
  1360. C    INITIALIZE THE DEVICE
  1361. C    *********************
  1362. C
  1363. 100    CONTINUE
  1364. C
  1365. C    FIRST, INITIALIZE THE BUFFER SUBROUTINES
  1366. C
  1367.     CALL GB_INITIALIZE(0,STR_END,TERMINAL,IERR)
  1368.     YA(1) = IERR
  1369.     LVECTOR_GOING = .FALSE.
  1370.     RETURN
  1371. C
  1372. C    **************************
  1373. C    GET FRESH PLOTTING SURFACE
  1374. C    **************************
  1375. C
  1376. 200    CONTINUE
  1377.     CALL GB_NEW_BUFFER
  1378.     CALL GB_IN_STRING(STR_BEGIN_PLOT)
  1379.     CALL GB_EMPTY
  1380.     CALL GDWAIT(2000)
  1381.     LVECTOR_GOING = .FALSE.
  1382.     RETURN
  1383. C
  1384. C    ****
  1385. C    MOVE
  1386. C    ****
  1387. C
  1388. 300    CONTINUE
  1389. C    CONVERT CM. TO GRAPHICS UNITS ROUNDED
  1390.     IXPOSN = XGUPCM*XA(1)+0.5
  1391.     IYPOSN = YGUPCM*YA(1)+0.5
  1392.     LVECTOR_GOING = .FALSE.
  1393.     RETURN
  1394. C
  1395. C    ****
  1396. C    DRAW
  1397. C    ****
  1398. C
  1399. 400    CONTINUE
  1400.     IX = XGUPCM*XA(1)+0.5
  1401.     IY = YGUPCM*YA(1)+0.5
  1402.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4))
  1403.     IF (LVECTOR_GOING) GO TO 410
  1404.     LDUMMY = GB_TEST_FLUSH(9)
  1405.     LVECTOR_GOING = .TRUE.
  1406.     CALL GB_INSERT(GS)
  1407.     CALL GD_4010_CONVERT(IXPOSN,IYPOSN)
  1408. 410    CALL GD_4010_CONVERT(IX,IY)
  1409.     IXPOSN = IX
  1410.     IYPOSN = IY
  1411.     RETURN
  1412. C
  1413. C    *****************************
  1414. C    FLUSH GRAPHICS COMMAND BUFFER
  1415. C    *****************************
  1416. C
  1417. 500    CONTINUE
  1418.     CALL GB_EMPTY
  1419.     CALL GB_INSERT(GS)
  1420.     CALL GD_4010_CONVERT(0,1020)
  1421.     CALL GB_EMPTY
  1422.     LVECTOR_GOING = .FALSE.
  1423.     RETURN
  1424. C
  1425. C    ******************
  1426. C    RELEASE THE DEVICE
  1427. C    ******************
  1428. C
  1429. 600    CONTINUE
  1430. C
  1431. C    DE-ASSIGN THE CHANNAL
  1432. C
  1433.     CALL GB_FINISH(0)
  1434.     RETURN
  1435. C
  1436. C    *****************************
  1437. C    RETURN DEVICE CHARACTERISTICS
  1438. C    *****************************
  1439. C
  1440. 700    CONTINUE
  1441.     DO 720 I=1,8
  1442.     XA(I) = DCHAR(I)
  1443. 720    CONTINUE
  1444.     RETURN
  1445. C
  1446. C    ****************************
  1447. C    SELECT CURRENT DRAWING COLOR
  1448. C    ****************************
  1449. C
  1450. 800    CONTINUE
  1451.     RETURN
  1452. C
  1453. C    **********************
  1454. C    PERFORM GRAPHICS INPUT
  1455. C    **********************
  1456. C
  1457. 900    CONTINUE
  1458.     CALL GB_EMPTY
  1459.     LVECTOR_GOING = .FALSE.
  1460. C
  1461. C    ASK FOR 1 GIN INPUT
  1462. C
  1463. C
  1464.     CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR)
  1465. C
  1466.     ICHAR = GINBUFR(1)
  1467.     IX1 = GINBUFR(2)
  1468.     IX2 = GINBUFR(3)
  1469.     IY1 = GINBUFR(4)
  1470.     IY2 = GINBUFR(5)
  1471. C
  1472.     XA(1) = IAND(ICHAR,127)        !PICK CHARACTER
  1473.     XA(2) = (32*IAND(IX1,31)+IAND(IX2,31))/XGUPCM
  1474.     XA(3) = (32*IAND(IY1,31)+IAND(IY2,31))/YGUPCM
  1475. C
  1476.     RETURN
  1477.     END
  1478.     SUBROUTINE GD4014(IFXN,XA,YA)
  1479.     DIMENSION XA(8), YA(3)
  1480. C
  1481. C    TEK 4014 DRIVER FOR DIGLIB/VAX
  1482. C
  1483. C-----------------------------------------------------------------------
  1484. C
  1485.     BYTE ESC, CSUB, GS, US, CR, FF
  1486.     PARAMETER (ESC=27, CSUB=26, GS=29, US=31, CR=13, FF=12)
  1487.     CHARACTER*(*) TERMINAL
  1488.     PARAMETER (TERMINAL='TT')
  1489. C
  1490. C    DEFINITIONS FOR DEVICE CONTROL
  1491. C
  1492.     BYTE STR_END(2)
  1493.     BYTE STR_BEGIN_PLOT(4)
  1494.     DATA STR_END /US,0/
  1495.     DATA STR_BEGIN_PLOT /ESC,FF,2*0/
  1496.  
  1497. C    DEFINITIONS FOR GIN
  1498. C
  1499.     BYTE GINBUFR(8), PROMPT(4)
  1500.     DATA PROMPT /ESC, CSUB, 2*0/
  1501.     DATA IGIN_IN_CHARS /5/
  1502. C
  1503. C    DECLARE BUFFERING FUNCTION
  1504. C
  1505.     LOGICAL GB_TEST_FLUSH
  1506. C
  1507. C    DECLARE VARS NEED FOR DRIVER OPERATION
  1508. C
  1509.     LOGICAL LVECTOR_GOING, LDUMMY
  1510.     DIMENSION DCHAR(8)
  1511. C
  1512. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  1513. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  1514. C
  1515.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  1516.     DATA DCHAR /4014.0, 36.212, 27.15, 28.25, 28.25, 1.0, 130.0, 1.0/
  1517. C
  1518. C*****************
  1519. C
  1520. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  1521. C
  1522.     IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN
  1523. C
  1524. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  1525. C
  1526.     GO TO (100,200,300,400,500,600,700,800,900) IFXN
  1527. C
  1528. C    *********************
  1529. C    INITIALIZE THE DEVICE
  1530. C    *********************
  1531. C
  1532. 100    CONTINUE
  1533. C
  1534. C    FIRST, INITIALIZE THE BUFFER SUBROUTINES
  1535. C
  1536.     CALL GB_INITIALIZE(0,STR_END,TERMINAL,IERR)
  1537.     LVECTOR_GOING = .FALSE.
  1538.     YA(1) = IERR
  1539.     RETURN
  1540. C
  1541. C    **************************
  1542. C    GET FRESH PLOTTING SURFACE
  1543. C    **************************
  1544. C
  1545. 200    CONTINUE
  1546.     CALL GB_NEW_BUFFER
  1547.     CALL GB_IN_STRING(STR_BEGIN_PLOT)
  1548.     CALL GB_EMPTY
  1549.     CALL GDWAIT(2000)
  1550.     LVECTOR_GOING = .FALSE.
  1551.     RETURN
  1552. C
  1553. C    ****
  1554. C    MOVE
  1555. C    ****
  1556. C
  1557. 300    CONTINUE
  1558. C    CONVERT CM. TO GRAPHICS UNITS ROUNDED
  1559.     IXPOSN = XGUPCM*XA(1)+0.5
  1560.     IYPOSN = YGUPCM*YA(1)+0.5
  1561.     LVECTOR_GOING = .FALSE.
  1562.     RETURN
  1563. C
  1564. C    ****
  1565. C    DRAW
  1566. C    ****
  1567. C
  1568. 400    CONTINUE
  1569.     IX = XGUPCM*XA(1)+0.5
  1570.     IY = YGUPCM*YA(1)+0.5
  1571.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4))
  1572.     IF (LVECTOR_GOING) GO TO 410
  1573.     LDUMMY = GB_TEST_FLUSH(9)
  1574.     LVECTOR_GOING = .TRUE.
  1575.     CALL GB_INSERT(GS)
  1576.     CALL GD_4010_CONVERT(IXPOSN,IYPOSN)
  1577. 410    CALL GD_4010_CONVERT(IX,IY)
  1578.     IXPOSN = IX
  1579.     IYPOSN = IY
  1580.     RETURN
  1581. C
  1582. C    *****************************
  1583. C    FLUSH GRAPHICS COMMAND BUFFER
  1584. C    *****************************
  1585. C
  1586. 500    CONTINUE
  1587.     CALL GB_EMPTY
  1588.     CALL GB_INSERT(GS)
  1589.     CALL GD_4010_CONVERT(0,1020)
  1590.     CALL GB_EMPTY
  1591.     LVECTOR_GOING = .FALSE.
  1592.     RETURN
  1593. C
  1594. C    ******************
  1595. C    RELEASE THE DEVICE
  1596. C    ******************
  1597. C
  1598. 600    CONTINUE
  1599. C
  1600. C    DE-ASSIGN THE CHANNAL
  1601. C
  1602.     CALL GB_FINISH(0)
  1603.     RETURN
  1604. C
  1605. C    *****************************
  1606. C    RETURN DEVICE CHARACTERISTICS
  1607. C    *****************************
  1608. C
  1609. 700    CONTINUE
  1610.     DO 720 I=1,8
  1611.     XA(I) = DCHAR(I)
  1612. 720    CONTINUE
  1613.     RETURN
  1614. C
  1615. C    ****************************
  1616. C    SELECT CURRENT DRAWING COLOR
  1617. C    ****************************
  1618. C
  1619. 800    CONTINUE
  1620.     RETURN
  1621. C
  1622. C    **********************
  1623. C    PERFORM GRAPHICS INPUT
  1624. C    **********************
  1625. C
  1626. 900    CONTINUE
  1627.     CALL GB_EMPTY
  1628.     LVECTOR_GOING = .FALSE.
  1629. C
  1630. C    ASK FOR 1 GIN INPUT
  1631. C
  1632. C
  1633.     CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR)
  1634. C
  1635.     ICHAR = GINBUFR(1)
  1636.     IX1 = GINBUFR(2)
  1637.     IX2 = GINBUFR(3)
  1638.     IY1 = GINBUFR(4)
  1639.     IY2 = GINBUFR(5)
  1640. C
  1641.     XA(1) = IAND(ICHAR,127)        !PICK CHARACTER
  1642.     XA(2) = (32*IAND(IX1,31)+IAND(IX2,31))/XGUPCM
  1643.     XA(3) = (32*IAND(IY1,31)+IAND(IY2,31))/YGUPCM
  1644. C
  1645.     RETURN
  1646.     END
  1647.     SUBROUTINE GD_4014_CONVERT(IX,IY)
  1648. C
  1649. C    CONVERTS (IX,IY) TO THE 4014 12-BIT FORMAT AND PLACES THE
  1650. C    CHARACTERS INTO THE BUFFER.   OPTIMIZED FOR MINIMUM CHARS TO BE
  1651. C    TRANSMITTED.
  1652. C
  1653.     COMMON /GD_4014_STATE_MEM/ IOLD_HIY, IOLD_EX, IOLD_LOY, IOLD_HIX
  1654.     DATA IOLD_HIY, IOLD_EX, IOLD_LOY, IOLD_HIX /4*-1/
  1655.     IHIY = 32+IY/128
  1656.     IEX = 96+4*IAND(IY,3)+IAND(IX,3)
  1657.     ILOY = 96+IAND(IY/4,31)
  1658.     IHIX = 32+IX/128
  1659. C
  1660. C    HI-Y ONLY NEEDS BE SENT WHEN IT CHANGES
  1661. C
  1662.     IF (IHIY .NE. IOLD_HIY) THEN
  1663.         IOLD_HIY = IHIY
  1664.         CALL GB_INSERT(IHIY)
  1665.     ENDIF
  1666. C
  1667. C    EXTRA-BITS ONLY NEEDS BE SENT WHEN IT CHANGES, BUT IF SENT, THEN
  1668. C    LO-Y MUST BE SENT EVEN IF IT DIDN'T CHANGE.
  1669. C
  1670.     IF (IEX .NE. IOLD_EX) THEN
  1671.         IOLD_EX = IEX
  1672.         CALL GB_INSERT(IEX)
  1673.         CALL GB_INSERT(ILOY)
  1674.         IOLD_LOY = ILOY
  1675.         ELSE
  1676. C
  1677. C        SEND LO-Y IF IT CHANGED OR IF WE NEED TO SEND A HI-X
  1678. C
  1679.         IF (ILOY .NE. IOLD_LOY .OR.
  1680.     1       IHIX .NE. IOLD_HIX) THEN
  1681.             IOLD_LOY = ILOY
  1682.             CALL GB_INSERT(ILOY)
  1683.         ENDIF
  1684.     ENDIF
  1685. C
  1686. C    HI-X CAN ONLY BE SENT IF PRECEEDED BY LO-Y --> THIS IS HANDLED
  1687. C    PREVIOUSLY.
  1688. C
  1689.     IF (IHIX .NE. IOLD_HIX) THEN
  1690.         IOLD_HIX = IHIX
  1691.         CALL GB_INSERT(IHIX)
  1692.     ENDIF
  1693. C
  1694. C    LO-X MUST ALWAYS BE SENT
  1695. C
  1696.     CALL GB_INSERT(64+IAND(IX/4,31))
  1697.     RETURN
  1698.     END
  1699.  
  1700.     SUBROUTINE GD_4014_ZORCH
  1701.     COMMON /GD_4014_STATE_MEM/ IOLD_HIY, IOLD_EX, IOLD_LOY, IOLD_HIX
  1702.     IOLD_HIY = -1
  1703.     IOLD_EX = -1
  1704.     IOLD_LOY = -1
  1705.     IOLD_HIX = -1
  1706.     RETURN
  1707.     END
  1708.     SUBROUTINE GD4014REM(IFXN,XA,YA)
  1709.     DIMENSION XA(8), YA(3)
  1710. C
  1711. C    REMOTE (OTHER TT LINE) TEK 4014 DRIVER FOR DIGLIB/VAX
  1712. C
  1713. C-----------------------------------------------------------------------
  1714. C
  1715.     BYTE ESC, CSUB, GS, US, CR, FF
  1716.     PARAMETER (ESC=27, CSUB=26, GS=29, US=31, CR=13, FF=12)
  1717.     CHARACTER*(*) TERMINAL
  1718.     PARAMETER (TERMINAL='DIG_4014_TTY')
  1719. C
  1720. C    DEFINITIONS FOR DEVICE CONTROL
  1721. C
  1722.     BYTE STR_END(2)
  1723.     BYTE STR_BEGIN_PLOT(4)
  1724.     DATA STR_END /US,0/
  1725.     DATA STR_BEGIN_PLOT /ESC,FF,2*0/
  1726.  
  1727. C    DEFINITIONS FOR GIN
  1728. C
  1729.     BYTE GINBUFR(8), PROMPT(4)
  1730.     DATA PROMPT /ESC, CSUB, 2*0/
  1731.     DATA IGIN_IN_CHARS /5/
  1732. C
  1733. C    DECLARE BUFFERING FUNCTION
  1734. C
  1735.     LOGICAL GB_TEST_FLUSH
  1736. C
  1737. C    DECLARE VARS NEED FOR DRIVER OPERATION
  1738. C
  1739.     LOGICAL LVECTOR_GOING, LDUMMY
  1740.     DIMENSION DCHAR(8)
  1741. C
  1742. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  1743. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  1744. C
  1745.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  1746.     DATA DCHAR /4014.0, 36.212, 27.15, 28.25, 28.25, 1.0, 146.0, 1.0/
  1747. C
  1748. C*****************
  1749. C
  1750. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  1751. C
  1752.     IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN
  1753. C
  1754. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  1755. C
  1756.     GO TO (100,200,300,400,500,600,700,800,900) IFXN
  1757. C
  1758. C    *********************
  1759. C    INITIALIZE THE DEVICE
  1760. C    *********************
  1761. C
  1762. 100    CONTINUE
  1763. C
  1764. C    FIRST, INITIALIZE THE BUFFER SUBROUTINES
  1765. C
  1766.     CALL GB_INITIALIZE(0,STR_END,TERMINAL,IERR)
  1767.     YA(1) = IERR
  1768.     LVECTOR_GOING = .FALSE.
  1769.     RETURN
  1770. C
  1771. C    **************************
  1772. C    GET FRESH PLOTTING SURFACE
  1773. C    **************************
  1774. C
  1775. 200    CONTINUE
  1776.     CALL GB_NEW_BUFFER
  1777.     CALL GB_IN_STRING(STR_BEGIN_PLOT)
  1778.     CALL GB_EMPTY
  1779.     CALL GDWAIT(2000)
  1780.     LVECTOR_GOING = .FALSE.
  1781.     RETURN
  1782. C
  1783. C    ****
  1784. C    MOVE
  1785. C    ****
  1786. C
  1787. 300    CONTINUE
  1788. C    CONVERT CM. TO GRAPHICS UNITS ROUNDED
  1789.     IXPOSN = XGUPCM*XA(1)+0.5
  1790.     IYPOSN = YGUPCM*YA(1)+0.5
  1791.     LVECTOR_GOING = .FALSE.
  1792.     RETURN
  1793. C
  1794. C    ****
  1795. C    DRAW
  1796. C    ****
  1797. C
  1798. 400    CONTINUE
  1799.     IX = XGUPCM*XA(1)+0.5
  1800.     IY = YGUPCM*YA(1)+0.5
  1801.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4))
  1802.     IF (LVECTOR_GOING) GO TO 410
  1803.     LDUMMY = GB_TEST_FLUSH(9)
  1804.     LVECTOR_GOING = .TRUE.
  1805.     CALL GB_INSERT(GS)
  1806.     CALL GD_4010_CONVERT(IXPOSN,IYPOSN)
  1807. 410    CALL GD_4010_CONVERT(IX,IY)
  1808.     IXPOSN = IX
  1809.     IYPOSN = IY
  1810.     RETURN
  1811. C
  1812. C    *****************************
  1813. C    FLUSH GRAPHICS COMMAND BUFFER
  1814. C    *****************************
  1815. C
  1816. 500    CONTINUE
  1817.     CALL GB_EMPTY
  1818.     CALL GB_INSERT(GS)
  1819.     CALL GD_4010_CONVERT(0,50)
  1820.     CALL GB_EMPTY
  1821.     LVECTOR_GOING = .FALSE.
  1822.     RETURN
  1823. C
  1824. C    ******************
  1825. C    RELEASE THE DEVICE
  1826. C    ******************
  1827. C
  1828. 600    CONTINUE
  1829. C
  1830. C    DE-ASSIGN THE CHANNAL
  1831. C
  1832.     CALL GB_FINISH(0)
  1833.     RETURN
  1834. C
  1835. C    *****************************
  1836. C    RETURN DEVICE CHARACTERISTICS
  1837. C    *****************************
  1838. C
  1839. 700    CONTINUE
  1840.     DO 720 I=1,8
  1841.     XA(I) = DCHAR(I)
  1842. 720    CONTINUE
  1843.     RETURN
  1844. C
  1845. C    ****************************
  1846. C    SELECT CURRENT DRAWING COLOR
  1847. C    ****************************
  1848. C
  1849. 800    CONTINUE
  1850.     RETURN
  1851. C
  1852. C    **********************
  1853. C    PERFORM GRAPHICS INPUT
  1854. C    **********************
  1855. C
  1856. 900    CONTINUE
  1857.     CALL GB_EMPTY
  1858.     LVECTOR_GOING = .FALSE.
  1859. C
  1860. C    ASK FOR 1 GIN INPUT
  1861. C
  1862. C
  1863.     CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR)
  1864. C
  1865.     ICHAR = GINBUFR(1)
  1866.     IX1 = GINBUFR(2)
  1867.     IX2 = GINBUFR(3)
  1868.     IY1 = GINBUFR(4)
  1869.     IY2 = GINBUFR(5)
  1870. C
  1871.     XA(1) = IAND(ICHAR,127)        !PICK CHARACTER
  1872.     XA(2) = (32*IAND(IX1,31)+IAND(IX2,31))/XGUPCM
  1873.     XA(3) = (32*IAND(IY1,31)+IAND(IY2,31))/YGUPCM
  1874. C
  1875.     RETURN
  1876.     END
  1877.     SUBROUTINE GD4025(IFXN,XA,YA)
  1878.     DIMENSION XA(8), YA(3)
  1879. C
  1880. C    TEKTRONIX 4025 DRIVER FOR DIGLIB/VAX
  1881. C
  1882. C-----------------------------------------------------------------------
  1883. C
  1884.     BYTE CMD, CSUB, US, GS, CR, FF
  1885.     PARAMETER (CMD=33, CSUB=26, US=31, GS=29, CR=13, FF=12)
  1886.     CHARACTER*(*) TERMINAL
  1887.     PARAMETER (TERMINAL='TT')
  1888. C
  1889. C    DEFINITIONS FOR DEVICE CONTROL
  1890. C
  1891.     BYTE STR_END(2), STR_BEGIN_PLOT(14), STR_COLOR_SET(8)
  1892.     BYTE STR_INIT_4025(32)
  1893.     BYTE ASCIID, ASCIIA, ASCIIT
  1894. C
  1895.     DATA ASCIID, ASCIIA, ASCIIT /'D','A','T'/
  1896.     DATA STR_END /13,0/
  1897.     DATA STR_INIT_4025 /
  1898.     1   CMD,'W','O','R',' ','3','0',
  1899.     2   CMD,'G','R','A',' ','1',',','3','0',
  1900.     3   CMD,'J','U','M',' ','1',',','1',
  1901.     4   CMD,'L','I','N',' ','1',2*0/
  1902.     DATA STR_BEGIN_PLOT /
  1903.     1   CMD,'E','R','A',' ','G',
  1904.     2   CMD,'L','I','N',' ','1',2*0/
  1905.     DATA STR_COLOR_SET /
  1906.     1   CMD,'L','I','N',' ','1',2*0/
  1907. C
  1908. C    DEFINITIONS FOR GIN
  1909. C
  1910.     BYTE GINBUFR(28), PROMPT(8)
  1911. C
  1912.     DATA PROMPT /
  1913.     1   CMD,'E','N','A',' ','1',CR,0/
  1914.     DATA IGIN_IN_CHARS /27/
  1915. C
  1916. C    DECLARE BUFFERING FUNCTION
  1917. C
  1918.     LOGICAL GB_TEST_FLUSH
  1919. C
  1920. C    DECLARE VARS NEED FOR DRIVER OPERATION
  1921. C
  1922.     LOGICAL LVECTOR_GOING, LDUMMY
  1923.     DIMENSION DCHAR(8)
  1924. C
  1925. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  1926. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  1927. C
  1928.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  1929.     DATA DCHAR /4025.0, 21.69, 14.223, 29.46, 29.46, 1.0, 133.0, 1.0/
  1930. C
  1931. C*****************
  1932. C
  1933. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  1934. C
  1935.     IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN
  1936. C
  1937. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  1938. C
  1939.     GO TO (100,200,300,400,500,600,700,800,900) IFXN
  1940. C
  1941. C    *********************
  1942. C    INITIALIZE THE DEVICE
  1943. C    *********************
  1944. C
  1945. 100    CONTINUE
  1946. C
  1947. C    FIRST, INITIALIZE THE BUFFER SUBROUTINES
  1948. C
  1949.     CALL GB_INITIALIZE(US,STR_END,TERMINAL,IERR)
  1950.     YA(1) = IERR
  1951.     IF (IERR .NE. 0) RETURN
  1952.     LVECTOR_GOING = .FALSE.
  1953. C
  1954. C    CREATE WORKSPACE AND GRAPHICS AREA
  1955. C
  1956.     CALL GB_IN_STRING(STR_INIT_4025)
  1957.     CALL GB_EMPTY
  1958.     RETURN
  1959. C
  1960. C    **************************
  1961. C    GET FRESH PLOTTING SURFACE
  1962. C    **************************
  1963. C
  1964. 200    CONTINUE
  1965.     CALL GB_NEW_BUFFER
  1966.     CALL GB_IN_STRING(STR_BEGIN_PLOT)
  1967.     CALL GB_EMPTY
  1968.     LVECTOR_GOING = .FALSE.
  1969.     RETURN
  1970. C
  1971. C    ****
  1972. C    MOVE
  1973. C    ****
  1974. C
  1975. 300    CONTINUE
  1976. C    CONVERT CM. TO GRAPHICS UNITS ROUNDED
  1977.     IXPOSN = XGUPCM*XA(1)+0.5
  1978.     IYPOSN = YGUPCM*YA(1)+0.5
  1979.     LVECTOR_GOING = .FALSE.
  1980.     RETURN
  1981. C
  1982. C    ****
  1983. C    DRAW
  1984. C    ****
  1985. C
  1986. 400    CONTINUE
  1987.     IX = XGUPCM*XA(1)+0.5
  1988.     IY = YGUPCM*YA(1)+0.5
  1989.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4))
  1990.     IF (LVECTOR_GOING) GO TO 410
  1991.     LDUMMY = GB_TEST_FLUSH(9)
  1992.     LVECTOR_GOING =  .TRUE.
  1993.     CALL GB_INSERT(GS)
  1994.     CALL GB_USE_TERMINATOR
  1995.     CALL GD_4010_CONVERT(IXPOSN,IYPOSN)
  1996. 410    CALL GD_4010_CONVERT(IX,IY)
  1997.     IXPOSN = IX
  1998.     IYPOSN = IY
  1999.     RETURN
  2000. C
  2001. C    *****************************
  2002. C    FLUSH GRAPHICS COMMAND BUFFER
  2003. C    *****************************
  2004. C
  2005. 500    CONTINUE
  2006.     CALL GB_EMPTY
  2007.     LVECTOR_GOING = .FALSE.
  2008.     RETURN
  2009. C
  2010. C    ******************
  2011. C    RELEASE THE DEVICE
  2012. C    ******************
  2013. C
  2014. 600    CONTINUE
  2015. C
  2016. C    DO NOTHING - LET USER KILL PICTURE
  2017. C
  2018.     CALL GB_EMPTY
  2019.     RETURN
  2020. C
  2021. C    *****************************
  2022. C    RETURN DEVICE CHARACTERISTICS
  2023. C    *****************************
  2024. C
  2025. 700    CONTINUE
  2026.     DO 720 I=1,8
  2027.     XA(I) = DCHAR(I)
  2028. 720    CONTINUE
  2029.     RETURN
  2030. C
  2031. C    ****************************
  2032. C    SELECT CURRENT DRAWING COLOR
  2033. C    ****************************
  2034. C
  2035. 800    CONTINUE
  2036.     CALL GB_EMPTY
  2037.     ICOLOR = XA(1)
  2038.     IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 1) RETURN
  2039.     IF (ICOLOR .EQ. 1) THEN
  2040.         STR_COLOR_SET(6) = 49
  2041.         ELSE
  2042.         STR_COLOR_SET(6) = 69
  2043.         ENDIF
  2044.     CALL GB_IN_STRING(STR_COLOR_SET)
  2045.     LVECTOR_GOING = .FALSE.
  2046.     RETURN
  2047. C
  2048. C    **********************
  2049. C    PERFORM GRAPHICS INPUT
  2050. C    **********************
  2051. C
  2052. 900    CONTINUE
  2053.     CALL GB_EMPTY
  2054.     LVECTOR_GOING = .FALSE.
  2055. C
  2056. C    ASK FOR 1 GIN INPUT
  2057. C
  2058. C
  2059. 920    CONTINUE
  2060.     CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.FALSE.,GINBUFR)
  2061.     IF ((GINBUFR(2) .NE. ASCIID) .OR. (GINBUFR(3) .NE. ASCIIA) .OR.
  2062.     1   (GINBUFR(4) .NE. ASCIIT)) GOTO 920
  2063. C
  2064. C    GET KEY PRESSED, X AND Y
  2065. C
  2066. C    KEY IS AT 9, X IS AT 13, AND Y IS AT 17
  2067. C
  2068.     DECODE (11,911,GINBUFR(9)) XA(1), XA(2), XA(3)
  2069. 911    FORMAT(F3.0,1X,F3.0,1X,F3.0)
  2070.     XA(2) = XA(2)/XGUPCM
  2071.     XA(3) = XA(3)/YGUPCM
  2072.     RETURN
  2073.     END
  2074.     SUBROUTINE GD4027(IFXN,XA,YA)
  2075.     DIMENSION XA(8), YA(3)
  2076. C
  2077. C    TEKTRONIX 4027 DRIVER FOR DIGLIB/VAX
  2078. C        UNTESTED but derived from the 4025 driver, so it should
  2079. C            mostly work
  2080. C
  2081. C-----------------------------------------------------------------------
  2082. C
  2083.     BYTE CSUB, US, GS, CR, FF, ESC
  2084.     PARAMETER (CSUB=26, US=31, GS=29, CR=13, FF=12, ESC=27)
  2085.     CHARACTER*(*) TERMINAL, LOG_CC, LOG_COM
  2086.     PARAMETER (TERMINAL='TT')
  2087.     PARAMETER (LOG_CC='TEK_4025CC')
  2088.     PARAMETER (LOG_COM = 'TEK_4025COM')
  2089. C
  2090. C    DEFINITIONS FOR DEVICE CONTROL
  2091. C
  2092.     CHARACTER*1 NEW_CC
  2093.     CHARACTER*80 NEW_COM
  2094.     BYTE CMD, BCHAR
  2095.     BYTE STR_END(2)
  2096.     BYTE ASCIID, ASCIIA, ASCIIT
  2097.     BYTE BCOLOR_MAP(8)
  2098. C
  2099.     DATA CMD /33/
  2100.     DATA ASCIID, ASCIIA, ASCIIT /'D','A','T'/
  2101.     DATA STR_END /13,0/
  2102.     DATA BCOLOR_MAP / '7', '0', '1', '2', '3', '4', '5', '6' /
  2103. C
  2104. C    DEFINITIONS FOR GIN
  2105. C
  2106.     BYTE GINBUFR(28), PROMPT(8)
  2107. C
  2108.     DATA PROMPT /
  2109.     1   0,'E','N','A',' ','1',CR,0/
  2110.     DATA IGIN_IN_CHARS /27/
  2111. C
  2112. C    DECLARE BUFFERING FUNCTION
  2113. C
  2114.     LOGICAL GB_TEST_FLUSH
  2115. C
  2116. C    DECLARE VARS NEED FOR DRIVER OPERATION
  2117. C
  2118.     INTEGER*4 SYS$TRNLOG, STR$UPCASE
  2119.     LOGICAL LVECTOR_GOING, LDUMMY
  2120.     DIMENSION DCHAR(8)
  2121. C
  2122. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  2123. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  2124. C
  2125.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  2126.     DATA DCHAR /4027.0, 24.706, 16.2, 25.864, 25.864, 7.0, 229.0, 1.0/
  2127. C
  2128. C*****************
  2129. C
  2130. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  2131. C
  2132.     IF (IFXN .LE. 0 .OR. IFXN .GT. 11) RETURN
  2133. C
  2134. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  2135. C
  2136.     GO TO (100,200,300,400,500,600,700,800,900,1000,1100) IFXN
  2137. C
  2138. C    *********************
  2139. C    INITIALIZE THE DEVICE
  2140. C    *********************
  2141. C
  2142. 100    CONTINUE
  2143. C
  2144. C    FIRST, INITIALIZE THE BUFFER SUBROUTINES
  2145. C
  2146.     CALL GB_INITIALIZE(US,STR_END,TERMINAL,IERR)
  2147.     YA(1) = IERR
  2148.     IF (IERR .NE. 0) RETURN
  2149.     LVECTOR_GOING = .FALSE.
  2150. C
  2151. C    SEE IF USER DEFINED COMMAND CHARACTER
  2152. C
  2153.     ISTATUS = SYS$TRNLOG(LOG_CC,ILENCC,NEW_CC, , , )
  2154.     IF (ISTATUS) THEN
  2155.         CMD = ICHAR(NEW_CC)
  2156.     ENDIF
  2157. C
  2158. C    EXIT ANSI MODE (JUST INCASE TERMINAL IS IN ANSI MODE)
  2159. C
  2160.     CALL GB_INSERT(ESC)
  2161.     CALL GB_IN_STRING('[~')
  2162. C
  2163. C    CREATE WORKSPACE AND GRAPHICS AREA
  2164. C
  2165.     CALL GB_INSERT(CMD)
  2166.     CALL GB_IN_STRING('WOR 30')
  2167.     CALL GB_INSERT(CMD)
  2168.     CALL GB_IN_STRING('GRA 1,30')
  2169.     CALL GB_INSERT(CMD)
  2170.     CALL GB_IN_STRING('JUM 1,1')
  2171.     CALL GB_INSERT(CMD)
  2172.     CALL GB_IN_STRING('LIN 1')
  2173.     CALL GB_INSERT(CMD)
  2174.     CALL GB_IN_STRING('COL C0')
  2175.     CALL GB_EMPTY
  2176.     RETURN
  2177. C
  2178. C    **************************
  2179. C    GET FRESH PLOTTING SURFACE
  2180. C    **************************
  2181. C
  2182. 200    CONTINUE
  2183.     CALL GB_EMPTY
  2184.     CALL GB_INSERT(CMD)
  2185.     CALL GB_IN_STRING('ERA G')
  2186.     CALL GB_INSERT(CMD)
  2187.     CALL GB_IN_STRING('COL C0')
  2188.     CALL GB_EMPTY
  2189. C
  2190. C    COMMENT OUT THE FOLLOWING IF YOU DON'T WANT YOUR 4027s COLORS
  2191. C    CHANGED TO "NORMAL" BY DIGLIB
  2192. C
  2193.     CALL GD4027_MIX(CMD,0,0,0,0)
  2194.     CALL GD4027_MIX(CMD,1,100,100,100)
  2195.     CALL GD4027_MIX(CMD,2,100,0,0)
  2196.     CALL GD4027_MIX(CMD,3,0,100,0)
  2197.     CALL GB_EMPTY
  2198.     CALL GD4027_MIX(CMD,4,0,0,100)
  2199.     CALL GD4027_MIX(CMD,5,100,100,0)
  2200.     CALL GD4027_MIX(CMD,6,100,0,100)
  2201.     CALL GD4027_MIX(CMD,7,0,100,100)
  2202.     CALL GB_EMPTY
  2203.     LVECTOR_GOING = .FALSE.
  2204.     RETURN
  2205. C
  2206. C    ****
  2207. C    MOVE
  2208. C    ****
  2209. C
  2210. 300    CONTINUE
  2211. C    CONVERT CM. TO GRAPHICS UNITS ROUNDED
  2212.     IXPOSN = XGUPCM*XA(1)+0.5
  2213.     IYPOSN = YGUPCM*YA(1)+0.5
  2214.     LVECTOR_GOING = .FALSE.
  2215.     RETURN
  2216. C
  2217. C    ****
  2218. C    DRAW
  2219. C    ****
  2220. C
  2221. 400    CONTINUE
  2222.     IX = XGUPCM*XA(1)+0.5
  2223.     IY = YGUPCM*YA(1)+0.5
  2224.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4))
  2225.     IF (LVECTOR_GOING) GO TO 410
  2226.     LDUMMY = GB_TEST_FLUSH(9)
  2227.     LVECTOR_GOING =  .TRUE.
  2228.     CALL GB_INSERT(GS)
  2229.     CALL GB_USE_TERMINATOR
  2230.     CALL GD_4010_CONVERT(IXPOSN,IYPOSN)
  2231. 410    IF (IX .NE. IXPOSN .OR. IY .NE. IYPOSN) THEN
  2232.         CALL GD_4010_CONVERT(IX,IY)
  2233.         IXPOSN = IX
  2234.         IYPOSN = IY
  2235.     ENDIF
  2236.     RETURN
  2237. C
  2238. C    *****************************
  2239. C    FLUSH GRAPHICS COMMAND BUFFER
  2240. C    *****************************
  2241. C
  2242. 500    CONTINUE
  2243.     CALL GB_EMPTY
  2244.     LVECTOR_GOING = .FALSE.
  2245.     RETURN
  2246. C
  2247. C    ******************
  2248. C    RELEASE THE DEVICE
  2249. C    ******************
  2250. C
  2251. 600    CONTINUE
  2252. C
  2253. C    SEE IF USER WANTS ANYTHING DONE, IF SO, DO IT
  2254. C
  2255.     ISTATUS = SYS$TRNLOG(LOG_COM,ILENCOM,NEW_COM, , , )
  2256.     IF (ISTATUS) THEN
  2257.         ISTATUS = STR$UPCASE(NEW_COM,NEW_COM)
  2258.         IF (NEW_COM(1:4) .EQ. 'ANSI') THEN
  2259.             TYPE 601
  2260. 601            FORMAT('$Hit return to return terminal to ANSI mode.')
  2261.             ACCEPT 602, ISTATUS
  2262. 602            FORMAT(A1)
  2263.         ENDIF
  2264.         CALL GB_EMPTY
  2265.         CALL GB_INSERT(CMD)
  2266.         DO 610 I=1,ILENCOM
  2267.             BCHAR = ICHAR(NEW_COM(I:I))
  2268.             CALL GB_INSERT(BCHAR)
  2269. 610            CONTINUE
  2270.     ENDIF
  2271.     CALL GB_EMPTY
  2272.     RETURN
  2273. C
  2274. C    *****************************
  2275. C    RETURN DEVICE CHARACTERISTICS
  2276. C    *****************************
  2277. C
  2278. 700    CONTINUE
  2279.     DO 720 I=1,8
  2280.     XA(I) = DCHAR(I)
  2281. 720    CONTINUE
  2282.     RETURN
  2283. C
  2284. C    ****************************
  2285. C    SELECT CURRENT DRAWING COLOR
  2286. C    ****************************
  2287. C
  2288. 800    CONTINUE
  2289.     CALL GB_EMPTY
  2290.     ICOLOR = XA(1)
  2291.     IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 7) RETURN
  2292.     CALL GB_INSERT(CMD)
  2293.     CALL GB_IN_STRING('COL C')
  2294.     CALL GB_INSERT(BCOLOR_MAP(ICOLOR+1))
  2295.     LVECTOR_GOING = .FALSE.
  2296.     RETURN
  2297. C
  2298. C    **********************
  2299. C    PERFORM GRAPHICS INPUT
  2300. C    **********************
  2301. C
  2302. 900    CONTINUE
  2303.     CALL GB_EMPTY
  2304.     LVECTOR_GOING = .FALSE.
  2305. C
  2306. C    ASK FOR 1 GIN INPUT
  2307. C
  2308. 920    CONTINUE
  2309.     PROMPT(1) = CMD
  2310.     CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.FALSE.,GINBUFR)
  2311.     IF ((GINBUFR(2) .NE. ASCIID) .OR. (GINBUFR(3) .NE. ASCIIA) .OR.
  2312.     1   (GINBUFR(4) .NE. ASCIIT)) GOTO 920
  2313. C
  2314. C    GET KEY PRESSED, X AND Y
  2315. C
  2316. C    KEY IS AT 9, X IS AT 13, AND Y IS AT 17
  2317. C
  2318.     DECODE (11,911,GINBUFR(9)) XA(1), XA(2), XA(3)
  2319. 911    FORMAT(F3.0,1X,F3.0,1X,F3.0)
  2320.     XA(2) = XA(2)/XGUPCM
  2321.     XA(3) = XA(3)/YGUPCM
  2322.     RETURN
  2323. C
  2324. C    DEFINE COLOR VIA RGB
  2325. C
  2326. 1000    CONTINUE
  2327.     CALL GB_EMPTY
  2328.     LVECTOR_GOING = .FALSE.
  2329.     CALL GD4027_MIX(CMD,INT(XA(1)),INT(YA(1)),INT(YA(2)),INT(YA(3)))
  2330.     RETURN
  2331. C
  2332. C    DEFINE COLOR VIA HLS
  2333. C
  2334. 1100    CONTINUE
  2335.     CALL GB_EMPTY
  2336.     LVECTOR_GOING = .FALSE.
  2337.     CALL GD4027_MAP(CMD,INT(XA(1)),INT(YA(1)),INT(YA(2)),INT(YA(3)))
  2338.     RETURN
  2339.     END
  2340.     SUBROUTINE GD4027_MAP(CC,ICOLOR,IHUE,ILIGHTNESS,ISATURATION)
  2341. C
  2342. C    THIS SUBROUTINE DOES A 4027 "MAP" COMMAND
  2343. C
  2344.     BYTE STR_MAP(20)
  2345. c    
  2346.     ENCODE (19,11,STR_MAP) CC, ICOLOR, IHUE, ILIGHTNESS, ISATURATION
  2347. 11    FORMAT(A1,'MAP C',I1,',',I3,',',I3,',',I3)
  2348.     STR_MAP(20) = 0
  2349.     CALL GB_IN_STRING(STR_MAP)
  2350.     RETURN
  2351.     END
  2352.     SUBROUTINE GD4027_MIX(CC,ICOLOR,IRED,IGREEN,IBLUE)
  2353. C
  2354. C    THIS SUBROUTINE DOES A 4027 "MIX" COMMAND
  2355. C
  2356.     BYTE STR_MIX(20)
  2357. C
  2358.     ENCODE (19,11,STR_MIX) CC,ICOLOR, IRED, IGREEN, IBLUE
  2359. 11    FORMAT(A1,'MIX C',I1,',',I3,',',I3,',',I3)
  2360.     STR_MIX(20) = 0
  2361.     CALL GB_IN_STRING(STR_MIX)
  2362.     RETURN
  2363.     END
  2364.     SUBROUTINE GD4105(IFXN,XA,YA)
  2365.     DIMENSION XA(8), YA(3)
  2366. C
  2367. C    TEK 4105 DRIVER FOR DIGLIB/VAX
  2368. C        VERSION 2.1A - CURSOR POSITIONING AND HARDWARE POLYGONS (fixed)
  2369. C
  2370. CCCCCCCCCCCCCCCCC
  2371. C
  2372. C    PARAMETERS TO MAKE THIS A 4105 DRIVER
  2373. C
  2374.     PARAMETER (TERM_NUMBER = 4105.0)
  2375.     PARAMETER (SCREEN_WIDTH_CM = 24.564)
  2376.     PARAMETER (SCREEN_HEIGHT_CM = 18.41)
  2377.     PARAMETER (X_DOTS = 480.0)
  2378.     PARAMETER (Y_DOTS = 360.0)
  2379.     PARAMETER (NUMBER_FG_COLORS = 7)
  2380. C
  2381. C    AND NOW, THE GENERIC 410X STUFF
  2382. C
  2383.     INCLUDE 'GD410X.FOR'
  2384.     END
  2385.     SUBROUTINE GD4107(IFXN,XA,YA)
  2386.     DIMENSION XA(8), YA(3)
  2387. C
  2388. C    TEK 4107 DRIVER FOR DIGLIB/VAX
  2389. C        VERSION 2.1 - CURSOR POSITIONING AND HARDWARE POLYGONS
  2390. C
  2391.     BYTE ESC, CSUB, GS, CR, FF, US
  2392.     PARAMETER (ESC=27, CSUB=26, GS=29, CR=13, FF=12, US=31)
  2393.     CHARACTER*(*) TERMINAL
  2394.     PARAMETER (TERMINAL='TT')
  2395. C
  2396. C    DEFINITIONS FOR DEVICE CONTROL
  2397. C
  2398.     BYTE STR_END(2), STR_INIT_DEV(26), STR_WINDOW(4)
  2399.     BYTE STR_BEGIN_PLOT(4), STR_COLOR_SET(6)
  2400.     BYTE STR_END_PLOT(2), STR_RLS_DEV(6)
  2401.     BYTE STR_BEGIN_POLY(4), STR_END_POLY(6)
  2402.     DATA STR_END /US,0/
  2403.     DATA STR_INIT_DEV/
  2404.     1   ESC,'%','!','0',        !CODE TEK
  2405.     2   ESC,'K','A','1',        !DAENABLE YES
  2406.     3   ESC,'L','M','0',        !DAMODE REPLACE
  2407.     4   ESC,'M','L','1',        !LINEINDEX 1 (COLOR 1)
  2408.     5   ESC,'N','U',':',        !BYPASS CANCEL CHARACTER (LF)
  2409.     6   ESC,'N','T','1','=',0/    !EOL STRING <CR> <NULL>
  2410.     DATA STR_WINDOW / ESC,'R','W',0/
  2411.     DATA STR_BEGIN_PLOT/
  2412.     1   ESC,FF,0,0/            !ERASE SCREEN
  2413.     DATA STR_COLOR_SET /
  2414.     1   ESC,'M','L','1',0,0/    !LINEINDEX 1 (COLOR N)
  2415.     DATA STR_END_PLOT /0,0/
  2416.     DATA STR_RLS_DEV /
  2417.     1   ESC,'%','!','1',0,0/    !CODE ANSI
  2418.     DATA STR_BEGIN_POLY / ESC,'L','P',0/
  2419.     DATA STR_END_POLY / US,ESC,'L','E',2*0/
  2420. C
  2421. C    DEFINITIONS FOR GIN
  2422. C
  2423.     BYTE GINBUFR(8), PROMPT(4), STR_END_GIN(2), STR_MOVE_GIN_CURSOR(6)
  2424.     DATA PROMPT /ESC, CSUB, 0, 0/
  2425.     DATA IGIN_IN_CHARS /6/
  2426.     DATA STR_END_GIN /10,0/
  2427.     DATA STR_MOVE_GIN_CURSOR / ESC, 'S', 'X', '0', 0,0/
  2428.     DATA IX_GIN_CURSOR, IY_GIN_CURSOR / 240, 180 /
  2429. C
  2430. C    DECLARE BUFFERING FUNCTION
  2431. C
  2432.     LOGICAL GB_TEST_FLUSH
  2433. C
  2434. C    DECLARE VARS NEED FOR DRIVER OPERATION
  2435. C
  2436.     LOGICAL LVECTOR_GOING, LDUMMY
  2437.     DIMENSION DCHAR(8)
  2438. C
  2439. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  2440. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  2441. C
  2442.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  2443.     DATA DCHAR /4107.0, 24.577, 18.423, 26.0, 26.0, 7.0, 389.0, 1.0/
  2444. C
  2445. C*****************
  2446. C
  2447. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  2448. C
  2449.     IF (IFXN .GT. 1026) GOTO 20000
  2450.     IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN
  2451. C
  2452. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  2453. C
  2454.     GO TO (100,200,300,400,500,600,700,800,900) IFXN
  2455. C
  2456. C    *********************
  2457. C    INITIALIZE THE DEVICE
  2458. C    *********************
  2459. C
  2460. 100    CONTINUE
  2461. C
  2462. C    FIRST, INITIALIZE THE BUFFER SUBROUTINES
  2463. C
  2464.     CALL GB_INITIALIZE(0,STR_END,TERMINAL,IERR)
  2465.     YA(1) = IERR
  2466.     IF (IERR .NE. 0) RETURN
  2467. C
  2468. C    INITIALIZE THE 4107
  2469. C
  2470.     CALL GB_IN_STRING(STR_INIT_DEV)
  2471.     CALL GB_IN_STRING(STR_WINDOW)
  2472.     CALL GD_4010_CONVERT(0,0)
  2473.     IX = INT(DCHAR(2)*XGUPCM+0.5)
  2474.     IY = INT(DCHAR(3)*YGUPCM+0.5)
  2475.     CALL GD_4010_CONVERT(IX,IY)
  2476.     CALL GB_EMPTY
  2477.     LVECTOR_GOING = .FALSE.
  2478.     RETURN
  2479. C
  2480. C    **************************
  2481. C    GET FRESH PLOTTING SURFACE
  2482. C    **************************
  2483. C
  2484. 200    CONTINUE
  2485.     CALL GB_NEW_BUFFER
  2486.     CALL GB_IN_STRING(STR_BEGIN_PLOT)
  2487.     CALL GB_EMPTY
  2488.     LVECTOR_GOING = .FALSE.
  2489.     RETURN
  2490. C
  2491. C    ****
  2492. C    MOVE
  2493. C    ****
  2494. C
  2495. 300    CONTINUE
  2496. C    CONVERT CM. TO GRAPHICS UNITS ROUNDED
  2497.     IXPOSN = XGUPCM*XA(1)+0.5
  2498.     IYPOSN = YGUPCM*YA(1)+0.5
  2499.     LVECTOR_GOING = .FALSE.
  2500.     RETURN
  2501. C
  2502. C    ****
  2503. C    DRAW
  2504. C    ****
  2505. C
  2506. 400    CONTINUE
  2507.     IX = XGUPCM*XA(1)+0.5
  2508.     IY = YGUPCM*YA(1)+0.5
  2509.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4))
  2510.     IF (LVECTOR_GOING) GO TO 410
  2511.     LDUMMY = GB_TEST_FLUSH(9)
  2512.     LVECTOR_GOING = .TRUE.
  2513.     CALL GB_INSERT(GS)
  2514.     CALL GD_4010_CONVERT(IXPOSN,IYPOSN)
  2515. 410    CALL GD_4010_CONVERT(IX,IY)
  2516.     IXPOSN = IX
  2517.     IYPOSN = IY
  2518.     RETURN
  2519. C
  2520. C    *****************************
  2521. C    FLUSH GRAPHICS COMMAND BUFFER
  2522. C    *****************************
  2523. C
  2524. 500    CONTINUE
  2525.     CALL GB_EMPTY
  2526.     CALL GB_IN_STRING(STR_END_PLOT)
  2527.     CALL GB_EMPTY
  2528.     LVECTOR_GOING = .FALSE.
  2529.     RETURN
  2530. C
  2531. C    ******************
  2532. C    RELEASE THE DEVICE
  2533. C    ******************
  2534. C
  2535. 600    CONTINUE
  2536. C
  2537. C    DE-ASSIGN THE CHANNAL
  2538. C
  2539.     CALL GB_EMPTY
  2540.     CALL GB_IN_STRING(STR_WINDOW)
  2541.     CALL GD_4010_CONVERT(0,0)
  2542.     CALL GD_4010_CONVERT(1023,767)
  2543.     CALL GB_FINISH(STR_RLS_DEV)
  2544.     RETURN
  2545. C
  2546. C    *****************************
  2547. C    RETURN DEVICE CHARACTERISTICS
  2548. C    *****************************
  2549. C
  2550. 700    CONTINUE
  2551.     DO 720 I=1,8
  2552.     XA(I) = DCHAR(I)
  2553. 720    CONTINUE
  2554.     RETURN
  2555. C
  2556. C    ****************************
  2557. C    SELECT CURRENT DRAWING COLOR
  2558. C    ****************************
  2559. C
  2560. 800    CONTINUE
  2561.     LDUMMY = GB_TEST_FLUSH(6)
  2562.     ICOLOR = XA(1)
  2563.     IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 7) RETURN
  2564.     STR_COLOR_SET(4) = 48+ICOLOR    !MAKE ASCII CHARACTER
  2565.     CALL GB_IN_STRING(STR_COLOR_SET)
  2566.     LVECTOR_GOING = .FALSE.
  2567.     RETURN
  2568. C
  2569. C    **********************
  2570. C    PERFORM GRAPHICS INPUT
  2571. C    **********************
  2572. C
  2573. 900    CONTINUE
  2574. C
  2575. C    POSITION CURSOR TO ITS LAST GIN POSITION (ELSE MIDDLE OF SCREEN)
  2576. C
  2577.     CALL GB_TEST_FLUSH(10)
  2578.     CALL GB_IN_STRING(STR_MOVE_GIN_CURSOR)
  2579.     CALL GD_4010_CONVERT(IX_GIN_CURSOR,IY_GIN_CURSOR)
  2580.     CALL GB_EMPTY
  2581. C
  2582.     CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR)
  2583. C
  2584.     ICHAR = GINBUFR(1)
  2585.     IX1 = GINBUFR(2)
  2586.     IX2 = GINBUFR(3)
  2587.     IY1 = GINBUFR(4)
  2588.     IY2 = GINBUFR(5)
  2589. C
  2590.     XA(1) = IAND(ICHAR,127)        !PICK CHARACTER
  2591.     IX_GIN_CURSOR = 32*IAND(IX1,31)+IAND(IX2,31)
  2592.     XA(2) = IX_GIN_CURSOR/XGUPCM
  2593.     IY_GIN_CURSOR = 32*IAND(IY1,31)+IAND(IY2,31)
  2594.     XA(3) = IY_GIN_CURSOR/YGUPCM
  2595. C
  2596.     CALL GB_IN_STRING(STR_END_GIN)
  2597.     CALL GB_EMPTY
  2598.     RETURN
  2599. C
  2600. C    *******************
  2601. C    DRAW FILLED POLYGON
  2602. C    *******************
  2603. C
  2604. 20000    CONTINUE
  2605.     NPTS = IFXN - 1024
  2606.     IX = XGUPCM*XA(1)+0.5
  2607.     IY = YGUPCM*YA(1)+0.5
  2608.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(20))
  2609.     IF (LVECTOR_GOING) THEN
  2610.         CALL GB_INSERT(US)
  2611.         LVECTOR_GOING = .FALSE.
  2612.     ENDIF
  2613.     CALL GB_IN_STRING(STR_BEGIN_POLY)
  2614.     CALL GD_4010_CONVERT(IX,IY)
  2615. C
  2616. C    DO VERTICES 2 THRU N.   NOTE: WE START WITH A <GS> SINCE
  2617. C     LVECTOR_GOING IS "FALSE"
  2618. C
  2619.         DO 20010 I = 2, NPTS
  2620. C        MAKE SURE 10 CHARS (4 FOR X,Y AND 6 FOR END POLYGON)
  2621.         LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(10))
  2622.         IF (.NOT. LVECTOR_GOING) CALL GB_INSERT(GS)
  2623.         CALL GD_4010_CONVERT(INT(XGUPCM*XA(I)+0.5),
  2624.     1        INT(YGUPCM*YA(I)+0.5))
  2625. 20010        CONTINUE
  2626.     CALL GB_IN_STRING(STR_END_POLY)
  2627.     LVECTOR_GOING = .FALSE.
  2628.     RETURN
  2629.     END
  2630.     PARAMETER (X_RES = (X_DOTS-1.0)/SCREEN_WIDTH_CM)
  2631.     PARAMETER (Y_RES = (Y_DOTS-1.0)/SCREEN_HEIGHT_CM)
  2632.     PARAMETER (RESOLUTION = (X_RES+Y_RES)/2.0)
  2633.     PARAMETER (XLENGTH = (X_DOTS-1.0)/RESOLUTION)
  2634.     PARAMETER (YLENGTH = (Y_DOTS-1.0)/RESOLUTION)
  2635.     PARAMETER (COLORS_FG = NUMBER_FG_COLORS)
  2636.     PARAMETER (IX_CENTER = RESOLUTION*XLENGTH/2.0)
  2637.     PARAMETER (IY_CENTER = RESOLUTION*YLENGTH/2.0)
  2638.     BYTE ESC,CSUB,GS,CR,FF,US
  2639.     PARAMETER (ESC=27, CSUB=26, GS=29, CR=13, FF=12, US=31)
  2640.     CHARACTER*(*) TERMINAL
  2641.     PARAMETER (TERMINAL='TT')
  2642. C
  2643. C    DEFINITIONS FOR DEVICE CONTROL
  2644. C
  2645.     BYTE STR_END(2), STR_INIT_DEV(26), STR_WINDOW(4)
  2646.     BYTE STR_BEGIN_PLOT(4), STR_COLOR_SET(6)
  2647.     BYTE STR_END_PLOT(2), STR_RLS_DEV(6)
  2648.     BYTE STR_BEGIN_POLY(4), STR_END_POLY(6)
  2649.     BYTE STR_FILL_PATRN(6)
  2650.     DATA STR_END /US,0/
  2651.     DATA STR_INIT_DEV/
  2652.     1   ESC,'%','!','0',        !CODE TEK
  2653.     2   ESC,'K','A','1',        !DAENABLE YES
  2654.     3   ESC,'L','M','0',        !DAMODE REPLACE
  2655.     4   ESC,'M','L','1',        !LINEINDEX 1 (COLOR 1)
  2656.     5   ESC,'N','U',':',        !BYPASS CANCEL CHARACTER (LF)
  2657.     6   ESC,'N','T','1','=',0/    !EOL STRING <CR> <NULL>
  2658.     DATA STR_WINDOW / ESC,'R','W',0/
  2659.     DATA STR_BEGIN_PLOT/
  2660.     1   ESC,FF,0,0/            !ERASE SCREEN
  2661.     DATA STR_COLOR_SET /
  2662.     1   ESC,'M','L','1',0,0/    !LINEINDEX 1 (COLOR N)
  2663.     DATA STR_END_PLOT /0,0/
  2664.     DATA STR_RLS_DEV /
  2665.     1   ESC,'%','!','1',0,0/    !CODE ANSI
  2666.     DATA STR_BEGIN_POLY / ESC,'L','P',0/
  2667.     DATA STR_END_POLY / US,ESC,'L','E',2*0/
  2668.     DATA STR_FILL_PATRN /ESC,'M','P',' ',2*0/
  2669. C
  2670. C    DEFINITIONS FOR GIN
  2671. C
  2672.     BYTE GINBUFR(8), PROMPT(4), STR_END_GIN(2), STR_MOVE_GIN_CURSOR(6)
  2673.     DATA PROMPT /ESC, CSUB, 0, 0/
  2674.     DATA IGIN_IN_CHARS /6/
  2675.     DATA STR_END_GIN /10,0/
  2676.     DATA STR_MOVE_GIN_CURSOR / ESC, 'S', 'X', '0', 0,0/
  2677.     DATA IX_GIN_CURSOR, IY_GIN_CURSOR / IX_CENTER, IY_CENTER /
  2678. C
  2679. C    DECLARE BUFFERING FUNCTION
  2680. C
  2681.     LOGICAL GB_TEST_FLUSH
  2682. C
  2683. C    DECLARE VARS NEED FOR DRIVER OPERATION
  2684. C
  2685.     LOGICAL LVECTOR_GOING, LDUMMY
  2686.     DIMENSION DCHAR(8)
  2687. C
  2688. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  2689. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  2690. C
  2691.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  2692.     DATA DCHAR / TERM_NUMBER, XLENGTH, YLENGTH, RESOLUTION,
  2693.     1   RESOLUTION, COLORS_FG, 389.0, 1.0/
  2694. C
  2695. C*****************
  2696. C
  2697. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  2698. C
  2699.     IF (IFXN .GT. 1026) GOTO 20000
  2700.     IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN
  2701. C
  2702. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  2703. C
  2704.     GO TO (100,200,300,400,500,600,700,800,900) IFXN
  2705. C
  2706. C    *********************
  2707. C    INITIALIZE THE DEVICE
  2708. C    *********************
  2709. C
  2710. 100    CONTINUE
  2711. C
  2712. C    FIRST, INITIALIZE THE BUFFER SUBROUTINES
  2713. C
  2714.     CALL GB_INITIALIZE(0,STR_END,TERMINAL,IERR)
  2715.     YA(1) = IERR
  2716.     IF (IERR .NE. 0) RETURN
  2717. C
  2718. C    INITIALIZE THE 4105
  2719. C
  2720.     CALL GB_IN_STRING(STR_INIT_DEV)
  2721.     CALL GB_IN_STRING(STR_WINDOW)
  2722.     CALL GD_4010_CONVERT(0,0)
  2723.     IX = INT(DCHAR(2)*XGUPCM+0.5)
  2724.     IY = INT(DCHAR(3)*YGUPCM+0.5)
  2725.     CALL GD_4010_CONVERT(IX,IY)
  2726.     CALL GB_EMPTY
  2727.     LVECTOR_GOING = .FALSE.
  2728.     RETURN
  2729. C
  2730. C    **************************
  2731. C    GET FRESH PLOTTING SURFACE
  2732. C    **************************
  2733. C
  2734. 200    CONTINUE
  2735.     CALL GB_EMPTY
  2736.     CALL GB_IN_STRING(STR_BEGIN_PLOT)
  2737.     CALL GB_EMPTY
  2738.     LVECTOR_GOING = .FALSE.
  2739.     RETURN
  2740. C
  2741. C    ****
  2742. C    MOVE
  2743. C    ****
  2744. C
  2745. 300    CONTINUE
  2746. C    CONVERT CM. TO GRAPHICS UNITS ROUNDED
  2747.     IXPOSN = XGUPCM*XA(1)+0.5
  2748.     IYPOSN = YGUPCM*YA(1)+0.5
  2749.     LVECTOR_GOING = .FALSE.
  2750.     RETURN
  2751. C
  2752. C    ****
  2753. C    DRAW
  2754. C    ****
  2755. C
  2756. 400    CONTINUE
  2757.     IX = XGUPCM*XA(1)+0.5
  2758.     IY = YGUPCM*YA(1)+0.5
  2759.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4))
  2760.     IF (LVECTOR_GOING) GO TO 410
  2761.     LDUMMY = GB_TEST_FLUSH(9)
  2762.     LVECTOR_GOING = .TRUE.
  2763.     CALL GB_INSERT(GS)
  2764.     CALL GD_4010_CONVERT(IXPOSN,IYPOSN)
  2765. 410    CALL GD_4010_CONVERT(IX,IY)
  2766.     IXPOSN = IX
  2767.     IYPOSN = IY
  2768.     RETURN
  2769. C
  2770. C    *****************************
  2771. C    FLUSH GRAPHICS COMMAND BUFFER
  2772. C    *****************************
  2773. C
  2774. 500    CONTINUE
  2775.     CALL GB_EMPTY
  2776.     CALL GB_IN_STRING(STR_END_PLOT)
  2777.     CALL GB_EMPTY
  2778.     LVECTOR_GOING = .FALSE.
  2779.     RETURN
  2780. C
  2781. C    ******************
  2782. C    RELEASE THE DEVICE
  2783. C    ******************
  2784. C
  2785. 600    CONTINUE
  2786. C
  2787. C    DE-ASSIGN THE CHANNAL
  2788. C
  2789.     CALL GB_EMPTY
  2790.     CALL GB_IN_STRING(STR_WINDOW)
  2791.     CALL GD_4010_CONVERT(0,0)
  2792.     CALL GD_4010_CONVERT(1023,767)
  2793.     CALL GB_FINISH(STR_RLS_DEV)
  2794.     RETURN
  2795. C
  2796. C    *****************************
  2797. C    RETURN DEVICE CHARACTERISTICS
  2798. C    *****************************
  2799. C
  2800. 700    CONTINUE
  2801.     DO 720 I=1,8
  2802.     XA(I) = DCHAR(I)
  2803. 720    CONTINUE
  2804.     RETURN
  2805. C
  2806. C    ****************************
  2807. C    SELECT CURRENT DRAWING COLOR
  2808. C    ****************************
  2809. C
  2810. 800    CONTINUE
  2811.     LDUMMY = GB_TEST_FLUSH(6)
  2812.     ICOLOR = XA(1)
  2813.     IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. NUMBER_FG_COLORS) RETURN
  2814.     STR_COLOR_SET(4) = 48+ICOLOR    !MAKE ASCII CHARACTER
  2815.     CALL GB_IN_STRING(STR_COLOR_SET)
  2816.     LVECTOR_GOING = .FALSE.
  2817.     RETURN
  2818. C
  2819. C    **********************
  2820. C    PERFORM GRAPHICS INPUT
  2821. C    **********************
  2822. C
  2823. 900    CONTINUE
  2824. C
  2825. C    POSITION CURSOR TO ITS LAST GIN POSITION (ELSE MIDDLE OF SCREEN)
  2826. C
  2827.     CALL GB_TEST_FLUSH(10)
  2828.     CALL GB_IN_STRING(STR_MOVE_GIN_CURSOR)
  2829.     CALL GD_4010_CONVERT(IX_GIN_CURSOR,IY_GIN_CURSOR)
  2830.     CALL GB_EMPTY
  2831. C
  2832.     CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR)
  2833. C
  2834.     ICHAR = GINBUFR(1)
  2835.     IX1 = GINBUFR(2)
  2836.     IX2 = GINBUFR(3)
  2837.     IY1 = GINBUFR(4)
  2838.     IY2 = GINBUFR(5)
  2839. C
  2840.     XA(1) = IAND(ICHAR,127)        !PICK CHARACTER
  2841.     IX_GIN_CURSOR = 32*IAND(IX1,31)+IAND(IX2,31)
  2842.     XA(2) = IX_GIN_CURSOR/XGUPCM
  2843.     IY_GIN_CURSOR = 32*IAND(IY1,31)+IAND(IY2,31)
  2844.     XA(3) = IY_GIN_CURSOR/YGUPCM
  2845. C
  2846.     CALL GB_IN_STRING(STR_END_GIN)
  2847.     CALL GB_EMPTY
  2848.     RETURN
  2849. C
  2850. C    *******************
  2851. C    DRAW FILLED POLYGON
  2852. C    *******************
  2853. C
  2854. 20000    CONTINUE
  2855.     NPTS = IFXN - 1024
  2856.     IX = XGUPCM*XA(1)+0.5
  2857.     IY = YGUPCM*YA(1)+0.5
  2858.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(26))
  2859.     IF (LVECTOR_GOING) THEN
  2860.         CALL GB_INSERT(US)
  2861.         LVECTOR_GOING = .FALSE.
  2862.     ENDIF
  2863.     STR_FILL_PATRN(4) = 32 + ICOLOR
  2864.     IF (ICOLOR .EQ. 0) STR_FILL_PATRN(4) = 80
  2865.     CALL GB_IN_STRING(STR_FILL_PATRN)
  2866.     CALL GB_IN_STRING(STR_BEGIN_POLY)
  2867.     CALL GD_4010_CONVERT(IX,IY)
  2868. C
  2869. C    DO VERTICES 2 THRU N.   NOTE: WE START WITH A <GS> SINCE
  2870. C     LVECTOR_GOING IS "FALSE"
  2871. C
  2872.         DO 20010 I = 2, NPTS
  2873. C        MAKE SURE 10 CHARS (4 FOR X,Y AND 6 FOR END POLYGON)
  2874.         LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(10))
  2875.         IF (.NOT. LVECTOR_GOING) CALL GB_INSERT(GS)
  2876.         CALL GD_4010_CONVERT(INT(XGUPCM*XA(I)+0.5),
  2877.     1        INT(YGUPCM*YA(I)+0.5))
  2878. 20010        CONTINUE
  2879.     CALL GB_IN_STRING(STR_END_POLY)
  2880.     LVECTOR_GOING = .FALSE.
  2881.     RETURN
  2882.     SUBROUTINE GD4115B(IFXN,XA,YA)
  2883.     DIMENSION XA(8), YA(3)
  2884. C
  2885. C    TEK 4115B DRIVER FOR DIGLIB/VAX
  2886. C        VERSION 1.0 - CURSOR POSITIONING AND HARDWARE POLYGONS
  2887. C
  2888.     BYTE ESC, CSUB, GS, CR, FF, US, LF
  2889.     PARAMETER (ESC=27, CSUB=26, GS=29, CR=13, FF=12, US=31, LF=10)
  2890.     CHARACTER*(*) TERMINAL
  2891.     PARAMETER (TERMINAL='TEK4115B_TERM')
  2892. C
  2893. C    DEFINITIONS FOR DEVICE CONTROL
  2894. C
  2895.     BYTE STR_END(2), STR_INIT_DEV(48), STR_WINDOW(4)
  2896.     BYTE STR_BEGIN_PLOT(6), STR_COLOR_SET(4)
  2897.     BYTE STR_END_PLOT(2), STR_RLS_DEV(6)
  2898.     BYTE STR_BEGIN_POLY(4), STR_END_POLY(6)
  2899.     BYTE STR_FILL_PATRN(4), STR_SET_GIN_WINDOW(4)
  2900.     BYTE STR_SET_GIN_AREA(6)
  2901.     DATA STR_END /US,0/
  2902.     DATA STR_INIT_DEV/
  2903.     1   ESC,'%','!','0',        !CODE TEK
  2904.     2   ESC,'K','A','1',        !DAENABLE YES
  2905.     3   ESC,'L','M','0',        !DAMODE REPLACE
  2906.     4   ESC,'M','L','1',        !LINEINDEX 1 (COLOR 1)
  2907.     5   ESC,'N','U',':',        !BYPASS CANCEL CHARACTER (LF)
  2908.     6   ESC,'N','T','1','=',    !EOL STRING <CR> <NULL>
  2909.     7   ESC,'N','F','3',        !FLAGGING IN/OUT (XON/XOFF IN USE)
  2910.     8   ESC,'I','C','0','0',    !USE CROSS HAIR CURSOR
  2911.     9   ESC,'I','G','0','0','0',    !NO GIN GRIDDING
  2912.     1   ESC,'T','M','4','1','1',2*0/!SET_COLOR_MODE (MACHINE/OPAQUE/COLOR)
  2913.     DATA STR_WINDOW / ESC,'R','W',0/
  2914.     DATA STR_SET_GIN_WINDOW / ESC,'I','W',0/
  2915.     DATA STR_SET_GIN_AREA / ESC,'I','V','0',33,0/
  2916.     DATA STR_BEGIN_PLOT/
  2917.     1   ESC,'R','D','1','4',0/    !1 DISPLAY SURFACE OF 4 BIT PLANES
  2918.     DATA STR_COLOR_SET /
  2919.     1   ESC,'M','L',0/        !LINEINDEX 1 (COLOR N)
  2920.     DATA STR_END_PLOT /0,0/
  2921.     DATA STR_RLS_DEV /
  2922.     1   ESC,'%','!','1',0,0/    !CODE ANSI
  2923.     DATA STR_BEGIN_POLY / ESC,'L','P',0/
  2924.     DATA STR_END_POLY / US,ESC,'L','E',2*0/
  2925.     DATA STR_FILL_PATRN /ESC,'M','P',0/
  2926. C
  2927. C    DEFINITIONS FOR GIN
  2928. C
  2929.     BYTE GINBUFR(10), PROMPT(6), STR_MOVE_GIN_CURSOR(6)
  2930.     DATA PROMPT /ESC, 'I','E','0','1', 0/
  2931.     DATA IGIN_IN_CHARS /8/
  2932.     DATA STR_MOVE_GIN_CURSOR / ESC, 'S', 'X', '0', 0,0/
  2933.     DATA IX_GIN_CURSOR, IY_GIN_CURSOR / 640, 512 /
  2934. C
  2935. C    DECLARE BUFFERING FUNCTION
  2936. C
  2937.     LOGICAL GB_TEST_FLUSH
  2938. C
  2939. C    DECLARE VARS NEED FOR DRIVER OPERATION
  2940. C
  2941.     LOGICAL LVECTOR_GOING, LDUMMY
  2942.     DIMENSION DCHAR(8)
  2943. C
  2944. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  2945. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  2946. C
  2947.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  2948.     DATA DCHAR /4115.0, 34.778, 27.817, 36.776, 36.776, 15.0, 389.0, 1.0/
  2949. C
  2950. C*****************
  2951. C
  2952. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  2953. C
  2954.     IF (IFXN .GT. 1026) GOTO 20000
  2955.     IF (IFXN .LE. 0 .OR. IFXN .GT. 10) RETURN
  2956. C
  2957. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  2958. C
  2959.     GO TO (100,200,300,400,500,600,700,800,900,1000) IFXN
  2960. C
  2961. C    *********************
  2962. C    INITIALIZE THE DEVICE
  2963. C    *********************
  2964. C
  2965. 100    CONTINUE
  2966. C
  2967. C    FIRST, INITIALIZE THE BUFFER SUBROUTINES
  2968. C
  2969.     CALL GB_INITIALIZE(0,STR_END,TERMINAL,IERR)
  2970.     YA(1) = IERR
  2971.     IF (IERR .NE. 0) RETURN
  2972. C
  2973. C    INITIALIZE THE 4115
  2974. C
  2975.     CALL GB_IN_STRING(STR_INIT_DEV)
  2976.     CALL GB_IN_STRING(STR_WINDOW)
  2977.     CALL GD_4014_CONVERT(0,0)
  2978.     IX = INT(DCHAR(2)*XGUPCM+0.5)
  2979.     IY = INT(DCHAR(3)*YGUPCM+0.5)
  2980.     CALL GD_4014_CONVERT(IX,IY)
  2981.     CALL GB_IN_STRING(STR_SET_GIN_WINDOW)
  2982.     CALL GD_4014_CONVERT(0,0)
  2983.     CALL GD_4014_CONVERT(4095,4095)
  2984.     CALL GB_IN_STRING(STR_SET_GIN_AREA)
  2985.     CALL GD_4014_CONVERT(0,0)
  2986.     CALL GD_4014_CONVERT(4095,4095)
  2987.     CALL GB_EMPTY
  2988.     LVECTOR_GOING = .FALSE.
  2989.     ICOLOR = 1
  2990.     RETURN
  2991. C
  2992. C    **************************
  2993. C    GET FRESH PLOTTING SURFACE
  2994. C    **************************
  2995. C
  2996. 200    CONTINUE
  2997.     CALL GB_EMPTY
  2998.     CALL GB_IN_STRING(STR_BEGIN_PLOT)
  2999.     CALL GD4115_CMAP(1,100.0,100.0,100.0)
  3000.     CALL GD4115_CMAP(2,100.0,0.0,0.0)
  3001.     CALL GD4115_CMAP(3,0.0,100.0,0.0)
  3002.     CALL GD4115_CMAP(4,0.0,0.0,100.0)
  3003.     CALL GD4115_CMAP(5,100.0,100.0,0.0)
  3004.     CALL GD4115_CMAP(6,100.0,0.0,100.0)
  3005.     CALL GD4115_CMAP(7,0.0,100.0,100.0)
  3006.     CALL GB_EMPTY
  3007.     LVECTOR_GOING = .FALSE.
  3008.     RETURN
  3009. C
  3010. C    ****
  3011. C    MOVE
  3012. C    ****
  3013. C
  3014. 300    CONTINUE
  3015. C    CONVERT CM. TO GRAPHICS UNITS ROUNDED
  3016.     IXPOSN = XGUPCM*XA(1)+0.5
  3017.     IYPOSN = YGUPCM*YA(1)+0.5
  3018.     LVECTOR_GOING = .FALSE.
  3019.     RETURN
  3020. C
  3021. C    ****
  3022. C    DRAW
  3023. C    ****
  3024. C
  3025. 400    CONTINUE
  3026.     IX = XGUPCM*XA(1)+0.5
  3027.     IY = YGUPCM*YA(1)+0.5
  3028.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(5))
  3029.     IF (LVECTOR_GOING) GO TO 410
  3030.     LDUMMY = GB_TEST_FLUSH(11)
  3031.     LVECTOR_GOING = .TRUE.
  3032.     CALL GB_INSERT(GS)
  3033.     CALL GD_4014_CONVERT(IXPOSN,IYPOSN)
  3034. 410    IF (IX .NE. IXPOSN .OR. IY .NE. IYPOSN) THEN
  3035.         CALL GD_4014_CONVERT(IX,IY)
  3036.         IXPOSN = IX
  3037.         IYPOSN = IY
  3038.     ENDIF
  3039.     RETURN
  3040. C
  3041. C    *****************************
  3042. C    FLUSH GRAPHICS COMMAND BUFFER
  3043. C    *****************************
  3044. C
  3045. 500    CONTINUE
  3046.     CALL GB_EMPTY
  3047.     CALL GB_IN_STRING(STR_END_PLOT)
  3048.     CALL GB_EMPTY
  3049.     LVECTOR_GOING = .FALSE.
  3050.     RETURN
  3051. C
  3052. C    ******************
  3053. C    RELEASE THE DEVICE
  3054. C    ******************
  3055. C
  3056. 600    CONTINUE
  3057. C
  3058. C    DE-ASSIGN THE CHANNAL
  3059. C
  3060.     CALL GB_EMPTY
  3061.     CALL GB_IN_STRING(STR_WINDOW)
  3062.     CALL GD_4014_CONVERT(0,0)
  3063.     CALL GD_4014_CONVERT(4095,4095)
  3064.     CALL GB_FINISH(STR_RLS_DEV)
  3065.     RETURN
  3066. C
  3067. C    *****************************
  3068. C    RETURN DEVICE CHARACTERISTICS
  3069. C    *****************************
  3070. C
  3071. 700    CONTINUE
  3072.     DO 720 I=1,8
  3073.     XA(I) = DCHAR(I)
  3074. 720    CONTINUE
  3075.     RETURN
  3076. C
  3077. C    ****************************
  3078. C    SELECT CURRENT DRAWING COLOR
  3079. C    ****************************
  3080. C
  3081. 800    CONTINUE
  3082.     LDUMMY = GB_TEST_FLUSH(10)
  3083.     ICOLOR = XA(1)
  3084.     IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. INT(DCHAR(6))) RETURN
  3085.     CALL GB_IN_STRING(STR_COLOR_SET)
  3086.     CALL GD_4110_INT(ICOLOR)
  3087.     LVECTOR_GOING = .FALSE.
  3088.     RETURN
  3089. C
  3090. C    **********************
  3091. C    PERFORM GRAPHICS INPUT
  3092. C    **********************
  3093. C
  3094. 900    CONTINUE
  3095. C
  3096. C    POSITION CURSOR TO ITS LAST GIN POSITION (ELSE MIDDLE OF SCREEN)
  3097. C
  3098.     CALL GB_TEST_FLUSH(12)
  3099.     CALL GB_IN_STRING(STR_MOVE_GIN_CURSOR)
  3100.     CALL GD_4014_CONVERT(IX_GIN_CURSOR,IY_GIN_CURSOR)
  3101.     CALL GB_EMPTY
  3102. C
  3103.     CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR)
  3104. C
  3105.     CALL GB_INSERT(LF)        !SEND BYPASS CANCEL CHARACTER
  3106.     CALL GB_EMPTY
  3107. C
  3108.     IF (GINBUFR(7) .EQ. CR .AND. GINBUFR(8) .EQ. CR) GO TO 960
  3109.         CALL GB_IN_STRING('Error reading cursor, try again.')
  3110.         CALL GB_INSERT(CR)
  3111.         CALL GB_EMPTY
  3112. D        TYPE 9999, (I,GINBUFR(I), I=1,IGIN_IN_CHARS)
  3113. D9999        FORMAT(' Character ',I2,' is ',I4,' decimal.')
  3114.         GO TO 900
  3115. C
  3116. 960    CONTINUE
  3117.     ICHAR = GINBUFR(1)
  3118.     IY1 = GINBUFR(2)
  3119.     IEX = GINBUFR(3)
  3120.     IY2 = GINBUFR(4)
  3121.     IX1 = GINBUFR(5)
  3122.     IX2 = GINBUFR(6)
  3123. C
  3124.     XA(1) = IAND(ICHAR,127)        !PICK CHARACTER
  3125.     IX_GIN_CURSOR = 128*IAND(IX1,31)+4*IAND(IX2,31)+IAND(IEX,3)
  3126.     XA(2) = IX_GIN_CURSOR/XGUPCM
  3127.     IY_GIN_CURSOR = 128*IAND(IY1,31)+4*IAND(IY2,31)+IAND(IEX/4,3)
  3128.     XA(3) = IY_GIN_CURSOR/YGUPCM
  3129.     RETURN
  3130. C
  3131. C    *********************
  3132. C    DEFINE COLOR WITH RGB
  3133. C    *********************
  3134. C
  3135. 1000    CONTINUE
  3136.     CALL GB_TEST_FLUSH(14)
  3137.     CALL GD4115_CMAP(INT(XA(1)),YA(1),YA(2),YA(3))
  3138.     LVECTOR_GOING = .FALSE.
  3139.     RETURN
  3140. C
  3141. C    *******************
  3142. C    DRAW FILLED POLYGON
  3143. C    *******************
  3144. C
  3145. 20000    CONTINUE
  3146.     NPTS = IFXN - 1024
  3147.     IX = XGUPCM*XA(1)+0.5
  3148.     IY = YGUPCM*YA(1)+0.5
  3149.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(40))
  3150.     IF (LVECTOR_GOING) THEN
  3151.         CALL GB_INSERT(US)
  3152.         LVECTOR_GOING = .FALSE.
  3153.     ENDIF
  3154.     CALL GB_IN_STRING(STR_FILL_PATRN)
  3155.     CALL GD_4110_INT(-ICOLOR)
  3156.     CALL GB_IN_STRING(STR_BEGIN_POLY)
  3157.     CALL GD_4014_CONVERT(IX,IY)
  3158. C
  3159. C    DO VERTICES 2 THRU N.   NOTE: WE START WITH A <GS> SINCE
  3160. C     LVECTOR_GOING IS "FALSE"
  3161. C
  3162.         DO 20010 I = 2, NPTS
  3163. C        MAKE SURE 11 CHARS (5 FOR X,Y AND 6 FOR END POLYGON)
  3164.         LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(11))
  3165.         IF (.NOT. LVECTOR_GOING) CALL GB_INSERT(GS)
  3166.         CALL GD_4014_CONVERT(INT(XGUPCM*XA(I)+0.5),
  3167.     1        INT(YGUPCM*YA(I)+0.5))
  3168. 20010        CONTINUE
  3169.     CALL GB_IN_STRING(STR_END_POLY)
  3170.     LVECTOR_GOING = .FALSE.
  3171.     RETURN
  3172.     END
  3173.  
  3174.     SUBROUTINE GD_4110_INT(INT)
  3175. C
  3176. C    CONVERT AN INTEGER INTO THE 4110 32-BIT INTEGER FORMAT AND PLACES
  3177. C    IT IN THE OUTPUT BUFFER
  3178. C
  3179.     BYTE STRING(6)
  3180.     DATA STRING(6) /0/
  3181. C
  3182.     INTABS = IABS(INT)
  3183.     STRING(5) = 48 + IAND(INTABS,15)
  3184.     IF (INT .LT. 0) STRING(5) = STRING(5) - 16
  3185.     I = 5
  3186.     INTABS = INTABS/16
  3187. 100        CONTINUE
  3188.         IF (INTABS .EQ. 0) GO TO 120
  3189.         I = I-1
  3190.         STRING(I) = 64 + IAND(INTABS,63)
  3191.         INTABS = INTABS/64
  3192.         GO TO 100
  3193. 120    CONTINUE
  3194.     CALL GB_IN_STRING(STRING(I))
  3195.     RETURN
  3196.     END
  3197.  
  3198.  
  3199.     SUBROUTINE GD4115_CMAP(ICOLOR,RED,GRN,BLU)
  3200. C
  3201. C    THIS SUBROUTINE SETS THE SPECIFIED COLOR INTO THE LOOK-UP TABLE.
  3202. C    IT ASSUMES THE CALLER HAS MADE SURE THERE ARE ATLEAST 12 BYTES
  3203. C    AVAILABLE IN THE BUFFER.
  3204. C
  3205.     BYTE ESC
  3206.     PARAMETER (ESC=27)
  3207.     PARAMETER (COLORS = 2.55)
  3208.     PARAMETER (MAXCOL = 255)
  3209. C
  3210.     BYTE SET_SURFACE_COLOR_MAP(6)
  3211.     DATA SET_SURFACE_COLOR_MAP /ESC, 'T', 'G', '1', '4', 0/
  3212. C
  3213.     CALL GB_TEST_FLUSH(20)
  3214.     CALL GB_IN_STRING(SET_SURFACE_COLOR_MAP)
  3215.     CALL GD_4110_INT(ICOLOR)
  3216.     CALL GD_4110_INT(MIN(MAXCOL,INT(COLORS*RED+0.5)))
  3217.     CALL GD_4110_INT(MIN(MAXCOL,INT(COLORS*GRN+0.5)))
  3218.     CALL GD_4110_INT(MIN(MAXCOL,INT(COLORS*BLU+0.5)))
  3219.     RETURN
  3220.     END
  3221.     SUBROUTINE GD4692 (IFXN,XA,YA)
  3222. c  TEKtronix 4692 DRIVER FOR DIGLIB/VAX
  3223. c    Author believed to be Giles Peterson.
  3224. c    Slightly modified by Hal Brand:
  3225. c        * Logical name TEK4692_TTY for terminal port
  3226.  
  3227.     DIMENSION XA(8), YA(3)
  3228.  
  3229.     PARAMETER (TERM_NUMBER = 4692.0)
  3230.     PARAMETER (SCREEN_WIDTH_CM = 24.564)
  3231.     PARAMETER (SCREEN_HEIGHT_CM = 18.41)
  3232.     PARAMETER (X_DOTS = 4096.0)
  3233.     PARAMETER (Y_DOTS = 3133.0)
  3234.     PARAMETER (NUMBER_FG_COLORS = 255)
  3235.  
  3236.       parameter (xdm1 = x_dots-1.)
  3237.       parameter (ydm1 = y_dots-1.)
  3238.     PARAMETER (X_RES = xdm1/SCREEN_WIDTH_CM)
  3239.     PARAMETER (Y_RES = ydm1/SCREEN_HEIGHT_CM)
  3240.     PARAMETER (RESOLUTION = (X_RES+Y_RES)/2.0)
  3241.       parameter (tallx = resolution*x_dots/y_dots)
  3242.       parameter (tally = resolution*y_dots/x_dots)
  3243.     PARAMETER (XLENGTH = xdm1/RESOLUTION)
  3244.     PARAMETER (YLENGTH = ydm1/RESOLUTION)
  3245.     PARAMETER (COLORS_FG = NUMBER_FG_COLORS)
  3246.     PARAMETER (IX_CENTER = RESOLUTION*XLENGTH/2.0)
  3247.     PARAMETER (IY_CENTER = RESOLUTION*YLENGTH/2.0)
  3248.     BYTE eb,ESC,CSUB,GS,CR,FF,US
  3249.     PARAMETER (eb=23,ESC=27, CSUB=26, GS=29, CR=13, FF=12, US=31)
  3250.     CHARACTER*(*) TERMINAL
  3251.     PARAMETER (TERMINAL='TEK4692_TTY')
  3252.  
  3253. C    DEFINITIONS FOR DEVICE CONTROL
  3254.       byte fillpattern(4),lineindex(4),textindex(4)
  3255.     BYTE STR_END(2), STR_INIT_DEV(25), STR_WINDOW(4)
  3256.     BYTE STR_BEGIN_PLOT(3)
  3257.     BYTE STR_END_PLOT(3), unreserve(5)
  3258.     BYTE beginpanel(4),endpanel(4)
  3259.       logical tall
  3260.       data beginpanel /ESC,'L','P',0/,
  3261.      *  fillpattern/esc,'M','P',0/,
  3262.      *  lineindex/esc,'M','L',0/,
  3263.      *  textindex/esc,'M','T',0/
  3264.     DATA STR_END /US,0/
  3265.     DATA STR_INIT_DEV/esc,'K','C',
  3266.      *  esc,'Q','O','0',
  3267.      *  ESC,'K','A','1',        !ENABLE dialog area
  3268.      *  ESC,'M','L','1',        !COLOR 1
  3269.      *  ESC,'N','U',':',        !BYPASS CANCEL CHARACTER (LF)
  3270.      *  ESC,'N','T','1','=',0/    !EOL STRING <CR> <NULL>
  3271.     DATA STR_WINDOW / ESC,'R','W',0/
  3272.     DATA STR_BEGIN_PLOT/ESC,FF,0/
  3273.     DATA STR_END_PLOT /esc,eb,0/
  3274.     DATA unreserve /ESC,'Q','R','0',0/
  3275.     DATA endpanel /ESC,'L','E',0/
  3276.  
  3277. C    DEFINITIONS FOR GIN
  3278.     BYTE GINBUFR(8), PROMPT(4), STR_END_GIN(2), STR_MOVE_GIN_CURSOR(6)
  3279.     DATA PROMPT /ESC, CSUB, 0, 0/
  3280.     DATA IGIN_IN_CHARS /6/
  3281.     DATA STR_END_GIN /10,0/
  3282.     DATA STR_MOVE_GIN_CURSOR / ESC, 'S', 'X', '0', 0,0/
  3283.     DATA IX_GIN_CURSOR, IY_GIN_CURSOR / IX_CENTER, IY_CENTER /
  3284.  
  3285. C    DECLARE BUFFERING FUNCTION
  3286.     LOGICAL GB_TEST_FLUSH
  3287.  
  3288. C    DECLARE VARS NEED FOR DRIVER OPERATION
  3289.     LOGICAL LVECTOR_GOING, LDUMMY
  3290.     DIMENSION DCHAR(8)
  3291.  
  3292. c  "GUPCM" IS GRAPHICS UNITS PER CENTIMETER
  3293.       EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  3294.       DATA DCHAR / TERM_NUMBER, XLENGTH, YLENGTH, RESOLUTION,
  3295.      *  RESOLUTION, COLORS_FG, 389.0, 1.0/
  3296.  
  3297. C*****************
  3298.       tall = .false.
  3299. 10    IF (IFXN .GT. 1026) GOTO 1000
  3300.       IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN
  3301.       GO TO (100,200,300,400,500,600,700,800,900) IFXN
  3302.  
  3303. c  *********************
  3304. c  INITIALIZE
  3305. 100    CALL GB_INITIALIZE (0,STR_END,TERMINAL,IERR)
  3306.     YA(1) = IERR
  3307.     IF (IERR .NE. 0) RETURN
  3308.  
  3309.     CALL GB_IN_STRING (STR_INIT_DEV)
  3310.     CALL GB_EMPTY
  3311.     LVECTOR_GOING = .FALSE.
  3312.     RETURN
  3313.  
  3314. C    **************************
  3315. C    GET FRESH PLOTTING SURFACE
  3316. 200    CONTINUE
  3317.     CALL GB_NEW_BUFFER
  3318.     CALL GB_IN_STRING (STR_BEGIN_PLOT)
  3319.     CALL GB_EMPTY
  3320.     LVECTOR_GOING = .FALSE.
  3321.     RETURN
  3322.  
  3323. C    ****
  3324. C    MOVE
  3325. 300    CONTINUE
  3326. C    CONVERT CM. TO GRAPHICS UNITS ROUNDED
  3327.       if (tall) then
  3328.     IxPOSN = xdm1 -tallx*YA(1)+0.5
  3329.     IyPOSN = tally*XA(1)+0.5
  3330.       else
  3331.     IXPOSN = XGUPCM*XA(1)+0.5
  3332.     IYPOSN = YGUPCM*YA(1)+0.5
  3333.       endif
  3334.       LVECTOR_GOING = .FALSE.
  3335.       RETURN
  3336.  
  3337. C    ****
  3338. C    DRAW
  3339. 400    CONTINUE
  3340.       if (tall) then
  3341.     Ix = xdm1 -tallx*YA(1)+0.5
  3342.     Iy = tally*XA(1)+0.5
  3343.       else
  3344.     IX = XGUPCM*XA(1)+0.5
  3345.     IY = YGUPCM*YA(1)+0.5
  3346.       endif
  3347.       LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4))
  3348.       IF (.not.LVECTOR_GOING) then
  3349.         LDUMMY = GB_TEST_FLUSH(9)
  3350.         LVECTOR_GOING = .TRUE.
  3351.         CALL GB_INSERT (GS)
  3352.         CALL xyto4692 (IXPOSN,IYPOSN)
  3353.       endif
  3354.       CALL xyto4692 (IX,IY)
  3355.       IXPOSN = IX
  3356.       IYPOSN = IY
  3357.       RETURN
  3358.  
  3359. C    *****************************
  3360. C    FLUSH GRAPHICS COMMAND BUFFER
  3361. 500    CONTINUE
  3362.     CALL GB_EMPTY
  3363.     CALL GB_IN_STRING (STR_END_PLOT)
  3364.     CALL GB_EMPTY
  3365.     LVECTOR_GOING = .FALSE.
  3366.     RETURN
  3367.  
  3368. C    ******************
  3369. C    RELEASE THE DEVICE
  3370. 600    CONTINUE
  3371.  
  3372. C    DE-ASSIGN THE CHANNAL
  3373.     CALL GB_EMPTY
  3374.     CALL GB_FINISH (unreserve)
  3375.     CALL GB_EMPTY
  3376.       call sys$dalloc (namdev)
  3377.     RETURN
  3378.  
  3379. C    *****************************
  3380. C    RETURN DEVICE CHARACTERISTICS
  3381. 700    CONTINUE
  3382.     DO 720 I=1,8
  3383.     XA(I) = DCHAR(I)
  3384. 720    CONTINUE
  3385.     RETURN
  3386.  
  3387. C    ****************************
  3388. C    SELECT CURRENT DRAWING COLOR
  3389. 800   LDUMMY = GB_TEST_FLUSH(24)
  3390.       call gb_in_string (lineindex)
  3391.       call intto4692 (xa(1))
  3392.       call gb_in_string (textindex)
  3393.       call intto4692 (xa(1))
  3394.       call gb_in_string (fillpattern)
  3395.       call intto4692 (xa(1))
  3396.       LVECTOR_GOING = .FALSE.
  3397.       RETURN
  3398.  
  3399. c  **********************
  3400. c  PERFORM GRAPHICS INPUT
  3401. 900   RETURN
  3402.  
  3403. c  *******************
  3404. c  DRAW FILLED POLYGON
  3405. 1000  ldummy = gb_test_flush (11)
  3406.       CALL GB_IN_STRING (beginpanel)
  3407.       if (tall) then
  3408.     Ix = xdm1 -tallx*YA(1)+0.5
  3409.     Iy = tally*XA(1)+0.5
  3410.       else
  3411.     IX = XGUPCM*XA(1)+0.5
  3412.     IY = YGUPCM*YA(1)+0.5
  3413.       endif
  3414.       call xyto4692 (ix,iy)
  3415.       call gb_insert ('0')
  3416.       call gb_insert (gs)
  3417.       LVECTOR_GOING = .FALSE.
  3418.       NPTS = IFXN - 1024
  3419.       DO 1010 I = 2, NPTS
  3420.       LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(5))
  3421.       IF (.NOT. LVECTOR_GOING) then
  3422.         ldummy = gb_test_flush (11)
  3423.         lvector_going = .true.
  3424.         CALL GB_INSERT(GS)
  3425.       endif
  3426.       if (tall) then
  3427.     Ix = xdm1 -tallx*YA(i)+0.5
  3428.     Iy = tally*XA(i)+0.5
  3429.       else
  3430.     IX = XGUPCM*XA(i)+0.5
  3431.     IY = YGUPCM*YA(i)+0.5
  3432.       endif
  3433. 1010  call xyto4692 (ix,iy)
  3434.       CALL GB_IN_STRING (endpanel)
  3435.       LVECTOR_GOING = .FALSE.
  3436.       RETURN
  3437.  
  3438. c******************************************************************************
  3439.       entry GD4692n (IFXN,XA,YA)
  3440. c  Tektronix 4692 narrow driver.
  3441.  
  3442.       tall = .true.
  3443.       go to 10
  3444.       END
  3445.  
  3446. c******************************************************************************
  3447. c******************************************************************************
  3448.       subroutine intto4692 (f)
  3449. c  insert char(f) into buffer.
  3450.       byte ic(5)
  3451.  
  3452.       i = abs(f)
  3453.       ic(4) = mod(i,2**4) +2**5
  3454.       if (f.ge..0) ic(4) = ic(4) +2**4
  3455.       ic(3) = mod(i/(2**4),2**6) +64
  3456.       ic(2) = mod(i/(2**10),2**6) +64
  3457.       ic(1) = mod(i/(2**16),2**6) +64
  3458.       n = 4
  3459.       if (ic(3).ne.64) n = 3
  3460.       if (ic(2).ne.64) n = 2
  3461.       if (ic(1).ne.64) n = 1
  3462.       call gb_in_string (ic(n))
  3463.       return
  3464.       end
  3465.  
  3466. c******************************************************************************
  3467. c******************************************************************************
  3468.       subroutine xyto4692 (ix,iy)
  3469. c  convert (ix,iy) to Tektronix 4692 code.
  3470.  
  3471.       call gb_insert (32 +iy/128)
  3472.       call gb_insert (96 +mod(ix,4) +4*mod(iy,4))
  3473.       call gb_insert (96 +mod(iy/4,32))
  3474.       call gb_insert (32 +ix/128)
  3475.       call gb_insert (64 +mod(ix/4,32))
  3476.       return
  3477.       end
  3478.     SUBROUTINE GD550(IFXN,XA,YA)
  3479.     DIMENSION XA(8), YA(3)
  3480. C
  3481. C    Visual 550 DRIVER FOR DIGLIB/VAX V3.
  3482. C    Modified so a scrolling    window is set at the top of the
  3483. C    screen for user interaction.
  3484. C    Joe P. Garbarini Jr.  30-May-1984
  3485. C
  3486. C---------------------------------------------------------------------------
  3487. C
  3488.     BYTE ESC, CSUB, GS, US, CR, FF
  3489.     BYTE CAN
  3490.     PARAMETER (ESC=27, CSUB=26, GS=29, US=31, CR=13, FF=12)
  3491.     PARAMETER (CAN=24)
  3492.     CHARACTER*(*) TERMINAL
  3493.     PARAMETER (TERMINAL='TT')
  3494. C
  3495. C    DEFINITIONS FOR DEVICE CONTROL
  3496. C
  3497.     BYTE STR_END(2)
  3498.     DATA STR_END /CAN,0/
  3499. C
  3500.     BYTE STR_BEGIN_PLOT(8)
  3501.     DATA STR_BEGIN_PLOT /ESC,FF,ESC,'/','1','h',2*0/
  3502. C
  3503.     BYTE STR_COLOR_SET(6)
  3504.     DATA STR_COLOR_SET /ESC,'/','0','d',2*0/
  3505. C
  3506.     LOGICAL*1 V_300(6)
  3507.     LOGICAL*1 V_CAN(2),V_BOTH(6),V_ERA(6),V_SCR(10),V_1TO1(6)
  3508.     DATA V_300  /ESC,'[','?','2','h',0/
  3509.     DATA V_CAN  /CAN, 0/
  3510.     DATA V_BOTH /ESC,'[','?','5','v',0/
  3511.     DATA V_ERA  /ESC,'[','2','J',0, 0/
  3512.     DATA V_SCR  /ESC,'[','1',';','4','r',4*0/
  3513. C
  3514. C    DEFINITIONS FOR GIN
  3515. C
  3516.     BYTE GINBUFR(8), PROMPT(4)
  3517.     DATA PROMPT /ESC, CSUB, 2*0/
  3518.     DATA IGIN_IN_CHARS /5/
  3519. C
  3520. C    DECLARE BUFFERING FUNCTION
  3521. C
  3522.     LOGICAL GB_TEST_FLUSH
  3523. C
  3524. C    DECLARE VARS NEED FOR DRIVER OPERATION
  3525. C
  3526.     LOGICAL LVECTOR_GOING, LDUMMY
  3527.     DIMENSION DCHAR(8)
  3528. C
  3529. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  3530. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  3531. C
  3532.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  3533. CC
  3534. C    FULL SCREEN
  3535. C 
  3536. C    DATA DCHAR /550.0,23.36,17.79,32.88,32.88,1.0,133.0,1.0/
  3537. CC
  3538. C    SPLIT SCREEN
  3539. C
  3540.     DATA DCHAR /550.0,23.36,15.69,32.88,32.88,1.0,133.0,1.0/
  3541. CC
  3542. C
  3543. C*****************
  3544. C
  3545. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  3546. C
  3547.     IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN
  3548. C
  3549. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  3550. C
  3551.     GO TO (100,200,300,400,500,600,700,800,900) IFXN
  3552. C
  3553. C    *********************
  3554. C    INITIALIZE THE DEVICE
  3555. C    *********************
  3556. C
  3557. 100    CONTINUE
  3558. C
  3559. C    FIRST, INITIALIZE THE BUFFER SUBROUTINES
  3560. C
  3561.     CALL GB_INITIALIZE(0,STR_END,TERMINAL,IERR)
  3562.     YA(1) = IERR
  3563.     IF (IERR .NE. 0) RETURN
  3564.     LVECTOR_GOING = .FALSE.
  3565. C
  3566. C    SET UP THE SPLIT SCREEN
  3567. C
  3568.     CALL GB_IN_STRING(V_CAN)
  3569.     CALL GB_IN_STRING(V_300)
  3570.     CALL GB_IN_STRING(V_BOTH)
  3571.     CALL GB_IN_STRING(V_ERA)
  3572.     CALL GB_IN_STRING(V_SCR)
  3573.     CALL GB_EMPTY
  3574. C
  3575.     RETURN
  3576. C
  3577. C    **************************
  3578. C    GET FRESH PLOTTING SURFACE
  3579. C    **************************
  3580. C
  3581. 200    CONTINUE
  3582.     CALL GB_EMPTY
  3583.     CALL GB_IN_STRING(STR_BEGIN_PLOT)
  3584.     CALL GB_EMPTY
  3585.     LVECTOR_GOING = .FALSE.
  3586.     RETURN
  3587. C
  3588. C    ****
  3589. C    MOVE
  3590. C    ****
  3591. C
  3592. 300    CONTINUE
  3593. C    CONVERT CM. TO GRAPHICS UNITS ROUNDED
  3594.     IXPOSN = XGUPCM*XA(1)+0.5
  3595.     IYPOSN = YGUPCM*YA(1)+0.5
  3596.     LVECTOR_GOING = .FALSE.
  3597.     RETURN
  3598. C
  3599. C    ****
  3600. C    DRAW
  3601. C    ****
  3602. C
  3603. 400    CONTINUE
  3604.     IX = XGUPCM*XA(1)+0.5
  3605.     IY = YGUPCM*YA(1)+0.5
  3606.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4))
  3607.     IF (LVECTOR_GOING) GO TO 410
  3608.     LDUMMY = GB_TEST_FLUSH(9)
  3609.     LVECTOR_GOING = .TRUE.
  3610.     CALL GB_INSERT(GS)
  3611.     CALL GD_4010_CONVERT(IXPOSN,IYPOSN)
  3612. 410    CALL GD_4010_CONVERT(IX,IY)
  3613.     IXPOSN = IX
  3614.     IYPOSN = IY
  3615.     RETURN
  3616. C
  3617. C    *****************************
  3618. C    FLUSH GRAPHICS COMMAND BUFFER
  3619. C    *****************************
  3620. C
  3621. 500    CONTINUE
  3622.     CALL GB_EMPTY
  3623.     CALL GB_INSERT(GS)
  3624.     CALL GD_4010_CONVERT(0,584)
  3625.     CALL GB_EMPTY
  3626.     LVECTOR_GOING = .FALSE.
  3627.     RETURN
  3628. C
  3629. C    ******************
  3630. C    RELEASE THE DEVICE
  3631. C    ******************
  3632. C
  3633. 600    CONTINUE
  3634. C
  3635. C    DE-ASSIGN THE CHANNAL
  3636. C
  3637.     CALL GB_FINISH(0)
  3638.     RETURN
  3639. C
  3640. C    *****************************
  3641. C    RETURN DEVICE CHARACTERISTICS
  3642. C    *****************************
  3643. C
  3644. 700    CONTINUE
  3645.     DO 720 I=1,8
  3646.     XA(I) = DCHAR(I)
  3647. 720    CONTINUE
  3648.     RETURN
  3649. C
  3650. C    ****************************
  3651. C    SELECT CURRENT DRAWING COLOR
  3652. C    ****************************
  3653. C
  3654. 800    CONTINUE
  3655.     CALL GB_EMPTY
  3656.     ICOLOR = XA(1)
  3657.     IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 1) RETURN
  3658.     IF (ICOLOR .EQ. 1) THEN
  3659.       STR_COLOR_SET(3) = 48
  3660.     ELSE
  3661.       STR_COLOR_SET(3) = 49
  3662.     ENDIF
  3663.     CALL GB_INSERT(GS)
  3664.     CALL GB_IN_STRING(STR_COLOR_SET)
  3665.     CALL GB_EMPTY
  3666.     LVECTOR_GOING = .FALSE.
  3667.     RETURN
  3668. C
  3669. C    **********************
  3670. C    PERFORM GRAPHICS INPUT
  3671. C    **********************
  3672. C
  3673. 900    CONTINUE
  3674.     CALL GB_EMPTY
  3675.     LVECTOR_GOING = .FALSE.
  3676. C
  3677. C    ASK FOR 1 GIN INPUT
  3678. C
  3679. C
  3680.     CALL GB_SEND_CHARS(GS,1)
  3681.     CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR)
  3682. C
  3683.     ICHAR = GINBUFR(1)
  3684.     IX1 = GINBUFR(2)
  3685.     IX2 = GINBUFR(3)
  3686.     IY1 = GINBUFR(4)
  3687.     IY2 = GINBUFR(5)
  3688. C
  3689.     XA(1) = IAND(ICHAR,127)        !PICK CHARACTER
  3690.     XA(2) = (32*IAND(IX1,31)+IAND(IX2,31))/XGUPCM
  3691.     XA(3) = (32*IAND(IY1,31)+IAND(IY2,31))/YGUPCM
  3692. C
  3693.     CALL GB_SEND_CHARS(CAN,1)
  3694. C
  3695.     RETURN
  3696.     END
  3697.     SUBROUTINE GD9400(IFXN,XA,YA)
  3698.     DIMENSION XA(8), YA(3)
  3699. C
  3700. C    RAMTEK 9400 (WITHOUT LUT) DRIVER FOR DIGLIB/VAX
  3701. C        CURRENTLY CONFIGURED FOR 640X512
  3702. C
  3703. C-----------------------------------------------------------------------
  3704. C
  3705.     PARAMETER (MAXY=511)
  3706.     PARAMETER (IBUFFER_SIZE=256)
  3707.     CHARACTER*(*) DEVICE_NAME
  3708.     PARAMETER (DEVICE_NAME='_RAM0:')
  3709.     INTEGER*2 IWVL_AND_OP1, IWVL_PLAIN, ICOP_AND_FOREGROUND
  3710.     PARAMETER (IWVL_AND_OP1 = '0E03'X)
  3711.     PARAMETER (IWVL_PLAIN = '0E01'X)
  3712.     PARAMETER (ICOP_AND_FOREGROUND = '8002'X)
  3713.     DIMENSION DCHAR(8)
  3714.     INTEGER*4 SYS$ASSIGN, SYS$QIOW, SYS$DASSGN
  3715.     INTEGER*2 IOCHANTT, IX, IY, ICURRENT_COLOR, ICOLOR_MAP(0:7)
  3716.     INTEGER*2 BUFFER(IBUFFER_SIZE), IOCHAN
  3717.     INTEGER*2 INIT_RAMTEK(4), IERASE_RAMTEK
  3718.     INTEGER*2 IWRITE_CURSOR(3), IREAD_CURSOR
  3719.     LOGICAL*2 LMOVED
  3720.     BYTE CHARBUFR
  3721.     SAVE DCHAR, IOREADNOECHO
  3722.     SAVE IOCHAN, IOCHANTT, BUFFER, IBUFFER_POINTER, INITIAL_POINTER
  3723.     SAVE ICOLOR_MAP, ICURRENT_COLOR, IXPOSN, IYPOSN, LMOVED
  3724.     SAVE INIT_RAMTEK, INIT_BYTES, IERASE_RAMTEK, IERASE_BYTES
  3725.     SAVE IWRITE_CURSOR, IREAD_CURSOR, IOREADLBLK
  3726. C
  3727. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  3728. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  3729. C
  3730.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  3731. C
  3732. C    DATA WE WILL NEED
  3733. C
  3734.     DATA DCHAR /9400.0, 32.803, 26.232, 19.48, 19.48, 15.0, 149.0, 1.0/
  3735.     DATA ICOLOR_MAP / 0, 7, 1, 2, 4, 3, 5, 6 /
  3736.     DATA IOREADNOECHO /'00000071'X/
  3737.     DATA INIT_RAMTEK /'0600'X, '3300'X, 1, '3400'X/
  3738.     DATA INIT_BYTES /8/
  3739.     DATA IERASE_RAMTEK /'0900'X/
  3740.     DATA IERASE_BYTES /2/
  3741.     DATA IWRITE_CURSOR /'2C00'X, 320, 256/
  3742.     DATA IREAD_CURSOR /'2E00'X/
  3743.     DATA IWRITE_BYTES, IREAD_BYTES / 6, 2/
  3744.     DATA IOREADLBLK /'00000021'X/
  3745. C
  3746. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  3747. C
  3748.     IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN
  3749. C
  3750. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  3751. C
  3752.     GO TO (100,200,300,400,500,600,700,800,900) IFXN
  3753. C
  3754. C    *********************
  3755. C    INITIALIZE THE DEVICE
  3756. C    *********************
  3757. C
  3758. 100    CONTINUE
  3759. C
  3760. C    FIND THE I/O CHANNAL ASSICIATED WITH THE TERMINAL FOR DOING GINS
  3761. C
  3762.     ISTAT = SYS$ASSIGN(DEVICE_NAME,IOCHAN,,)
  3763. D    TYPE *,'DEVICE NAME ASSIGNMENT STATUS IS ',ISTAT
  3764.     IF (.NOT. ISTAT) THEN
  3765.         YA(1) = 1.0
  3766.         RETURN
  3767.     ENDIF
  3768.     ISTAT = SYS$ASSIGN('TT',IOCHANTT,,)
  3769. D    TYPE *,'ASSIGN STATUS IS ',ISTAT
  3770.     IF (.NOT. ISTAT) THEN
  3771.         YA(1) = 2.0
  3772.         RETURN
  3773.         ELSE
  3774.         YA(1) = 0.0
  3775.     ENDIF
  3776. C
  3777. C    INITIALIZE THE RAMTEK
  3778. C
  3779.     CALL GD94WRITE(INIT_RAMTEK,INIT_BYTES,IOCHAN)
  3780. 190    ICURRENT_COLOR = ICOLOR_MAP(1)
  3781.     LMOVED = .TRUE.
  3782.     IBUFFER_POINTER = 1
  3783.     RETURN
  3784. C
  3785. C    **************************
  3786. C    GET FRESH PLOTTING SURFACE
  3787. C    **************************
  3788. C
  3789. 200    CONTINUE
  3790. C
  3791. C    ERASE THE RAMTEK SCREEN AND RETURN TO NORMAL
  3792. C
  3793.     CALL GD94WRITE(IERASE_RAMTEK, IERASE_BYTES, IOCHAN)
  3794.     GO TO 190
  3795. C
  3796. C    ****
  3797. C    MOVE
  3798. C    ****
  3799. C
  3800. 300    CONTINUE
  3801. C    CONVERT CM. TO GRAPHICS UNITS ROUNDED
  3802.     IXPOSN = XGUPCM*XA(1)+0.5
  3803.     IYPOSN = MAXY - INT(YGUPCM*YA(1)+0.5)
  3804.     LMOVED = .TRUE.
  3805.     RETURN
  3806. C
  3807. C    ****
  3808. C    DRAW
  3809. C    ****
  3810. C
  3811. 400    CONTINUE
  3812.     IX = XGUPCM*XA(1)+0.5
  3813.     IY = MAXY - INT(YGUPCM*YA(1)+0.5)
  3814.     IF (.NOT. LMOVED) GO TO 450
  3815.     IF (IBUFFER_POINTER .LT. (IBUFFER_SIZE-10)) GO TO 420
  3816.     CALL GD94WRITE(BUFFER,2*(IBUFFER_POINTER-1),IOCHAN)
  3817.     IBUFFER_POINTER = 1
  3818. 420    BUFFER(IBUFFER_POINTER) = IWVL_AND_OP1
  3819.     BUFFER(IBUFFER_POINTER+1) = ICOP_AND_FOREGROUND
  3820.     BUFFER(IBUFFER_POINTER+2) = ICURRENT_COLOR
  3821.     BUFFER(IBUFFER_POINTER+3) = IXPOSN
  3822.     BUFFER(IBUFFER_POINTER+4) = IYPOSN
  3823.     BUFFER(IBUFFER_POINTER+5) = 0
  3824.     INDEX_NBYTES = IBUFFER_POINTER + 5
  3825.     IBUFFER_POINTER = IBUFFER_POINTER + 6
  3826.     LMOVED = .FALSE.
  3827.     GO TO 460
  3828. 450    IF (IBUFFER_POINTER .LE. (IBUFFER_SIZE-2)) GO TO 460
  3829.     CALL GD94WRITE(BUFFER,2*(IBUFFER_POINTER-1),IOCHAN)
  3830.     IBUFFER_POINTER = 3
  3831.     BUFFER(1) = IWVL_PLAIN
  3832.     BUFFER(2) = 0
  3833.     INDEX_NBYTES = 2
  3834. 460    BUFFER(IBUFFER_POINTER) = IX
  3835.     BUFFER(IBUFFER_POINTER+1) = IY
  3836.     IBUFFER_POINTER = IBUFFER_POINTER+2
  3837.     IXPOSN = IX
  3838.     IYPOSN = IY
  3839. C
  3840. C    COUNT BYTES OF DATA
  3841. C
  3842.     BUFFER(INDEX_NBYTES) = BUFFER(INDEX_NBYTES) + 4
  3843.     RETURN
  3844. C
  3845. C    *****************************
  3846. C    FLUSH GRAPHICS COMMAND BUFFER
  3847. C    *****************************
  3848. C
  3849. 500    CONTINUE
  3850.     IF (IBUFFER_POINTER .EQ. 1) RETURN
  3851.     CALL GD94WRITE(BUFFER,2*(IBUFFER_POINTER-1),IOCHAN)
  3852.     IBUFFER_POINTER = 1
  3853.     LMOVED = .TRUE.
  3854.     RETURN
  3855. C
  3856. C    ******************
  3857. C    RELEASE THE DEVICE
  3858. C    ******************
  3859. C
  3860. 600    CONTINUE
  3861. C
  3862. C    DE-ASSIGN THE CHANNALS
  3863. C
  3864.     ISTAT = SYS$DASSGN(%VAL(IOCHAN))
  3865.     ISTAT = SYS$DASSGN(%VAL(IOCHANTT))
  3866.     RETURN
  3867. C
  3868. C    *****************************
  3869. C    RETURN DEVICE CHARACTERISTICS
  3870. C    *****************************
  3871. C
  3872. 700    CONTINUE
  3873.     DO 720 I=1,8
  3874.     XA(I) = DCHAR(I)
  3875. 720    CONTINUE
  3876.     RETURN
  3877. C
  3878. C    ****************************
  3879. C    SELECT CURRENT DRAWING COLOR
  3880. C    ****************************
  3881. C
  3882. 800    CONTINUE
  3883.     ICOLOR = ICOLOR_MAP(INT(XA(1)))
  3884.     IF (ICOLOR .EQ. ICURRENT_COLOR) RETURN
  3885.     ICURRENT_COLOR = ICOLOR
  3886.     LMOVED = .TRUE.
  3887.     RETURN
  3888. C
  3889. C    **********************
  3890. C    PERFORM GRAPHICS INPUT
  3891. C    **********************
  3892. C
  3893. 900    CONTINUE
  3894.     IF (IBUFFER_POINTER .EQ. 1) GO TO 910
  3895.     CALL GD94WRITE(BUFFER,2*(IBUFFER_POINTER-1),IOCHAN)
  3896.     IBUFFER_POINTER = 1
  3897.     LMOVED = .TRUE.
  3898. C
  3899. C    SET VISIBLE BIT TO MAKE CURSOR VISIBLE
  3900. C
  3901. 910    IWRITE_CURSOR(3) = IOR(IWRITE_CURSOR(3),'0400'X)
  3902. C
  3903. C    BRING UP CURSOR AT LAST KNOWN LOCATION
  3904. C
  3905.     CALL GD94WRITE(IWRITE_CURSOR, IWRITE_BYTES, IOCHAN)
  3906. C
  3907. C    ASK FOR 1 CHARACTER FROM THE TERMINAL
  3908. C
  3909.     ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHANTT),%VAL(IOREADNOECHO),
  3910.     1   IOSB, , ,CHARBUFR,%VAL(1), , , , )
  3911.     IF (.NOT. ISTAT) STOP 'GD9400 - GIN FAILURE'
  3912. C
  3913. C    TELL 9400 WE WANT TO READ THE CURSOR
  3914. C
  3915.     CALL GD94WRITE(IREAD_CURSOR, IREAD_BYTES, IOCHAN)
  3916. C
  3917. C    READ THE CURSOR LOCATION INTO THE "WRITE CURSOR" AREA SO THE NEXT
  3918. C    "WRITE CURSOR" WILL PLACE THE CURSOR AT THIS NEW LOCATION.
  3919. C
  3920.     ISTAT = SYS$QIOW(%VAL(0), %VAL(IOCHAN), %VAL(IOREADLBLK),
  3921.     1   IOSB, , ,IWRITE_CURSOR(2), %VAL(4), , , , )
  3922.     IF (.NOT. ISTAT) STOP 'GD9400 - RAMTEK READ ERROR'
  3923. D    TYPE *,'CURSOR LOCATION ',IWRITE_CURSOR(2), IWRITE_CURSOR(3)
  3924. C
  3925. C    GET THE KEY, X POSITION, AND Y POSITION
  3926. C
  3927.     XA(1) = CHARBUFR        !PICK CHARACTER
  3928.     IWRITE_CURSOR(2) = IAND(IWRITE_CURSOR(2), '07FF'X)
  3929.     IWRITE_CURSOR(3) = IAND(IWRITE_CURSOR(3), '03FF'X)
  3930.     XA(2) = FLOAT(IWRITE_CURSOR(2))/XGUPCM    !X IN CENTIMETERS.
  3931.     XA(3) = FLOAT(MAXY-IWRITE_CURSOR(3))/YGUPCM    !Y IN CM.
  3932. C
  3933. C    MAKE THE CURSOR INVISIBLE
  3934. C
  3935.     CALL GD94WRITE(IWRITE_CURSOR, IWRITE_BYTES, IOCHAN)
  3936.     RETURN
  3937.     END
  3938.     SUBROUTINE GD94WRITE(BUFFER,NBYTES,IOCHAN)
  3939. C
  3940. C    THIS SUBROUTINE EMPTYS THE BUFFER IF IT HAS ANYTHING
  3941. C
  3942.     INTEGER*2 BUFFER(NBYTES/2)
  3943.     INTEGER*2 IOSB(4)
  3944.     INTEGER*4 SYS$QIOW
  3945.     SAVE IOWRITE
  3946.     DATA IOWRITE /'00000020'X/
  3947. D    TYPE 9999, NBYTES, (BUFFER(I), BUFFER(I), I=1,NBYTES/2)
  3948. D9999    FORMAT(' GD9400WRITE'/' BYTE COUNT IS ',I6/
  3949. D    1   128(1X,Z4,'H',4X,O6/))
  3950.     ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN),%VAL(IOWRITE),
  3951.     1   IOSB, , ,BUFFER,%VAL(NBYTES), , , , )
  3952. D    TYPE *,'GD9400 WRITE STATUS IS ',ISTAT
  3953.     IF (.NOT. ISTAT) STOP 'GD9400 - WRITE ERROR'
  3954.     RETURN
  3955.     END
  3956.  
  3957.     SUBROUTINE GD9400LUT(IFXN,XA,YA)
  3958.     DIMENSION XA(8), YA(3)
  3959. C
  3960. C    RAMTEK 9400 WITH LUT DRIVER FOR DIGLIB/VAX
  3961. C        CURRENTLY CONFIGURED FOR 1280x1024 AND TYPE 7A LUT
  3962. C
  3963. C-----------------------------------------------------------------------
  3964. C
  3965.     PARAMETER (MAXY=1023)
  3966.     CHARACTER*(*) DEVICE_NAME
  3967.     PARAMETER (DEVICE_NAME='RAA0:')
  3968.  
  3969. C    **********
  3970.     INTEGER*2 IOCHAN
  3971.     COMMON /GD9400_IO/ IOCHAN
  3972. C    **********
  3973.  
  3974.     DIMENSION DCHAR(8)
  3975.  
  3976.     INTEGER*4 SYS$ASSIGN, SYS$QIOW, SYS$DASSGN
  3977.     INTEGER*2 IOCHANTT
  3978.  
  3979.     INTEGER*2 INIT_RAMTEK(19), IERASE_RAMTEK
  3980.     INTEGER*2 IWRITE_CURSOR(3), IREAD_CURSOR
  3981.     INTEGER*2 LOAD_LUT(7)
  3982.     BYTE CHARBUFR
  3983. C
  3984. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  3985. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  3986. C
  3987.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  3988. C
  3989. C    DATA WE WILL NEED
  3990. C
  3991.     DATA DCHAR /9400.9, 32.8285, 26.258, 38.96, 38.96, 255.0, 213.0, 1.0/
  3992.     DATA IOREADNOECHO /'00000071'X/
  3993.     DATA INIT_RAMTEK /'0600'X, '2700'X, '3300'X, 1, '3400'X, '0300'X, 0,
  3994.     1   16, 0, 4095, 3840, 240, 15, 4080, 3855, 255, '0300'X, 0, 0/
  3995.     DATA INIT_BYTES /38/
  3996.     DATA IERASE_RAMTEK /'2B00'X/
  3997.     DATA IERASE_BYTES /2/
  3998.     DATA IWRITE_CURSOR /'2C01'X, 320, 256/
  3999.     DATA IREAD_CURSOR /'2E01'X/
  4000.     DATA IWRITE_BYTES, IREAD_BYTES / 6, 2/
  4001.     DATA IOREADLBLK /'00000021'X/
  4002.     DATA LOAD_LUT /'0300'X, 0, 0, 0, '0300'X, 0, 0/
  4003.     DATA LOAD_LUT_BYTES /14/
  4004. C
  4005. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  4006. C
  4007.     IF (IFXN .LE. 0 .OR. IFXN .GT. 10) RETURN
  4008. C
  4009. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  4010. C
  4011.     GO TO (100,200,300,300,500,600,700,800,900,1000) IFXN
  4012. C
  4013. C    *********************
  4014. C    INITIALIZE THE DEVICE
  4015. C    *********************
  4016. C
  4017. 100    CONTINUE
  4018. C
  4019. C    FIND THE I/O CHANNAL ASSICIATED WITH THE TERMINAL FOR DOING GINS
  4020. C
  4021.     ISTAT = SYS$ASSIGN(DEVICE_NAME,IOCHAN,,)
  4022. D    TYPE *,'DEVICE NAME ASSIGNMENT STATUS IS ',ISTAT
  4023.     IF (.NOT. ISTAT) THEN
  4024.         YA(1) = 1.0
  4025.         RETURN
  4026.     ENDIF
  4027.     ISTAT = SYS$ASSIGN('TT',IOCHANTT,,)
  4028. D    TYPE *,'ASSIGN STATUS IS ',ISTAT
  4029.     IF (.NOT. ISTAT) THEN
  4030.         YA(1) = 2.0
  4031.         RETURN
  4032.         ELSE
  4033.         YA(1) = 0.0
  4034.     ENDIF
  4035. C
  4036. C    INITIALIZE THE RAMTEK
  4037. C
  4038.     CALL GD94WRITE(INIT_RAMTEK,INIT_BYTES)
  4039. 190    CALL GD9400_BUFRINIT
  4040.     RETURN
  4041. C
  4042. C    **************************
  4043. C    GET FRESH PLOTTING SURFACE
  4044. C    **************************
  4045. C
  4046. 200    CONTINUE
  4047. C
  4048. C    ERASE THE RAMTEK SCREEN AND RETURN TO NORMAL
  4049. C
  4050.     CALL GD94WRITE(IERASE_RAMTEK, IERASE_BYTES)
  4051.     GO TO 190
  4052. C
  4053. C    *************
  4054. C    MOVE AND DRAW
  4055. C    *************
  4056. C
  4057. 300    CONTINUE
  4058. C
  4059. C    CONVERT CM. TO GRAPHICS UNITS ROUNDED
  4060. C
  4061.     IX = XGUPCM*XA(1) + 0.5
  4062.     IY = MAXY - INT(YGUPCM*YA(1) + 0.5)
  4063.     IF (IFXN .EQ. 3) THEN
  4064.         CALL GD9400_MOVE(IX,IY)
  4065.         ELSE
  4066.         CALL GD9400_DRAW(IX,IY)
  4067.     ENDIF
  4068.     RETURN
  4069. C
  4070. C    *****************************
  4071. C    FLUSH GRAPHICS COMMAND BUFFER
  4072. C    *****************************
  4073. C
  4074. 500    CONTINUE
  4075.     CALL GD9400_FLUSH
  4076.     RETURN
  4077. C
  4078. C    ******************
  4079. C    RELEASE THE DEVICE
  4080. C    ******************
  4081. C
  4082. 600    CONTINUE
  4083. C
  4084. C    DE-ASSIGN THE CHANNALS
  4085. C
  4086.     ISTAT = SYS$DASSGN(%VAL(IOCHAN))
  4087.     ISTAT = SYS$DASSGN(%VAL(IOCHANTT))
  4088.     RETURN
  4089. C
  4090. C    *****************************
  4091. C    RETURN DEVICE CHARACTERISTICS
  4092. C    *****************************
  4093. C
  4094. 700    CONTINUE
  4095.     DO 720 I=1,8
  4096.     XA(I) = DCHAR(I)
  4097. 720    CONTINUE
  4098.     RETURN
  4099. C
  4100. C    ****************************
  4101. C    SELECT CURRENT DRAWING COLOR
  4102. C    ****************************
  4103. C
  4104. 800    CONTINUE
  4105.     CALL GD9400_COLOR_SET(INT(XA(1)))
  4106.     RETURN
  4107. C
  4108. C    **********************
  4109. C    PERFORM GRAPHICS INPUT
  4110. C    **********************
  4111. C
  4112. 900    CONTINUE
  4113.     CALL GD9400_FLUSH
  4114. C
  4115. C    SET VISIBLE BIT TO MAKE CURSOR VISIBLE
  4116. C
  4117. 910    IWRITE_CURSOR(3) = IOR(IWRITE_CURSOR(3),'0400'X)
  4118. C
  4119. C    BRING UP CURSOR AT LAST KNOWN LOCATION
  4120. C
  4121.     CALL GD94WRITE(IWRITE_CURSOR, IWRITE_BYTES)
  4122. C
  4123. C    ASK FOR 1 CHARACTER FROM THE TERMINAL
  4124. C
  4125.     ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHANTT),%VAL(IOREADNOECHO),
  4126.     1   IOSB, , ,CHARBUFR,%VAL(1), , , , )
  4127.     IF (.NOT. ISTAT) STOP 'GD9400 - GIN FAILURE'
  4128. C
  4129. C    TELL 9400 WE WANT TO READ THE CURSOR
  4130. C
  4131.     CALL GD94WRITE(IREAD_CURSOR, IREAD_BYTES)
  4132. C
  4133. C    READ THE CURSOR LOCATION INTO THE "WRITE CURSOR" AREA SO THE NEXT
  4134. C    "WRITE CURSOR" WILL PLACE THE CURSOR AT THIS NEW LOCATION.
  4135. C
  4136.     ISTAT = SYS$QIOW(%VAL(0), %VAL(IOCHAN), %VAL(IOREADLBLK),
  4137.     1   IOSB, , ,IWRITE_CURSOR(2), %VAL(4), , , , )
  4138.     IF (.NOT. ISTAT) STOP 'GD9400 - RAMTEK READ ERROR'
  4139. D    TYPE *,'CURSOR LOCATION ',IWRITE_CURSOR(2), IWRITE_CURSOR(3)
  4140. C
  4141. C    GET THE KEY, X POSITION, AND Y POSITION
  4142. C
  4143.     XA(1) = CHARBUFR        !PICK CHARACTER
  4144.     IWRITE_CURSOR(2) = IAND(IWRITE_CURSOR(2), '07FF'X)
  4145.     IWRITE_CURSOR(3) = IAND(IWRITE_CURSOR(3), '03FF'X)
  4146.     XA(2) = FLOAT(IWRITE_CURSOR(2))/XGUPCM    !X IN CENTIMETERS.
  4147.     XA(3) = FLOAT(MAXY-IWRITE_CURSOR(3))/YGUPCM    !Y IN CM.
  4148. C
  4149. C    MAKE THE CURSOR INVISIBLE
  4150. C
  4151.     CALL GD94WRITE(IWRITE_CURSOR, IWRITE_BYTES)
  4152.     RETURN
  4153. C
  4154. C    **************************
  4155. C    SET COLOR USING RGB VALUES
  4156. C    **************************
  4157. C
  4158. 1000    LOAD_LUT(2) = XA(1)    !DIGLIB COLOR IS LUT ADDRESS
  4159.     LOAD_LUT(3) = 2        !2 BYTES TO SET A SINGLE COLOR
  4160.     LOAD_LUT(4) = 256*INT(0.15*YA(1))
  4161.     1    + 16*INT(0.15*YA(2)) + INT(0.15*YA(3))
  4162.     CALL GD94WRITE(LOAD_LUT,LOAD_LUT_BYTES)
  4163.     RETURN
  4164.     END
  4165.     SUBROUTINE GD9400_MOVE(IX,IY)
  4166. C
  4167. C    **********
  4168.     PARAMETER (IBUFFER_SIZE = 512)
  4169.     INTEGER*2 IBUFFER
  4170.     LOGICAL LMOVED, LCOLOR_CHANGED
  4171.     COMMON /GD9400_MD/ IBUFFER(IBUFFER_SIZE), ICURRENT_COLOR,
  4172.     1   IXPOSN, IYPOSN, IBUFFER_POINTER, LMOVED, LCOLOR_CHANGED
  4173. C    **********
  4174. C
  4175.     LMOVED = .TRUE.
  4176.     IXPOSN = IX
  4177.     IYPOSN = IY
  4178.     RETURN
  4179.     END
  4180.     SUBROUTINE GD9400_DRAW(IX,IY)
  4181. C
  4182. C    **********
  4183.     PARAMETER (IBUFFER_SIZE = 512)
  4184.     INTEGER*2 IBUFFER
  4185.     LOGICAL LMOVED, LCOLOR_CHANGED
  4186.     COMMON /GD9400_MD/ IBUFFER(IBUFFER_SIZE), ICURRENT_COLOR,
  4187.     1   IXPOSN, IYPOSN, IBUFFER_POINTER, LMOVED, LCOLOR_CHANGED
  4188. C    **********
  4189. C
  4190.     INTEGER*2 IWVL_AND_OP1, ICOP, ICOP_AND_FOREGROUND
  4191.     PARAMETER (IWVL_AND_OP1 = '0E03'X)
  4192.     PARAMETER (ICOP = '8000'X)
  4193.     PARAMETER (ICOP_AND_FOREGROUND = '8002'X)
  4194.     LOGICAL GD9400_FLUSHIF, LDUMMY
  4195. C
  4196. D    TYPE *,'GD9400_DRAW: IBUFFER_POINTER = ',IBUFFER_POINTER
  4197.     IF (LCOLOR_CHANGED .OR. LMOVED .OR. GD9400_FLUSHIF(2)) THEN
  4198.         LDUMMY = GD9400_FLUSHIF(9)
  4199.         IBUFFER(IBUFFER_POINTER) = IWVL_AND_OP1
  4200.         IBUFFER(IBUFFER_POINTER+1) = ICOP_AND_FOREGROUND
  4201.         IBUFFER(IBUFFER_POINTER+2) = ICURRENT_COLOR
  4202.         IBUFFER(IBUFFER_POINTER+3) = IXPOSN
  4203.         IBUFFER(IBUFFER_POINTER+4) = IYPOSN
  4204.         IBUFFER(IBUFFER_POINTER+5) = 0
  4205.         INDEX_NBYTES = IBUFFER_POINTER + 5
  4206.         IBUFFER_POINTER = IBUFFER_POINTER + 6
  4207.         LCOLOR_CHANGED = .FALSE.
  4208.         LMOVED = .FALSE.
  4209.       ENDIF
  4210.     IBUFFER(IBUFFER_POINTER) = IX
  4211.     IBUFFER(IBUFFER_POINTER+1) = IY
  4212.     IBUFFER_POINTER = IBUFFER_POINTER+2
  4213.     IXPOSN = IX
  4214.     IYPOSN = IY
  4215. C
  4216. C    COUNT BYTES OF DATA
  4217. C
  4218.     IBUFFER(INDEX_NBYTES) = IBUFFER(INDEX_NBYTES) + 4
  4219.     RETURN
  4220.     END
  4221.     SUBROUTINE GD9400_COLOR_SET(ICOLOR)
  4222. C
  4223. C    **********
  4224.     PARAMETER (IBUFFER_SIZE = 512)
  4225.     INTEGER*2 IBUFFER
  4226.     LOGICAL LMOVED, LCOLOR_CHANGED
  4227.     COMMON /GD9400_MD/ IBUFFER(IBUFFER_SIZE), ICURRENT_COLOR,
  4228.     1   IXPOSN, IYPOSN, IBUFFER_POINTER, LMOVED, LCOLOR_CHANGED
  4229. C    **********
  4230. C
  4231.     IF (ICOLOR .NE. ICURRENT_COLOR) THEN
  4232.         ICURRENT_COLOR = ICOLOR
  4233.         LCOLOR_CHANGED = .TRUE.
  4234.       ENDIF
  4235.     RETURN
  4236.     END
  4237.     FUNCTION GD9400_FLUSHIF(NWORDS)
  4238.     LOGICAL GD9400_FLUSHIF
  4239. C
  4240. C    **********
  4241.     PARAMETER (IBUFFER_SIZE = 512)
  4242.     INTEGER*2 IBUFFER
  4243.     LOGICAL LMOVED, LCOLOR_CHANGED
  4244.     COMMON /GD9400_MD/ IBUFFER(IBUFFER_SIZE), ICURRENT_COLOR,
  4245.     1   IXPOSN, IYPOSN, IBUFFER_POINTER, LMOVED, LCOLOR_CHANGED
  4246. C    **********
  4247. C
  4248. D    TYPE *,'GD9400_FLUSHIF(',NWORDS,') : IBUFFER_POINTER = ',
  4249.     1   IBUFFER_POINTER
  4250.     IF ((IBUFFER_SIZE+1-IBUFFER_POINTER) .GE. NWORDS) THEN
  4251.         GD9400_FLUSHIF = .FALSE.
  4252.       ELSE
  4253.         CALL GD9400_FLUSH
  4254.         GD9400_FLUSHIF = .TRUE.
  4255.       ENDIF
  4256.     RETURN
  4257.     END
  4258.     SUBROUTINE GD9400_FLUSH
  4259. C
  4260. C    **********
  4261.     PARAMETER (IBUFFER_SIZE = 512)
  4262.     INTEGER*2 IBUFFER
  4263.     LOGICAL LMOVED, LCOLOR_CHANGED
  4264.     COMMON /GD9400_MD/ IBUFFER(IBUFFER_SIZE), ICURRENT_COLOR,
  4265.     1   IXPOSN, IYPOSN, IBUFFER_POINTER, LMOVED, LCOLOR_CHANGED
  4266. C    **********
  4267. C
  4268.     IF (IBUFFER_POINTER .GT. 1) THEN
  4269.         CALL GD94WRITE(IBUFFER,2*(IBUFFER_POINTER-1))
  4270.         IBUFFER_POINTER = 1
  4271.         LMOVED = .TRUE.
  4272.       ENDIF
  4273.     RETURN
  4274.     END
  4275.     SUBROUTINE GD9400_BUFRINIT
  4276. C
  4277. C    **********
  4278.     PARAMETER (IBUFFER_SIZE = 512)
  4279.     INTEGER*2 IBUFFER
  4280.     LOGICAL LMOVED, LCOLOR_CHANGED
  4281.     COMMON /GD9400_MD/ IBUFFER(IBUFFER_SIZE), ICURRENT_COLOR,
  4282.     1   IXPOSN, IYPOSN, IBUFFER_POINTER, LMOVED, LCOLOR_CHANGED
  4283. C    **********
  4284. C
  4285.     IBUFFER_POINTER = 1
  4286.     LCOLOR_CHANGED = .TRUE.
  4287.     ICURRENT_COLOR = 1
  4288.     IXPOSN = 0
  4289.     IYPOSN = 0
  4290.     RETURN
  4291.     END
  4292.     SUBROUTINE GD94WRITE(BUFFER,NBYTES)
  4293.     INTEGER*2 BUFFER(NBYTES/2)
  4294. C
  4295. C    THIS SUBROUTINE WRITES A BUFFER TO THE RAMTEK.
  4296. C
  4297. C    **********
  4298.     INTEGER*2 IOCHAN
  4299.     COMMON /GD9400_IO/ IOCHAN
  4300. C    **********
  4301. C
  4302.     PARAMETER (IOWRITE = '00000020'X)
  4303.     INTEGER*2 IOSB(4)
  4304.     INTEGER*4 SYS$QIOW
  4305. D    TYPE 9999, NBYTES, (BUFFER(I), BUFFER(I), I=1,NBYTES/2)
  4306. D9999    FORMAT(' GD9400 WRITE'/' BYTE COUNT IS ',I6/
  4307. D    1   128(1X,Z4,'H',4X,O6/))
  4308.     ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN),%VAL(IOWRITE),
  4309.     1   IOSB, , ,BUFFER,%VAL(NBYTES), , , , )
  4310. D    TYPE *,'GD9400 WRITE STATUS IS ',ISTAT
  4311.     IF (.NOT. ISTAT) STOP 'GD9400 - WRITE ERROR'
  4312.     RETURN
  4313.     END
  4314.     SUBROUTINE GDAID(X,Y,XGUPCM,YGUPCM,IX,IY)
  4315. C
  4316.     IX = XGUPCM*X + 0.5
  4317.     IY = YGUPCM*Y + 0.5
  4318.     RETURN
  4319.     END
  4320.     SUBROUTINE GDGAID(IX,IY,XGUPCM,YGUPCM,X,Y)
  4321. C
  4322.     X = FLOAT(IX)/XGUPCM
  4323.     Y = FLOAT(IY)/YGUPCM
  4324.     RETURN
  4325.     END
  4326.     SUBROUTINE GDDM800(IFXN,XA,YA)
  4327.     DIMENSION XA(8), YA(3)
  4328. C
  4329. C    DATA MEDIA WITH DM800 RETRO-GRAPHICS UPGRADE
  4330. C     This driver assumes the terminal is normally in the VT100 mode
  4331. C     of operation.   Thus, on device initialization, the DM800 is set
  4332. C     to 4027 emulation from VT100 emulation.   On device release, the
  4333. C     DM800 is returned to VT100 emulation.
  4334. C
  4335. C-----------------------------------------------------------------------
  4336. C
  4337. C    DEFINE DATA MEDIA 4027 EMULATION COMMAND CHARACTER
  4338. C
  4339.     BYTE CMD
  4340.     PARAMETER (CMD=33)
  4341. C
  4342.     BYTE CSUB, US, GS, CR, FF
  4343.     PARAMETER (ESC=27, CSUB=26, US=31, GS=29, CR=13, FF=12)
  4344.     CHARACTER*(*) TERMINAL
  4345.     PARAMETER (TERMINAL='TT')
  4346. C
  4347. C    DEFINITIONS FOR DEVICE CONTROL
  4348. C
  4349.     BYTE STR_END(2), STR_BEGIN_PLOT(14), STR_COLOR_SET(8)
  4350.     BYTE STR_INIT_DM800(49), STR_RELEASE(6)
  4351.     BYTE COLOR_MAP(8)
  4352. C
  4353.     DATA STR_END /13,0/
  4354.     DATA STR_INIT_DM800 /
  4355.     1   GS, ESC, '"', '6', 'g',
  4356.     2   CMD,'W','O','R',' ','3','0',
  4357.     3   CMD,'G','R','A',' ','1',',','3','0',
  4358.     4   CMD,'J','U','M',' ','1',',','1',
  4359.     5   CMD,'L','I','N',' ','1',
  4360.     6   CMD,'S','H','R',' ','N',
  4361.     7   CMD,'C','O','L',' ','0',2*0/
  4362.     DATA STR_BEGIN_PLOT /
  4363.     1   CMD,'E','R','A',' ','G',
  4364.     2   CMD,'C','O','L',' ','C','0',0/
  4365.     DATA STR_COLOR_SET /
  4366.     1   CMD,'C','O','L',' ','C','0',0/
  4367.     DATA STR_RELEASE /
  4368.     1   ESC,'"','0','g',2*0/
  4369.     DATA COLOR_MAP / 0, 1, 2, 3, 4, 5, 6, 7 /
  4370. C
  4371. C    DEFINITIONS FOR GIN
  4372. C
  4373.     BYTE GINBUFR(28), PROMPT(8)
  4374. C
  4375.     DATA PROMPT /
  4376.     1   CMD,'E','N','A',' ','1',CR,0/
  4377.     DATA IGIN_IN_CHARS /27/
  4378. C
  4379. C    DECLARE BUFFERING FUNCTION
  4380. C
  4381.     LOGICAL GB_TEST_FLUSH
  4382. C
  4383. C    DECLARE VARS NEED FOR DRIVER OPERATION
  4384. C
  4385.     LOGICAL LVECTOR_GOING, LDUMMY
  4386.     DIMENSION DCHAR(8)
  4387. C
  4388. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  4389. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  4390. C
  4391.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  4392.     DATA DCHAR /800.0, 21.69, 14.223, 29.46, 29.46, 7.0, 229.0, 1.0/
  4393. C
  4394. C*****************
  4395. C
  4396. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  4397. C
  4398.     IF (IFXN .LE. 0 .OR. IFXN .GT. 11) RETURN
  4399. C
  4400. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  4401. C
  4402.     GO TO (100,200,300,400,500,600,700,800,900,1000,1100) IFXN
  4403. C
  4404. C    *********************
  4405. C    INITIALIZE THE DEVICE
  4406. C    *********************
  4407. C
  4408. 100    CONTINUE
  4409. C
  4410. C    FIRST, INITIALIZE THE BUFFER SUBROUTINES
  4411. C
  4412.     CALL GB_INITIALIZE(US,STR_END,TERMINAL,IERR)
  4413.     YA(1) = IERR
  4414.     IF (IERR .NE. 0) RETURN
  4415.     CALL GB_IN_STRING(STR_INIT_DM800)
  4416. 190    CONTINUE
  4417.     CALL GD4027_MAP(CC,0,0,100,100)
  4418.     CALL GD4027_MAP(CC,1,120,50,100)
  4419.     CALL GD4027_MAP(CC,2,240,50,100)
  4420.     CALL GD4027_MAP(CC,3,0,50,100)
  4421.     CALL GD4027_MAP(CC,4,180,50,100)
  4422.     CALL GD4027_MAP(CC,5,60,50,100)
  4423.     CALL GD4027_MAP(CC,6,300,50,100)
  4424.     CALL GD4027_MAP(CC,7,0,0,0)
  4425.     CALL GB_EMPTY
  4426.     LVECTOR_GOING = .FALSE.
  4427.     RETURN
  4428. C
  4429. C    **************************
  4430. C    GET FRESH PLOTTING SURFACE
  4431. C    **************************
  4432. C
  4433. 200    CONTINUE
  4434.     CALL GB_NEW_BUFFER
  4435.     CALL GB_IN_STRING(STR_BEGIN_PLOT)
  4436.     GO TO 190
  4437. C
  4438. C    ****
  4439. C    MOVE
  4440. C    ****
  4441. C
  4442. 300    CONTINUE
  4443. C    CONVERT CM. TO GRAPHICS UNITS ROUNDED
  4444.     IXPOSN = XGUPCM*XA(1)+0.5
  4445.     IYPOSN = YGUPCM*YA(1)+0.5
  4446.     LVECTOR_GOING = .FALSE.
  4447.     RETURN
  4448. C
  4449. C    ****
  4450. C    DRAW
  4451. C    ****
  4452. C
  4453. 400    CONTINUE
  4454.     IX = XGUPCM*XA(1)+0.5
  4455.     IY = YGUPCM*YA(1)+0.5
  4456.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4))
  4457.     IF (LVECTOR_GOING) GO TO 410
  4458.     LDUMMY = GB_TEST_FLUSH(9)
  4459.     LVECTOR_GOING =  .TRUE.
  4460.     CALL GB_INSERT(GS)
  4461.     CALL GB_USE_TERMINATOR
  4462.     CALL GD_4010_CONVERT(IXPOSN,IYPOSN)
  4463. 410    CALL GD_4010_CONVERT(IX,IY)
  4464.     IXPOSN = IX
  4465.     IYPOSN = IY
  4466.     RETURN
  4467. C
  4468. C    *****************************
  4469. C    FLUSH GRAPHICS COMMAND BUFFER
  4470. C    *****************************
  4471. C
  4472. 500    CONTINUE
  4473.     CALL GB_EMPTY
  4474.     LVECTOR_GOING = .FALSE.
  4475.     RETURN
  4476. C
  4477. C    ******************
  4478. C    RELEASE THE DEVICE
  4479. C    ******************
  4480. C
  4481. 600    CONTINUE
  4482. C
  4483. C    RETURN TO VT100 MODE
  4484. C
  4485.     CALL GB_EMPTY
  4486.     CALL GB_IN_STRING(STR_RELEASE)
  4487.     CALL GB_EMPTY
  4488.     RETURN
  4489. C
  4490. C    *****************************
  4491. C    RETURN DEVICE CHARACTERISTICS
  4492. C    *****************************
  4493. C
  4494. 700    CONTINUE
  4495.     DO 720 I=1,8
  4496.     XA(I) = DCHAR(I)
  4497. 720    CONTINUE
  4498.     RETURN
  4499. C
  4500. C    ****************************
  4501. C    SELECT CURRENT DRAWING COLOR
  4502. C    ****************************
  4503. C
  4504. 800    CONTINUE
  4505.     CALL GB_EMPTY
  4506.     ICOLOR = XA(1)
  4507.     IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 7) RETURN
  4508.     STR_COLOR_SET(7) = 48 + COLOR_MAP(ICOLOR)
  4509.     CALL GB_IN_STRING(STR_COLOR_SET)
  4510.     LVECTOR_GOING = .FALSE.
  4511.     RETURN
  4512. C
  4513. C    **********************
  4514. C    PERFORM GRAPHICS INPUT
  4515. C    **********************
  4516. C
  4517. 900    CONTINUE
  4518.     CALL GB_EMPTY
  4519.     LVECTOR_GOING = .FALSE.
  4520. C
  4521. C    ASK FOR 1 GIN INPUT
  4522. C
  4523. C
  4524.     CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.FALSE.,GINBUFR)
  4525. C
  4526. C    GET KEY PRESSED, X AND Y
  4527. C
  4528. C    KEY IS AT 9, X IS AT 13, AND Y IS AT 17
  4529. C
  4530.     DECODE (11,911,GINBUFR(9)) XA(1), XA(2), XA(3)
  4531. 911    FORMAT(F3.0,1X,F3.0,1X,F3.0)
  4532.     XA(2) = XA(2)/XGUPCM
  4533.     XA(3) = XA(3)/YGUPCM
  4534.     RETURN
  4535. C
  4536. C    *******************
  4537. C    SET COLOR USING RGB
  4538. C    *******************
  4539. C
  4540. 1000    CONTINUE
  4541.     ICOLOR = COLOR_MAP(INT(XA(1)))
  4542.     CALL GD4027_MIX(CC,ICOLOR,INT(YA(1)+0.5),INT(YA(2)+0.5),INT(YA(3)+0.5))
  4543.     RETURN
  4544. C
  4545. C    *******************
  4546. C    SET COLOR USING HLS
  4547. C    *******************
  4548. C
  4549. 1100    CONTINUE
  4550.     ICOLOR = COLOR_MAP(INT(XA(1)))
  4551.     CALL GD4027_MAP(CC,ICOLOR,INT(YA(1)+0.5),INT(YA(2)+0.5),INT(YA(3)+0.5))
  4552.     RETURN
  4553.     END
  4554.     SUBROUTINE GDDQ650(IFXN,XA,YA)
  4555.     DIMENSION XA(8), YA(3)
  4556. C
  4557. C    VT100 WITH DQ650 RETRO-GRAPHICS UPGRADE
  4558. C     This driver assumes the terminal is normally in the VT100 mode
  4559. C     of operation.   Thus, on device initialization, the DQ650 is set
  4560. C     to 4027 emulation from VT100 emulation.   On device release, the
  4561. C     DQ650 is returned to VT100 emulation.
  4562. C
  4563. C-----------------------------------------------------------------------
  4564. C
  4565.     BYTE CMD, CSUB, US, GS, CR, FF
  4566.     PARAMETER (esc=27, CMD=33, CSUB=26, US=31, GS=29, CR=13, FF=12)
  4567.     CHARACTER*(*) TERMINAL
  4568.     PARAMETER (TERMINAL='TT')
  4569. C
  4570. C    DEFINITIONS FOR DEVICE CONTROL
  4571. C
  4572.     BYTE STR_END(2), STR_BEGIN_PLOT(14), STR_COLOR_SET(8)
  4573.     BYTE STR_INIT_DQ650(49), STR_RELEASE(6)
  4574. C
  4575.     DATA STR_END /13,0/
  4576.     DATA STR_INIT_DQ650 /
  4577.     1   GS, ESC, '"', '6', 'g',
  4578.     2   CMD,'W','O','R',' ','3','0',
  4579.     3   CMD,'G','R','A',' ','1',',','3','0',
  4580.     4   CMD,'J','U','M',' ','1',',','1',
  4581.     5   CMD,'L','I','N',' ','1',
  4582.     6   CMD,'S','H','R',' ','N',
  4583.     7   CMD,'C','O','L',' ','0',2*0/
  4584.     DATA STR_BEGIN_PLOT /
  4585.     1   CMD,'E','R','A',' ','G',
  4586.     2   CMD,'C','O','L',' ','C','0',0/
  4587.     DATA STR_COLOR_SET /
  4588.     1   CMD,'C','O','L',' ','C','0',0/
  4589.     DATA STR_RELEASE /
  4590.     1   ESC,'"','0','g',2*0/
  4591. C
  4592. C    DEFINITIONS FOR GIN
  4593. C
  4594.     BYTE GINBUFR(28), PROMPT(8)
  4595. C
  4596.     DATA PROMPT /
  4597.     1   CMD,'E','N','A',' ','1',CR,0/
  4598.     DATA IGIN_IN_CHARS /27/
  4599. C
  4600. C    DECLARE BUFFERING FUNCTION
  4601. C
  4602.     LOGICAL GB_TEST_FLUSH
  4603. C
  4604. C    DECLARE VARS NEED FOR DRIVER OPERATION
  4605. C
  4606.     LOGICAL LVECTOR_GOING, LDUMMY
  4607.     DIMENSION DCHAR(8)
  4608. C
  4609. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  4610. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  4611. C
  4612.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  4613.     DATA DCHAR /650.0, 21.69, 14.223, 29.46, 29.46, 1.0, 133.0, 1.0/
  4614. C
  4615. C*****************
  4616. C
  4617. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  4618. C
  4619.     IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN
  4620. C
  4621. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  4622. C
  4623.     GO TO (100,200,300,400,500,600,700,800,900) IFXN
  4624. C
  4625. C    *********************
  4626. C    INITIALIZE THE DEVICE
  4627. C    *********************
  4628. C
  4629. 100    CONTINUE
  4630. C
  4631. C    FIRST, INITIALIZE THE BUFFER SUBROUTINES
  4632. C
  4633.     CALL GB_INITIALIZE(US,STR_END,TERMINAL,IERR)
  4634.     YA(1) = IERR
  4635.     IF (IERR .NE. 0) RETURN
  4636.     CALL GB_IN_STRING(STR_INIT_DQ650)
  4637.     CALL GD4027_MAP(CC,0,0,100,100)
  4638.     CALL GD4027_MAP(CC,7,0,0,0)
  4639. 190    CONTINUE
  4640.     CALL GB_EMPTY
  4641.     LVECTOR_GOING = .FALSE.
  4642.     RETURN
  4643. C
  4644. C    **************************
  4645. C    GET FRESH PLOTTING SURFACE
  4646. C    **************************
  4647. C
  4648. 200    CONTINUE
  4649.     CALL GB_NEW_BUFFER
  4650.     CALL GB_IN_STRING(STR_BEGIN_PLOT)
  4651.     GO TO 190
  4652. C
  4653. C    ****
  4654. C    MOVE
  4655. C    ****
  4656. C
  4657. 300    CONTINUE
  4658. C    CONVERT CM. TO GRAPHICS UNITS ROUNDED
  4659.     IXPOSN = XGUPCM*XA(1)+0.5
  4660.     IYPOSN = YGUPCM*YA(1)+0.5
  4661.     LVECTOR_GOING = .FALSE.
  4662.     RETURN
  4663. C
  4664. C    ****
  4665. C    DRAW
  4666. C    ****
  4667. C
  4668. 400    CONTINUE
  4669.     IX = XGUPCM*XA(1)+0.5
  4670.     IY = YGUPCM*YA(1)+0.5
  4671.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4))
  4672.     IF (LVECTOR_GOING) GO TO 410
  4673.     LDUMMY = GB_TEST_FLUSH(9)
  4674.     LVECTOR_GOING =  .TRUE.
  4675.     CALL GB_INSERT(GS)
  4676.     CALL GB_USE_TERMINATOR
  4677.     CALL GD_4010_CONVERT(IXPOSN,IYPOSN)
  4678. 410    CALL GD_4010_CONVERT(IX,IY)
  4679.     IXPOSN = IX
  4680.     IYPOSN = IY
  4681.     RETURN
  4682. C
  4683. C    *****************************
  4684. C    FLUSH GRAPHICS COMMAND BUFFER
  4685. C    *****************************
  4686. C
  4687. 500    CONTINUE
  4688.     CALL GB_EMPTY
  4689.     LVECTOR_GOING = .FALSE.
  4690.     RETURN
  4691. C
  4692. C    ******************
  4693. C    RELEASE THE DEVICE
  4694. C    ******************
  4695. C
  4696. 600    CONTINUE
  4697. C
  4698. C    RETURN TO VT100 MODE
  4699. C
  4700.     CALL GB_EMPTY
  4701.     CALL GB_IN_STRING(STR_RELEASE)
  4702.     CALL GB_EMPTY
  4703.     RETURN
  4704. C
  4705. C    *****************************
  4706. C    RETURN DEVICE CHARACTERISTICS
  4707. C    *****************************
  4708. C
  4709. 700    CONTINUE
  4710.     DO 720 I=1,8
  4711.     XA(I) = DCHAR(I)
  4712. 720    CONTINUE
  4713.     RETURN
  4714. C
  4715. C    ****************************
  4716. C    SELECT CURRENT DRAWING COLOR
  4717. C    ****************************
  4718. C
  4719. 800    CONTINUE
  4720.     CALL GB_EMPTY
  4721.     ICOLOR = XA(1)
  4722.     IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 1) RETURN
  4723.     IF (ICOLOR .EQ. 0) THEN
  4724.         STR_COLOR_SET(7) = 48+7
  4725.         ELSE
  4726.         STR_COLOR_SET(7) = 48
  4727.     ENDIF
  4728.     CALL GB_IN_STRING(STR_COLOR_SET)
  4729.     LVECTOR_GOING = .FALSE.
  4730.     RETURN
  4731. C
  4732. C    **********************
  4733. C    PERFORM GRAPHICS INPUT
  4734. C    **********************
  4735. C
  4736. 900    CONTINUE
  4737.     CALL GB_EMPTY
  4738.     LVECTOR_GOING = .FALSE.
  4739. C
  4740. C    ASK FOR 1 GIN INPUT
  4741. C
  4742. C
  4743.     CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.FALSE.,GINBUFR)
  4744. C
  4745. C    GET KEY PRESSED, X AND Y
  4746. C
  4747. C    KEY IS AT 9, X IS AT 13, AND Y IS AT 17
  4748. C
  4749.     DECODE (11,911,GINBUFR(9)) XA(1), XA(2), XA(3)
  4750. 911    FORMAT(F3.0,1X,F3.0,1X,F3.0)
  4751.     XA(2) = XA(2)/XGUPCM
  4752.     XA(3) = XA(3)/YGUPCM
  4753.     RETURN
  4754.     END
  4755.     SUBROUTINE GDGX1000(IFXN,XA,YA)
  4756.     DIMENSION XA(8), YA(3)
  4757. C
  4758. C    MODGRAPH GX-1000 DRIVER FOR DIGLIB/VAX
  4759. C
  4760. C-----------------------------------------------------------------------
  4761. C
  4762.     EXTERNAL LEN
  4763.     BYTE ESC, CSUB, TMODE, GS, CR, FF
  4764.     PARAMETER (ESC=27, CSUB=26, TMODE=24, GS=29, CR=13, FF=12)
  4765.     CHARACTER*(*) TERMINAL
  4766.     PARAMETER (TERMINAL='TT')
  4767. C
  4768. C    DEFINITIONS FOR DEVICE CONTROL
  4769. C
  4770.     BYTE STR_BEGIN_PLOT(10), STR_COLOR_SET(6), STR_INIT_DEV(22)
  4771.     DATA STR_INIT_DEV /ESC,'^','2','2','4','f',    !STATUS LINE OFF
  4772.     1   ESC,'^','1','9',';','0','s',        !TEXT OVER GRAPHICS
  4773.     2   ESC,'^','4','2',';','1','s',0,0/        !MANUAL SCREEN CONTROL
  4774.     DATA STR_BEGIN_PLOT /GS,ESC,FF,
  4775.     1   ESC,'/','0','d',ESC,'`',0/
  4776.     DATA STR_COLOR_SET /GS,ESC,'/','0','d',0/
  4777. C
  4778. C    DEFINITIONS FOR GIN
  4779. C
  4780.     BYTE GINBUFR(8), PROMPT(4)
  4781.     DATA PROMPT /GS, ESC, CSUB, 0/
  4782.     DATA IGIN_IN_CHARS /6/        !5 FROM 4010 GIN, PLUS CR
  4783. C
  4784. C    DECLARE BUFFERING FUNCTION
  4785. C
  4786.     LOGICAL GB_TEST_FLUSH
  4787. C
  4788. C    DECLARE VARS NEED FOR DRIVER OPERATION
  4789. C
  4790.     LOGICAL LVECTOR_GOING, LDUMMY
  4791.     DIMENSION DCHAR(8)
  4792. C
  4793. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  4794. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  4795. C
  4796.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  4797.     DATA DCHAR /1000.0, 25.5, 19.417, 40.12, 40.12, 1.0, 133.0, 1.0/
  4798. C
  4799. C*****************
  4800. C
  4801. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  4802. C
  4803.     IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN
  4804. C
  4805. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  4806. C
  4807.     GO TO (100,200,300,400,500,600,700,800,900) IFXN
  4808. C
  4809. C    *********************
  4810. C    INITIALIZE THE DEVICE
  4811. C    *********************
  4812. C
  4813. 100    CONTINUE
  4814. C
  4815. C    FIRST, INITIALIZE THE BUFFER SUBROUTINES
  4816. C
  4817.     CALL GB_INITIALIZE(TMODE,0,TERMINAL,IERR)
  4818.     YA(1) = IERR
  4819.     LVECTOR_GOING = .FALSE.
  4820.     CALL GB_NEW_BUFFER
  4821.     CALL GB_IN_STRING(STR_INIT_DEV)
  4822.     CALL GB_EMPTY
  4823.     RETURN
  4824. C
  4825. C    **************************
  4826. C    GET FRESH PLOTTING SURFACE
  4827. C    **************************
  4828. C
  4829. 200    CONTINUE
  4830.     CALL GB_EMPTY
  4831.     CALL GB_IN_STRING(STR_BEGIN_PLOT)
  4832.     CALL GB_USE_TERMINATOR
  4833.     LVECTOR_GOING = .FALSE.
  4834.     RETURN
  4835. C
  4836. C    ****
  4837. C    MOVE
  4838. C    ****
  4839. C
  4840. 300    CONTINUE
  4841. C    CONVERT CM. TO GRAPHICS UNITS ROUNDED
  4842.     IXPOSN = XGUPCM*XA(1)+0.5
  4843.     IYPOSN = YGUPCM*YA(1)+0.5
  4844.     LVECTOR_GOING = .FALSE.
  4845.     RETURN
  4846. C
  4847. C    ****
  4848. C    DRAW
  4849. C    ****
  4850. C
  4851. 400    CONTINUE
  4852.     IX = XGUPCM*XA(1)+0.5
  4853.     IY = YGUPCM*YA(1)+0.5
  4854.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4))
  4855.     IF (LVECTOR_GOING) GO TO 410
  4856.     LDUMMY = GB_TEST_FLUSH(9)
  4857.     LVECTOR_GOING = .TRUE.
  4858.     CALL GB_INSERT(GS)
  4859.     CALL GB_USE_TERMINATOR
  4860.     CALL GD_4010_CONVERT(IXPOSN,IYPOSN)
  4861. 410    CALL GD_4010_CONVERT(IX,IY)
  4862.     IXPOSN = IX
  4863.     IYPOSN = IY
  4864.     RETURN
  4865. C
  4866. C    *****************************
  4867. C    FLUSH GRAPHICS COMMAND BUFFER
  4868. C    *****************************
  4869. C
  4870. 500    CONTINUE
  4871.     CALL GB_EMPTY
  4872.     LVECTOR_GOING = .FALSE.
  4873.     RETURN
  4874. C
  4875. C    ******************
  4876. C    RELEASE THE DEVICE
  4877. C    ******************
  4878. C
  4879. 600    CONTINUE
  4880. C
  4881. C    DE-ASSIGN THE CHANNAL
  4882. C
  4883.     CALL GB_FINISH(0)
  4884.     RETURN
  4885. C
  4886. C    *****************************
  4887. C    RETURN DEVICE CHARACTERISTICS
  4888. C    *****************************
  4889. C
  4890. 700    CONTINUE
  4891.     DO 720 I=1,8
  4892.     XA(I) = DCHAR(I)
  4893. 720    CONTINUE
  4894.     RETURN
  4895. C
  4896. C    ****************************
  4897. C    SELECT CURRENT DRAWING COLOR
  4898. C    ****************************
  4899. C
  4900. 800    CONTINUE
  4901.     LDUMMY = GB_TEST_FLUSH(8)
  4902.     ICOLOR = XA(1)
  4903.     IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 1) RETURN
  4904.     ICOLOR = 1-ICOLOR        !CONVERT 1 TO 0 AND 0 INTO 1
  4905.     STR_COLOR_SET(4) = 48+ICOLOR    !MAKE ASCII CHARACTER 0 OR 1
  4906.     CALL GB_IN_STRING(STR_COLOR_SET)
  4907.     CALL GB_USE_TERMINATOR
  4908.     LVECTOR_GOING = .FALSE.
  4909.     RETURN
  4910. C
  4911. C    **********************
  4912. C    PERFORM GRAPHICS INPUT
  4913. C    **********************
  4914. C
  4915. 900    CONTINUE
  4916.     CALL GB_EMPTY
  4917.     LVECTOR_GOING = .FALSE.
  4918. C
  4919.     CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR)
  4920. C
  4921.     ICHAR = GINBUFR(1)
  4922.     IX1 = GINBUFR(2)
  4923.     IX2 = GINBUFR(3)
  4924.     IY1 = GINBUFR(4)
  4925.     IY2 = GINBUFR(5)
  4926. C
  4927.     XA(1) = IAND(ICHAR,127)        !PICK CHARACTER
  4928.     XA(2) = (32*IAND(IX1,31)+IAND(IX2,31))/XGUPCM
  4929.     XA(3) = (32*IAND(IY1,31)+IAND(IY2,31))/YGUPCM
  4930. C
  4931.     CALL GB_SEND_CHARS(TMODE,1)
  4932.     RETURN
  4933.     END
  4934.     SUBROUTINE GDHIREZ(IFXN,XA,YA)
  4935.     DIMENSION XA(8), YA(3)
  4936. CC
  4937. C    SELANAR HIREZ 100 (1024x768) DRIVER FOR DIGLIB/VAX
  4938. C       This driver almost works, but doesn't.   It is distributed only
  4939. C     as a time saver for those who have this device.   I (Hal) no longer
  4940. C     have access to this terminal, so I can not debug this driver.
  4941. C     Please call me about it ONLY AS A VERY LAST RESORT!!!!!
  4942. C
  4943. C-----------------------------------------------------------------------
  4944. C
  4945.     EXTERNAL LEN
  4946.     BYTE ESC, CSUB, TMODE, GS, CR, FF
  4947.     PARAMETER (ESC=27, CSUB=26, GS=29, CR=13, FF=12)
  4948.     CHARACTER*(*) TERMINAL
  4949.     PARAMETER (TERMINAL='TT')
  4950. C
  4951. C    DEFINITIONS FOR DEVICE CONTROL
  4952. C
  4953.     BYTE STR_BEGIN_PLOT(18), STR_COLOR_SET(6), STR_INIT_DEV(54)
  4954.     BYTE STR_END_PLOT(2), STR_ANSI(4)
  4955.     DATA STR_INIT_DEV /GS,ESC,'\',ESC,'O','D',32,96,32,64,64,
  4956.     1   ESC,'O','V',32,96,32,64,55,127,63,95,
  4957.     2   ESC,'O','O',32,96,32,64,64,
  4958.     3   ESC,'O','X',32,97,32,68,32,96,32,64,
  4959.     4   ESC,'O','Y',32,97,32,68,32,96,32,64,2*0/
  4960.     DATA STR_BEGIN_PLOT /ESC,'[','H',ESC,'[','J',GS,ESC,FF,
  4961.     1   ESC,'O','W',32,96,32,64,64,0/
  4962.     DATA STR_COLOR_SET /GS,ESC,'O','W',2*0/
  4963.     DATA STR_END_PLOT /0,0/
  4964.     DATA STR_ANSI /ESC,'2',2*0/
  4965. C
  4966. C    DEFINITIONS FOR GIN
  4967. C
  4968.     BYTE GINBUFR(8), PROMPT(4)
  4969.     DATA PROMPT /GS, ESC, CSUB, 0/
  4970.     DATA IGIN_IN_CHARS /6/        !5 FROM 4010 GIN, PLUS CR
  4971. C
  4972. C    DECLARE BUFFERING FUNCTION
  4973. C
  4974.     LOGICAL GB_TEST_FLUSH
  4975. C
  4976. C    DECLARE VARS NEED FOR DRIVER OPERATION
  4977. C
  4978.     LOGICAL LVECTOR_GOING, LDUMMY
  4979.     DIMENSION DCHAR(8)
  4980. C
  4981. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  4982. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  4983. C
  4984.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  4985.     DATA DCHAR /100.0, 20.46, 15.34, 50.0, 50.0, 1.0, 133.0, 1.0/
  4986. C
  4987. C*****************
  4988. C
  4989. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  4990. C
  4991.     IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN
  4992. C
  4993. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  4994. C
  4995.     GO TO (100,200,300,400,500,600,700,800,900) IFXN
  4996. C
  4997. C    *********************
  4998. C    INITIALIZE THE DEVICE
  4999. C    *********************
  5000. C
  5001. 100    CONTINUE
  5002. C
  5003. C    FIRST, INITIALIZE THE BUFFER SUBROUTINES
  5004. C
  5005.     CALL GB_INITIALIZE(CR,STR_ANSI,TERMINAL,IERR)
  5006.     YA(1) = IERR
  5007.     CALL GB_IN_STRING(STR_INIT_DEV)
  5008.     CALL GB_EMPTY
  5009.     LVECTOR_GOING = .FALSE.
  5010.     RETURN
  5011. C
  5012. C    **************************
  5013. C    GET FRESH PLOTTING SURFACE
  5014. C    **************************
  5015. C
  5016. 200    CONTINUE
  5017.     CALL GB_EMPTY
  5018.     CALL GB_IN_STRING(STR_BEGIN_PLOT)
  5019.     CALL GD_4010_CAN
  5020.     LVECTOR_GOING = .FALSE.
  5021.     RETURN
  5022. C
  5023. C    ****
  5024. C    MOVE
  5025. C    ****
  5026. C
  5027. 300    CONTINUE
  5028. C    CONVERT CM. TO GRAPHICS UNITS ROUNDED
  5029.     IXPOSN = XGUPCM*XA(1)+0.5
  5030.     IYPOSN = YGUPCM*YA(1)+0.5
  5031.     LVECTOR_GOING = .FALSE.
  5032.     RETURN
  5033. C
  5034. C    ****
  5035. C    DRAW
  5036. C    ****
  5037. C
  5038. 400    CONTINUE
  5039.     IX = XGUPCM*XA(1)+0.5
  5040.     IY = YGUPCM*YA(1)+0.5
  5041.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4))
  5042.     IF (.NOT. LVECTOR_GOING) THEN
  5043.         LDUMMY = GB_TEST_FLUSH(9)
  5044.         LVECTOR_GOING = .TRUE.
  5045.         CALL GB_INSERT(GS)
  5046.         CALL GB_USE_TERMINATOR
  5047.         CALL GD_4010_CONVERT(IXPOSN,IYPOSN)
  5048.     ENDIF
  5049.     CALL GD_4010_CONVERT(IX,IY)
  5050.     IXPOSN = IX
  5051.     IYPOSN = IY
  5052.     RETURN
  5053. C
  5054. C    *****************************
  5055. C    FLUSH GRAPHICS COMMAND BUFFER
  5056. C    *****************************
  5057. C
  5058. 500    CONTINUE
  5059.     CALL GB_EMPTY
  5060.     LVECTOR_GOING = .FALSE.
  5061.     RETURN
  5062. C
  5063. C    ******************
  5064. C    RELEASE THE DEVICE
  5065. C    ******************
  5066. C
  5067. 600    CONTINUE
  5068. C
  5069. C    DE-ASSIGN THE CHANNAL
  5070. C
  5071.     CALL GB_FINISH(0)
  5072.     RETURN
  5073. C
  5074. C    *****************************
  5075. C    RETURN DEVICE CHARACTERISTICS
  5076. C    *****************************
  5077. C
  5078. 700    CONTINUE
  5079.     DO 720 I=1,8
  5080.     XA(I) = DCHAR(I)
  5081. 720    CONTINUE
  5082.     RETURN
  5083. C
  5084. C    ****************************
  5085. C    SELECT CURRENT DRAWING COLOR
  5086. C    ****************************
  5087. C
  5088. 800    CONTINUE
  5089.     LDUMMY = GB_TEST_FLUSH(8)
  5090.     ICOLOR = XA(1)
  5091.     IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 1) RETURN
  5092.     IF (ICOLOR .EQ. 0) ICOLOR = 2
  5093.     CALL GB_IN_STRING(STR_COLOR_SET)
  5094.     CALL GD_4010_CONVERT(ICOLOR,0)
  5095.     CALL GD_4010_CONVERT(0,0)
  5096.     LVECTOR_GOING = .FALSE.
  5097.     RETURN
  5098. C
  5099. C    **********************
  5100. C    PERFORM GRAPHICS INPUT
  5101. C    **********************
  5102. C
  5103. 900    CONTINUE
  5104.     CALL GB_EMPTY
  5105.     LVECTOR_GOING = .FALSE.
  5106. C
  5107.     CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR)
  5108. C
  5109.     ICHAR = GINBUFR(1)
  5110.     IX1 = GINBUFR(2)
  5111.     IX2 = GINBUFR(3)
  5112.     IY1 = GINBUFR(4)
  5113.     IY2 = GINBUFR(5)
  5114. C
  5115.     XA(1) = IAND(ICHAR,127)        !PICK CHARACTER
  5116.     XA(2) = (32*IAND(IX1,31)+IAND(IX2,31))/XGUPCM
  5117.     XA(3) = (32*IAND(IY1,31)+IAND(IY2,31))/YGUPCM
  5118. C
  5119.     CALL GB_IN_STRING(STR_ANSI)
  5120.     CALL GB_EMPTY
  5121.     RETURN
  5122.     END
  5123.     SUBROUTINE GDHPGLCONVERT(IX,IY)
  5124. C
  5125. C    THIS SUBROUTINE CONVERTS THE (X,Y) PAIR INTO THE PROPER HPGL
  5126. C    STRING, AND PLACES IT INTO THE BUFFER.   IT IS ASSUMED THAT
  5127. C    THERE IS ROOM FOR THE WHOLE THING IN THE BUFFER.
  5128. C
  5129.     BYTE STRING(12)
  5130.     EXTERNAL LEN
  5131. C
  5132.     CALL NUMSTR(IX,STRING)
  5133.     IEND = LEN(STRING)
  5134.     STRING(IEND+1) = ','
  5135.     CALL NUMSTR(IY,STRING(IEND+2))
  5136.     CALL GB_IN_STRING(STRING)
  5137.     RETURN
  5138.     END
  5139. C This subroutine has an alternate entry point given by the ENTRY statement.
  5140. C  You MUST remember to change that name also when configuring for a
  5141. C  different HPGL plotter!!!!!!!
  5142.  
  5143.     SUBROUTINE GD7475_LONG(IFXN,XA,YA)
  5144.     DIMENSION XA(8), YA(3)
  5145. C
  5146. C    GENERIC HP PLOTTER (WITH RS-232C INTERFACE) DRIVER FOR DIGLIB/VAX
  5147. C    THIS DRIVER SHOULD HANDLE ALL HPGL SPEAKING PLOTTERS WHEN PROPERLY
  5148. C    CONFIGURED.   IT CAN BE USED ON A DEDICATED LINE, OR IN-LINE.
  5149. C     This driver has not be tested since it was modified to work in-line.
  5150. C     However, I have a lot of faith in it, but you all know that a
  5151. C     programmers faith and a buck won't even buy a cup of coffee.
  5152. C
  5153. C    ### THIS DRIVER REQUIRES DIGLIB V3.1H OR LATER ###
  5154. C
  5155. C************************************************************************
  5156. C                                    *
  5157. C    PLOTTER CONFIGURATION PARAMETERS                *
  5158. C                                    *
  5159.     PARAMETER (PLOTTER_ID = 7475.0)    !PLOTTER DESIGNATION        *
  5160.     PARAMETER (X_WIDTH_CM = 25.0)    !PAPER WIDTH IN CM.        *
  5161.     PARAMETER (Y_HEIGHT_CM = 18.0)    !PAPER HEIGHT IN CM.        *
  5162.     PARAMETER (X_RESOLUTION = 400.0)!X GRAPHICS UNITS PER CM.    *
  5163.     PARAMETER (Y_RESOLUTION = 400.0)!Y GRAPHICS UNITS PER CM.    *
  5164.     PARAMETER (NUMBER_FOREGROUND_COLORS = 6.0) !NUMBER OF PENS    *
  5165.     PARAMETER (PEN_WIDTH_IN_PLOTTER_UNITS = 15.0) !            *
  5166.     LOGICAL AUTO_PAGE_PLOTTER    !                *
  5167.     PARAMETER (AUTO_PAGE_PLOTTER = .FALSE.) !NO PAPER ADVANCE    *
  5168.     CHARACTER*(*) TERMINAL        !                *
  5169. C                                    *
  5170. C    ### CONFIGURED FOR DEDICATED RS232 LINE USE ###            *
  5171. C        TO CONFIGURE FOR IN-LINE USE, COMMENT OUT NEXT LINE    *
  5172. C        AND UNCOMMENT OUT LINE AFTER THAT.            *
  5173. C                                    *
  5174.     PARAMETER (TERMINAL='HP7475$TERM') !LOGICAL NAME OF RS-232 LINE    *
  5175. C    PARAMETER (TERMINAL='TT:')    !LOGICAL NAME FOR IN-LINE USE    *
  5176. C                                    *
  5177. C************************************************************************
  5178. C
  5179.     BYTE ESC, BCOMMA, BSEMICOLON
  5180.     PARAMETER (ESC=27, BCOMMA=',', BSEMICOLON=';')
  5181.  
  5182. C
  5183. C    DEVICE CONTROL DEFINITIONS
  5184. C
  5185.     BYTE STR_INIT_DEVICE(30), STR_BEGIN_PLOT(6)
  5186.     BYTE STR_COLOR_SET(6)
  5187.     BYTE STR_PUT_PEN_AWAY(8), STR_PLOTTER_OFF(4), STR_PLOTTER_ON(4)
  5188.     BYTE STR_PEN_UP(4), STR_PEN_DOWN(4)
  5189.     DATA STR_INIT_DEVICE /
  5190.     1   ESC,'.','@',';','0',':',    !NO HARDWIRED HANDSHAKE
  5191.     2   ESC,'.','I','8','1',';',';','1','7',':', !XON/XOFF HANDSHAKE
  5192.     3   ESC,'.','N',';','1','9',':', !XON/XOFF HANDSHAKE
  5193.     4   'D','F',';',        !SET PLOTTER DEFAULT VALUES
  5194.     5   'S','C',2*0 /        !START OF SCALING INSTRUCTION.
  5195.     DATA STR_BEGIN_PLOT /
  5196.     1   'S','P','1',';',2*0/    !SELECT PEN 1
  5197.     DATA STR_COLOR_SET /
  5198.     1   'S','P','x',';',2*0 /    !SELECT PEN x
  5199.     DATA STR_PUT_PEN_AWAY /
  5200.     1   'P','U',';',        !PEN PUP, THEN
  5201.     1   'S','P','0',';',0/        !SELECT PEN 0 (PUT PEN AWAY)
  5202.     DATA STR_PLOTTER_ON /
  5203.     1   ESC,'.','(',0/        !PLOTTER ON
  5204.     DATA STR_PLOTTER_OFF /
  5205.     1   ESC,'.',')',0/        !PLOTTER OFF
  5206.     DATA STR_PEN_UP /
  5207.     1   'P','U',';',0/        !PEN UP
  5208.     DATA STR_PEN_DOWN /
  5209.     1   'P','D',';',0/        !PEN DOWN
  5210. C
  5211. C    DECLARE BUFFERING FUNCTION TO BE LOGICAL
  5212. C
  5213.     LOGICAL GB_TEST_FLUSH
  5214. C
  5215. C    DELCARE VARS NEEDED FOR DRIVER OPERATION
  5216. C
  5217.     LOGICAL LVECTOR_GOING, LTALL
  5218. C
  5219.     DIMENSION DCHAR(8)
  5220. C
  5221. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  5222. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  5223. C
  5224.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  5225.     DATA DCHAR /PLOTTER_ID, X_WIDTH_CM, Y_HEIGHT_CM,
  5226.     1   X_RESOLUTION, Y_RESOLUTION, NUMBER_FOREGROUND_COLORS,
  5227.     2   24.0, PEN_WIDTH_IN_PLOTTER_UNITS/
  5228. C
  5229. C-------------------------------------------------------------------------
  5230. C
  5231. C    REMEMBER THAT WE ARE PLOTTER LONG IF THRU THE TOP
  5232. C
  5233.     LTALL = .FALSE.
  5234.     GO TO 10
  5235. C
  5236. C    ######### ALTERNATE ENTRY POINT ###########
  5237. C
  5238.     ENTRY GD7475_TALL(IFXN,XA,YA)
  5239.     LTALL = .TRUE.
  5240. 10    CONTINUE
  5241. C
  5242. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  5243. C
  5244.     IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN
  5245. C
  5246. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  5247. C
  5248.     GO TO (100,200,300,400,500,600,700,800) IFXN
  5249. C
  5250. C    *********************
  5251. C    INITIALIZE THE DEVICE
  5252. C    *********************
  5253. C
  5254. 100    CONTINUE
  5255.     CALL GB_INITIALIZE(BSEMICOLON,0,TERMINAL,IERR)
  5256.     YA(1) = IERR
  5257.     IF (IERR .NE. 0) RETURN
  5258.     CALL GB_BEGIN_STRING(STR_PLOTTER_ON)
  5259. C
  5260.     CALL GB_IN_STRING(STR_INIT_DEVICE)
  5261.     CALL GDHPGLCONVERT(0,INT(X_RESOLUTION*X_WIDTH_CM))
  5262.     CALL GB_INSERT(BCOMMA)
  5263.     IY_FULL_SCALE = Y_RESOLUTION*Y_HEIGHT_CM
  5264.     CALL GDHPGLCONVERT(0,IY_FULL_SCALE)
  5265.     CALL GB_INSERT(BSEMICOLON)
  5266.     CALL GB_EMPTY
  5267.     RETURN
  5268. C
  5269. C    **************************
  5270. C    GET FRESH PLOTTING SURFACE
  5271. C    **************************
  5272. C
  5273. 200    CONTINUE
  5274.     CALL GB_NEW_BUFFER
  5275.     CALL GB_IN_STRING(STR_PUT_PEN_AWAY)
  5276.     CALL GB_EMPTY
  5277.     LVECTOR_GOING = .FALSE.
  5278.     IF (AUTO_PAGE_PLOTTER) THEN
  5279.         CALL GB_IN_STRING(STR_ADVANCE_PAPER)
  5280.         ELSE
  5281.         TYPE 299
  5282. 299        FORMAT(
  5283.     1    '$Please place a fresh sheet of paper on the HP Plotter')
  5284.         ACCEPT 298, I
  5285. 298        FORMAT(A1)
  5286.     ENDIF
  5287.     CALL GB_IN_STRING(STR_BEGIN_PLOT)
  5288.     RETURN
  5289. C
  5290. C    ****
  5291. C    MOVE
  5292. C    ****
  5293. C
  5294. 300    CONTINUE
  5295.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(20))
  5296.     IF (.NOT. LPEN_UP) THEN
  5297.         IF (LVECTOR_GOING) THEN
  5298.             CALL GB_INSERT(BSEMICOLON)
  5299.             LVECTOR_GOING = .FALSE.
  5300.         ENDIF
  5301.         CALL GB_IN_STRING(STR_PEN_UP)
  5302.         LPEN_UP = .TRUE.
  5303.     ENDIF
  5304.     GO TO 450
  5305. C
  5306. C    ****
  5307. C    DRAW
  5308. C    ****
  5309. C
  5310. 400    CONTINUE
  5311.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(20))
  5312.     IF (LPEN_UP) THEN
  5313.         IF (LVECTOR_GOING) THEN
  5314.             CALL GB_INSERT(BSEMICOLON)
  5315.             LVECTOR_GOING = .FALSE.
  5316.         ENDIF
  5317.         CALL GB_IN_STRING(STR_PEN_DOWN)
  5318.         LPEN_UP = .FALSE.
  5319.     ENDIF
  5320. 450    CONTINUE
  5321.     IXPOSN = XGUPCM*XA(1)+0.5
  5322.     IYPOSN = YGUPCM*YA(1)+0.5
  5323.     IF (LTALL) THEN
  5324. C                    PLOTTER X = TALL_Y
  5325. C                    PLOTTER Y = Y_FULL_SCALE - TALL_X
  5326.         ITEMP = IXPOSN
  5327.         IXPOSN = IYPOSN
  5328.         IYPOSN = IY_FULL_SCALE - ITEMP
  5329.     ENDIF
  5330.     IF (LVECTOR_GOING) THEN
  5331.         CALL GB_INSERT(BCOMMA)
  5332.         ELSE
  5333.         CALL GB_IN_STRING('PA')
  5334.         LVECTOR_GOING = .TRUE.
  5335.         CALL GB_USE_TERMINATOR
  5336.     ENDIF
  5337.     CALL GDHPGLCONVERT(IXPOSN,IYPOSN)
  5338.     RETURN
  5339. C
  5340. C    *****************************
  5341. C    FLUSH GRAPHICS COMMAND BUFFER
  5342. C    *****************************
  5343. C
  5344. 500    CONTINUE
  5345.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(6))
  5346.     IF (LVECTOR_GOING) THEN
  5347.         CALL GB_INSERT(BSEMICOLON)
  5348.         LVECTOR_GOING = .FALSE.
  5349.         CALL GB_NO_TERMINATOR
  5350.     ENDIF
  5351.     IF (.NOT. LPEN_UP) THEN
  5352.         CALL GB_IN_STRING(STR_PEN_UP)
  5353.         LPEN_UP = .TRUE.
  5354.     ENDIF
  5355.     CALL GB_EMPTY
  5356.     RETURN
  5357. C
  5358. C    ******************
  5359. C    RELEASE THE DEVICE
  5360. C    ******************
  5361. C
  5362. 600    CONTINUE
  5363.     CALL GB_EMPTY
  5364.     CALL GB_IN_STRING(STR_PUT_PEN_AWAY)
  5365.     CALL GB_IN_STRING('PA')
  5366.     CALL GDHPGLCONVERT(INT(X_RESOLUTION*X_WIDTH_CM),
  5367.     1   INT(Y_RESOLUTION*Y_HEIGHT_CM))
  5368.     CALL GB_INSERT(BSEMICOLON)
  5369.     CALL GB_EMPTY
  5370.     CALL GB_FINISH(STR_PLOTTER_OFF)
  5371.     RETURN
  5372. C
  5373. C    *****************************
  5374. C    RETURN DEVICE CHARACTERISTICS
  5375. C    *****************************
  5376. C
  5377. 700    CONTINUE
  5378.     DO 720 I=1,8
  5379.     XA(I) = DCHAR(I)
  5380. 720    CONTINUE
  5381.     IF (LTALL) THEN
  5382.         XA(2) = DCHAR(3)
  5383.         XA(3) = DCHAR(2)
  5384.         XA(4) = DCHAR(5)
  5385.         XA(5) = DCHAR(4)
  5386.     ENDIF
  5387.     RETURN
  5388. C
  5389. C    ****************************
  5390. C    SELECT CURRENT DRAWING COLOR
  5391. C    ****************************
  5392. C
  5393. 800    CONTINUE
  5394.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(10))
  5395.     ICOLOR = XA(1)
  5396.     IF (ICOLOR .LE. 0 .OR.
  5397.     1   ICOLOR .GT. INT(NUMBER_FOREGROUND_COLORS)) RETURN
  5398.     IF (LVECTOR_GOING) THEN
  5399.         CALL GB_INSERT(BSEMICOLON)
  5400.         LVECTOR_GOING = .FALSE.
  5401.         CALL GB_NO_TERMINATOR
  5402.     ENDIF
  5403.     IF (.NOT. LPEN_UP) THEN
  5404.         CALL GB_IN_STRING(STR_PEN_UP)
  5405.         LPEN_UP = .TRUE.
  5406.     ENDIF
  5407.     STR_COLOR_SET(3) = 48+ICOLOR
  5408.     CALL GB_IN_STRING(STR_COLOR_SET)
  5409.     RETURN
  5410.     END
  5411.     SUBROUTINE GB_INITIALIZE(TERMIN,ENDSTR,TTNAME,IERR)
  5412.     CHARACTER*(*) TTNAME
  5413.     BYTE ENDSTR(2), TERMIN
  5414. C
  5415. C    *** VMS SPECIFIC ***
  5416. C
  5417. C    THIS SUBROUTINE INITIALIZES THE GRAPHICS DRIVERS BUFFERING
  5418. C     SUBROUTINES
  5419. C
  5420.     INCLUDE 'GBCOMMON.CMN'
  5421. C
  5422.     INTEGER*4 SYS$ASSIGN
  5423.     EXTERNAL LEN
  5424. C
  5425. C    ASSIGN A CHANNEL TO THE DEVICE OUTPUT DEVICE
  5426. C
  5427.     ISTAT = SYS$ASSIGN(TTNAME,IOCHAN,,)
  5428.     IF (.NOT. ISTAT) THEN
  5429.         IERR = 1
  5430.         RETURN
  5431.         ELSE
  5432.         IERR = 0
  5433.     ENDIF
  5434. C
  5435.     CALL SCOPY(ENDSTR,END_STRING)
  5436.     IEND_LENGTH = LEN(END_STRING)
  5437. C
  5438.     TERM_CHAR = TERMIN
  5439. C
  5440.     CALL GB_NEW_BUFFER
  5441.     RETURN
  5442.     END
  5443.  
  5444.  
  5445.  
  5446.     SUBROUTINE GB_NEW_BUFFER
  5447. C
  5448. C    SUBROUTINE TO INITIALIZE THE GRAPHIC COMMAND BUFFER
  5449. C
  5450.     INCLUDE 'GBCOMMON.CMN'
  5451. C
  5452.     IBFPTR = 1
  5453.     L_USE_TERMINATOR = .FALSE.
  5454.     RETURN
  5455.     END
  5456.  
  5457.  
  5458.  
  5459.     FUNCTION GB_TEST_FLUSH(NUMCHR)
  5460.     LOGICAL GB_TEST_FLUSH
  5461. C
  5462. C    THIS SUBROUTINE CHECKS TO MAKE SURE THERE IS ENOUGH ROOM IN
  5463. C    THE BUFFER FOR "NUMCHR" MORE CHARACTERS, IF NOT, IF MAKES ROOM BY
  5464. C    EMPTYING THE BUFFER.
  5465. C
  5466.     INCLUDE 'GBCOMMON.CMN'
  5467. C
  5468.     IF (IBFPTR+NUMCHR+IEND_LENGTH .GE. IBFSIZ) THEN
  5469.         CALL GB_EMPTY
  5470.         GB_TEST_FLUSH = .TRUE.
  5471.         ELSE
  5472.         GB_TEST_FLUSH = .FALSE.
  5473.         ENDIF
  5474.     RETURN
  5475.     END
  5476.  
  5477.  
  5478.  
  5479.     SUBROUTINE GB_USE_TERMINATOR
  5480. C
  5481. C    THIS SUBROUTINE SETS THE "USE TERMINATOR" FLAG TO TRUE.
  5482. C    THE FLAG IS SET TO FALSE BY EMPTYING/CLEARING THE BUFFER.
  5483. C
  5484.     INCLUDE 'GBCOMMON.CMN'
  5485. C
  5486.     L_USE_TERMINATOR = .TRUE.
  5487.     RETURN
  5488.     END
  5489.  
  5490.  
  5491.  
  5492.     SUBROUTINE GB_EMPTY
  5493. C
  5494. C    THIS SUBROUTINE EMPTYS THE BUFFER IF IT HAS ANYTHING
  5495. C
  5496.     INCLUDE 'GBCOMMON.CMN'
  5497. C
  5498. C
  5499.     IF (IBFPTR .EQ. 1) GO TO 900
  5500.     IF (L_USE_TERMINATOR) CALL GB_INSERT(TERM_CHAR)
  5501.     IF (IEND_LENGTH .NE. 0) CALL GB_IN_STRING(END_STRING)
  5502.     IF (IBFPTR .GT. IBFSIZ+1) STOP 'BUFFERING ERROR'
  5503. C
  5504. C    SEND TO TTY
  5505. C
  5506.     CALL GB_SEND_TTY(BUFFER,IBFPTR-1)
  5507. 900    CALL GB_NEW_BUFFER
  5508.     RETURN
  5509.     END
  5510.  
  5511.  
  5512.  
  5513.     SUBROUTINE GB_SEND_TTY(TTY_BUFFER,IBUFR_LEN)
  5514.     BYTE TTY_BUFFER(IBUFR_LEN)
  5515. C
  5516. C    *** VMS SPECIFIC ***
  5517. C
  5518. C    THIS SUBROUTINE EMPTYS THE BUFFER IF IT HAS ANYTHING
  5519. C
  5520.     INCLUDE 'GBCOMMON.CMN'
  5521. C
  5522.     INTEGER*4 CR_CONTROL
  5523.     PARAMETER (CR_CONTROL = 0)
  5524.     PARAMETER (IO_WRITEV = '00000130'X)    !IO$_WRITEVBLK+IO$M_NOFORMAT
  5525. C
  5526.     INTEGER*4 SYS$QIOW
  5527.     INTEGER*2 IOSB(4)
  5528. C
  5529. C    DO THE QIOW TO THE OUTPUT DEVICE
  5530. C
  5531.     ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN),%VAL(IO_WRITEV),IOSB, , ,
  5532.     1   TTY_BUFFER,%VAL(IBUFR_LEN), ,%VAL(CR_CONTROL), , )
  5533.     IF (.NOT. ISTAT) then
  5534.         type 999, istat
  5535. 999        format(' QIOW to terminal failed, status was ',i9)
  5536.       endif
  5537.     RETURN
  5538.     END
  5539.  
  5540.  
  5541.  
  5542.     SUBROUTINE GB_INSERT(BCHAR)
  5543.     BYTE BCHAR
  5544. C
  5545. C    THIS SUBROUTINE INSERTS A CHARACTER INTO THE BUFFER
  5546. C
  5547.     INCLUDE 'GBCOMMON.CMN'
  5548. C
  5549.     BUFFER(IBFPTR) = BCHAR
  5550.     IBFPTR = IBFPTR + 1
  5551.     RETURN
  5552.     END
  5553.  
  5554.  
  5555.     SUBROUTINE GB_IN_STRING(STRING)
  5556.     BYTE STRING(2)
  5557. C
  5558. C    THIS SUBROUTINE INSERTS THE STRING INTO THE GRAPHICS BUFFER
  5559. C
  5560.     EXTERNAL LEN
  5561. C
  5562.     DO 100 I=1, LEN(STRING)
  5563.       CALL GB_INSERT(STRING(I))
  5564. 100      CONTINUE
  5565.     RETURN
  5566.     END
  5567.  
  5568.  
  5569.     SUBROUTINE GB_FINISH(RELEASE_STRING)
  5570.     BYTE RELEASE_STRING(2)
  5571. C
  5572. C    *** VMS SPECIFIC ***
  5573. C
  5574. C    THIS SUBROUTINE RELEASES THE I/O CHANNAL TO THE OUTPUT DEVICE
  5575. C
  5576.     INCLUDE 'GBCOMMON.CMN'
  5577. C
  5578.     INTEGER*4 SYS$DASSGN
  5579.     EXTERNAL LEN
  5580. C
  5581.     IF (LEN(RELEASE_STRING) .NE. 0) THEN
  5582.         CALL GB_EMPTY
  5583.         CALL GB_IN_STRING(RELEASE_STRING)
  5584.         CALL GB_EMPTY
  5585.       ENDIF
  5586.     ISTAT = SYS$DASSGN(%VAL(IOCHAN))
  5587.     RETURN
  5588.     END
  5589.  
  5590.  
  5591.     SUBROUTINE GB_GIN(PROMPT,IGIN_CHARS_MAX,L_TERMS_OK,GINBUFR)
  5592.     BYTE GINBUFR(2), PROMPT(2)
  5593.     LOGICAL*1 L_TERMS_OK
  5594. C
  5595. C    *** VMS SPECIFIC ***
  5596. C
  5597. C    THIS SUBROUTINE DOES A GIN OPERATION VIA A "READ-AFTER-PROMPT"
  5598. C    QIOW.
  5599. C
  5600.     INCLUDE 'GBCOMMON.CMN'
  5601. C
  5602.     PARAMETER (IO_READ_PROMPT = '877'X)
  5603.     PARAMETER (IO_READ_NOECHO = '71'X)
  5604. C
  5605.     INTEGER*4 SYS$QIOW
  5606.     INTEGER*2 IOSB(4)
  5607.     EXTERNAL LEN
  5608. C
  5609.     IPRLEN = LEN(PROMPT)
  5610.     II = 1
  5611.     NUMBER_TO_GET = IGIN_CHARS_MAX
  5612.     ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN),%VAL(IO_READ_PROMPT),
  5613.     1   IOSB, , ,GINBUFR(II),%VAL(NUMBER_TO_GET),%VAL(0), ,
  5614.     2   PROMPT,%VAL(IPRLEN))
  5615.     IF (.NOT. ISTAT) STOP 'GIN QIOW FAILED'
  5616.     IF (.NOT. L_TERMS_OK) GO TO 800
  5617. 100    CONTINUE
  5618.     NUMBER_GOT = IOSB(2)+IOSB(4)
  5619. D    TYPE 9999, NUMBER_GOT, (GINBUFR(I), I=1,NUMBER_GOT+II-1)
  5620. D9999    FORMAT(/' GB_GIN just got ',I2,' characters.'
  5621. D    1   /' The characters buffered so far are:'
  5622. D    2   /,20(1X,I3))
  5623.     IF (NUMBER_GOT .GE. NUMBER_TO_GET) GOTO 800
  5624.     NUMBER_TO_GET = NUMBER_TO_GET - NUMBER_GOT
  5625.     II = NUMBER_GOT + II
  5626.     ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN),%VAL(IO_READ_NOECHO),
  5627.     1   IOSB, , ,GINBUFR(II),%VAL(NUMBER_TO_GET), , , , )
  5628.     IF (.NOT. ISTAT) STOP 'GIN QIOW FAILED'
  5629.     GO TO 100
  5630. 800    RETURN
  5631.     END
  5632.  
  5633.  
  5634.  
  5635.     SUBROUTINE GB_INTERLOCK(PROMPT,IN_BUFFER,IN_CHAR_COUNT)
  5636. C
  5637. C    *** VMS SPECIFIC ***
  5638. C
  5639. C    THIS SUBROUTINE IS USED BY THOSE DRIVERS THAT MUST USE AN INTERLOCKING
  5640. C      WITH THE TERMINAL SO THAT BUFFER OVERFLOW DOES NOT OCCUR IN THE
  5641. C      TERMINAL.   MOSTLY, THIS IS CAUSED BY HP TERMINALS.   IT SEEMS
  5642. C      THAT HP NEVER HAS UNDERSTOOD THE USEFULNESS OF XON/XOFF!
  5643. C
  5644.     INCLUDE 'GBCOMMON.CMN'
  5645. C
  5646.     PARAMETER (IO_READ_PROMPT = '877'X)
  5647. C        IO$_READPROMPT + IO$M_PURGE + IO$M_NOECHO
  5648. C
  5649.     INTEGER*4 SYS$QIOW
  5650.     INTEGER*2 IOSB(4)
  5651.     EXTERNAL LEN
  5652. C
  5653.     IPRLEN = LEN(PROMPT)
  5654.     ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN),%VAL(IO_READ_PROMPT),
  5655.     1   IOSB, , ,IN_BUFFER,%VAL(IN_CHAR_COUNT),%VAL(0),%VAL(0),
  5656.     2   PROMPT,%VAL(IPRLEN))
  5657.     IF (.NOT. ISTAT) STOP 'GIN QIOW FAILED'
  5658.     RETURN
  5659.     END
  5660.     SUBROUTINE GB_INITIALIZE(TERMIN,ENDSTR,TTNAME,IERR)
  5661.     CHARACTER*(*) TTNAME
  5662.     BYTE ENDSTR(2), TERMIN
  5663. C
  5664. C    *** VMS SPECIFIC ***
  5665. C
  5666. C    THIS SUBROUTINE INITIALIZES THE GRAPHICS DRIVERS BUFFERING
  5667. C     SUBROUTINES FOR DOUBLE BUFFERING
  5668. C    DOUBLE BUFFERING ADDED 18-OCT-1984
  5669. C
  5670.     INCLUDE 'GBCOMMON2.CMN'
  5671. C
  5672.     INTEGER*4 SYS$ASSIGN, SYS$SETEF, LIB$GET_EF
  5673.     EXTERNAL LEN
  5674. C
  5675. C    ASSIGN A CHANNEL TO THE DEVICE OUTPUT DEVICE
  5676. C
  5677.     ISTAT = SYS$ASSIGN(TTNAME,IOCHAN,,)
  5678.     IF (.NOT. ISTAT) THEN
  5679.         IERR = 1
  5680.         RETURN
  5681.     ENDIF
  5682. C
  5683. C    GET TWO FREE EVENT FLAGS, 1 FOR EACH BUFFER
  5684. C
  5685.     ISTAT = LIB$GET_EF(IFLAG(1))
  5686. D    TYPE *,'EVENT FLAG 1 IS ',IFLAG(1)
  5687.     IF (.NOT. ISTAT) THEN
  5688.         IERR = 1
  5689.         RETURN
  5690.     ENDIF
  5691.     ISTAT = LIB$GET_EF(IFLAG(2))
  5692. D    TYPE *,'EVENT FLAG 2 IS ',IFLAG(2)
  5693.     IF (.NOT. ISTAT) THEN
  5694.         IERR = 1
  5695.         RETURN
  5696.         ELSE
  5697.         IERR = 0
  5698.     ENDIF
  5699.     IACTIVE_BUFFER = 1
  5700.     ISTAT = SYS$SETEF(%VAL(IFLAG(1)))
  5701. D    IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT))
  5702.     ISTAT = SYS$SETEF(%VAL(IFLAG(2)))
  5703. D    IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT))
  5704. C
  5705.     CALL SCOPY(ENDSTR,END_STRING)
  5706.     IEND_LENGTH = LEN(END_STRING)
  5707.     BEGIN_STRING(1) = 0
  5708.     IBEGIN_LENGTH = 0
  5709. C
  5710.     TERM_CHAR = TERMIN
  5711. C
  5712.     CALL GB_INIT_BUFFER
  5713.     RETURN
  5714.     END
  5715.  
  5716.  
  5717.     SUBROUTINE GB_BEGIN_STRING(STRING)
  5718. C
  5719. C    THIS SUBROUTINE SETS THE "BEGINNING OF EACH BUFFER STRING"
  5720. C     IT SHOULD BE CALLED ONCE IMMEDIATELY AFTER CALLING GB_INITIALIZE
  5721. C
  5722.     EXTERNAL LEN
  5723. C
  5724.     CALL SCOPY(STRING,BEGIN_STRING)
  5725.     IBEGIN_LENGTH = LEN(BEGIN_STRING)
  5726.     CALL GB_INIT_BUFFER
  5727.     RETURN
  5728.     END
  5729.  
  5730.  
  5731.  
  5732.     SUBROUTINE GB_NEW_BUFFER
  5733. C
  5734. C    SUBROUTINE TO INITIALIZE THE GRAPHIC COMMAND BUFFER
  5735. C
  5736.     INCLUDE 'GBCOMMON2.CMN'
  5737. C
  5738.     INTEGER*4 SYS$WAITFR
  5739. C
  5740.     IACTIVE_BUFFER = IACTIVE_BUFFER+1
  5741.     IF (IACTIVE_BUFFER .GT. 2) IACTIVE_BUFFER = 1
  5742. D    TYPE *,'IACTIVE_BUFFER IS ',IACTIVE_BUFFER
  5743. D    TYPE *,'THAT FLAG IS ',IFLAG(IACTIVE_BUFFER)
  5744. C
  5745. C    MAKE SURE THIS NEW BUFFER IS EMPTY, IF NOT, WAIT FOR IT
  5746. C    TO EMPTY
  5747. C
  5748.     ISTAT = SYS$WAITFR(%VAL(IFLAG(IACTIVE_BUFFER)))
  5749. D    IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT))
  5750.     GO TO 100
  5751. C
  5752.     ENTRY GB_INIT_BUFFER()
  5753. C
  5754. 100    CALL SCOPY(BEGIN_STRING,BUFFER(1,IACTIVE_BUFFER))
  5755.     IBFPTR = IBEGIN_LENGTH + 1
  5756.     L_USE_TERMINATOR = .FALSE.
  5757.     RETURN
  5758.     END
  5759.  
  5760.  
  5761.  
  5762.     FUNCTION GB_TEST_FLUSH(NUMCHR)
  5763.     LOGICAL GB_TEST_FLUSH
  5764. C
  5765. C    THIS SUBROUTINE CHECKS TO MAKE SURE THERE IS ENOUGH ROOM IN
  5766. C    THE BUFFER FOR "NUMCHR" MORE CHARACTERS, IF NOT, IF MAKES ROOM BY
  5767. C    EMPTYING THE BUFFER.
  5768. C
  5769.     INCLUDE 'GBCOMMON2.CMN'
  5770. C
  5771.     IF (IBFPTR+NUMCHR+IEND_LENGTH .GE. IBFSIZ) THEN
  5772.         CALL GB_EMPTY
  5773.         GB_TEST_FLUSH = .TRUE.
  5774.         ELSE
  5775.         GB_TEST_FLUSH = .FALSE.
  5776.         ENDIF
  5777.     RETURN
  5778.     END
  5779.  
  5780.  
  5781.  
  5782.     SUBROUTINE GB_USE_TERMINATOR
  5783. C
  5784. C    THIS SUBROUTINE SETS THE "USE TERMINATOR" FLAG TO TRUE.
  5785. C    THE FLAG IS SET TO FALSE BY CALLING GB_NO_TERMINATOR OR BY
  5786. C    EMPTYING/CLEARING THE BUFFER.
  5787. C
  5788.     INCLUDE 'GBCOMMON2.CMN'
  5789. C
  5790.     L_USE_TERMINATOR = .TRUE.
  5791.     RETURN
  5792.     END
  5793.  
  5794.  
  5795.  
  5796.     SUBROUTINE GB_NO_TERMINATOR
  5797. C
  5798. C    THIS SUBROUTINE CLEARS THE "USE TERMINATOR" FLAG TO FALSE.
  5799. C
  5800.     INCLUDE 'GBCOMMON2.CMN'
  5801. C
  5802.     L_USE_TERMINATOR = .FALSE.
  5803.     RETURN
  5804.     END
  5805.  
  5806.  
  5807.  
  5808.     SUBROUTINE GB_EMPTY
  5809. C
  5810. C    THIS SUBROUTINE EMPTYS THE BUFFER IF IT HAS ANYTHING
  5811. C
  5812.     INCLUDE 'GBCOMMON2.CMN'
  5813.     INTEGER*2 IOSB(4,2)
  5814. C
  5815. C
  5816.     IF (IBFPTR-1 .LE. IBEGIN_LENGTH) THEN
  5817.         CALL GB_INIT_BUFFER
  5818.         RETURN
  5819.     ENDIF
  5820.     IF (L_USE_TERMINATOR) CALL GB_INSERT(TERM_CHAR)
  5821.     IF (IEND_LENGTH .NE. 0) CALL GB_IN_STRING(END_STRING)
  5822.     IF (IBFPTR .GT. IBFSIZ+1) STOP 'BUFFERING ERROR - BUFFER OVERFLOWED'
  5823. C
  5824. C    SEND TO TTY
  5825. C
  5826.     CALL GB_SEND_TTY(BUFFER(1,IACTIVE_BUFFER),
  5827.     1   IBFPTR-1,IFLAG(IACTIVE_BUFFER),IOSB(1,IACTIVE_BUFFER))
  5828.     CALL GB_NEW_BUFFER
  5829.     RETURN
  5830.     END
  5831.  
  5832.  
  5833.  
  5834.     SUBROUTINE GB_SEND_CHARS(STRING,LENGTH)
  5835.     BYTE STRING(LENGTH)
  5836. C
  5837.     INTEGER*2 IOSB(4)
  5838. C
  5839.     CALL GB_SEND_TTY(STRING,LENGTH,0,IOSB)
  5840.     RETURN
  5841.     END
  5842.  
  5843.  
  5844.  
  5845.     SUBROUTINE GB_SEND_TTY(TTY_BUFFER,IBUFR_LEN,IEVFLAG,IOSB)
  5846.     BYTE TTY_BUFFER(IBUFR_LEN)
  5847.     INTEGER*2 IOSB(4)
  5848. C
  5849. C    *** VMS SPECIFIC ***
  5850. C    NOTE: FOR INTERNAL USE ONLY.   NO DRIVERS SHOULD CALL THIS ROUTINE.
  5851. C    DRIVERS SHOULD USE GB_SEND_CHARS INSTEAD.
  5852. C
  5853. C    THIS SUBROUTINE EMPTYS THE BUFFER IF IT HAS ANYTHING
  5854. C
  5855.     INCLUDE '($IODEF)'
  5856. C    PARAMETER (IO_WRITEV = '00000130'X)    !IO$_WRITEVBLK+IO$M_NOFORMAT
  5857.     INCLUDE '($SSDEF)'
  5858.     INCLUDE 'GBCOMMON2.CMN'
  5859. C
  5860.     INTEGER*4 CR_CONTROL
  5861.     PARAMETER (CR_CONTROL = 0)
  5862. C
  5863.     INTEGER*4 SYS$QIO
  5864. C
  5865. C    DO THE QIO TO THE OUTPUT DEVICE
  5866. C
  5867. 10    CONTINUE
  5868.     ISTAT = SYS$QIO(%VAL(IEVFLAG),%VAL(IOCHAN),
  5869.     1   %VAL(IO$_WRITEVBLK+IO$M_NOFORMAT),
  5870.     2   IOSB, , ,
  5871.     3   TTY_BUFFER,%VAL(IBUFR_LEN), ,%VAL(CR_CONTROL), , )
  5872.     IF (.NOT. ISTAT) then
  5873.         type 999, istat
  5874. 999        format(' QIOW to terminal failed, status was ',i9)
  5875.     ENDIF
  5876.     RETURN
  5877.     END
  5878.  
  5879.  
  5880.  
  5881.     SUBROUTINE GB_INSERT(BCHAR)
  5882.     BYTE BCHAR
  5883. C
  5884. C    THIS SUBROUTINE INSERTS A CHARACTER INTO THE BUFFER
  5885. C
  5886.     INCLUDE 'GBCOMMON2.CMN'
  5887. C
  5888.     BUFFER(IBFPTR,IACTIVE_BUFFER) = BCHAR
  5889.     IBFPTR = IBFPTR + 1
  5890.     RETURN
  5891.     END
  5892.  
  5893.  
  5894.     SUBROUTINE GB_IN_STRING(STRING)
  5895.     BYTE STRING(80)
  5896. C
  5897. C    THIS SUBROUTINE INSERTS THE STRING INTO THE GRAPHICS BUFFER
  5898. C
  5899.     EXTERNAL LEN
  5900. C
  5901.     DO 100 I=1, LEN(STRING)
  5902.       CALL GB_INSERT(STRING(I))
  5903. 100      CONTINUE
  5904.     RETURN
  5905.     END
  5906.  
  5907.  
  5908.     SUBROUTINE GB_FINISH(RELEASE_STRING)
  5909.     BYTE RELEASE_STRING(2)
  5910. C
  5911. C    *** VMS SPECIFIC ***
  5912. C
  5913. C    THIS SUBROUTINE RELEASES THE I/O CHANNAL TO THE OUTPUT DEVICE
  5914. C
  5915.     INCLUDE 'GBCOMMON2.CMN'
  5916. C
  5917.     INTEGER*4 SYS$DASSGN, SYS$WAITFR
  5918.     EXTERNAL LEN
  5919. C
  5920.     IF (LEN(RELEASE_STRING) .NE. 0) THEN
  5921.         CALL GB_EMPTY
  5922.         CALL GB_IN_STRING(RELEASE_STRING)
  5923.         CALL GB_EMPTY
  5924.       ENDIF
  5925.     ISTAT = SYS$WAITFR(%VAL(IFLAG(1)))
  5926. D    IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT))
  5927.     ISTAT = SYS$WAITFR(%VAL(IFLAG(2)))
  5928. D    IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT))
  5929.     ISTAT = SYS$DASSGN(%VAL(IOCHAN))
  5930. D    IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT))
  5931.     ISTAT = LIB$FREE_EF(IFLAG(1))
  5932. D    IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT))
  5933.     ISTAT = LIB$FREE_EF(IFLAG(2))
  5934. D    IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT))
  5935.     RETURN
  5936.     END
  5937.  
  5938.  
  5939.     SUBROUTINE GB_GIN(PROMPT,IGIN_CHARS_MAX,L_TERMS_OK,GINBUFR)
  5940.     BYTE GINBUFR(2), PROMPT(2)
  5941.     LOGICAL*1 L_TERMS_OK
  5942. C
  5943. C    *** VMS SPECIFIC ***
  5944. C
  5945. C    THIS SUBROUTINE DOES A GIN OPERATION VIA A "READ-AFTER-PROMPT"
  5946. C    QIOW.
  5947. C
  5948.     INCLUDE 'GBCOMMON2.CMN'
  5949. C
  5950. C    PARAMETER (IO_READ_PROMPT = '877'X)
  5951. C    PARAMETER (IO_READ_NOECHO = '71'X)
  5952.     INCLUDE '($IODEF)'
  5953. C
  5954.     INTEGER*4 SYS$QIOW
  5955.     INTEGER*2 IOSB(4)
  5956.     EXTERNAL LEN
  5957. C
  5958.     IPRLEN = LEN(PROMPT)
  5959.     IF (IPRLEN .EQ. 0) THEN
  5960.         IFXN = IO$_READVBLK + IO$M_NOECHO
  5961.         ELSE
  5962.         IFXN = IO$_READPROMPT + IO$M_PURGE + IO$M_NOECHO
  5963.     ENDIF
  5964.     II = 1
  5965.     NUMBER_TO_GET = IGIN_CHARS_MAX
  5966.     ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN),
  5967.     1   %VAL(IFXN),
  5968.     1   IOSB, , ,GINBUFR(II),%VAL(NUMBER_TO_GET),%VAL(0), ,
  5969.     2   PROMPT,%VAL(IPRLEN))
  5970.     IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT))
  5971.     IF (.NOT. L_TERMS_OK) GO TO 800
  5972. 100    CONTINUE
  5973.     NUMBER_GOT = IOSB(2)+IOSB(4)
  5974. D    TYPE 9999, NUMBER_GOT, (GINBUFR(I), I=1,NUMBER_GOT+II-1)
  5975. D9999    FORMAT(/' GB_GIN just got ',I2,' characters.'
  5976. D    1   /' The characters buffered so far are:'
  5977. D    2   /,20(1X,I3))
  5978.     IF (NUMBER_GOT .GE. NUMBER_TO_GET) GOTO 800
  5979.     NUMBER_TO_GET = NUMBER_TO_GET - NUMBER_GOT
  5980.     II = NUMBER_GOT + II
  5981.     ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN),
  5982.     1   %VAL(IO$_READVBLK+IO$M_NOECHO),
  5983.     1   IOSB, , ,GINBUFR(II),%VAL(NUMBER_TO_GET), , , , )
  5984.     IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT))
  5985.     GO TO 100
  5986. 800    RETURN
  5987.     END
  5988.  
  5989.  
  5990.  
  5991.     SUBROUTINE GB_INTERLOCK(PROMPT,IN_BUFFER,IN_CHAR_COUNT)
  5992. C
  5993. C    *** VMS SPECIFIC ***
  5994. C
  5995. C    THIS SUBROUTINE IS USED BY THOSE DRIVERS THAT MUST USE AN INTERLOCKING
  5996. C      WITH THE TERMINAL SO THAT BUFFER OVERFLOW DOES NOT OCCUR IN THE
  5997. C      TERMINAL.   MOSTLY, THIS IS CAUSED BY HP TERMINALS.   IT SEEMS
  5998. C      THAT HP NEVER HAS UNDERSTOOD THE USEFULNESS OF XON/XOFF!
  5999. C
  6000.     INCLUDE 'GBCOMMON2.CMN'
  6001. C
  6002.     INCLUDE '($IODEF)'
  6003. C    PARAMETER (IO_READ_PROMPT = '877'X)
  6004. C        IO$_READPROMPT + IO$M_PURGE + IO$M_NOECHO
  6005. C
  6006.     INTEGER*4 SYS$QIOW
  6007.     INTEGER*2 IOSB(4)
  6008.     EXTERNAL LEN
  6009. C
  6010.     IPRLEN = LEN(PROMPT)
  6011.     ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN),
  6012.     1   %VAL(IO$_READPROMPT+IO$M_NOECHO+IO$M_PURGE),
  6013.     2   IOSB, , ,IN_BUFFER,%VAL(IN_CHAR_COUNT),%VAL(0),%VAL(0),
  6014.     3   PROMPT,%VAL(IPRLEN))
  6015.     IF (.NOT. ISTAT) STOP 'INTERLOCK QIOW FAILED'
  6016.     RETURN
  6017.     END
  6018.  
  6019.  
  6020.  
  6021.     SUBROUTINE GB_OUTPUT_BUFFER(BUFFER,IBUFLEN)
  6022.     BYTE BUFFER(IBUFLEN)
  6023. C
  6024. C    SUBROUTINE TO OUTPUT A BUFFER
  6025. C
  6026.     INTEGER*2 IOSB(4)
  6027.     INTEGER*4 LIB$GET_EF, SYS$WAITFR
  6028. C
  6029.     DATA IEVFLAG /-1/
  6030. C
  6031.     IF (IEVFLAG .LT. 0) THEN
  6032.         ISTAT = LIB$GET_EF(IEVFLAG)
  6033.     ENDIF
  6034.     CALL GB_SEND_TTY(BUFFER,IBUFLEN,IEVFLAG,IOSB)
  6035. CCCC    ISTAT = SYS$WAITFR(%VAL(IEVFLAG))
  6036.     RETURN
  6037.     END
  6038.  
  6039.  
  6040.  
  6041.     SUBROUTINE GB_INPUT_BUFFER(PROMPT,IPRLEN,
  6042.     1   IN_BUFFER,IN_CHAR_COUNT,IGOT)
  6043. C
  6044. C    *** VMS SPECIFIC ***
  6045. C
  6046. C    SUBROUTINE TO READ IN A BUFFER AFTER ISSUING A PROMPT
  6047. C
  6048.     INCLUDE '($IODEF)'
  6049. C    PARAMETER (IO_READ_PROMPT = '877'X)
  6050. C        IO$_READPROMPT + IO$M_PURGE + IO$M_NOECHO
  6051. C
  6052.     INCLUDE 'GBCOMMON2.CMN'
  6053. C
  6054.     INTEGER*4 SYS$QIOW, IOTERMS(2)
  6055.     INTEGER*2 IOSB(4)
  6056. C
  6057.     DATA IOTERMS /0,'2000'X/ !<CR> IS ONLY TERMINATOR
  6058. C
  6059.     ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHAN),
  6060.     1   %VAL(IO$_READPROMPT+IO$M_NOECHO+IO$M_PURGE),
  6061.     2   IOSB, , ,IN_BUFFER,%VAL(IN_CHAR_COUNT),%VAL(0),IOTERMS,
  6062.     3   PROMPT,%VAL(IPRLEN))
  6063.     IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT))
  6064.     IGOT = IOSB(2)
  6065.     RETURN
  6066.     END
  6067.     SUBROUTINE GDLASER_WIDE(IFXN,XA,YA)
  6068.     DIMENSION XA(8), YA(3)
  6069. C
  6070. C    QMS 1200 LASER PRINTER DRIVER - MULTIPLE COMMANDS ON A SINGLE LINE
  6071. C
  6072. C-----------------------------------------------------------------------
  6073. C
  6074. C    DECLARE VARS NEED FOR DRIVER OPERATION
  6075. C
  6076.     LOGICAL*1 L_NOTHING_PLOTTED, L_WIDE
  6077.     BYTE COORD(12)
  6078. C
  6079.     DIMENSION DCHAR(8)
  6080. C
  6081. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  6082. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  6083. C
  6084.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  6085.     DATA DCHAR /1200.0, 26.67, 19.685, 118.11, 118.11, 1.0, 27.0, 3.0/
  6086. C
  6087.     L_WIDE = .TRUE.
  6088. 10    CONTINUE
  6089. C
  6090. C*****************
  6091. C
  6092. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  6093. C
  6094.     IF (IFXN .LE. 0 .OR. IFXN .GT. 7) RETURN
  6095. C
  6096. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  6097. C
  6098.     GO TO (100,200,300,400,500,600,700) IFXN
  6099. C
  6100. C    *********************
  6101. C    INITIALIZE THE DEVICE
  6102. C    *********************
  6103. C
  6104. 100    CONTINUE
  6105.     LUN = XA(1)
  6106.     OPEN (UNIT=LUN,NAME='SYS$SCRATCH:LASER.DIG',TYPE='NEW',
  6107.     1   CARRIAGECONTROL='LIST',ERR=9000)
  6108. C
  6109. C    SHOW INITIALIZATION WORKED, I.E. WE OPENED THE FILE.
  6110. C
  6111.     YA(1) = 0.0
  6112.     WRITE (LUN,101)
  6113. 101    FORMAT('^PY^-'/'^F'/'^IGV ^PW03')
  6114. 190    CONTINUE
  6115.     CALL GDLSR_OPEN_BUFR(LUN)
  6116.     L_NOTHING_PLOTTED = .TRUE.
  6117.     L_PEN_IS_UP = .FALSE.
  6118.     RETURN
  6119. C
  6120. C    **************************
  6121. C    GET FRESH PLOTTING SURFACE
  6122. C    **************************
  6123. C
  6124. 200    CONTINUE
  6125.     IF (L_NOTHING_PLOTTED) RETURN
  6126.     CALL GDLSR_DUMP_BUFR
  6127.     WRITE (LUN,201)
  6128. 201    FORMAT('^,')
  6129.     GO TO 190
  6130. C
  6131. C    ****
  6132. C    MOVE
  6133. C    ****
  6134. C
  6135. 300    CONTINUE
  6136.     IF (L_PEN_IS_UP) GO TO 450
  6137.     L_PEN_IS_UP = .TRUE.
  6138.     CALL GDLSR_INSERT('^U')
  6139.     GO TO 450
  6140. C
  6141. C    ****
  6142. C    DRAW
  6143. C    ****
  6144. C
  6145. 400    CONTINUE
  6146.     IF (.NOT. L_PEN_IS_UP) GO TO 450
  6147.     CALL GDLSR_INSERT('^D')
  6148.     L_PEN_IS_UP = .FALSE.
  6149. 450    CONTINUE
  6150.     IF (L_WIDE) THEN
  6151.         IX = (10.0*XGUPCM*XA(1)/3.0)+0.5
  6152.         IY = (10.0*YGUPCM*(DCHAR(3)-YA(1))/3.0)+0.5
  6153.         ELSE
  6154.         IX = (10.0*XGUPCM*YA(1)/3.0) + 0.5
  6155.         IY = (10.0*YGUPCM*XA(1)/3.0) + 0.5
  6156.     ENDIF
  6157.     ENCODE (11,451,COORD) IX,IY
  6158. 451    FORMAT(I5,':',I5)
  6159.     DO 460 I=1,11
  6160.         IF (COORD(I) .EQ. 32) COORD(I) = 48
  6161. 460        CONTINUE
  6162.     COORD(12) = 0
  6163.     CALL GDLSR_INSERT(COORD)
  6164.     L_NOTHING_PLOTTED = .FALSE.
  6165.     RETURN
  6166. C
  6167. C    *****************************
  6168. C    FLUSH GRAPHICS COMMAND BUFFER
  6169. C    *****************************
  6170. C
  6171. 500    CONTINUE
  6172.     RETURN        !DONE BY BGNPLT WHEN NECESSARY.
  6173. C
  6174. C    ******************
  6175. C    RELEASE THE DEVICE
  6176. C    ******************
  6177. C
  6178. 600    CONTINUE
  6179. CC    IF (.NOT. L_NOTHING_PLOTTED) WRITE (LUN,602)
  6180. CC602    FORMAT('^,')
  6181.     CALL GDLSR_DUMP_BUFR
  6182.     WRITE (LUN,601)
  6183. 601    FORMAT('^IGE'/'^O'/'^PN^-')
  6184.     CLOSE (UNIT=LUN)
  6185.     ISTATUS = LIB$SPAWN('$ DIGLASEROUT SYS$SCRATCH:LASER.DIG')
  6186.     RETURN
  6187. C
  6188. C    *****************************
  6189. C    RETURN DEVICE CHARACTERISTICS
  6190. C    *****************************
  6191. C
  6192. 700    CONTINUE
  6193.     DO 720 I=1,8
  6194.     XA(I) = DCHAR(I)
  6195. 720    CONTINUE
  6196.     IF (.NOT. L_WIDE) THEN
  6197.         XA(2) = DCHAR(3)
  6198.         XA(3) = DCHAR(2)
  6199.     ENDIF
  6200.     RETURN
  6201. C
  6202. C    HANDLE FILE OPEN ERROR
  6203. C
  6204. 9000    CONTINUE
  6205.     YA(1) = 3.0
  6206.     RETURN
  6207. C
  6208. C    ***********************************************************
  6209. C
  6210.     ENTRY GDLASER_TALL(IFXN,XA,YA)
  6211.     L_WIDE = .FALSE.
  6212.     GO TO 10
  6213.     END
  6214.  
  6215.  
  6216.     SUBROUTINE GDLSR_OPEN_BUFR(LUN)
  6217. C
  6218.     PARAMETER (IBUFR_SIZE = 120)
  6219.     BYTE BUFFER
  6220.     COMMON /GDLSR/ NXTCHR, LUNOUT, BUFFER(IBUFR_SIZE)
  6221. C
  6222.     LUNOUT = LUN
  6223.     NXTCHR = 1
  6224.     RETURN
  6225.     END
  6226.  
  6227.  
  6228.     SUBROUTINE GDLSR_INIT_BUFR
  6229. C
  6230.     PARAMETER (IBUFR_SIZE = 120)
  6231.     BYTE BUFFER
  6232.     COMMON /GDLSR/ NXTCHR, LUNOUT, BUFFER(IBUFR_SIZE)
  6233. C
  6234.     NXTCHR = 1
  6235.     RETURN
  6236.     END
  6237.  
  6238.  
  6239.     SUBROUTINE GDLSR_INSERT(STRING)
  6240.     BYTE STRING(2)
  6241. C
  6242.     PARAMETER (IBUFR_SIZE = 120)
  6243.     BYTE BUFFER
  6244.     COMMON /GDLSR/ NXTCHR, LUNOUT, BUFFER(IBUFR_SIZE)
  6245. C
  6246.     EXTERNAL LEN
  6247. C
  6248.     L = LEN(STRING)
  6249.     IF ((NXTCHR+L) .GT. IBUFR_SIZE) CALL GDLSR_DUMP_BUFR
  6250.         DO 100 I = 1, L
  6251.         BUFFER(NXTCHR) = STRING(I)
  6252.         NXTCHR = NXTCHR + 1
  6253. 100        CONTINUE
  6254.     RETURN
  6255.     END
  6256.  
  6257.     SUBROUTINE GDLSR_DUMP_BUFR
  6258. C
  6259.     PARAMETER (IBUFR_SIZE = 120)
  6260.     BYTE BUFFER
  6261.     COMMON /GDLSR/ NXTCHR, LUNOUT, BUFFER(IBUFR_SIZE)
  6262. C
  6263.     IF (NXTCHR .EQ. 1) RETURN
  6264.     WRITE (LUNOUT,11) (BUFFER(I), I=1,NXTCHR-1)
  6265. 11    FORMAT(132A1)
  6266.     NXTCHR = 1
  6267.     RETURN
  6268.     END
  6269.     SUBROUTINE GDLEX(IFXN,XA,YA)
  6270.     DIMENSION XA(8), YA(3)
  6271. C
  6272. C    LEXIDATA 3400 DRIVER FOR VAX/VMS
  6273. C
  6274. C-----------------------------------------------------------------------
  6275. C
  6276.     PARAMETER (MAXY=511)
  6277.     CHARACTER*(*) DEVICE_NAME
  6278.     PARAMETER (DEVICE_NAME='LXA0:')
  6279.  
  6280.     INTEGER LX_BUFFER_SIZE
  6281.     PARAMETER (LX_BUFFER_SIZE = 512)
  6282.     PARAMETER (LX_COMMAND_LOAD_LUT = 20)
  6283.     PARAMETER (LX_COMMAND_CVEC = 41)
  6284.     PARAMETER (LX_COMMAND_POLY = 42)
  6285.  
  6286. C
  6287. C    DEFINE BUFFER STATES FOR "LX_BUFFER_STATUS"
  6288. C
  6289.     INTEGER NO_VECTOR, VECTOR_MOVE, VECTOR_DRAW
  6290.     PARAMETER (NO_VECTOR = 0)
  6291.     PARAMETER (VECTOR_MOVE = 1)
  6292.     PARAMETER (VECTOR_DRAW = 2)
  6293.  
  6294.     DIMENSION DCHAR(8)
  6295.     INTEGER*2 BUFFER(LX_BUFFER_SIZE)
  6296.     INTEGER*2 LX_ERASE_INIT(55)
  6297.     INTEGER*2 LX_CURSOR(4), LX_READ_CURSOR(5)
  6298.  
  6299.     INTEGER*4 SYS$ASSIGN, SYS$QIOW, SYS$DASSGN
  6300.     INTEGER*2 IOCHANTT
  6301.  
  6302.     BYTE CHARBUFR
  6303. C
  6304. C    FUNNY BUSINESS NEEDED TO PREVENT "INTEGER OVERFLOW" MESSAGE
  6305. C
  6306.     INTEGER*4 IX
  6307.     INTEGER*2 IXEQ(2)
  6308.     EQUIVALENCE (IX,IXEQ(1))
  6309. C
  6310. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  6311. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  6312. C
  6313.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  6314. C
  6315. C    DATA WE WILL NEED
  6316. C
  6317.     DATA DCHAR /3400, 32.79, 26.23, 19.5, 19.5, 1023.0, 981.0, 1.0/
  6318.     DATA IOREADNOECHO /'00000071'X/
  6319.  
  6320.     DATA LX_ERASE_INIT / 3,4095,    !ERASE ALL 12 PLANES
  6321.     1   24,639,511,20,        !CONFIGURE
  6322.     1   10,0,0,1,            !NO ZOOM OR PAN
  6323.     2   2,1023,1023,1023,        !ENABLE FIRST 10 BIT PLANES
  6324.     3   27,                !ERASE MATRIX CURSOR
  6325.     4   26,2,76,32,            !SELECT MATRIX CURSOR WITH OFFSETS
  6326.     5   7,0,0,            !ZERO LITES
  6327.     6   20,1024,8,0,255,255,0,0,255,255,0,    !RED PORTION LUT 0->7
  6328.     7   20,2048,8,0,255,0,255,0,255,0,255,    !GREEN PART
  6329.     8   20,3072,8,0,255,0,0,255,0,255,255/    !BLUE PART
  6330.     DATA LX_ERASE_INIT_WORDS /55/
  6331.     DATA LX_INIT_START /3/
  6332.  
  6333.     DATA LX_CURSOR /26, 0, 76, 38/    !SELECT CROSS HAIR CURSOR
  6334.     DATA LX_CURSOR_WORDS /4/
  6335.     DATA LX_READ_CURSOR /26, 2, 76, 38,    !SELECT MATRIX CURSOR
  6336.     1   5/                    !READ X,Y,SWITCHES
  6337.     DATA LX_READ_CURSOR_WORDS /5/
  6338.  
  6339. C
  6340. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  6341. C
  6342.     IF (IFXN .GE. 1027) GO TO 20000    !POLYGON
  6343.     IF (IFXN .LE. 0 .OR. IFXN .GT. 10) RETURN
  6344. C
  6345. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  6346. C
  6347.     GO TO (100,200,300,300,500,600,700,800,900,1000) IFXN
  6348. C
  6349. C    *********************
  6350. C    INITIALIZE THE DEVICE
  6351. C    *********************
  6352. C
  6353. 100    CONTINUE
  6354. C
  6355. C    FIND THE I/O CHANNAL ASSICIATED WITH THE TERMINAL FOR DOING GINS
  6356. C
  6357.     ISTAT = LX_OPEN()
  6358.     IF (ISTAT .NE. 1) THEN
  6359.         YA(1) = 2.0
  6360.         RETURN
  6361.     ENDIF
  6362.     ISTAT = SYS$ASSIGN('TT',IOCHANTT,,)
  6363.     IF (.NOT. ISTAT) THEN
  6364.         YA(1) = 2.0
  6365.         RETURN
  6366.         ELSE
  6367.         YA(1) = 0.0
  6368.     ENDIF
  6369. C
  6370. C    INITIALIZE THE LEXIDATA
  6371. C
  6372.     I = LX_INIT_START
  6373. 120    CONTINUE
  6374.     CALL LX_WRITE(LX_ERASE_INIT(I),LX_ERASE_INIT_WORDS+1-I)
  6375.     NXT = 1
  6376.     LX_BUFFER_STATUS = NO_VECTOR
  6377.     ICURRENT_COLOR = 1
  6378.     IX = 0
  6379.     IY = 0
  6380.     RETURN
  6381. C
  6382. C    **************************
  6383. C    GET FRESH PLOTTING SURFACE
  6384. C    **************************
  6385. C
  6386. 200    CONTINUE
  6387. C
  6388. C    ERASE THE LEXIDATA SCREEN AND RETURN TO NORMAL
  6389. C
  6390.     I = 1
  6391.     GO TO 120
  6392. C
  6393. C    *************
  6394. C    MOVE AND DRAW
  6395. C    *************
  6396. C
  6397. 300    CONTINUE
  6398.     IF ((LX_BUFFER_STATUS .EQ. NO_VECTOR) .OR.
  6399.     1   (NXT+2 .GE. LX_BUFFER_SIZE)) THEN
  6400.         IF (LX_BUFFER_STATUS .NE. NO_VECTOR) THEN
  6401.             CALL GDLEX_TERM_VECT(BUFFER,ICOUNT,NXT)
  6402.         ENDIF
  6403.         IF (NXT+32 .GE. LX_BUFFER_SIZE) THEN
  6404.             CALL LX_WRITE(BUFFER,NXT-1)
  6405.             NXT = 1
  6406.         ENDIF
  6407.         BUFFER(NXT) = LX_COMMAND_CVEC
  6408.         BUFFER(NXT+1) = ICURRENT_COLOR
  6409.         ICOUNT = NXT+2
  6410.         IX = IX .OR. "100000
  6411.         BUFFER(NXT+3) = IXEQ(1)
  6412.         BUFFER(NXT+4) = IY
  6413.         NXT = NXT + 5
  6414.         LX_BUFFER_STATUS = VECTOR_MOVE
  6415.     ENDIF
  6416. C
  6417. C    CONVERT CM. TO GRAPHICS UNITS ROUNDED
  6418. C
  6419.     IX = XGUPCM*XA(1) + 0.5
  6420.     IY = MAXY - INT(YGUPCM*YA(1) + 0.5)
  6421.     IF (IFXN .EQ. 3) THEN
  6422.         IX = IX .OR. "100000
  6423.         IF (LX_BUFFER_STATUS .EQ. VECTOR_MOVE) NXT = NXT - 2
  6424.         LX_BUFFER_STATUS = VECTOR_MOVE
  6425.         ELSE
  6426.         LX_BUFFER_STATUS = VECTOR_DRAW
  6427.     ENDIF
  6428.     BUFFER(NXT) = IXEQ(1)
  6429.     BUFFER(NXT+1) = IY
  6430.     NXT = NXT + 2
  6431.     RETURN
  6432. C
  6433. C    *****************************
  6434. C    FLUSH GRAPHICS COMMAND BUFFER
  6435. C    *****************************
  6436. C
  6437. 500    CONTINUE
  6438.     IF (LX_BUFFER_STATUS .NE. NO_VECTOR) THEN
  6439.         CALL GDLEX_TERM_VECT(BUFFER,ICOUNT,NXT)
  6440.         LX_BUFFER_STATUS = NO_VECTOR
  6441.     ENDIF
  6442.     IF (NXT .GT. 1) CALL LX_WRITE(BUFFER,NXT-1)
  6443.     RETURN
  6444. C
  6445. C    ******************
  6446. C    RELEASE THE DEVICE
  6447. C    ******************
  6448. C
  6449. 600    CONTINUE
  6450. C
  6451. C    DE-ASSIGN THE CHANNALS
  6452. C
  6453.     ISTAT = SYS$DASSGN(%VAL(IOCHANTT))
  6454.     CALL LX_CLOSE
  6455.     RETURN
  6456. C
  6457. C    *****************************
  6458. C    RETURN DEVICE CHARACTERISTICS
  6459. C    *****************************
  6460. C
  6461. 700    CONTINUE
  6462.     DO 720 I=1,8
  6463.     XA(I) = DCHAR(I)
  6464. 720    CONTINUE
  6465.     RETURN
  6466. C
  6467. C    ****************************
  6468. C    SELECT CURRENT DRAWING COLOR
  6469. C    ****************************
  6470. C
  6471. 800    CONTINUE
  6472.     ICURRENT_COLOR = XA(1)
  6473.     IF (LX_BUFFER_STATUS .NE. NO_VECTOR) THEN
  6474.         CALL GDLEX_TERM_VECT(BUFFER,ICOUNT,NXT)
  6475.         LX_BUFFER_STATUS = NO_VECTOR
  6476.     ENDIF
  6477.     RETURN
  6478. C
  6479. C    **********************
  6480. C    PERFORM GRAPHICS INPUT
  6481. C    **********************
  6482. C
  6483. 900    CONTINUE
  6484.     IF (LX_BUFFER_STATUS .NE. NO_VECTOR) THEN
  6485.         CALL GDLEX_TERM_VECT(BUFFER,ICOUNT,NXT)
  6486.     ENDIF
  6487.     IF (NXT+LX_CURSOR_WORDS .GE. LX_BUFFER_SIZE) THEN
  6488.         CALL LX_WRITE(BUFFER,NXT-1)
  6489.         NXT = 1
  6490.     ENDIF
  6491.     DO 910 I=1,LX_CURSOR_WORDS
  6492.         BUFFER(NXT) = LX_CURSOR(I)
  6493.         NXT = NXT + 1
  6494. 910        CONTINUE
  6495.     CALL LX_WRITE(BUFFER,NXT-1)
  6496.     LX_BUFFER_STATUS = NO_VECTOR
  6497.     NXT = 1
  6498. C
  6499. C    ASK FOR 1 CHARACTER FROM THE TERMINAL
  6500. C
  6501.     ISTAT = SYS$QIOW(%VAL(0),%VAL(IOCHANTT),%VAL(IOREADNOECHO),
  6502.     1   IOSB, , ,CHARBUFR,%VAL(1), , , , )
  6503.     IF (.NOT. ISTAT) STOP 'GD9400 - GIN FAILURE'
  6504. C
  6505. C    TELL LEXIDATA TO DROP CROSS HAIR CURSOR AND TO READ
  6506. C     THE CURSOR POSITION
  6507. C
  6508.     CALL LX_WRITE(LX_READ_CURSOR,LX_READ_CURSOR_WORDS)
  6509.     CALL LX_READ(BUFFER,3)
  6510. D    TYPE *,'CURSOR LOCATION ',BUFFER(1), BUFFER(2)
  6511. C
  6512. C    GET THE KEY, X POSITION, AND Y POSITION
  6513. C
  6514.     XA(1) = CHARBUFR            !PICK CHARACTER
  6515.     XA(2) = FLOAT(BUFFER(1))/XGUPCM        !X IN CENTIMETERS.
  6516.     XA(3) = FLOAT(MAXY-BUFFER(2))/YGUPCM    !Y IN CM.
  6517.     RETURN
  6518. C
  6519. C    **************************
  6520. C    SET COLOR USING RGB VALUES
  6521. C    **************************
  6522. C
  6523. 1000    CONTINUE
  6524.     IF (LX_BUFFER_STATUS .NE. NO_VECTOR) THEN
  6525.         CALL GDLEX_TERM_VECT(BUFFER,ICOUNT,NXT)
  6526.     ENDIF
  6527.     IF (NXT+16 .GT. LX_BUFFER_SIZE) THEN
  6528.         CALL LX_WRITE(BUFFER,NXT-1)
  6529.         NXT = 1
  6530.     ENDIF
  6531.     LX_BUFFER_STATUS = NO_VECTOR
  6532.     ICOLOR = XA(1)
  6533.     DO 1010 I=1,3
  6534.         BUFFER(NXT) = LX_COMMAND_LOAD_LUT
  6535.         ICOLOR = ICOLOR + 1024
  6536.         BUFFER(NXT+1) = ICOLOR        !LUT ADDRESS
  6537.         BUFFER(NXT+2) = 1        !1 LUT ADDRESS TO LOAD
  6538.         BUFFER(NXT+3) = 2.55*YA(I)+0.5
  6539.         NXT = NXT + 4
  6540. 1010        CONTINUE
  6541. D    TYPE 9997, ICOLOR, (BUFFER(I), I=NXT-9,NXT-1,4)
  6542. D9997    FORMAT(' COLOR ',I4,' IS ',3(I4,2X))
  6543.     RETURN
  6544. C
  6545. C    ***************
  6546. C    CONVEX POLYGONS
  6547. C    ***************
  6548. C
  6549. 20000    CONTINUE
  6550.     NPTS = IFXN - 1024
  6551.     IF (LX_BUFFER_STATUS .NE. NO_VECTOR) THEN
  6552.         CALL GDLEX_TERM_VECT(BUFFER,ICOUNT,NXT)
  6553.         LX_BUFFER_STATUS = NO_VECTOR
  6554.     ENDIF
  6555.     IF ((NXT+3+2*NPTS) .GE. LX_BUFFER_SIZE) THEN
  6556.         CALL LX_WRITE(BUFFER,NXT-1)
  6557.         NXT = 1
  6558.     ENDIF
  6559.     BUFFER(NXT) = LX_COMMAND_POLY
  6560.     BUFFER(NXT+1) = ICURRENT_COLOR
  6561.     BUFFER(NXT+2) = 2*NPTS
  6562.     NXT = NXT + 3
  6563.     DO 20010 I=1,NPTS
  6564.         BUFFER(NXT) = XGUPCM*XA(I) + 0.5
  6565.         BUFFER(NXT+1) = MAXY - INT(YGUPCM*YA(I)+0.5)
  6566.         NXT = NXT + 2
  6567. 20010        CONTINUE
  6568.     RETURN
  6569.     END
  6570.     SUBROUTINE GDLEX_TERM_VECT(BUFFER,ICOUNT,NXT)
  6571.     INTEGER*2 BUFFER(NXT)
  6572. C
  6573. C    THIS SUBROUTINE PROPERLY TERMINATES A CHAINED VECTOR SEQUENCE
  6574. C     BY CALCULATING THE WORD COUNT AND PLACING IT INTO THE BUFFER
  6575. C
  6576.     NWORDS = (NXT-ICOUNT) - 1
  6577.     IF (NWORDS .EQ. 0) THEN
  6578.         NXT = NXT - 3
  6579.         ELSE
  6580.         BUFFER(ICOUNT) = NWORDS
  6581. D        TYPE 9999, (BUFFER(I), I=ICOUNT-2,NXT-1)
  6582. D9999        FORMAT(//' Vector buffer is:',10000(/1X,I6))
  6583.     ENDIF
  6584.     RETURN
  6585.     END
  6586.     SUBROUTINE GDLXY11(IFXN,XA,YA)
  6587.     DIMENSION XA(8), YA(3)
  6588. C
  6589. C    DIGLIB LXY-11 GRAPHICS DEVICE DRIVER
  6590. C
  6591. C-----------------------------------------------------------------------
  6592. C
  6593.     DIMENSION DCHAR(8)
  6594.     LOGICAL*2 LDUMPIT, LWIDE
  6595. C
  6596. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  6597. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  6598. C
  6599.     EQUIVALENCE (DCHAR(2),X_FULL_SCALE)
  6600.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  6601.     DATA DCHAR /302.0, 21.59, 26.67, 78.7402, 78.7402, 1.0, 3.0, 1.0/
  6602.     SAVE LDUMPIT
  6603. C
  6604. C    SHOW WE WANT wide NOT tall PLOTTING AREA
  6605. C
  6606.     LWIDE = .TRUE.
  6607. 10    CONTINUE
  6608. C
  6609. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  6610. C
  6611.     IF (IFXN .LE. 0 .OR. IFXN .GT. 7) RETURN
  6612. C
  6613. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  6614. C
  6615.     GO TO (100,200,300,400,500,600,700) IFXN
  6616. C
  6617. C    *********************
  6618. C    INITIALIZE THE DEVICE
  6619. C    *********************
  6620. C
  6621. 100    CONTINUE
  6622.         FACT = 1.0                        ! ENLARGE   
  6623.         IS = 0                            ! SELEST POSTPROCESSING
  6624.         LU = XA(1)                        ! LU IS IGNORED, INCLUDED ANYWAY
  6625.     CALL PLOTST (1,'CM',IS)
  6626.     CALL FACTOR (FACT)
  6627.     LDUMPIT = .FALSE.
  6628.     YA(1) = 0.0
  6629.     RETURN
  6630. C
  6631. C    **************************
  6632. C    GET FRESH PLOTTING SURFACE
  6633. C    **************************
  6634. C
  6635. 200    CONTINUE
  6636.     IF (LDUMPIT) THEN
  6637.         CALL PLOT(0.0, 0.0, -3)
  6638. C        CALL FACTOR(1.0/2.54)
  6639.       ENDIF
  6640.     LDUMPIT = .FALSE.
  6641.     RETURN
  6642. C
  6643. C    ******************************
  6644. C    MOVE CURRENT REFERENCE POINTER
  6645. C    ******************************
  6646. C
  6647. 300    CONTINUE
  6648.     IPEN = +3
  6649.     GO TO 450
  6650. C
  6651. C    ****************************
  6652. C    DRAW VECTER TO POSITION X,Y
  6653. C    ****************************
  6654. C
  6655. 400    CONTINUE
  6656.     IPEN = +2
  6657. 450    IF (LWIDE) THEN
  6658.                     CALL PLOT(X_FULL_SCALE-YA(1), XA(1), IPEN)
  6659.            ELSE
  6660.                     CALL PLOT(XA(1), YA(1), IPEN)
  6661.         END IF
  6662. C
  6663.     LDUMPIT = .TRUE.
  6664.     RETURN
  6665. C
  6666. C    *****************************************************************
  6667. C    FLUSH GRAPHICS COMMAND BUFFER,CLOSE VECTOR FILE TO TERMINATE PLOT
  6668. C    *****************************************************************
  6669. C
  6670. 500    CONTINUE
  6671.         CALL PLOTND
  6672. C
  6673.     RETURN
  6674. C
  6675. C    ******************
  6676. C    RELEASE THE DEVICE
  6677. C    ******************
  6678. C
  6679. 600    CONTINUE
  6680.         ISTATUS = LIB$SPAWN(' $ RUN SYS$SYSTEM:PLXY')     !CREATE VECTOR FILE
  6681.         ISTATUS = LIB$SPAWN(' $ PRINT PLTDAT.PLT/NOFEED ') !PRINT OUTPUT FILE
  6682.     RETURN
  6683. C
  6684. C    *****************************
  6685. C    RETURN DEVICE CHARACTERISTICS
  6686. C    *****************************
  6687. C
  6688. 700    CONTINUE
  6689.     DO 720 I=1,8
  6690.     XA(I) = DCHAR(I)
  6691. 720    CONTINUE
  6692.     IF (.NOT. LWIDE) RETURN
  6693.     XA(2) = DCHAR(3)
  6694.     XA(3) = DCHAR(2)
  6695.     RETURN
  6696. C
  6697. C    ALTERNATE ENTRY FOR WIDE PLOTTING AREA
  6698. C
  6699.     ENTRY GDLXY11_tall(IFXN,XA,YA)
  6700.     LWIDE = .FALSE.
  6701.     GO TO 10
  6702.     END
  6703.     SUBROUTINE GDMCRO(IFXN,XA,YA)
  6704.     DIMENSION XA(8), YA(3)
  6705. C
  6706. C    MICROTERM ERGO 301 w/4010 graphics DRIVER FOR DIGLIB/VAX
  6707. C        1024 x 780 (4010 resolution) effective
  6708. C        hardware mapped to 768 x 245
  6709. C
  6710. C    Converted from Retro-Graphics driver by Andy Simmons.
  6711. C    Refinements by Hal R. Brand and R. A. Saroyan   Jan 85
  6712. C
  6713. C    GB_Empty puts the terminal to VT100 mode so interactive
  6714. C    graphics can be done. 
  6715. C    Must put the terminal into Plot-10 mode for each graphical
  6716. C    operation.
  6717. C
  6718. C    The fast method of sending drawing coordinates to the terminal
  6719. C    cannot be used (probably because of the switching in and out of
  6720. C    plot-10 mode). The slow method of sending coordinates is included
  6721. C    here as the subroutine GD_4010_Convert_Slo.
  6722. C
  6723. C-----------------------------------------------------------------------
  6724. C
  6725.     EXTERNAL LEN
  6726.     BYTE ESC, CSUB, TMODE, GS, CR, FF
  6727.     PARAMETER (ESC=27, CSUB=26, TMODE=24, GS=29, CR=13, FF=12)
  6728.     parameter (ENTNTV=49, ENTP10=42, EXP10=79, EXNTV=50, ENQ=5)
  6729.     CHARACTER*(*) TERMINAL
  6730.     PARAMETER (TERMINAL='TT')
  6731. C
  6732. C    DEFINITIONS FOR DEVICE CONTROL
  6733. C
  6734.     BYTE STR_BEGIN_PLOT1(6), STR_BEGIN_PLOT2(4)
  6735.     BYTE STR_ENTER_PLOT10(6), STR_EXIT_PLOT10(6)
  6736.     BYTE STR_END_PLOT(6)
  6737. C
  6738.     DATA STR_BEGIN_PLOT1 /ESC,'[','2','J',0,0/
  6739.     DATA STR_BEGIN_PLOT2 /ESC,FF,2*0/
  6740.     DATA STR_ENTER_PLOT10 /ESC,ENTNTV,ESC,ENTP10,2*0/
  6741.     DATA STR_EXIT_PLOT10 /ESC,EXP10,ESC,EXNTV,2*0/
  6742.     DATA STR_END_PLOT /ESC,'[','2','J',0,0/
  6743.     DATA LENGTH_END_PLOT /4/
  6744. C
  6745. C    DEFINITIONS FOR GIN
  6746. C
  6747. C    Enter Plot-10 mode and request GIN mode.
  6748. C
  6749.     BYTE GINBUFR(8), PROMPT(8)
  6750.     DATA prompt /ESC,ENTNTV,ESC,ENTP10,esc,csub,2*0/
  6751.     DATA IGIN_IN_CHARS /6/        !5 FROM 4010 GIN, PLUS CR
  6752. C
  6753. C    DECLARE BUFFERING FUNCTION
  6754. C
  6755.     LOGICAL GB_TEST_FLUSH
  6756. C
  6757. C    DECLARE VARS NEED FOR DRIVER OPERATION
  6758. C
  6759.     LOGICAL LVECTOR_GOING
  6760.     DIMENSION DCHAR(8)
  6761. C
  6762. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  6763. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  6764. C
  6765.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  6766.     DATA DCHAR /100.0, 21.001, 15.747, 30.419, 30.419, 1.0, 133.0, 1.0/
  6767. C
  6768. C*****************
  6769. C
  6770. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  6771. C
  6772.     IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN
  6773. C
  6774. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  6775. C
  6776.     GO TO (100,200,300,400,500,600,700,800,900) IFXN
  6777. C
  6778. C    *********************
  6779. C    INITIALIZE THE DEVICE
  6780. C    *********************
  6781. C
  6782. 100    CONTINUE
  6783. C
  6784. C    FIRST, INITIALIZE THE BUFFER SUBROUTINES
  6785. C
  6786.     CALL GB_INITIALIZE(CR,STR_EXIT_PLOT10,TERMINAL,IERR)
  6787.     YA(1) = IERR
  6788.     LVECTOR_GOING = .FALSE.
  6789.     RETURN
  6790. C
  6791. C    **************************
  6792. C    GET FRESH PLOTTING SURFACE
  6793. C    **************************
  6794. C
  6795. 200    CONTINUE
  6796.     CALL GB_EMPTY
  6797.     CALL GB_IN_STRING(STR_BEGIN_PLOT1)
  6798.     CALL GB_IN_STRING(STR_ENTER_PLOT10)
  6799.     CALL GB_IN_STRING(STR_BEGIN_PLOT2)
  6800.     CALL GB_EMPTY
  6801.     LVECTOR_GOING = .FALSE.
  6802.     RETURN
  6803. C
  6804. C    ****
  6805. C    MOVE
  6806. C    ****
  6807. C
  6808. 300    CONTINUE
  6809. C    CONVERT CM. TO GRAPHICS UNITS ROUNDED
  6810.     IXPOSN = XGUPCM*XA(1)+0.5
  6811.     IYPOSN = YGUPCM*YA(1)+0.5
  6812.     LVECTOR_GOING = .FALSE.
  6813.     RETURN
  6814. C
  6815. C    ****
  6816. C    DRAW
  6817. C    ****
  6818. C
  6819. 400    CONTINUE
  6820.     IX = XGUPCM*XA(1)+0.5
  6821.     IY = YGUPCM*YA(1)+0.5
  6822. C
  6823. C    MAKE SURE BUFFER SPACE AVAILABLE AND IN GRAPHICS MODE
  6824. C
  6825.     IF (LVECTOR_GOING) THEN
  6826.         IF (GB_TEST_FLUSH(4)) THEN
  6827.             CALL GB_IN_STRING(STR_ENTER_PLOT10)
  6828.             LVECTOR_GOING = .FALSE.
  6829.         ENDIF
  6830.         ELSE
  6831.         CALL GB_TEST_FLUSH(20)
  6832.         CALL GB_IN_STRING(STR_ENTER_PLOT10)
  6833.         LVECTOR_GOING = .FALSE.
  6834.     ENDIF
  6835.     IF (LVECTOR_GOING) GO TO 410
  6836.     LVECTOR_GOING = .TRUE.
  6837.     CALL GB_INSERT(GS)
  6838.     CALL GB_USE_TERMINATOR
  6839.     CALL GD_4010_Convert_Slo((8*IXPOSN/5),(13*IYPOSN)/8)
  6840. 410    CALL GD_4010_Convert_Slo((8*IX/5),(13*IY)/8)
  6841.     IXPOSN = IX
  6842.     IYPOSN = IY
  6843.     RETURN
  6844. C
  6845. C    *****************************
  6846. C    FLUSH GRAPHICS COMMAND BUFFER
  6847. C    *****************************
  6848. C
  6849. 500    CONTINUE
  6850.     CALL GB_EMPTY
  6851.     LVECTOR_GOING = .FALSE.
  6852.     CALL GB_SEND_CHARS(STR_END_PLOT,LENGTH_END_PLOT)
  6853.     RETURN
  6854. C
  6855. C    ******************
  6856. C    RELEASE THE DEVICE
  6857. C    ******************
  6858. C
  6859. 600    CONTINUE
  6860. C
  6861. C    DE-ASSIGN THE CHANNAL
  6862. C
  6863.     CALL GB_FINISH(0)
  6864.     RETURN
  6865. C
  6866. C    *****************************
  6867. C    RETURN DEVICE CHARACTERISTICS
  6868. C    *****************************
  6869. C
  6870. 700    CONTINUE
  6871.     DO 720 I=1,8
  6872.     XA(I) = DCHAR(I)
  6873. 720    CONTINUE
  6874.     RETURN
  6875. C
  6876. C    ****************************
  6877. C    SELECT CURRENT DRAWING COLOR
  6878. C    ****************************
  6879. C
  6880.  800    CONTINUE
  6881. c    LDUMMY = GB_TEST_FLUSH(8)
  6882. c    ICOLOR = XA(1)
  6883. c    IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 1) RETURN
  6884. c    ICOLOR = 1-ICOLOR        !CONVERT 1 TO 0 AND 0 INTO 1
  6885. c    STR_COLOR_SET(4) = 48+ICOLOR    !MAKE ASCII CHARACTER 0 OR 1
  6886. c    CALL GB_IN_STRING(STR_COLOR_SET)
  6887. c    CALL GB_USE_TERMINATOR
  6888. c    LVECTOR_GOING = .FALSE.
  6889.     RETURN
  6890. C
  6891. C    **********************
  6892. C    PERFORM GRAPHICS INPUT
  6893. C    **********************
  6894. C
  6895.  900    CONTINUE
  6896.     CALL GB_EMPTY
  6897.     LVECTOR_GOING = .FALSE.
  6898. C
  6899.     CALL GB_EMPTY
  6900.     CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR)
  6901.     CALL GB_INSERT(CR)
  6902.     CALL GB_EMPTY
  6903. C
  6904.     ICHAR = GINBUFR(1)
  6905.     IX1 = GINBUFR(2)
  6906.     IX2 = GINBUFR(3)
  6907.     IY1 = GINBUFR(4)
  6908.     IY2 = GINBUFR(5)
  6909. C
  6910.     XA(1) = IAND(ICHAR,127)        !PICK CHARACTER
  6911.     XA(2) = (5.0*(32*IAND(IX1,31)+IAND(IX2,31))/8.0)/XGUPCM
  6912.     XA(3) = (8.0*(32*IAND(IY1,31)+IAND(IY2,31))/13.0)/YGUPCM
  6913. C
  6914.     RETURN
  6915.     END
  6916.  
  6917.  
  6918.     SUBROUTINE GD_4010_Convert_SLO(IX,IY)
  6919. C
  6920. C    THIS SUBROUTINE CONVERTS THE POINT (IX,IY) INTO THE 4010 SCHEME
  6921. C    OF ENCODING COORDINATES
  6922. C
  6923.     CALL GB_INSERT(32+IY/32)
  6924.     CALL GB_INSERT(96+IAND(IY,31))
  6925.     CALL GB_INSERT(32+IX/32)
  6926.     CALL GB_INSERT(64+IAND(IX,31))
  6927.  
  6928.     RETURN
  6929.     END
  6930.     SUBROUTINE GDPOSTSCR_TALL(IFXN,XA,YA)
  6931.     DIMENSION XA(8), YA(3)
  6932. C
  6933. C    POST SCRIPT DRIVER - HARD COPY DEVICE HAS 300 DOTS/INCH
  6934.     PARAMETER (DOTS_PER_INCH = 300.0)
  6935. C
  6936. C-----------------------------------------------------------------------
  6937. C
  6938. C    DECLARE VARS NEED FOR DRIVER OPERATION
  6939. C
  6940.     LOGICAL*1 L_NOTHING_PLOTTED, L_WIDE
  6941.     BYTE COORD(20)
  6942.     CHARACTER*8 CTIME
  6943.     CHARACTER*80 FILENAME
  6944.     CHARACTER*120 COMMAND
  6945. C
  6946.     DIMENSION DCHAR(8)
  6947. C
  6948. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  6949. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  6950. C
  6951.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  6952. C
  6953. C    PAPER DEFINITIONS (INCHES)
  6954. C
  6955.     PARAMETER (PSRES = 72.0)
  6956.     REAL*4 LEFT_MARGIN
  6957.     PARAMETER (LEFT_MARGIN = 0.5)
  6958.     PARAMETER (RIGHT_MARGIN = 0.25)
  6959.     PARAMETER (TOP_MARGIN = 0.5)
  6960.     PARAMETER (BOTTOM_MARGIN = 0.25)
  6961.     PARAMETER (PAPER_HEIGHT = 11.0)
  6962.     PARAMETER (PAPER_WIDTH = 8.5)
  6963. C        DERIVED PARAMETERS
  6964.     PARAMETER (USEABLE_WIDTH = PAPER_WIDTH-LEFT_MARGIN-RIGHT_MARGIN)
  6965.     PARAMETER (USEABLE_HEIGHT = PAPER_HEIGHT-TOP_MARGIN-BOTTOM_MARGIN)
  6966.     PARAMETER (WIDTH_CM = 2.54*USEABLE_WIDTH)
  6967.     PARAMETER (HEIGHT_CM = 2.54*USEABLE_HEIGHT)
  6968.     PARAMETER (RESOLUTION = DOTS_PER_INCH/2.54)
  6969.     PARAMETER (PSRESCM = PSRES/2.54)
  6970.     PARAMETER (XOFF = PSRES*LEFT_MARGIN)
  6971.     PARAMETER (YOFF = PSRES*BOTTOM_MARGIN)
  6972. C
  6973.     PARAMETER (MAX_POINTS_PER_PATH = 900)
  6974. C
  6975. C    DIGLIB DEVICE CHARACTERISTICS WORDS
  6976. C
  6977.     DATA DCHAR /910.0, WIDTH_CM, HEIGHT_CM, RESOLUTION,
  6978.     1   RESOLUTION, 1.0, 27.0, 4.0/
  6979. C
  6980.     BYTE EOF(2)
  6981.     DATA EOF /4,0/
  6982. C
  6983.     L_WIDE = .FALSE.
  6984. 10    CONTINUE
  6985. C
  6986. C*****************
  6987. C
  6988. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  6989. C
  6990.     IF (IFXN .LE. 0 .OR. IFXN .GT. 7) RETURN
  6991. C
  6992. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  6993. C
  6994.     GO TO (100,200,300,400,500,600,700) IFXN
  6995. C
  6996. C    *********************
  6997. C    INITIALIZE THE DEVICE
  6998. C    *********************
  6999. C
  7000. 100    CONTINUE
  7001.     LUN = XA(1)
  7002.     CALL IDATE(IM,ID,IY)
  7003.     CALL TIME(CTIME)
  7004.     FILENAME = 'SYS$SCRATCH:POSTSCRIPT.DIG'//CHAR(IM+64)//CHAR(ID+64)
  7005.     1   //CTIME(1:2)//CTIME(4:5)//CTIME(7:8)
  7006.     OPEN (UNIT=LUN,NAME=FILENAME,TYPE='NEW',
  7007.     1   FORM='UNFORMATTED',CARRIAGECONTROL='NONE',RECORDTYPE='VARIABLE',
  7008.     2   INITIALSIZE = 50, EXTENDSIZE = 50, ERR=9000)
  7009. C
  7010. C    SHOW INITIALIZATION WORKED, I.E. WE OPENED THE FILE.
  7011. C
  7012.     YA(1) = 0.0
  7013.     CALL GDLSR_OPEN_BUFR(LUN)
  7014.     CALL GDLSR_INSERT(EOF)
  7015.     CALL GDLSR_INSERT('erasepage initgraphics 1 setlinecap 1 setlinejoin ')
  7016.     CALL GDLSR_INSERT('/m {moveto} def /l {lineto} def ')
  7017.     CALL GDLSR_DUMP_BUFR
  7018. 190    CONTINUE
  7019.     L_NOTHING_PLOTTED = .TRUE.
  7020.     N_POINTS_IN_PATH = 0
  7021.     RETURN
  7022. C
  7023. C    **************************
  7024. C    GET FRESH PLOTTING SURFACE
  7025. C    **************************
  7026. C
  7027. 200    CONTINUE
  7028.     IF (.NOT. L_NOTHING_PLOTTED) THEN
  7029.         CALL GDLSR_INSERT('stroke showpage ')
  7030.     ENDIF
  7031.     CALL GDLSR_INSERT('newpath ')
  7032.     GO TO 190
  7033. C
  7034. C    ****
  7035. C    MOVE
  7036. C    ****
  7037. C
  7038. 300    CONTINUE
  7039. C
  7040. C    ****
  7041. C    DRAW
  7042. C    ****
  7043. C
  7044. 400    CONTINUE
  7045.     N_POINTS_IN_PATH = N_POINTS_IN_PATH + 1
  7046.     IF (N_POINTS_IN_PATH .GT. MAX_POINTS_PER_PATH) THEN
  7047.         CALL GDLSR_INSERT('stroke newpath ')
  7048.         IF (IFXN .EQ. 4) THEN
  7049.             CALL GDLSR_INSERT(COORD)
  7050.             CALL GDLSR_INSERT('m ')
  7051.         ENDIF
  7052.         N_POINTS_IN_PATH = 1
  7053.     ENDIF
  7054.     IF (L_WIDE) THEN
  7055.         X = PSRESCM*YA(1)+XOFF
  7056.         Y = PSRESCM*(HEIGHT_CM-XA(1))+YOFF
  7057.         ELSE
  7058.         X = PSRESCM*XA(1)+XOFF
  7059.         Y = PSRESCM*YA(1)+YOFF
  7060.     ENDIF
  7061.     ENCODE (14,451,COORD) X,Y
  7062. 451    FORMAT(F6.1,1X,F6.1,1X)
  7063.     COORD(15) = 0
  7064.     CALL GDLSR_INSERT(COORD)
  7065.     IF (IFXN .EQ. 3) THEN
  7066.         CALL GDLSR_INSERT('m ')
  7067.         ELSE
  7068.         CALL GDLSR_INSERT('l ')
  7069.     ENDIF
  7070.     L_NOTHING_PLOTTED = .FALSE.
  7071.     RETURN
  7072. C
  7073. C    *****************************
  7074. C    FLUSH GRAPHICS COMMAND BUFFER
  7075. C    *****************************
  7076. C
  7077. 500    CONTINUE
  7078.     RETURN        !DONE BY BGNPLT WHEN NECESSARY.
  7079. C
  7080. C    ******************
  7081. C    RELEASE THE DEVICE
  7082. C    ******************
  7083. C
  7084. 600    CONTINUE
  7085.     IF (.NOT. L_NOTHING_PLOTTED) THEN
  7086.         CALL GDLSR_INSERT('stroke showpage ')
  7087.         CALL GDLSR_INSERT(EOF)
  7088.         CALL GDLSR_DUMP_BUFR
  7089.     ENDIF
  7090.     CLOSE (UNIT=LUN)
  7091.     COMMAND = '$ PROCESSPS '//FILENAME
  7092.     ISTATUS = LIB$SPAWN(COMMAND, , ,1)
  7093.     RETURN
  7094. C
  7095. C    *****************************
  7096. C    RETURN DEVICE CHARACTERISTICS
  7097. C    *****************************
  7098. C
  7099. 700    CONTINUE
  7100.     DO 720 I=1,8
  7101.     XA(I) = DCHAR(I)
  7102. 720    CONTINUE
  7103.     IF (L_WIDE) THEN
  7104.         XA(2) = DCHAR(3)
  7105.         XA(3) = DCHAR(2)
  7106.     ENDIF
  7107.     RETURN
  7108. C
  7109. C    HANDLE FILE OPEN ERROR
  7110. C
  7111. 9000    CONTINUE
  7112.     YA(1) = 3.0
  7113.     RETURN
  7114. C
  7115. C    ***********************************************************
  7116. C
  7117.     ENTRY GDPOSTSCR_WIDE(IFXN,XA,YA)
  7118.     L_WIDE = .TRUE.
  7119.     GO TO 10
  7120.     END
  7121.  
  7122.  
  7123.     SUBROUTINE GDLSR_OPEN_BUFR(LUN)
  7124. C
  7125.     PARAMETER (IBUFR_SIZE = 80)
  7126.     BYTE BUFFER
  7127.     COMMON /GDLSR/ NXTCHR, LUNOUT, BUFFER(IBUFR_SIZE)
  7128. C
  7129.     LUNOUT = LUN
  7130.     NXTCHR = 1
  7131.     RETURN
  7132.     END
  7133.  
  7134.  
  7135.     SUBROUTINE GDLSR_INIT_BUFR
  7136. C
  7137.     PARAMETER (IBUFR_SIZE = 80)
  7138.     BYTE BUFFER
  7139.     COMMON /GDLSR/ NXTCHR, LUNOUT, BUFFER(IBUFR_SIZE)
  7140. C
  7141.     NXTCHR = 1
  7142.     RETURN
  7143.     END
  7144.  
  7145.  
  7146.     SUBROUTINE GDLSR_INSERT(STRING)
  7147.     BYTE STRING(2)
  7148. C
  7149.     PARAMETER (IBUFR_SIZE = 80)
  7150.     BYTE BUFFER
  7151.     COMMON /GDLSR/ NXTCHR, LUNOUT, BUFFER(IBUFR_SIZE)
  7152. C
  7153.     EXTERNAL LEN
  7154. C
  7155.     L = LEN(STRING)
  7156.     IF ((NXTCHR+L) .GT. IBUFR_SIZE) CALL GDLSR_DUMP_BUFR
  7157.         DO 100 I = 1, L
  7158.         BUFFER(NXTCHR) = STRING(I)
  7159.         NXTCHR = NXTCHR + 1
  7160. 100        CONTINUE
  7161.     RETURN
  7162.     END
  7163.  
  7164.     SUBROUTINE GDLSR_DUMP_BUFR
  7165. C
  7166.     PARAMETER (IBUFR_SIZE = 80)
  7167.     BYTE CR
  7168.     PARAMETER (CR = 13)
  7169.     BYTE BUFFER
  7170.     COMMON /GDLSR/ NXTCHR, LUNOUT, BUFFER(IBUFR_SIZE)
  7171. C
  7172.     IF (NXTCHR .EQ. 1) RETURN
  7173.     WRITE (LUNOUT) (BUFFER(I), I=1,NXTCHR-1), CR
  7174.     NXTCHR = 1
  7175.     RETURN
  7176.     END
  7177.     SUBROUTINE GDRASTECH(IFXN,XA,YA)
  7178. C
  7179. C    RASTER TECHNOLOGIES MODEL ONE DIGLIB DRIVER 9/4/85
  7180. C    ( 512 X 512 RESOLUTION )
  7181. C
  7182. C    JOHN C PETERSON
  7183. C    TRW/MED INC. MS RC2/2639
  7184. C    ONE RANCHO CARMEL
  7185. C    SAN DIEGO, CA 92128
  7186. C
  7187.     DIMENSION XA(1),YA(1)
  7188. C
  7189. C    VARIABLE DECLARATIONS FOR DEVICE CONTROL
  7190. C
  7191.     CHARACTER*(*) TERMINAL
  7192.     PARAMETER ( TERMINAL='TT' )
  7193. C
  7194.     BYTE STR_GRAPHICS_MODE(1)
  7195.     BYTE STR_COLD_START(1)
  7196.     BYTE STR_INIT_DEV(32)
  7197.     BYTE STR_BEGIN_PLOT(10)
  7198.     BYTE STR_MOVE(1)
  7199.     BYTE STR_DRAW(1)
  7200.     BYTE STR_SET_COLOR(1)
  7201.     BYTE STR_POLY(2)
  7202.     BYTE STR_XHAIR(3)
  7203.     BYTE STR_PROMPT(2)
  7204.     BYTE STR_FLUSH(1)
  7205.     BYTE STR_READ_BUTTON(3)
  7206.     BYTE STR_READ_REGISTER(2)
  7207.     BYTE STR_GIN_BUFFER(16)
  7208.     BYTE STR_ACKNOWLEDGE(1)
  7209.     BYTE STR_END_PLOT(1)
  7210.     BYTE STR_DEBUG(5)
  7211.     BYTE STR_END(2)
  7212. C
  7213. C    DATA LOAD DEVICE CONTROL VARIABLES
  7214. C
  7215.     DATA STR_GRAPHICS_MODE /'84'X /            !ENTER GRAPHICS MODE
  7216.     DATA STR_COLD_START /    'FD'X /            !COLD START
  7217.     DATA STR_INIT_DEV /    '84'X,            !ENTER GRAPHICS MODE
  7218.     1            '37'X,            !RESET COORDINATE ORIGIN
  7219.     2            0,0,0,0,        !HIX,LOX,HIY,LOY BYTES
  7220.     3            '36'X,            !RESET SCREEN ORIGIN
  7221.     4            0,0,0,0,        !HIX,LOX,HIY,LOY BYTES
  7222.     5            '3A'X,            !RESET WINDOW
  7223.     6            0,0,0,0,        !HIX,LOX,HIY,LOY BYTES
  7224.     7            0,0,0,0,        !HIX,LOX,HIY,LOY BYTES
  7225.     8            '1F'X,1,        !POLYGONS ARE FILLED
  7226.     9            '8B'X,0,        !DEFINE MACRO TO MAKE
  7227.     1            'A1'X,5,2,        ! THE CROSS HAIR FOLLOW
  7228.     2            '0C'X,            ! THE DIGITIZER MOUSE
  7229.     3            'AA'X,0,0,        !EXECUTE 1/30 SEC INT
  7230.     4            'FF'X /            !EXIT GRAPHICS MODE
  7231.     DATA STR_BEGIN_PLOT /    '84'X,
  7232.     1            '06'X,            !SET PIXEL VALUES
  7233.     2            0,0,0,            !RED, GREEN, BLUE
  7234.     3            '07'X,            !FLOOD THE SCREEN
  7235.     4            '06'X,            !SET PIXEL VALUES
  7236.     5            255,255,255 /        !RED, GREEN, BLUE
  7237.     DATA STR_MOVE /        '01'X /            !MOVE ABSOLUTE CODE
  7238.     DATA STR_DRAW /        '81'X /            !DRAW ABSOLUTE CODE
  7239.     DATA STR_SET_COLOR /    '06'X /            !SET PIXEL VALUES
  7240.     DATA STR_POLY /        '12'X,1 /        !DRAW ONE POLYGON CODE
  7241.     DATA STR_XHAIR /    '9C'X,0,0 /        !CURSOR VISIBILITY CODE
  7242.     DATA STR_PROMPT /    '?',0 /            !PROMPT USER FOR PICK
  7243.     DATA STR_FLUSH /    '15'X /            !EMPTY BUTTON QUEUE
  7244.     DATA STR_READ_REGISTER /'98'X,2 /        !READ TABLET REGISTER
  7245.     DATA STR_READ_BUTTON /    '9A'X,1,1 /        !READ MOUSE BUTTON VALUE
  7246.     DATA STR_ACKNOWLEDGE /    '86'X /            !ACKNOWLEDGE RECEPTION
  7247.     DATA STR_END_PLOT /    'FF'X /            !EXIT GRAPHICS MODE
  7248.     DATA STR_DEBUG /    '84'X,'A8'X,1,'FF'X,0 /    !******DEBUG MODE******
  7249.     DATA STR_END /        0,0 /
  7250. C
  7251. C    INTEGER*2 COORDINATE VARIABLES
  7252. C
  7253.     INTEGER*2 ICORORG,ISCRORG,IWINDOW
  7254. C
  7255.     DATA ICORORG /-256 /    !THESE VALUES DEPENDENT ON RESOLUTION
  7256.     DATA ISCRORG / 256 /
  7257.     DATA IWINDOW / 511 /
  7258. C
  7259.     INTEGER*2 IXMOVE,IYMOVE,IXDRAW,IYDRAW
  7260.     INTEGER*2 IXCURP,IYCURP,IXVERT,IYVERT
  7261. C
  7262.     BYTE STR_CORORG(2)
  7263.     BYTE STR_SCRORG(2)
  7264.     BYTE STR_WINDOW(2)
  7265.     BYTE STR_XMOVE(2)
  7266.     BYTE STR_YMOVE(2)
  7267.     BYTE STR_XDRAW(2)
  7268.     BYTE STR_YDRAW(2)
  7269.     BYTE STR_NVERT(2)
  7270.     BYTE STR_XVERT(2)
  7271.     BYTE STR_YVERT(2)
  7272. C
  7273. C    COLOR MAP TABLE
  7274. C
  7275.     BYTE COLOR_MAP(3,0:7)
  7276. C
  7277.     DATA COLOR_MAP /  0,  0,  0,    !BLACK
  7278.     1        255,255,255,    !WHITE
  7279.     2        255,  0,  0,    !RED
  7280.     3          0,255,  0,    !GREEN
  7281.     4          0,  0,255,    !BLUE
  7282.     5        255,255,  0,    !YELLOW
  7283.     6        255,  0,255,    !MAGENTA
  7284.     7          0,255,255 /    !CYAN
  7285. C
  7286. C    VARIABLE TO RECIEVE USER "PICK" CHARACTER
  7287. C
  7288.     BYTE IPICK
  7289. C
  7290. C    DECLARE FUNCTIONS AND VARIABLES NEED FOR DRIVER OPERATION
  7291. C
  7292.     LOGICAL GB_TEST_FLUSH,LVECTOR_DRAWING,LDUMMY
  7293. C
  7294. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  7295. C    ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  7296. C    ("YGUPCM" IS Y GRAPHICS UNITS PER CENTIMETER)
  7297. C
  7298.     DIMENSION DCHAR(8)
  7299. C
  7300.     EQUIVALENCE (DCHAR(4),XGUPCM)
  7301.     EQUIVALENCE (DCHAR(5),YGUPCM)
  7302. C
  7303.     DATA DCHAR /    9999.0,        !DIGLIB DEVICE NUMBER
  7304.     1        32.803, 26.232,    !X,Y SCREEN DIMENSIONS (CM)
  7305.     2        15.608, 19.518,    !XGUPCM, YGUPCM
  7306.     3        7.0,        !NUMBER OF FOREGROUND COLORS
  7307.     4        1411.0,        !DEVICE CHARACTERISTICS MASK
  7308.     5        1.0 /        !NUMBER OF SCAN LINES TO SKIP
  7309. C
  7310. C    *********************
  7311. C
  7312. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  7313. C
  7314.     IF (IFXN.GT.1024) GOTO 1300
  7315. C
  7316.     IF (IFXN.LE.0.OR.IFXN.GT.12) RETURN
  7317. C
  7318. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  7319. C
  7320.     GO TO (100,200,300,400,500,600,700,800,900,1000,1100,1200) IFXN
  7321. C
  7322. C    *********************
  7323. C    INITIALIZE THE DEVICE
  7324. C    *********************
  7325. C
  7326. 100    CONTINUE
  7327. C
  7328. C    FIRST INITIALIZE THE DIGLIB BUFFER SUBROUTINES
  7329. C
  7330.     CALL GB_INITIALIZE(0,STR_END,TERMINAL,IERR)
  7331.     YA(1)= IERR
  7332.     IF (IERR.NE.0) RETURN
  7333. C
  7334. C    NOW COLD START THE MODEL ONE
  7335. C
  7336.     CALL GB_INSERT(STR_GRAPHICS_MODE(1))
  7337.     CALL GB_INSERT(STR_COLD_START(1))
  7338.     CALL GB_EMPTY
  7339. C
  7340. C    WAIT 10 SECONDS FOR COLD START TO COMPLETE BEFORE GOING ON
  7341. C
  7342.     CALL GDWAIT(10000)
  7343. C
  7344. C    FINISH WITH INITIALIZATION
  7345. C
  7346.     CALL RASTER_TECH_CONVERT(ICORORG,STR_CORORG)
  7347.     STR_INIT_DEV( 3)= STR_CORORG(1)
  7348.     STR_INIT_DEV( 4)= STR_CORORG(2)
  7349.     STR_INIT_DEV( 5)= STR_CORORG(1)
  7350.     STR_INIT_DEV( 6)= STR_CORORG(2)
  7351. C
  7352.     CALL RASTER_TECH_CONVERT(ISCRORG,STR_SCRORG)
  7353.     STR_INIT_DEV( 8)= STR_SCRORG(1)
  7354.     STR_INIT_DEV( 9)= STR_SCRORG(2)
  7355.     STR_INIT_DEV(10)= STR_SCRORG(1)
  7356.     STR_INIT_DEV(11)= STR_SCRORG(2)
  7357. C
  7358.     CALL RASTER_TECH_CONVERT(IWINDOW,STR_WINDOW)
  7359.     STR_INIT_DEV(17)= STR_WINDOW(1)
  7360.     STR_INIT_DEV(18)= STR_WINDOW(2)
  7361.     STR_INIT_DEV(19)= STR_WINDOW(1)
  7362.     STR_INIT_DEV(20)= STR_WINDOW(2)
  7363. C
  7364. C    CALL GB_IN_STRING(STR_DEBUG)    !******DEBUG******
  7365. C    CALL GB_EMPTY            !******DEBUG******
  7366. C
  7367.     DO N= 1,32
  7368.       CALL GB_INSERT(STR_INIT_DEV(N))
  7369.     ENDDO
  7370. C
  7371.     IXMOVE= 0
  7372.     IYMOVE= 0
  7373.     CALL RASTER_TECH_CONVERT(IXMOVE,STR_XMOVE)
  7374.     CALL RASTER_TECH_CONVERT(IYMOVE,STR_YMOVE)
  7375.     CALL GB_INSERT(STR_XMOVE(1))
  7376.     CALL GB_INSERT(STR_XMOVE(2))
  7377.     CALL GB_INSERT(STR_YMOVE(1))
  7378.     CALL GB_INSERT(STR_YMOVE(2))
  7379.     LVECTOR_DRAWING= .FALSE.
  7380.     IXCURP= IXMOVE
  7381.     IYCURP= IYMOVE
  7382. C
  7383.     CALL GB_EMPTY
  7384. C
  7385.     RETURN
  7386. C
  7387. C    **************************
  7388. C    GET FRESH PLOTTING SURFACE
  7389. C    **************************
  7390. C
  7391. 200    CONTINUE
  7392. C
  7393.     CALL GB_NEW_BUFFER
  7394. C
  7395.     DO N= 1,10
  7396.       CALL GB_INSERT(STR_BEGIN_PLOT(N))
  7397.     ENDDO
  7398. C
  7399.     IXMOVE= 0
  7400.     IYMOVE= 0
  7401.     CALL RASTER_TECH_CONVERT(IXMOVE,STR_XMOVE)
  7402.     CALL RASTER_TECH_CONVERT(IYMOVE,STR_YMOVE)
  7403.     CALL GB_INSERT(STR_XMOVE(1))
  7404.     CALL GB_INSERT(STR_XMOVE(2))
  7405.     CALL GB_INSERT(STR_YMOVE(1))
  7406.     CALL GB_INSERT(STR_YMOVE(2))
  7407.     LVECTOR_DRAWING= .FALSE.
  7408.     IXCURP= IXMOVE
  7409.     IYCURP= IYMOVE
  7410. C
  7411.     CALL GB_EMPTY
  7412. C
  7413.     RETURN
  7414. C
  7415. C    ****
  7416. C    MOVE
  7417. C    ****
  7418. C
  7419. 300    CONTINUE
  7420.     IXMOVE= XGUPCM*XA(1)+0.5
  7421.     IYMOVE= YGUPCM*YA(1)+0.5
  7422.     LVECTOR_DRAWING= .FALSE.
  7423.     RETURN
  7424. C
  7425. C    ****
  7426. C    DRAW
  7427. C    ****
  7428. C
  7429. 400    CONTINUE
  7430.     IXDRAW= XGUPCM*XA(1)+0.5
  7431.     IYDRAW= YGUPCM*YA(1)+0.5
  7432.     IF (LVECTOR_DRAWING) GO TO 450
  7433.     LDUMMY= GB_TEST_FLUSH(5)
  7434.     CALL GB_INSERT(STR_MOVE)
  7435.     CALL RASTER_TECH_CONVERT(IXMOVE,STR_XMOVE)
  7436.     CALL RASTER_TECH_CONVERT(IYMOVE,STR_YMOVE)
  7437.     CALL GB_INSERT(STR_XMOVE(1))
  7438.     CALL GB_INSERT(STR_XMOVE(2))
  7439.     CALL GB_INSERT(STR_YMOVE(1))
  7440.     CALL GB_INSERT(STR_YMOVE(2))
  7441.     LVECTOR_DRAWING= .TRUE.
  7442. C
  7443. 450    CONTINUE
  7444.     LDUMMY= GB_TEST_FLUSH(5)
  7445.     CALL GB_INSERT(STR_DRAW)
  7446.     CALL RASTER_TECH_CONVERT(IXDRAW,STR_XDRAW)
  7447.     CALL RASTER_TECH_CONVERT(IYDRAW,STR_YDRAW)
  7448.     CALL GB_INSERT(STR_XDRAW(1))
  7449.     CALL GB_INSERT(STR_XDRAW(2))
  7450.     CALL GB_INSERT(STR_YDRAW(1))
  7451.     CALL GB_INSERT(STR_YDRAW(2))
  7452.     IXMOVE= IXDRAW
  7453.     IYMOVE= IYDRAW
  7454.     IXCURP= IXDRAW
  7455.     IYCURP= IYDRAW
  7456.     RETURN
  7457. C
  7458. C    *****************************
  7459. C    FLUSH GRAPHICS COMMAND BUFFER
  7460. C    *****************************
  7461. C
  7462. 500    CONTINUE
  7463.     LVECTOR_DRAWING= .FALSE.
  7464.     LDUMMY= GB_TEST_FLUSH(1)
  7465.     CALL GB_INSERT(STR_END_PLOT(1))
  7466.     CALL GB_EMPTY
  7467.     RETURN
  7468. C
  7469. C    ******************
  7470. C    RELEASE THE DEVICE
  7471. C    ******************
  7472. C
  7473. 600    CONTINUE
  7474.     CALL GB_FINISH(STR_END)
  7475.     RETURN
  7476. C
  7477. C    *****************************
  7478. C    RETURN DEVICE CHARACTERISTICS
  7479. C    *****************************
  7480. C
  7481. 700    CONTINUE
  7482.     DO 750 I= 1,8
  7483.       XA(I)= DCHAR(I)
  7484. 750    CONTINUE
  7485.     RETURN
  7486. C
  7487. C    ****************************
  7488. C    SELECT CURRENT DRAWING COLOR
  7489. C    ****************************
  7490. C
  7491. 800    CONTINUE
  7492.     ICOLOR= IFIX( XA(1) )
  7493.     IF (ICOLOR.LT.0 .OR. ICOLOR.GT.7) RETURN
  7494. C
  7495.     LDUMMY= GB_TEST_FLUSH(4)
  7496.     CALL GB_INSERT(STR_SET_COLOR(1))
  7497.     CALL GB_INSERT(COLOR_MAP(1,ICOLOR))
  7498.     CALL GB_INSERT(COLOR_MAP(2,ICOLOR))
  7499.     CALL GB_INSERT(COLOR_MAP(3,ICOLOR))
  7500.     RETURN
  7501. C
  7502. C    ******************************************
  7503. C    PERFORM GRAPHICS INPUT WITH PICK CHARACTER
  7504. C    ******************************************
  7505. C
  7506. 900    CONTINUE
  7507. C
  7508.     STR_XHAIR(3)= 1
  7509.     LDUMMY= GB_TEST_FLUSH(4)
  7510.     CALL GB_INSERT(STR_XHAIR(1))        !MAKE CURSOR VISIBLE
  7511.     CALL GB_INSERT(STR_XHAIR(2))
  7512.     CALL GB_INSERT(STR_XHAIR(3))
  7513.     CALL GB_INSERT(STR_END_PLOT(1))        !GET READY FOR PICK CHARACTER
  7514.     CALL GB_EMPTY
  7515. C
  7516.     CALL GB_GIN(STR_PROMPT,1,.TRUE.,IPICK)
  7517. C
  7518.     LDUMMY= GB_TEST_FLUSH(3)
  7519.     CALL GB_INSERT(STR_GRAPHICS_MODE(1))
  7520.     CALL GB_INSERT(STR_READ_REGISTER(1))
  7521.     CALL GB_INSERT(STR_READ_REGISTER(2))
  7522.     CALL GB_EMPTY
  7523. C
  7524.     CALL GB_GIN(STR_PROMPT,12,.TRUE.,STR_GIN_BUFFER)!TERMINAL IGNORES PROMPT
  7525. C
  7526.     DECODE (12,950,STR_GIN_BUFFER) IX_GIN,IY_GIN
  7527. 950    FORMAT(I6,I6)
  7528. C
  7529.     XA(1)= IPICK
  7530.     XA(2)= IX_GIN/XGUPCM
  7531.     XA(3)= IY_GIN/YGUPCM
  7532. C
  7533.     STR_XHAIR(3)= 0
  7534.     LDUMMY= GB_TEST_FLUSH(4)
  7535.     CALL GB_INSERT(STR_ACKNOWLEDGE(1))
  7536.     CALL GB_INSERT(STR_XHAIR(1))        !MAKE CURSOR INVISIBLE
  7537.     CALL GB_INSERT(STR_XHAIR(2))
  7538.     CALL GB_INSERT(STR_XHAIR(3))
  7539. C
  7540.     RETURN
  7541. C
  7542. C    **********************
  7543. C    DEFINE COLOR USING RGB
  7544. C    **********************
  7545. C
  7546. 1000    CONTINUE
  7547. C
  7548.     RETURN
  7549. C
  7550. C    **********************
  7551. C    DEFINE COLOR USING HLB
  7552. C    **********************
  7553. C
  7554. 1100    CONTINUE
  7555. C
  7556.     RETURN
  7557. C
  7558. C    ***********************************
  7559. C    PERFORM GRAPHICS INPUT WITH BUTTONS
  7560. C    ***********************************
  7561. C
  7562. 1200    CONTINUE
  7563. C
  7564.     STR_XHAIR(3)= 1
  7565.     LDUMMY= GB_TEST_FLUSH(7)
  7566.     CALL GB_INSERT(STR_FLUSH(1))
  7567.     CALL GB_INSERT(STR_XHAIR(1))        !MAKE CROSS HAIR VISIBLE
  7568.     CALL GB_INSERT(STR_XHAIR(2))
  7569.     CALL GB_INSERT(STR_XHAIR(3))
  7570.     CALL GB_INSERT(STR_READ_BUTTON(1))    !WAIT FOR NEXT MOUSE BUTTON
  7571.     CALL GB_INSERT(STR_READ_BUTTON(2))
  7572.     CALL GB_INSERT(STR_READ_BUTTON(3))
  7573.     CALL GB_EMPTY
  7574. C
  7575.     CALL GB_GIN(0,15,.TRUE.,STR_GIN_BUFFER)    !IMPORTANT: SEND NO PROMPTS
  7576. C
  7577.     DECODE (15,1250,STR_GIN_BUFFER) IB_GIN,IX_GIN,IY_GIN
  7578. 1250    FORMAT(I3,I6,I6)
  7579. C
  7580.     XA(1)= 2**(IB_GIN-1)
  7581.     XA(2)= IX_GIN/XGUPCM
  7582.     XA(3)= IY_GIN/YGUPCM
  7583. C
  7584.     STR_XHAIR(3)= 0
  7585.     LDUMMY= GB_TEST_FLUSH(4)
  7586.     CALL GB_INSERT(STR_ACKNOWLEDGE(1))
  7587.     CALL GB_INSERT(STR_XHAIR(1))        !MAKE CURSOR INVISIBLE
  7588.     CALL GB_INSERT(STR_XHAIR(2))
  7589.     CALL GB_INSERT(STR_XHAIR(3))
  7590. C
  7591.     RETURN
  7592. C
  7593. C    *******************
  7594. C    DRAW FILLED POLYGON
  7595. C    *******************
  7596. C
  7597. 1300    CONTINUE
  7598.     NVERT= IFXN-1024
  7599.     LVECTOR_DRAWING= .FALSE.
  7600.     IF (NVERT.LT.3) RETURN
  7601. C
  7602.     IF (IXCURP.NE.0 .OR. IYCURP.NE.0) THEN
  7603.     LDUMMY= GB_TEST_FLUSH(5)
  7604.     CALL GB_INSERT(STR_MOVE)
  7605.     IXCURP= 0
  7606.     IYCURP= 0
  7607.     CALL RASTER_TECH_CONVERT(IXCURP,STR_XMOVE)
  7608.     CALL RASTER_TECH_CONVERT(IYCURP,STR_YMOVE)
  7609.     CALL GB_INSERT(STR_XMOVE(1))
  7610.     CALL GB_INSERT(STR_XMOVE(2))
  7611.     CALL GB_INSERT(STR_YMOVE(1))
  7612.     CALL GB_INSERT(STR_YMOVE(2))
  7613.     ENDIF
  7614. C
  7615.     LDUMMY= GB_TEST_FLUSH(4)
  7616.     CALL GB_INSERT(STR_POLY(1))
  7617.     CALL GB_INSERT(STR_POLY(2))
  7618.     CALL RASTER_TECH_CONVERT(NVERT,STR_NVERT)
  7619.     CALL GB_INSERT(STR_NVERT(1))
  7620.     CALL GB_INSERT(STR_NVERT(2))
  7621. C
  7622.     DO 1350 N= 1,NVERT
  7623.     LDUMMY= GB_TEST_FLUSH(4)
  7624.     IXVERT= XGUPCM*XA(N)+0.5
  7625.     IYVERT= YGUPCM*YA(N)+0.5
  7626.     CALL RASTER_TECH_CONVERT(IXVERT,STR_XVERT)
  7627.     CALL RASTER_TECH_CONVERT(IYVERT,STR_YVERT)
  7628.     CALL GB_INSERT(STR_XVERT(1))
  7629.     CALL GB_INSERT(STR_XVERT(2))
  7630.     CALL GB_INSERT(STR_YVERT(1))
  7631.     CALL GB_INSERT(STR_YVERT(2))
  7632. 1350    CONTINUE
  7633. C
  7634.     RETURN
  7635. C
  7636.     END
  7637.     SUBROUTINE RASTER_TECH_CONVERT(N,STR_N)
  7638. C
  7639. C    THIS ROUTINE CONVERTS INTEGER*2 TO RASTER TECHNOLOGY HI-LO BYTE
  7640. C
  7641.     INTEGER*2 N, NPOS, HIBYTE, LOBYTE
  7642. C
  7643.     BYTE STR_N(2), STR_BYTE(2)
  7644. C
  7645.     EQUIVALENCE (STR_BYTE(1),HIBYTE)
  7646.     EQUIVALENCE (STR_BYTE(2),LOBYTE)
  7647. C
  7648.     LOGICAL CARRY
  7649. C
  7650.     NPOS= IABS(N)
  7651. C
  7652.     HIBYTE= NPOS/256
  7653.     LOBYTE= MOD(NPOS,256)
  7654. C
  7655.     IF (N.GE.0) GO TO 100
  7656. C
  7657.     CARRY= (LOBYTE.EQ.0)
  7658.     HIBYTE= INOT(HIBYTE)        !NEXT FOUR LINES VAX/VHS SPECIFIC
  7659.     LOBYTE= INOT(LOBYTE) + 1
  7660.     HIBYTE= IIAND(255,HIBYTE)
  7661.     LOBYTE= IIAND(255,LOBYTE)
  7662. C
  7663.     IF (CARRY) HIBYTE= HIBYTE + 1
  7664. C
  7665. 100    CONTINUE
  7666.     STR_N(1)= STR_BYTE(1)
  7667.     STR_N(2)= STR_BYTE(2)
  7668. C
  7669.     RETURN
  7670. C
  7671.     END
  7672.     SUBROUTINE GDRTRO(IFXN,XA,YA)
  7673.     DIMENSION XA(8), YA(3)
  7674. C
  7675. C    VT100 WITH 640x480 RETROGRAPHICS DRIVER FOR DIGLIB/VAX
  7676. C
  7677. C-----------------------------------------------------------------------
  7678. C
  7679.     EXTERNAL LEN
  7680.     BYTE ESC, CSUB, TMODE, GS, CR, FF
  7681.     PARAMETER (ESC=27, CSUB=26, TMODE=24, GS=29, CR=13, FF=12)
  7682.     CHARACTER*(*) TERMINAL
  7683.     PARAMETER (TERMINAL='TT')
  7684. C
  7685. C    DEFINITIONS FOR DEVICE CONTROL
  7686. C
  7687.     BYTE STR_BEGIN_PLOT(14), STR_COLOR_SET(6)
  7688.     BYTE STR_END_PLOT(8)
  7689.     DATA STR_BEGIN_PLOT /ESC,'[','H',ESC,'[','J',GS,ESC,FF,
  7690.     1   ESC,'/','0','d',0/
  7691.     DATA STR_COLOR_SET /GS,ESC,'/','0','d',0/
  7692.     DATA STR_END_PLOT /ESC,'[','H',ESC,'[','J',0,0/
  7693. C
  7694. C    DEFINITIONS FOR GIN
  7695. C
  7696.     BYTE GINBUFR(8), PROMPT(4)
  7697.     DATA PROMPT /GS, ESC, CSUB, 0/
  7698.     DATA IGIN_IN_CHARS /6/        !5 FROM 4010 GIN, PLUS CR
  7699. C
  7700. C    DECLARE BUFFERING FUNCTION
  7701. C
  7702.     LOGICAL GB_TEST_FLUSH
  7703. C
  7704. C    DECLARE VARS NEED FOR DRIVER OPERATION
  7705. C
  7706.     LOGICAL LVECTOR_GOING, LDUMMY
  7707.     DIMENSION DCHAR(8)
  7708. C
  7709. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  7710. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  7711. C
  7712.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  7713.     DATA DCHAR /100.0, 21.001, 15.747, 30.419, 30.419, 1.0, 133.0, 1.0/
  7714. C
  7715. C*****************
  7716. C
  7717. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  7718. C
  7719.     IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN
  7720. C
  7721. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  7722. C
  7723.     GO TO (100,200,300,400,500,600,700,800,900) IFXN
  7724. C
  7725. C    *********************
  7726. C    INITIALIZE THE DEVICE
  7727. C    *********************
  7728. C
  7729. 100    CONTINUE
  7730. C
  7731. C    FIRST, INITIALIZE THE BUFFER SUBROUTINES
  7732. C
  7733.     CALL GB_INITIALIZE(TMODE,0,TERMINAL,IERR)
  7734.     YA(1) = IERR
  7735.     LVECTOR_GOING = .FALSE.
  7736.     RETURN
  7737. C
  7738. C    **************************
  7739. C    GET FRESH PLOTTING SURFACE
  7740. C    **************************
  7741. C
  7742. 200    CONTINUE
  7743.     CALL GB_NEW_BUFFER
  7744.     CALL GB_IN_STRING(STR_BEGIN_PLOT)
  7745.     CALL GB_USE_TERMINATOR
  7746.     LVECTOR_GOING = .FALSE.
  7747.     RETURN
  7748. C
  7749. C    ****
  7750. C    MOVE
  7751. C    ****
  7752. C
  7753. 300    CONTINUE
  7754. C    CONVERT CM. TO GRAPHICS UNITS ROUNDED
  7755.     IXPOSN = XGUPCM*XA(1)+0.5
  7756.     IYPOSN = YGUPCM*YA(1)+0.5
  7757.     LVECTOR_GOING = .FALSE.
  7758.     RETURN
  7759. C
  7760. C    ****
  7761. C    DRAW
  7762. C    ****
  7763. C
  7764. 400    CONTINUE
  7765.     IX = XGUPCM*XA(1)+0.5
  7766.     IY = YGUPCM*YA(1)+0.5
  7767.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4))
  7768.     IF (LVECTOR_GOING) GO TO 410
  7769.     LDUMMY = GB_TEST_FLUSH(9)
  7770.     LVECTOR_GOING = .TRUE.
  7771.     CALL GB_INSERT(GS)
  7772.     CALL GB_USE_TERMINATOR
  7773.     CALL GD_4010_CONVERT((8*IXPOSN/5),(13*IYPOSN)/8)
  7774. 410    CALL GD_4010_CONVERT((8*IX/5),(13*IY)/8)
  7775.     IXPOSN = IX
  7776.     IYPOSN = IY
  7777.     RETURN
  7778. C
  7779. C    *****************************
  7780. C    FLUSH GRAPHICS COMMAND BUFFER
  7781. C    *****************************
  7782. C
  7783. 500    CONTINUE
  7784.     CALL GB_EMPTY
  7785.     CALL GB_IN_STRING(STR_END_PLOT)
  7786.     CALL GB_EMPTY
  7787.     LVECTOR_GOING = .FALSE.
  7788.     RETURN
  7789. C
  7790. C    ******************
  7791. C    RELEASE THE DEVICE
  7792. C    ******************
  7793. C
  7794. 600    CONTINUE
  7795. C
  7796. C    DE-ASSIGN THE CHANNAL
  7797. C
  7798.     CALL GB_FINISH(0)
  7799.     RETURN
  7800. C
  7801. C    *****************************
  7802. C    RETURN DEVICE CHARACTERISTICS
  7803. C    *****************************
  7804. C
  7805. 700    CONTINUE
  7806.     DO 720 I=1,8
  7807.     XA(I) = DCHAR(I)
  7808. 720    CONTINUE
  7809.     RETURN
  7810. C
  7811. C    ****************************
  7812. C    SELECT CURRENT DRAWING COLOR
  7813. C    ****************************
  7814. C
  7815. 800    CONTINUE
  7816.     LDUMMY = GB_TEST_FLUSH(8)
  7817.     ICOLOR = XA(1)
  7818.     IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 1) RETURN
  7819.     ICOLOR = 1-ICOLOR        !CONVERT 1 TO 0 AND 0 INTO 1
  7820.     STR_COLOR_SET(4) = 48+ICOLOR    !MAKE ASCII CHARACTER 0 OR 1
  7821.     CALL GB_IN_STRING(STR_COLOR_SET)
  7822.     CALL GB_USE_TERMINATOR
  7823.     LVECTOR_GOING = .FALSE.
  7824.     RETURN
  7825. C
  7826. C    **********************
  7827. C    PERFORM GRAPHICS INPUT
  7828. C    **********************
  7829. C
  7830. 900    CONTINUE
  7831.     CALL GB_EMPTY
  7832.     LVECTOR_GOING = .FALSE.
  7833. C
  7834.     CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR)
  7835. C
  7836.     ICHAR = GINBUFR(1)
  7837.     IX1 = GINBUFR(2)
  7838.     IX2 = GINBUFR(3)
  7839.     IY1 = GINBUFR(4)
  7840.     IY2 = GINBUFR(5)
  7841. C
  7842.     XA(1) = IAND(ICHAR,127)        !PICK CHARACTER
  7843.     XA(2) = (5.0*(32*IAND(IX1,31)+IAND(IX2,31))/8.0)/XGUPCM
  7844.     XA(3) = (8.0*(32*IAND(IY1,31)+IAND(IY2,31))/13.0)/YGUPCM
  7845. C
  7846.     CALL GB_SEND_TTY(TMODE,1)
  7847.     RETURN
  7848.     END
  7849.     SUBROUTINE GDVERSTALL(IFXN,XA,YA)
  7850.     DIMENSION XA(8), YA(3)
  7851. C
  7852. C    DIGLIB VERSATEC GRAPHICS DEVICE DRIVER
  7853. C
  7854. C-----------------------------------------------------------------------
  7855. C
  7856.     DIMENSION DCHAR(8)
  7857.     LOGICAL*2 LDUMPIT, LWIDE
  7858. C
  7859. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  7860. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  7861. C
  7862.     EQUIVALENCE (DCHAR(2),X_FULL_SCALE)
  7863.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  7864.     DATA DCHAR /80.0, 21.336, 26.67, 78.7402, 78.7402, 1.0, 3.0, 1.0/
  7865.     SAVE LDUMPIT
  7866. C
  7867. C    SHOW WE WANT TALL NOT WIDE PLOTTING AREA
  7868. C
  7869.     LWIDE = .FALSE.
  7870. 10    CONTINUE
  7871. C
  7872. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  7873. C
  7874.     IF (IFXN .LE. 0 .OR. IFXN .GT. 7) RETURN
  7875. C
  7876. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  7877. C
  7878.     GO TO (100,200,300,400,500,600,700) IFXN
  7879. C
  7880. C    *********************
  7881. C    INITIALIZE THE DEVICE
  7882. C    *********************
  7883. C
  7884. 100    CONTINUE
  7885.     CALL PLOTS(0,0,0)
  7886.     CALL FACTOR(1.0/2.54)
  7887.     LDUMPIT = .FALSE.
  7888.     YA(1) = 0.0
  7889.     RETURN
  7890. C
  7891. C    **************************
  7892. C    GET FRESH PLOTTING SURFACE
  7893. C    **************************
  7894. C
  7895. 200    CONTINUE
  7896.     IF (LDUMPIT) THEN
  7897.         CALL PLOT(0.0, 0.0, -999)
  7898.         CALL FACTOR(1.0/2.54)
  7899.       ENDIF
  7900.     LDUMPIT = .FALSE.
  7901.     RETURN
  7902. C
  7903. C    ****
  7904. C    MOVE
  7905. C    ****
  7906. C
  7907. 300    CONTINUE
  7908.     IPEN = +3
  7909.     GO TO 450
  7910. C
  7911. C    ****
  7912. C    DRAW
  7913. C    ****
  7914. C
  7915. 400    CONTINUE
  7916.     IPEN = +2
  7917. 450    IF (LWIDE) THEN
  7918.         CALL PLOT(X_FULL_SCALE-YA(1), XA(1), IPEN)
  7919.       ELSE
  7920.         CALL PLOT(XA(1), YA(1), IPEN)
  7921.       END IF
  7922.     LDUMPIT = .TRUE.
  7923.     RETURN
  7924. C
  7925. C    *****************************
  7926. C    FLUSH GRAPHICS COMMAND BUFFER
  7927. C    *****************************
  7928. C
  7929. 500    CONTINUE
  7930. C
  7931. C    NOP ON VERSATEC - BGNPLT WILL TERMINATE PREVIOUS PLOT ON START
  7932. C        OF NEW PLOT.
  7933. C
  7934.     RETURN
  7935. C
  7936. C    ******************
  7937. C    RELEASE THE DEVICE
  7938. C    ******************
  7939. C
  7940. 600    CONTINUE
  7941.     CALL PLOT(0.0, 0.0, +999)
  7942.     CALL GDVERS_VPINIT
  7943.     RETURN
  7944. C
  7945. C    *****************************
  7946. C    RETURN DEVICE CHARACTERISTICS
  7947. C    *****************************
  7948. C
  7949. 700    CONTINUE
  7950.     DO 720 I=1,8
  7951.     XA(I) = DCHAR(I)
  7952. 720    CONTINUE
  7953.     IF (.NOT. LWIDE) RETURN
  7954.     XA(2) = DCHAR(3)
  7955.     XA(3) = DCHAR(2)
  7956.     RETURN
  7957. C
  7958. C    ALTERNATE ENTRY FOR WIDE PLOTTING AREA
  7959. C
  7960.     ENTRY GDVERSWIDE(IFXN,XA,YA)
  7961.     LWIDE = .TRUE.
  7962.     GO TO 10
  7963.     END
  7964.  
  7965.     SUBROUTINE GDVERS_VPINIT
  7966. C
  7967. C    Release versatec driver
  7968. C
  7969. C    Problem:
  7970. C
  7971. C    The Versaplot software has no way to re-initialize itself
  7972. C    once and "end of plot, end of run" call has been made.
  7973. C    That is, once DIGLIB releases the Versatec driver
  7974. C    (either because of a call to RLSDEV or DEVSEL) the application
  7975. C    program can NOT make more plots with the Versatec driver.
  7976. C
  7977. C    Solution:
  7978. C
  7979. C    Call this routine before calling after releasing the VERSATEC.
  7980. C    Then, the next call to DEVSEL, to select the Versatec driver, will
  7981. C    act as if it were the first call to DEVSEL.
  7982. C
  7983. C
  7984.     COMMON    /PPEP0/    LBLK, NBLK, LREC, LVEC, IUNIT, JUNIT, KUNIT, LUNIT,
  7985.     1    MUNIT, IPARM, IPCTR, IPREC, IEOF, IPBUF(128)
  7986. C
  7987.     COMMON    /PPEP1/    IX1, IY1, IX2, IY2, ISCAN, NSCAN, NBAND, NIPS, NIP0,
  7988.     1    NIPM1, LYNES, NIBSX, MSGLVL, XDOTS, YDOTS, PREF(2), RORG(2),
  7989.     2    PORT(2,2), IEND(4), ALMT, FACT, JPEN, XOFF, XFAC, YOFF, YFAC,
  7990.     3    NBITS, NBITM1, NBYTES, NBYTM1, MSK, LMSK, IOPEN, XA(13),
  7991.     4    YA(13), XC, YC, XO, YO, XT, YT, THETA, ANCC, ANCS, RADCO, FNN,
  7992.     5    FCTR, FACC, ISTAT, IPAT(16), NTP, JRCD, JWRD, MINREC, MAXREC,
  7993.     6    MAXPLT, NPLOT, FPLOT, NCLIP, NBAD, JBUF(128)
  7994. C
  7995. C    Make VERSAPLOT initialize itself on next call to
  7996. C    DEVSEL.
  7997. C
  7998. C    PPEP0
  7999. C
  8000.     IPCTR  = 129
  8001.     IPREC  = 1
  8002. C
  8003. C    PPEP1
  8004. C
  8005.     IOPEN  = 0
  8006.     RADCO  = 0.01745329
  8007.     FNN    = 999.0
  8008.     FCTR   = 0.7
  8009.     FACC   = 0.0
  8010.     THETA  = 0.0
  8011.     ANCC   = 1.0
  8012.     ANCS   = 0.0
  8013.     XC     = 0.0
  8014.     YC     = 0.0
  8015.     XT     = 0.0
  8016.     YT     = 0.0
  8017.     XO     = 0.0
  8018.     YO     = 0.0
  8019. C
  8020.     DO 10 I=1,13
  8021.        XA(I) = 0.0
  8022.        YA(I) = 0.0
  8023.  10    CONTINUE
  8024. C
  8025.     ISTAT  = 1
  8026.     NTP    = 1
  8027. C
  8028.     DO 20 I=1,16
  8029.        IPAT(I) = -1
  8030.  20    CONTINUE
  8031. C
  8032.     JRCD   = 1
  8033.     JWRD   = 1
  8034.     MINREC = 999999
  8035.     MAXREC = -1
  8036.     MAXPLT = -1
  8037.     NPLOT  = 1
  8038.     FPLOT  = 0.0
  8039.     NCLIP  = 0
  8040.     NBAD   = 0
  8041.     RETURN
  8042.     END
  8043.     SUBROUTINE GDVHR19(IFXN,XA,YA)
  8044.     DIMENSION XA(8), YA(3)
  8045. C
  8046. C    INTECOLOR VHR-19 DRIVER FOR DIGLIB/VAX
  8047. C       Drawing is done via the TEK 4010 compatability mode since this
  8048. C       provides a much more dense (and so faster) coordinate stream.
  8049. C       The terminal itself is placed in the ANSI mode.   It is switched
  8050. C       temporarily to TEK mode only for the duration of a buffer (or
  8051. C       less) of lines.
  8052. C
  8053.     BYTE ESC, CSUB, GS, CR, FF, US, BCOMMA
  8054.     PARAMETER (ESC=27, CSUB=26, GS=29, CR=13, FF=12, US=31, BCOMMA=44)
  8055.     CHARACTER*(*) TERMINAL
  8056.     PARAMETER (TERMINAL='TT')
  8057. C
  8058. C    DEFINITIONS FOR DEVICE CONTROL
  8059. C
  8060.     BYTE STR_END(4)
  8061.     BYTE STR_INIT_DEV(38)
  8062.     BYTE STR_BEGIN_PLOT(6), STR_COLOR_SET(8), STR_START_VECTOR(4)
  8063.     BYTE STR_POLYGON_START(8), STR_POLYGON_PATTERN(4)
  8064.     BYTE STR_COMMA_END(4), STR_END_PLOT(10)
  8065.     BYTE STRING(20)
  8066.     EXTERNAL LEN
  8067. C
  8068.     DATA STR_END /ESC,'A',2*0/
  8069.     DATA STR_INIT_DEV/
  8070.     1   ESC,'B',ESC,'T',
  8071.     1   'Z',',','1',',',        !ZOOM FACTOR OF 1
  8072.     2   'N',',','1','0','2','3',',','7',',', !PAN TO BOTTOM LEFT
  8073.     3   'I','H',',','7',',',    !STD COLORS, COLOR 1 (INTECOLOR 7)
  8074.     4   'T','F','F','F','F',',',    !LINE STYLE SOLID
  8075.     5   '#',',','7',',',        !WRITE TO ALL 3 PLANES
  8076.     6   'L',',','7',',','?',0/    !DISPLAY FROM ALL 3 PLANES, EXIT
  8077.     DATA STR_BEGIN_PLOT/
  8078.     1   ESC,'C',ESC,FF,0,0/        !ERASE SCREEN
  8079.     DATA STR_START_VECTOR/
  8080.     1   ESC,'C',GS,0/        !START A 4010 VECTOR
  8081.     DATA STR_END_PLOT /
  8082.     1   ESC,'A',
  8083.     2   ESC,'[','H',ESC,'[','J',2*0/!ERASE TEXT
  8084.     DATA STR_COLOR_SET /
  8085.     1   ESC,'B',ESC,'T','H',',',2*0/!SET COLOR PARTIAL COMMAND
  8086.     DATA STR_POLYGON_START/
  8087.     1   ESC,'B',ESC,'T','D',',',2*0/!START POLYGON
  8088.     DATA STR_POLYGON_PATTERN/
  8089.     1   ',','2',',',0/
  8090.     DATA STR_COMMA_END/
  8091.     1   ',','?',2*0/        !ENDS A COMMAND AND EXIT GRAPHICS MODE.
  8092. C
  8093. C    DEFINITIONS FOR GIN
  8094. C
  8095.     BYTE GINBUFR(8), PROMPT(6), STR_END_GIN(2)
  8096.     DATA PROMPT /ESC, 'C', ESC, CSUB, 0, 0/
  8097.     DATA IGIN_IN_CHARS /6/
  8098.     DATA STR_END_GIN /10,0/
  8099. C
  8100. C    COLOR MAP
  8101. C
  8102.     DIMENSION MAP_COLOR(8)
  8103.     DATA MAP_COLOR /0,7,1,2,4,3,5,6/
  8104. C
  8105. C    DECLARE BUFFERING FUNCTION
  8106. C
  8107.     LOGICAL GB_TEST_FLUSH
  8108. C
  8109. C    DECLARE VARS NEED FOR DRIVER OPERATION
  8110. C
  8111.     LOGICAL LVECTOR_GOING, LDUMMY
  8112.     DIMENSION DCHAR(8)
  8113. C
  8114. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  8115. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  8116. C
  8117.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  8118.     DATA DCHAR /19.0, 38.0, 28.5, 26.921, 26.921, 7.0, 389.0, 1.0/
  8119. C
  8120. C*****************
  8121. C
  8122. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  8123. C
  8124.     IF (IFXN .GT. 1026) GOTO 20000
  8125.     IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN
  8126. C
  8127. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  8128. C
  8129.     GO TO (100,200,300,400,500,600,700,800,900) IFXN
  8130. C
  8131. C    *********************
  8132. C    INITIALIZE THE DEVICE
  8133. C    *********************
  8134. C
  8135. 100    CONTINUE
  8136. C
  8137. C    FIRST, INITIALIZE THE BUFFER SUBROUTINES
  8138. C
  8139.     CALL GB_INITIALIZE(0,STR_END,TERMINAL,IERR)
  8140.     YA(1) = IERR
  8141.     IF (IERR .NE. 0) RETURN
  8142. C
  8143. C    INITIALIZE THE VHR-19
  8144. C
  8145.     CALL GB_IN_STRING(STR_INIT_DEV)
  8146.     CALL GB_EMPTY
  8147.     LVECTOR_GOING = .FALSE.
  8148.     RETURN
  8149. C
  8150. C    **************************
  8151. C    GET FRESH PLOTTING SURFACE
  8152. C    **************************
  8153. C
  8154. 200    CONTINUE
  8155.     CALL GB_EMPTY
  8156.     CALL GB_IN_STRING(STR_BEGIN_PLOT)
  8157.     CALL GB_EMPTY
  8158.     LVECTOR_GOING = .FALSE.
  8159.     RETURN
  8160. C
  8161. C    ****
  8162. C    MOVE
  8163. C    ****
  8164. C
  8165. 300    CONTINUE
  8166. C    CONVERT CM. TO GRAPHICS UNITS ROUNDED
  8167.     IXPOSN = XGUPCM*XA(1)+0.5
  8168.     IYPOSN = YGUPCM*YA(1)+0.5
  8169.     LVECTOR_GOING = .FALSE.
  8170.     RETURN
  8171. C
  8172. C    ****
  8173. C    DRAW
  8174. C    ****
  8175. C
  8176. 400    CONTINUE
  8177.     IX = XGUPCM*XA(1)+0.5
  8178.     IY = YGUPCM*YA(1)+0.5
  8179.     LVECTOR_GOING = LVECTOR_GOING .AND. (.NOT. GB_TEST_FLUSH(4))
  8180.     IF (LVECTOR_GOING) GO TO 410
  8181.     LDUMMY = GB_TEST_FLUSH(9)
  8182.     LVECTOR_GOING = .TRUE.
  8183.     CALL GB_IN_STRING(STR_START_VECTOR)
  8184.     CALL GD_4010_CONVERT(IXPOSN,IYPOSN)
  8185. 410    CALL GD_4010_CONVERT(IX,IY)
  8186.     IXPOSN = IX
  8187.     IYPOSN = IY
  8188.     RETURN
  8189. C
  8190. C    *****************************
  8191. C    FLUSH GRAPHICS COMMAND BUFFER
  8192. C    *****************************
  8193. C
  8194. 500    CONTINUE
  8195.     CALL GB_TEST_FLUSH(LEN(STR_END_PLOT))
  8196.     CALL GB_IN_STRING(STR_END_PLOT)
  8197.     CALL GB_EMPTY
  8198.     LVECTOR_GOING = .FALSE.
  8199.     RETURN
  8200. C
  8201. C    ******************
  8202. C    RELEASE THE DEVICE
  8203. C    ******************
  8204. C
  8205. 600    CONTINUE
  8206. C
  8207. C    DE-ASSIGN THE CHANNAL
  8208. C
  8209.     CALL GB_EMPTY
  8210.     CALL GB_FINISH(0)
  8211.     RETURN
  8212. C
  8213. C    *****************************
  8214. C    RETURN DEVICE CHARACTERISTICS
  8215. C    *****************************
  8216. C
  8217. 700    CONTINUE
  8218.     DO 720 I=1,8
  8219.     XA(I) = DCHAR(I)
  8220. 720    CONTINUE
  8221.     RETURN
  8222. C
  8223. C    ****************************
  8224. C    SELECT CURRENT DRAWING COLOR
  8225. C    ****************************
  8226. C
  8227. 800    CONTINUE
  8228.     LDUMMY = GB_TEST_FLUSH(12)
  8229.     ICOLOR = XA(1)
  8230.     IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 7) RETURN
  8231.     CALL GB_IN_STRING(STR_COLOR_SET)
  8232.     CALL NUMSTR(MAP_COLOR(1+ICOLOR),STRING)
  8233.     CALL GB_IN_STRING(STRING)
  8234.     CALL GB_IN_STRING(STR_COMMA_END)
  8235.     LVECTOR_GOING = .FALSE.
  8236.     RETURN
  8237. C
  8238. C    **********************
  8239. C    PERFORM GRAPHICS INPUT
  8240. C    **********************
  8241. C
  8242. 900    CONTINUE
  8243. C
  8244. C    DO A GIN
  8245. C
  8246.     CALL GB_EMPTY
  8247. C
  8248.     CALL GB_GIN(PROMPT,IGIN_IN_CHARS,.TRUE.,GINBUFR)
  8249. C
  8250.     ICHAR = GINBUFR(1)
  8251.     IX1 = GINBUFR(2)
  8252.     IX2 = GINBUFR(3)
  8253.     IY1 = GINBUFR(4)
  8254.     IY2 = GINBUFR(5)
  8255. C
  8256.     XA(1) = IAND(ICHAR,127)        !PICK CHARACTER
  8257.     IX_GIN_CURSOR = 32*IAND(IX1,31)+IAND(IX2,31)
  8258.     XA(2) = IX_GIN_CURSOR/XGUPCM
  8259.     IY_GIN_CURSOR = 32*IAND(IY1,31)+IAND(IY2,31)
  8260.     XA(3) = IY_GIN_CURSOR/YGUPCM
  8261. C
  8262.     CALL GB_IN_STRING(STR_END_GIN)
  8263.     CALL GB_EMPTY
  8264.     RETURN
  8265. C
  8266. C    *******************
  8267. C    DRAW FILLED POLYGON
  8268. C    *******************
  8269. C
  8270. 20000    CONTINUE
  8271.     NPTS = IFXN - 1024
  8272.     CALL GB_EMPTY
  8273.     CALL GB_IN_STRING(STR_POLYGON_START)
  8274.     CALL NUMSTR(NPTS,STRING)
  8275.     CALL GB_IN_STRING(STRING)
  8276.     CALL GB_IN_STRING(STR_POLYGON_PATTERN)
  8277. C
  8278. C    DO VERTICES 1 THRU N.
  8279. C
  8280.         DO 20010 I = 1, NPTS
  8281.         IX = XGUPCM*XA(I)+0.5
  8282.         IY = YGUPCM*YA(I)+0.5
  8283.         CALL NUMSTR(IX,STRING)
  8284.         CALL GB_IN_STRING(STRING)
  8285.         CALL GB_INSERT(BCOMMA)
  8286.         CALL NUMSTR(IY,STRING)
  8287.         CALL GB_IN_STRING(STRING)
  8288.         CALL GB_INSERT(BCOMMA)
  8289. 20010        CONTINUE
  8290.     CALL GB_IN_STRING(STR_COMMA_END)
  8291.     LVECTOR_GOING = .FALSE.
  8292.     RETURN
  8293.     END
  8294.     SUBROUTINE GDVT125(IFXN,XA,YA)
  8295.     DIMENSION XA(8), YA(3)
  8296. C
  8297. C    VT125 DRIVER FOR DIGLIB/VAX
  8298. C        Modified for DIGLIB V3 by Hal Brand 8-Feb-1985.
  8299. C
  8300. C    Opinion of Hal Brand:
  8301. C        It is completely misleading to even think of VT125 as graphics
  8302. C        devices.   DEC does not know the first thing about making
  8303. C        graphics terminals, and by their track record (VT240/241)
  8304. C        probably never will.   You will probably be very disappointed
  8305. C        if you use this driver for two reasons: 1) The driver may not
  8306. C        work well (and I don't really care cause of the above), and
  8307. C        2) The truth in the opinions above.
  8308. C
  8309. C---------------------------------------------------------------------------
  8310. C
  8311.     BYTE ESC
  8312.     PARAMETER (ESC=27)
  8313.     CHARACTER*(*) TERMINAL
  8314.     PARAMETER (TERMINAL='TT')
  8315. C
  8316. C    DEFINITIONS FOR DEVICE CONTROL
  8317. C
  8318.     BYTE STR_END(4)
  8319.     BYTE STR_INIT(39)
  8320.     BYTE STR_BEGIN_PLOT(16)
  8321.     BYTE STR_COLOR_SET(10)
  8322.     BYTE STR_PREFACE(4)
  8323.     BYTE GINBUFR(14)
  8324.     BYTE PROMPT(7)
  8325.     BYTE STR_COORD(10)
  8326.     BYTE BEGIN_CHAR, CHAR_P, CHAR_V
  8327.     DATA CHAR_LEFT_BRACKET /'['/
  8328.     DATA CHAR_RIGHT_BRACKET /']'/
  8329.     DATA CHAR_V /'V'/
  8330.     DATA CHAR_P /'P'/
  8331.     BYTE COLOR(8)
  8332.     DATA COLOR /'D','W','R','G','B','Y','M','C'/
  8333. C
  8334. C    THE VT125 DRIVER USES THE DIGLIB/VAX STANDARD TERMINAL BUFFERING
  8335. C     SUBROUTINES.   GRAPHIC COMMANDS ARE BUFFERED BY THESE SUBROUTINES
  8336. C     AND SENT TO THE USERS TERMINAL UNDER PROGRAM CONTROL.
  8337. C
  8338. C    ***
  8339. C    STR_END CONTAINS THE STRING WHICH IS APPENDED TO THE COMMAND BUFFER
  8340. C     JUST BEFORE IT IS SENT TO THE TERMINAL.   THIS ELIMINATES THE NEED
  8341. C     TO CONSTANTLY REMEMBER TO APPEND THIS STRING JUST BEFORE FLUSHING
  8342. C     THE BUFFER.
  8343. C    ***
  8344.     DATA STR_END /ESC,'\',0,0/
  8345. C
  8346. C    ***
  8347. C    STR_INIT CONTAINS THE STRING TO INITIALIZE THE VT125.   THIS STRING
  8348. C     IS ONLY SENT WHEN WHEN IFXN=1 (I.E. AT "DEVSEL" TIME).
  8349. C    ***
  8350.     DATA STR_INIT /
  8351.     1   ESC,'[','H',            !HOME ALPHA CURSOR
  8352.     2   ESC,'[','J',            !ERASE ALPHA TO END OF SCREEN
  8353.     3   ESC,'P','p',            !ENTER ReGIS
  8354.     4   'S','(','I','D',            !SET SCREEN MODE dark
  8355.     5   'A','[','0',',','4','7','9',']',    !SET ADDRESS TRANSLATION
  8356.     6   '[','7','6','7',',','0',']',')',    !so origin is lower left
  8357.     5   'W','(','I','W','R','P','1',')',    !SET WRITING MODE
  8358.     6   0,0/
  8359. C
  8360. C    ***
  8361. C    STR_BEGIN_PLOT CONTAINS THE STRING TO "GET A FRESH PLOTTING SURFACE"
  8362. C     AND TO MAKE SURE THE DEVICE IS IN "NORMAL" MODE, READY TO PLOT.
  8363. C    ***
  8364.     DATA STR_BEGIN_PLOT /
  8365.     1   ESC,'P','p',            !ENTER ReGIS
  8366.     2   'S','(','I','D','E',')',        !SET BKGD DARK & ERASE SCREEN
  8367.     3   'W','(','I','W','R',')',0/        !WRITE IN WHITE
  8368. C
  8369. C    ***
  8370. C    STR_COLOR_SET CONTAINS THE STRING TO SELECT A NEW COLOR.
  8371. C     THIS STRINGS CONTAINS A DUMMY ARGUMENT THAT IS MODIFIED AT RUN TIME
  8372. C     TO BE THE COLOR SELECTED.
  8373. C    ICOLOR_BYTE IS THE SUBSCRIPT OF THE BYTE TO BE MODIFIED IN THE
  8374. C     SET COLOR COMMAND.
  8375. C    ***
  8376.     DATA STR_COLOR_SET /
  8377.     1   ESC,'P','p',            !ENTER ReGIS
  8378.     2   'W','(','I','W',')',0,0/        !WRITE IN COLOR or MONO
  8379.     DATA ICOLOR_BYTE /7/
  8380. C
  8381. C    ***
  8382. C    STR_PREFACE CONTAINS THE ReGIS ENTRY STRING.
  8383. C    ***
  8384.     DATA STR_PREFACE / ESC,'P','p',0/
  8385. C
  8386. C    ***
  8387. C    PROMPT IS STRING SENT TO VT125 TO REQUEST IT DISPLAY THE GRAPHICS
  8388. C     CURSOR, WAIT TILL USER HITS A KEY, THEN RETURN THE GRAPHICS CURSOR
  8389. C     POSITION ALONG WITH THE KEY THE USER HIT.
  8390. C    ***
  8391.     DATA PROMPT /
  8392.     1   ESC,'P','p',            !ENTER ReGIS
  8393.     2   'R','(','P',')'/
  8394. C
  8395. C    ***
  8396. C    IGIN_IN_CHARACTERS IS THE EXPECTED NUMBER OF CHARACTERS RETURNED
  8397. C     BY THE VT125 IN RESPONSE TO "PROMPT".
  8398. C    ***
  8399.     DATA IGIN_IN_CHARS /12/
  8400. C
  8401. C    ***
  8402. C****************************************************************************
  8403. C
  8404. C    DECLARE BUFFERING FUNCTION
  8405. C
  8406.     LOGICAL GB_TEST_FLUSH
  8407. C
  8408. C    DECLARE VARS NEED FOR DRIVER OPERATION
  8409. C
  8410.     LOGICAL L_PREFACED, LDUMMY
  8411.     DIMENSION DCHAR(7)
  8412. C
  8413. C    MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  8414. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  8415. C
  8416.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  8417. C
  8418. C    FOR DESCRIPTION OF DCHAR, SEE "DEVICE CHARACTERISTICS" RETURNED
  8419. C     BY DRIVER WHEN IFXN=7 (I.E. GET DEVICE CHARACTERISTICS)
  8420. C
  8421.     DATA DCHAR /125.0, 25.583, 15.933, 30.0, 15.0, 3.0, 5.0, 1.0/
  8422. C
  8423. C*****************
  8424. C
  8425. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  8426. C
  8427.     IF (IFXN .LE. 0 .OR. IFXN .GT. 9) RETURN
  8428. C
  8429. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  8430. C
  8431.     GO TO (100,200,300,400,500,600,700,800,900) IFXN
  8432. C
  8433. C    *********************
  8434. C    INITIALIZE THE DEVICE
  8435. C    *********************
  8436. C
  8437. 100    CONTINUE
  8438. C
  8439. C    FIRST, INITIALIZE THE BUFFER SUBROUTINES
  8440. C
  8441.     CALL GB_INITIALIZE(13,STR_END,TERMINAL,IERR)
  8442.     YA(1) = IERR
  8443.     IF (IERR .NE. 0) RETURN
  8444. C
  8445. C    THEN, INITIALIZE THE VT125
  8446. C
  8447.     CALL GB_IN_STRING(STR_INIT)
  8448.     GO TO 290
  8449. C
  8450. C    **************************
  8451. C    GET FRESH PLOTTING SURFACE
  8452. C    **************************
  8453. C
  8454. 200    CONTINUE
  8455.     CALL GB_NEW_BUFFER
  8456.     CALL GB_IN_STRING(STR_BEGIN_PLOT)
  8457. 290    CALL GB_EMPTY
  8458.     L_PREFACED = .FALSE.
  8459.     RETURN
  8460. C
  8461. C    ****
  8462. C    MOVE
  8463. C    ****
  8464. C
  8465. 300    CONTINUE
  8466.     BEGIN_CHAR = CHAR_P
  8467.     GO TO 420
  8468. C
  8469. C    ****
  8470. C    DRAW
  8471. C    ****
  8472. C
  8473. 400    CONTINUE
  8474.     BEGIN_CHAR = CHAR_V
  8475. C
  8476. 420    CONTINUE
  8477. C
  8478. C    CONVERT CM TO VT125 GRAPHICS UNITS
  8479. C
  8480.     IX = XGUPCM*XA(1)+0.5
  8481.     IY = 2*INT(YGUPCM*YA(1)+0.5)
  8482. C
  8483. C    SEE IF ENOUGH ROOM IN BUFFER FOR THIS COMMAND
  8484. C     WE NEED 10 CHARACTERS OF ROOM, SO BE SAFE AS MAKE SURE 12 LEFT.
  8485. C
  8486.     L_PREFACED = L_PREFACED .AND. (.NOT. GB_TEST_FLUSH(12))
  8487.     IF (.NOT. L_PREFACED) CALL GB_IN_STRING(STR_PREFACE)
  8488. C
  8489. C    INSERT THE ReGIS COMMAND TO MOVE/DRAW
  8490.     CALL GB_INSERT(BEGIN_CHAR)
  8491.     ENCODE (9,431,STR_COORD) IX,IY
  8492. 431    FORMAT('[',I3,',',I3,']')
  8493.     STR_COORD(10) = 0
  8494.     CALL GB_IN_STRING(STR_COORD)
  8495.     RETURN
  8496. C
  8497. C    *****************************
  8498. C    FLUSH GRAPHICS COMMAND BUFFER
  8499. C    *****************************
  8500. C
  8501. 500    CONTINUE
  8502.     CALL GB_EMPTY
  8503.     L_PREFACED = .FALSE.
  8504.     RETURN
  8505. C
  8506. C    ******************
  8507. C    RELEASE THE DEVICE
  8508. C    ******************
  8509. C
  8510. 600    CONTINUE
  8511. C
  8512. C    DO NOTHING - LET USER KILL PICTURE
  8513. C
  8514.     CALL GB_EMPTY
  8515.     RETURN
  8516. C
  8517. C    *****************************
  8518. C    RETURN DEVICE CHARACTERISTICS
  8519. C    *****************************
  8520. C
  8521. 700    CONTINUE
  8522.     DO 720 I=1,8
  8523.     XA(I) = DCHAR(I)
  8524. 720    CONTINUE
  8525.     RETURN
  8526. C
  8527. C    ****************************
  8528. C    SELECT CURRENT DRAWING COLOR
  8529. C    ****************************
  8530. C
  8531. 800    CONTINUE
  8532.     CALL GB_EMPTY
  8533.     ICOLOR = XA(1) + 1
  8534.     IF (ICOLOR .LT. 1 .OR. ICOLOR .GT. 8) RETURN
  8535.     STR_COLOR_SET(ICOLOR_BYTE) = COLOR(ICOLOR)
  8536.     CALL GB_IN_STRING(STR_COLOR_SET)
  8537.     L_PREFACED = .TRUE.
  8538.     RETURN
  8539. C
  8540. C    **********************
  8541. C    PERFORM GRAPHICS INPUT
  8542. C    **********************
  8543. C
  8544. 900    CONTINUE
  8545.     CALL GB_EMPTY
  8546.     L_PREFACED = .FALSE.
  8547. C
  8548. C    ASK FOR 1 GIN INPUT
  8549. C
  8550.     CALL GB_GIN(PROMPT,-IGIN_IN_CHARS,.TRUE.,GINBUFR)
  8551.     TYPE 992,GINBUFR
  8552. 992    FORMAT(' Ginbufr',14O4)
  8553. C
  8554. C    GET KEY PRESSED
  8555. C
  8556. c    I = 3
  8557. c    XA(1) = GINBUFR(1)
  8558. c    IF (GINBUFR(1) .EQ. CHAR_LEFT_BRACKET) THEN
  8559. c        XA(1) = 13
  8560. c        I = 2
  8561. c    ENDIF
  8562. C
  8563. C    GET X,Y
  8564. C
  8565. c    DECODE (11,991,GINBUFR(I)) XA(2), XA(3)
  8566. 991    FORMAT(F3.0,1X,F3.0)
  8567. c    XA(2) = XA(2)/XGUPCM
  8568. c    XA(3) = 0.5*XA(3)/YGUPCM
  8569.     RETURN
  8570.     END
  8571.     subroutine gdvt240(ifxn,xa,ya)
  8572. c******************************************************************************
  8573. c
  8574. c Title: GDVT240
  8575. c Version: 1.0
  8576. c Date: 5-Apr-84
  8577. c Written by: Steve Wolfe
  8578. c             Mini Micro Systems Group
  8579. c             Applications Systems Division 
  8580. c             Computations Department
  8581. C MODIFIED: HAL BRAND  14-AUG-84
  8582. c
  8583. c Purpose:
  8584. c
  8585. c    GDVT240 is the DIGLIB device driver for the DEC VT240/241 graphics
  8586. c    terminals. 
  8587. c
  8588. C WARNING: THIS DRIVER MAY HAVE BUGS - IT IS NOT SUPPORTED.
  8589. C    It is my (Hal Brand's) opinion that 240 resolution in Y is far too
  8590. C    little.   In addition, the VT240 doesn't separate the alphatext
  8591. C    from the graphics leading to numerous problems.   If you have never
  8592. C    used a real graphics terminal before, your probably won't hate using
  8593. C    a VT240 for graphics, however, if you have ever used a real graphics
  8594. C    terminal, you will be very very disappointed.
  8595. c
  8596. c******************************************************************************
  8597.     dimension xa(8), ya(3)
  8598. c
  8599. c    DEC VT240 driver for diglib/vax
  8600. c
  8601.     byte esc
  8602.     integer f1,f2,str_length
  8603.     parameter (esc=27)
  8604.     character*(*) terminal
  8605.     parameter (terminal='TT')
  8606.     logical cursor_moved
  8607. c
  8608. c    definitions for device control
  8609. c
  8610.     byte str_init_dev(66)
  8611.     byte str_begin_plot(14)
  8612.     byte str_rls_dev(6)
  8613.     byte str_move_pos(14)
  8614.     byte str_draw_vec(11)
  8615.     byte str_regis_mode(5)
  8616.     byte str_draw_point(4)
  8617.     BYTE STR_COLOR_SET(6)
  8618.     data str_init_dev/
  8619.      1        esc,'[','?','3','8','l',    !4014 => VT200 mode
  8620.      2        esc,'P','1','p',        !VT200 => REGIS mode
  8621.      3        's','(','a','[','0',',','4','9','9',']',
  8622.      4        '[','7','9','9',',','0',']',')',!Origin is lower left
  8623.      5        'w','(','f','3',')',        !allow writing to both planes
  8624.      6        'w','(','i','1',')',        !select color 3 (white)
  8625.     7   'S','(','M','1','(','A','W',')',
  8626.     8   '2','(','A','R',')','3','(','A','G',')',
  8627.      9        esc,'/',ESC,'[','H',ESC,'[','J',0,0/ !back to VT200 mode
  8628.     data str_begin_plot/
  8629.      1        esc,'P','1','p',        !VT200 => REGIS mode
  8630.      2        's','(','e',')',        !erase screen
  8631.      3        esc,'/',            !Back to VT200 mode
  8632.      4        esc,'[','H',0/            !Home the alpha cursor
  8633.     data str_rls_dev /esc,'/',esc,'[','H',0/
  8634.     data str_move_pos/'p','[',3*'x',',',3*'y',']','V','[',']',0/
  8635.     data str_draw_vec/'v','[',3*'x',',',3*'y',']',0/
  8636.     data str_regis_mode/esc,'P','1','p',0/
  8637.     data str_draw_point/'p','[',']',0/
  8638.     DATA STR_COLOR_SET / 'w','(','i','1',')',0 /
  8639. c
  8640. c    definitions for gin
  8641. c
  8642.     byte ginbufr(40), prompt(8)
  8643.     data prompt /'r','(','p','(','i',2*')',0/
  8644.     data igin_in_chars /18/
  8645.     DATA ICURX /400/
  8646.     DATA ICURY /240/
  8647. c
  8648. c    declare buffering function
  8649. c
  8650.     logical gb_test_flush, LDUMMY
  8651. c
  8652. c    declare vars need for driver operation
  8653. c
  8654.     dimension dchar(8)
  8655. c
  8656. c    make nice names for the devices resolution in x and y
  8657. c     ("xgupcm" is x graphics units per centimeter)
  8658. c
  8659.     equivalence (dchar(4),xgupcm), (dchar(5),ygupcm)
  8660.     data dchar /240.0, 23.78, 14.88, 33.6, 16.8, 3.0, 129.0, 1.0/
  8661.     DATA YFUDGE /2.0/
  8662. c
  8663. c*****************
  8664. c
  8665. c    first verify we got a graphics function we can handle
  8666. c
  8667.     if (ifxn .le. 0 .or. ifxn .gt. 9) return
  8668. c
  8669. c    now dispatch to the proper code to handle that function
  8670. c
  8671.     go to (100,200,300,400,500,600,700,800,900) ifxn
  8672. c
  8673. c    *********************
  8674. c    initialize the device
  8675. c    *********************
  8676. c
  8677. 100    continue
  8678. c
  8679. c    first, initialize the buffer subroutines
  8680. c
  8681.     call gb_initialize(0,0,terminal,ierr)
  8682.     ya(1) = ierr
  8683.     if (ierr .ne. 0) return
  8684. c
  8685. C    INITIALIZE THE VT240
  8686. c
  8687.  
  8688.     call gb_in_string(str_init_dev)
  8689. 190    call gb_empty
  8690.     lvector_going = .false.
  8691.     return
  8692. c
  8693. c    **************************
  8694. c    get fresh plotting surface
  8695. c    **************************
  8696. c
  8697. 200    continue
  8698.     call gb_empty
  8699.     call gb_in_string(str_begin_plot)
  8700.     GO TO 190
  8701. c
  8702. c    ****
  8703. c    move
  8704. c    ****
  8705. c
  8706. 300    continue
  8707. c    convert cm. to graphics units rounded
  8708.     ixposn = xgupcm*xa(1)+0.5
  8709.     iyposn = YFUDGE*ygupcm*ya(1)+0.5
  8710.     lvector_going = .false.
  8711.     return
  8712. c
  8713. c    ****
  8714. c    draw
  8715. c    ****
  8716. c
  8717. 400    continue
  8718.     ix = xgupcm*xa(1)+0.5
  8719.     iy = YFUDGE*ygupcm*ya(1)+0.5
  8720. C    if (ix .ne. ixposn .or. iy .ne. iyposn) then
  8721. c
  8722. c Draw a vector from the current position to the new position
  8723. c
  8724. c Go into graphics mode
  8725. c
  8726.       call gb_test_flush(4)
  8727.       call gb_in_string(str_regis_mode)
  8728. c
  8729. c Move to the current position first (if necessary)
  8730. c
  8731.       If (.not. lvector_going) then
  8732.         f1 = num_dig(ixposn)
  8733.         f2 = num_dig(iyposn)
  8734.         str_length = f1 + f2 + 4
  8735.         encode((f1 + f2 + 2),9000,str_move_pos(3))ixposn,iyposn
  8736. 9000        format(i<f1>','i<f2>']')
  8737. C        str_move_pos(str_length + 1) = 0
  8738.         CALL SCOPY('v[]',STR_MOVE_POS(STR_LENGTH+1))
  8739.         call gb_test_flush(str_length+4)
  8740.         call gb_in_string(str_move_pos)
  8741.       endif
  8742. c
  8743. c Now draw the vector
  8744. c
  8745.       f1 = num_dig(ix)
  8746.       f2 = num_dig(iy)
  8747.       str_length = f1 + f2 + 4
  8748.       encode((f1 + f2 + 2),9000,str_draw_vec(3))ix,iy
  8749.       str_draw_vec(str_length + 1) = 0
  8750.       call gb_test_flush(str_length)
  8751.       call gb_in_string(str_draw_vec)
  8752. c
  8753. c update the current position
  8754. c
  8755.       ixposn = ix
  8756.       iyposn = iy
  8757. c
  8758. c Go back to alpha mode
  8759. c
  8760.       call gb_test_flush(5)
  8761.       call gb_in_string(str_rls_dev)
  8762.       call gb_empty
  8763.       lvector_going = .true.
  8764.     return
  8765. c
  8766. c    *****************************
  8767. c    flush graphics command buffer
  8768. c    *****************************
  8769. c
  8770. 500    continue
  8771.     call gb_empty
  8772.     return
  8773. c
  8774. c    ******************
  8775. c    release the device
  8776. c    ******************
  8777. c
  8778. 600    continue
  8779.     call gb_finish(str_rls_dev)
  8780.     return
  8781. c
  8782. c    *****************************
  8783. c    return device characteristics
  8784. c    *****************************
  8785. c
  8786. 700    continue
  8787.     do 720 i=1,8
  8788.     xa(i) = dchar(i)
  8789. 720    continue
  8790.     return
  8791. c
  8792. c    ****************************
  8793. c    select current drawing color
  8794. c    ****************************
  8795. c
  8796. 800    continue
  8797.     CALL GB_TEST_FLUSH(10)
  8798.     CALL GB_IN_STRING(STR_REGIS_MODE)
  8799.     ICOLOR = XA(1)
  8800.     IF (ICOLOR .LT. 0 .OR. ICOLOR .GT. 3) RETURN
  8801.     STR_COLOR_SET(4) = ICOLOR+48
  8802.     CALL GB_IN_STRING(STR_COLOR_SET)
  8803.     LVECTOR_GOING = .FALSE.
  8804.     CALL GB_TEST_FLUSH(5)
  8805.     CALL GB_IN_STRING(STR_RLS_DEV)
  8806.     CALL GB_EMPTY
  8807.     return
  8808. c
  8809. c    **********************
  8810. c    perform graphics input
  8811. c    **********************
  8812. c
  8813. 900    continue
  8814. c
  8815. c Move the cursor to previous position
  8816. c
  8817.     lvector_going = .false.
  8818.     call gb_test_flush(4)
  8819.     call gb_in_string(str_regis_mode)
  8820.     if (ixposn .ne. icurx .or. iyposn .ne. icury) then
  8821.       f1 = num_dig(icurx)
  8822.       f2 = num_dig(icury)
  8823.       str_length = f1 + f2 + 4
  8824.       encode((f1 + f2 + 2),9000,str_move_pos(3))icurx,icury
  8825.       str_move_pos(str_length + 1) = 0
  8826.       call gb_test_flush(str_length)
  8827.       call gb_in_string(str_move_pos)
  8828.     endif
  8829.     call gb_empty
  8830. c
  8831. c Wait for graphic input
  8832. c
  8833.   905    continue
  8834.     call gb_gin(prompt,igin_in_chars,.false.,ginbufr)
  8835.     IF (GINBUFR(1) .EQ. 13) THEN
  8836.         CALL GB_GIN(0,IGIN_IN_CHARS-1,.FALSE.,GINBUFR(2))
  8837.     ENDIF
  8838.     call gb_in_string(str_rls_dev)
  8839.     call gb_empty
  8840. c
  8841. c Parse the graphic input. It comes in the form: p[xxxxE-1,yyyyE-1], where
  8842. c 'p' is the pick character, 'xxxxE-1' & 'yyyyE-1' are the X & Y coordinates.
  8843. c The 'xE-1' or 'yE-1' may or may not be present in the coordinates. If the
  8844. c user is fast enough (dumb enough) to type two pick characters quickly then
  8845. c the graphic input will contain two pick characters (or more) and the 
  8846. c cursor position will be shifted to the right by the extra characters.
  8847. c This routine will always return the pick character JUST BEFORE THE
  8848. C LEFT BRACKET.
  8849. c
  8850. c Look for the left bracket
  8851. c
  8852.     do ilbrakt = 2,40
  8853.       if (ginbufr(ilbrakt) .eq. '[') goto 910
  8854.     enddo
  8855.     goto 905
  8856. c
  8857. c Look for the right bracket
  8858. c
  8859.   910    continue
  8860.     do irbrakt = ilbrakt + 1,40
  8861.       if (ginbufr(irbrakt) .eq. ']') goto 920
  8862.     enddo
  8863.     goto 905
  8864. c
  8865. c Decode and return the values
  8866. c
  8867.   920    continue
  8868.     length = irbrakt - ilbrakt - 1
  8869.     decode(length,9100,ginbufr(ilbrakt + 1))curx,cury
  8870.  9100    format(2f10.0)
  8871.     xa(1) = ginbufr(ILBRAKT-1)
  8872.     xa(2) = curx / xgupcm
  8873.     xa(3) = cury / (YFUDGE*ygupcm)
  8874.     icurx = curx
  8875.     icury = cury
  8876.     return
  8877.     end
  8878.  
  8879.  
  8880.     integer function num_dig(integer)
  8881.     implicit integer (a-z)
  8882.     num_dig = 1
  8883.     if (integer .gt. 9) num_dig = 2
  8884.     if (integer .gt. 99) num_dig = 3
  8885.     return
  8886.     end
  8887.     SUBROUTINE GDVECTRIX(IFXN,XA,YA)
  8888.     DIMENSION XA(8), YA(3)
  8889. C
  8890. C    VECTRIX VX128 DRIVER FOR DIGLIB/VAX (USES "HEX" FORMAT)
  8891. C
  8892. C---------------------------------------------------------------------------
  8893. C
  8894.     CHARACTER*(*) TERMINAL
  8895.     PARAMETER (TERMINAL='DIG_VECTRIX_TTY')
  8896. C
  8897. C    DEFINITIONS FOR DEVICE CONTROL
  8898. C
  8899.     BYTE STR_INIT_VECTRIX(4)
  8900.     DATA STR_INIT_VECTRIX /'G','K','F',0/
  8901.     INTEGER*2 COLOR_MAP(0:7)
  8902.     DATA COLOR_MAP /0,7,1,2,4,3,5,6/
  8903. C
  8904. C    DECLARE ARRAY FOR DEVICE PARAMETERS
  8905. C     MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  8906. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  8907. C
  8908.     DIMENSION DCHAR(8)
  8909.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  8910.     DATA DCHAR /128.0, 26.84, 19.16, 25.0, 25.0, 7.0, 789.0, 1.0/
  8911. C
  8912. C    DECLARE BUFFERING FUNCTION
  8913. C
  8914.     LOGICAL GB_TEST_FLUSH
  8915. C
  8916.     LOGICAL LDUMMY
  8917. C
  8918. C*****************
  8919. C
  8920. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  8921. C
  8922.     IF (IFXN .GT. 1026) GO TO 1200    !FILLED POLYGON
  8923.     IF (IFXN .LE. 0 .OR. IFXN .GT. 8) RETURN
  8924. C
  8925. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  8926. C
  8927.     GO TO (100,200,300,400,500,600,700,800) IFXN
  8928. C
  8929. C    *********************
  8930. C    INITIALIZE THE DEVICE
  8931. C    *********************
  8932. C
  8933. 100    CONTINUE
  8934. C
  8935. C    FIRST, INITIALIZE THE BUFFER SUBROUTINES
  8936. C
  8937.     CALL GB_INITIALIZE(0,0,TERMINAL,IERR)
  8938.     YA(1) = IERR
  8939.     IF (IERR .NE. 0) RETURN
  8940.     CALL GB_IN_STRING(STR_INIT_VECTRIX)
  8941.     RETURN
  8942. C
  8943. C    **************************
  8944. C    GET FRESH PLOTTING SURFACE
  8945. C    **************************
  8946. C
  8947. 200    CONTINUE
  8948.     CALL GB_NEW_BUFFER
  8949.     CALL GB_INSERT('E')
  8950.     CALL GD_VECTRIX_WORD(0)
  8951.     CALL GB_IN_STRING('REC')
  8952.     ICOLOR = 1
  8953.     CALL GD_VECTRIX_WORD(COLOR_MAP(ICOLOR))
  8954.     RETURN
  8955. C
  8956. C    ****
  8957. C    MOVE
  8958. C    ****
  8959. C
  8960. 300    CONTINUE
  8961.     CALL GB_INSERT('M')
  8962.     GO TO 410
  8963. C
  8964. C    ****
  8965. C    DRAW
  8966. C    ****
  8967. C
  8968. 400    CONTINUE
  8969.     CALL GB_INSERT('L')
  8970. 410    CONTINUE
  8971. C
  8972.     IX = XGUPCM*XA(1)+0.5
  8973.     IY = YGUPCM*YA(1)+0.5
  8974.     LDUMMY = GB_TEST_FLUSH(6)
  8975.     CALL GD_VECTRIX_WORD(IX)
  8976.     CALL GD_VECTRIX_WORD(IY)
  8977.     RETURN
  8978. C
  8979. C    *****************************
  8980. C    FLUSH GRAPHICS COMMAND BUFFER
  8981. C    *****************************
  8982. C
  8983. 500    CONTINUE
  8984.     CALL GB_EMPTY
  8985.     RETURN
  8986. C
  8987. C    ******************
  8988. C    RELEASE THE DEVICE
  8989. C    ******************
  8990. C
  8991. 600    CONTINUE
  8992. C
  8993. C    DE-ASSIGN THE CHANNAL
  8994. C
  8995.     CALL GB_FINISH(0)
  8996.     RETURN
  8997. C
  8998. C    *****************************
  8999. C    RETURN DEVICE CHARACTERISTICS
  9000. C    *****************************
  9001. C
  9002. 700    CONTINUE
  9003.     DO 720 I=1,8
  9004.     XA(I) = DCHAR(I)
  9005. 720    CONTINUE
  9006.     RETURN
  9007. C
  9008. C    ****************************
  9009. C    SELECT CURRENT DRAWING COLOR
  9010. C    ****************************
  9011. C
  9012. 800    CONTINUE
  9013.     IF (XA(1) .LT. 0.0 .OR. XA(1) .GT. 7.0) RETURN
  9014.     ICOLOR = XA(1)
  9015.     CALL GB_INSERT('C')
  9016.     CALL GD_VECTRIX_WORD(COLOR_MAP(ICOLOR))
  9017.     RETURN
  9018. C
  9019. C    ***************
  9020. C    FILLED POLYGONS
  9021. C    ***************
  9022. C
  9023. 1200    CONTINUE
  9024.     N = IFXN-1024
  9025.     CALL GB_INSERT('F')
  9026.     CALL GD_VECTRIX_WORD(COLOR_MAP(ICOLOR))
  9027.     CALL GD_VECTRIX_WORD(N)
  9028.     DO 1220 I=1, N
  9029.         CALL GD_VECTRIX_WORD(INT(XGUPCM*XA(I)+0.5))
  9030.         CALL GD_VECTRIX_WORD(INT(YGUPCM*YA(I)+0.5))
  9031. 1220        CONTINUE
  9032.     RETURN
  9033.     END
  9034.  
  9035.  
  9036.     SUBROUTINE GD_VECTRIX_WORD(INT)
  9037.     INTEGER*2 INT
  9038. C
  9039.     CALL GB_INSERT(INT)
  9040.     CALL GB_INSERT(INT/256)
  9041.     RETURN
  9042.     END
  9043.     SUBROUTINE GDVECTRIX384(IFXN,XA,YA)
  9044.     DIMENSION XA(8), YA(3)
  9045. C
  9046. C    VECTRIX VX384 DRIVER FOR DIGLIB/VAX (USES "HEX" FORMAT)
  9047. C
  9048. C---------------------------------------------------------------------------
  9049. C
  9050.     CHARACTER*(*) TERMINAL
  9051.     PARAMETER (TERMINAL='DIG_VECTRIX_TTY')
  9052. C
  9053. C    DEFINITIONS FOR DEVICE CONTROL
  9054. C
  9055.     BYTE STR_INIT_VECTRIX(4)
  9056.     DATA STR_INIT_VECTRIX /'G','K','F',0/
  9057.     BYTE INIT_RGB(24)
  9058.     DATA INIT_RGB /0,0,0, 255,255,255, 255,0,0, 0,255,0, 0,0,255,
  9059.     1   255,255,0, 255,0,255, 0,255,255 /
  9060. C
  9061. C    DECLARE ARRAY FOR DEVICE PARAMETERS
  9062. C     MAKE NICE NAMES FOR THE DEVICES RESOLUTION IN X AND Y
  9063. C     ("XGUPCM" IS X GRAPHICS UNITS PER CENTIMETER)
  9064. C
  9065.     DIMENSION DCHAR(8)
  9066.     EQUIVALENCE (DCHAR(4),XGUPCM), (DCHAR(5),YGUPCM)
  9067.     DATA DCHAR /128.0, 26.84, 19.16, 25.0, 25.0, 7.0, 789.0, 1.0/
  9068. C
  9069. C    DECLARE BUFFERING FUNCTION
  9070. C
  9071.     LOGICAL GB_TEST_FLUSH
  9072. C
  9073.     LOGICAL LDUMMY
  9074. C
  9075. C*****************
  9076. C
  9077. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  9078. C
  9079.     IF (IFXN .GT. 1026) GO TO 1200    !FILLED POLYGON
  9080.     IF (IFXN .LE. 0 .OR. IFXN .GT. 10) RETURN
  9081. C
  9082. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  9083. C
  9084.     GO TO (100,200,300,400,500,600,700,800,900,1000) IFXN
  9085. C
  9086. C    *********************
  9087. C    INITIALIZE THE DEVICE
  9088. C    *********************
  9089. C
  9090. 100    CONTINUE
  9091. C
  9092. C    FIRST, INITIALIZE THE BUFFER SUBROUTINES
  9093. C
  9094.     CALL GB_INITIALIZE(0,0,TERMINAL,IERR)
  9095.     YA(1) = IERR
  9096.     IF (IERR .NE. 0) RETURN
  9097.     CALL GB_IN_STRING(STR_INIT_VECTRIX)
  9098.     RETURN
  9099. C
  9100. C    **************************
  9101. C    GET FRESH PLOTTING SURFACE
  9102. C    **************************
  9103. C
  9104. 200    CONTINUE
  9105.     CALL GB_NEW_BUFFER
  9106.     CALL GB_INSERT('E')
  9107.     CALL GD_VECTRIX_WORD(0)
  9108.     CALL GB_IN_STRING('REC')
  9109.     ICOLOR = 1
  9110.     CALL GD_VECTRIX_WORD(ICOLOR)
  9111.     CALL GB_INSERT('Q')
  9112.     CALL GD_VECTRIX_WORD(0)
  9113.     CALL GD_VECTRIX_WORD(8)
  9114.     DO 220 I=1,24
  9115.         CALL GB_INSERT(INIT_RGB(I))
  9116. 220        CONTINUE
  9117.     RETURN
  9118. C
  9119. C    ****
  9120. C    MOVE
  9121. C    ****
  9122. C
  9123. 300    CONTINUE
  9124.     CALL GB_INSERT('M')
  9125.     GO TO 410
  9126. C
  9127. C    ****
  9128. C    DRAW
  9129. C    ****
  9130. C
  9131. 400    CONTINUE
  9132.     CALL GB_INSERT('L')
  9133. 410    CONTINUE
  9134. C
  9135.     IX = XGUPCM*XA(1)+0.5
  9136.     IY = YGUPCM*YA(1)+0.5
  9137.     LDUMMY = GB_TEST_FLUSH(6)
  9138.     CALL GD_VECTRIX_WORD(IX)
  9139.     CALL GD_VECTRIX_WORD(IY)
  9140.     RETURN
  9141. C
  9142. C    *****************************
  9143. C    FLUSH GRAPHICS COMMAND BUFFER
  9144. C    *****************************
  9145. C
  9146. 500    CONTINUE
  9147.     CALL GB_EMPTY
  9148.     RETURN
  9149. C
  9150. C    ******************
  9151. C    RELEASE THE DEVICE
  9152. C    ******************
  9153. C
  9154. 600    CONTINUE
  9155. C
  9156. C    DE-ASSIGN THE CHANNAL
  9157. C
  9158.     CALL GB_FINISH(0)
  9159.     RETURN
  9160. C
  9161. C    *****************************
  9162. C    RETURN DEVICE CHARACTERISTICS
  9163. C    *****************************
  9164. C
  9165. 700    CONTINUE
  9166.     DO 720 I=1,8
  9167.     XA(I) = DCHAR(I)
  9168. 720    CONTINUE
  9169.     RETURN
  9170. C
  9171. C    ****************************
  9172. C    SELECT CURRENT DRAWING COLOR
  9173. C    ****************************
  9174. C
  9175. 800    CONTINUE
  9176.     IF (XA(1) .LT. 0.0 .OR. XA(1) .GT. 7.0) RETURN
  9177.     ICOLOR = XA(1)
  9178.     CALL GB_INSERT('C')
  9179.     CALL GD_VECTRIX_WORD(COLOR_MAP(ICOLOR))
  9180.     RETURN
  9181. 900    RETURN
  9182. C
  9183. C    **********************
  9184. C    DEFINE COLOR USING RGB
  9185. C    **********************
  9186. C
  9187. 1000    CONTINUE
  9188.     CALL GB_INSERT('Q')
  9189.     CALL GD_VECTRIX_WORD(INT(XA(1))
  9190.     CALL GD_VECTRIX_WORD(1)
  9191.     DO 1010 I=1,3
  9192.         CALL GB_INSERT(INT(2.55*YA(I)+0.5))
  9193. 1010        CONTINUE
  9194.     RETURN
  9195. C
  9196. C    ***************
  9197. C    FILLED POLYGONS
  9198. C    ***************
  9199. C
  9200. 1200    CONTINUE
  9201.     N = IFXN-1024
  9202.     CALL GB_INSERT('F')
  9203.     CALL GD_VECTRIX_WORD(COLOR_MAP(ICOLOR))
  9204.     CALL GD_VECTRIX_WORD(N)
  9205.     DO 1220 I=1, N
  9206.         CALL GD_VECTRIX_WORD(INT(XGUPCM*XA(I)+0.5))
  9207.         CALL GD_VECTRIX_WORD(INT(YGUPCM*YA(I)+0.5))
  9208. 1220        CONTINUE
  9209.     RETURN
  9210.     END
  9211.  
  9212.  
  9213.     SUBROUTINE GD_VECTRIX_WORD(INT)
  9214.     INTEGER*2 INT
  9215. C
  9216.     CALL GB_INSERT(INT)
  9217.     CALL GB_INSERT(INT/256)
  9218.     RETURN
  9219.     END
  9220.     SUBROUTINE GDWAIT(MILLISECONDS)
  9221. C
  9222. C    THIS SUBROUTINE DELAYS A GIVEN NUMBER OF MILLISECONDS.
  9223. C
  9224.     INTEGER*4 SYS$SETIMR,SYS$WAITFR
  9225. C
  9226.     INTEGER*4 DELTIME(2)
  9227. C
  9228.     DELTIME(1) = -MILLISECONDS*10000 !10,000 (100ns) UNITS PER MILLISEC.
  9229.     DELTIME(2) = -1
  9230.     ISTAT = SYS$SETIMR(%VAL(1),DELTIME, , )
  9231.     IF (.NOT. ISTAT) STOP 'SET TIME FAILURE'
  9232.     ISTAT = SYS$WAITFR(%VAL(1))
  9233.     IF (.NOT. ISTAT) STOP 'WAITFOR FAILURE'
  9234.     RETURN
  9235.     END
  9236. This code is completely untested!!!!!
  9237.     SUBROUTINE GDZETA8TALL(IFXN,XA,YA)
  9238.     DIMENSION XA(8), YA(3)
  9239. C
  9240. C    DIGLIB ZETA 8 GRAPHICS DEVICE DRIVER
  9241. C     USES THE ZETA "FUNDAMENTAL PLOTTING SUBROUTINES"
  9242. C
  9243. C-----------------------------------------------------------------------
  9244. C
  9245.     DIMENSION DCHAR(8)
  9246.     LOGICAL*2 LWIDE
  9247. C
  9248. C    THE ZETA 8 IS ASSUMED TO BE SET FOR RESOLUTION OF 0.025 mm
  9249. C    DIGLIB ASSUMES 8.5 INCH FAN FOLD PAPER.   DIGLIB USES A PLOTTING
  9250. C     SURFACE OF 8X10 INCHES, WITH EQUAL 0.25 INCH BORDERS IN THE X
  9251. C     DIRECTION, A BOTTOM BORDER OF 0.25 INCH, AND A TOP BORDER OF
  9252. C     0.75 INCH.   THUS THE DIGLIB PLOTTING SURFACE OF 8X10 IS PLACED
  9253. C     NICELY ON 8.5X11.0 INCH PAPER.
  9254. C    THIS DIGLIB DRIVER PROVIDES AN ALTERNATE ENTRY POINT FOR ROTATING
  9255. C     THE PLOT 90 DEGREES WHEN THE USER WANTS A PLOT THAT IS WIDER THAN
  9256. C     IT IS TALL.   THE ENTRY POINT NAME IS "GDZETA8WIDE".   THE SAME
  9257. C     BOTTOM AND LEFT BORDERS ARE USED.
  9258. C
  9259.     PARAMETER (CM_PER_INCH = 2.54)
  9260. C-----------------------------------------------------------------------
  9261. C
  9262. C PAPER DEFINITIONS - ALL IN INCHES
  9263. C
  9264.     PARAMETER (PAPER_WIDTH = 8.5)    !PAPER FAN FOLD WIDTH
  9265.     PARAMETER (PAPER_HEIGHT = 11.0)    !PAPER HEIGHT
  9266.     PARAMETER (LEFT_BORDER = 0.25)    !LEFT SIDE BORDER
  9267.     PARAMETER (BOTTOM_BORDER = 0.25)!BOTTOM OF PAPER BORDER
  9268.     PARAMETER (PLOT_WIDTH = 8.0)    !WIDTH OF PAPER USED FOR PLOTTING
  9269.     PARAMETER (PLOT_HEIGHT = 11.0)    !HEIGHT OF PAPER USE FOR PLOTTING
  9270. C
  9271. C PLOTTER DEFINITIONS - ALL IN CENTIMETERS
  9272. C
  9273.     PARAMETER (RESOLUTION = 0.0025)    !RESOLUTION
  9274.     PARAMETER (PEN_WIDTH = 0.002)    !PEN LINE WIDTH
  9275. C
  9276. C***********************************************************************
  9277. C
  9278. C CALCULATED QUANTITIES FOR PLOTTER
  9279. C
  9280.     PARAMETER (X_WIDE = CM_PER_INCH*PLOT_WIDTH)
  9281.     PARAMETER (Y_HIGH = CM_PER_INCH*PLOT_HEIGHT)
  9282.     PARAMETER (SKIPPED_LINES = PEN_WIDTH/RESOLUTION)
  9283. C
  9284. C***********************************************************************
  9285. C
  9286.     DATA DCHAR /8.0, X_WIDE, Y_HIGH, RESOLUTION, RESOLUTION,
  9287.     1   7.0, 3.0, SKIPPED_LINES/
  9288. C
  9289. C    SHOW WE WANT TALL NOT WIDE PLOTTING AREA
  9290. C
  9291.     LWIDE = .FALSE.
  9292. 10    CONTINUE
  9293. C
  9294. C    FIRST VERIFY WE GOT A GRAPHICS FUNCTION WE CAN HANDLE
  9295. C
  9296.     IF (IFXN .LE. 0 .OR. IFXN .GT. 8) RETURN
  9297. C
  9298. C    NOW DISPATCH TO THE PROPER CODE TO HANDLE THAT FUNCTION
  9299. C
  9300.     GO TO (100,200,300,400,500,600,700,800) IFXN
  9301. C
  9302. C    *********************
  9303. C    INITIALIZE THE DEVICE
  9304. C    *********************
  9305. C
  9306. 100    CONTINUE
  9307. ???    CALL PLOTS(53,0,4)
  9308.     YA(1) = 0.0
  9309.     RETURN
  9310. C
  9311. C    **************************
  9312. C    GET FRESH PLOTTING SURFACE
  9313. C    **************************
  9314. C
  9315. 200    CONTINUE
  9316.     CALL NEWPEN(1)
  9317.     CALL PLOT(PAPER_WIDTH,0.0,-3)
  9318.     RETURN
  9319. C
  9320. C    ****
  9321. C    MOVE
  9322. C    ****
  9323. C
  9324. 300    CONTINUE
  9325.     IPEN = +3
  9326.     GO TO 450
  9327. C
  9328. C    ****
  9329. C    DRAW
  9330. C    ****
  9331. C
  9332. 400    CONTINUE
  9333.     IPEN = +2
  9334. 450    CONTINUE
  9335. C
  9336. C    ZETA "PLOT" SUBROUTINE WANTS INCHES, SO CONVERT
  9337. C
  9338.     X = XA(1)/CM_PER_INCH
  9339.     Y = YA(1)/CM_PER_INCH
  9340.     IF (LWIDE) THEN
  9341.         CALL PLOT(LEFT_BORDER+PLOT_WIDTH-Y,BOTTOM_BORDER+X,IPEN)
  9342.         ELSE
  9343.         CALL PLOT(LEFT_BORDER+X,BOTTOM_BORDER+Y,IPEN)
  9344.     END IF
  9345.     RETURN
  9346. C
  9347. C    *****************************
  9348. C    FLUSH GRAPHICS COMMAND BUFFER
  9349. C    *****************************
  9350. C
  9351. 500    CONTINUE
  9352. C
  9353. C    NOP FOR ZETA 8 CAUSE I DON'T KNOW HOW TO MAKE THE FUNDAMENTAL
  9354. C     PLOTTING ROUTINES DO IT
  9355. C
  9356.     RETURN
  9357. C
  9358. C    ******************
  9359. C    RELEASE THE DEVICE
  9360. C    ******************
  9361. C
  9362. 600    CONTINUE
  9363.     CALL PLOT(PAPER_WIDTH, 0.0, +999)
  9364.     RETURN
  9365. C
  9366. C    *****************************
  9367. C    RETURN DEVICE CHARACTERISTICS
  9368. C    *****************************
  9369. C
  9370. 700    CONTINUE
  9371.     DO 720 I=1,8
  9372.     XA(I) = DCHAR(I)
  9373. 720    CONTINUE
  9374.     IF (.NOT. LWIDE) RETURN
  9375.     XA(2) = DCHAR(3)
  9376.     XA(3) = DCHAR(2)
  9377.     RETURN
  9378. C
  9379. C    SELECT NEW COLOR
  9380. C
  9381. 800    CONTINUE
  9382.     CALL NEWPEN(INT(XA(1))
  9383.     RETURN
  9384. C
  9385. C    ALTERNATE ENTRY FOR WIDE PLOTTING AREA
  9386. C
  9387.     ENTRY GDZETA8WIDE(IFXN,XA,YA)
  9388.     LWIDE = .TRUE.
  9389.     GO TO 10
  9390.     END
  9391.