C*TJDRIV -- PGPLOT Tektronix 4510 driver
C+
      SUBROUTINE TJDRIV (IFUNC, RBUF, NBUF, CHR, LCHR)
      INTEGER IFUNC, NBUF, LCHR
      REAL    RBUF(*)
      CHARACTER*(*) CHR
C
C PGPLOT driver for Tektronix 4510 series rasterizer/printer
C
C Version 0.9 - 1991 Oct 30 - B. H. Toby (quickly hacked from TK4100 driver)
C
C Commands sent to device:
C ESC, 'RU1;6'
C       Begin pixel operations: surface 1; replace mode; 6 bit/pixel
C ESC, 'RS', C1, C2
C       Set pixel viewport: lower left, upper right.
C ESC, 'TM111'
C       Set color mode: RGB, opaque, normal color
C ESC, 'RR', C1, C2, '0'
C       Rectangle fill: lower left (xycoord), upper right (xy coord),
C       fill index (integer)
C ESC, 'ML', C3(:NC3)
C       Set line index: line-index (integer)
C ESC, 'LF', C1
C       Move: position (xy coord)
C ESC, 'LG', C1
C       Draw: position (xy coord)
C ESC, 'TG14', C1(:NC1), C2(:NC2),
C       Set surface color map: surface number, color mixtures
C ESC, 'KH'
C       Print page
C-----------------------------------------------------------------------
      CHARACTER*(*) TYPE
      PARAMETER (TYPE='T4510')
      INTEGER NX, NY, NCOL
      real MAXPIX
C 41xx parameters
C     PARAMETER (NX=639, NY=479, NCOL=15, maxpix=640.)
C 4510A parameters
      PARAMETER (NX=2047, NY=1532, NCOL=15, maxpix=2048.)
C
      INTEGER  UNIT, IER, I
      LOGICAL  APPEND
      CHARACTER*5 C1, C2, C3, C4
      INTEGER  NC1, NC2, NC3, NC4
      INTEGER  CI, I0, J0, I1, J1, Ih, Il, Is, LASTI, LASTJ
      REAL r,g,b,h,l,s
C
      INTEGER CTABLE(3,0:15)
      DATA CTABLE /000,000,000, 100,100,100, 100,000,000, 000,100,000,
     1             000,000,100, 000,100,100, 100,000,100, 100,100,000,
     2             100, 50,000,  50,100,000, 000,100, 50, 000, 50,100,
     3              50,000,100, 100,000, 50,  33, 33, 33,  67, 67, 67/
C
      SAVE CI, LASTI, LASTJ
C-----------------------------------------------------------------------
C
      GOTO( 10, 20, 30, 40, 50, 60, 70, 80, 90,100,110,120,
     &     130,140,150,160,170,180,190,200,210,220,230,240), IFUNC
  900 CALL GRWARN('Unimplemented function in TJ device driver.')
      NBUF = -1
      RETURN
C
C--- IFUNC = 1, Return device name.-------------------------------------
C
   10 CHR = TYPE
      LCHR = LEN(TYPE)
      RETURN
C
C--- IFUNC = 2, Return physical min and max for plot device, and range
C               of color indices.---------------------------------------
C
   20 RBUF(1) = 0
      RBUF(2) = NX
      RBUF(3) = 0
      RBUF(4) = NY
      RBUF(5) = 0
      RBUF(6) = NCOL
      NBUF = 6
      RETURN
C
C--- IFUNC = 3, Return device resolution. ------------------------------
C
   30 RBUF(1) = 100.0
      RBUF(2) = 100.0
      RBUF(3) = 1
      NBUF = 3
      RETURN
C
C--- IFUNC = 4, Return misc device info. -------------------------------
C    (This device is Hardcopy, No cursor, No dashed lines, No area
C    fill, No thick lines, No rectangle fill)
C
   40 CHR = 'HNNNNNNNNN'
      LCHR = 10
      RETURN
C
C--- IFUNC = 5, Return default file name. ------------------------------
C
   50 CHR = 'PGPLOT.T4510'
      LCHR = 13
      RETURN
C
C--- IFUNC = 6, Return default physical size of plot. ------------------
C
   60 RBUF(1) = 0
      RBUF(2) = NX
      RBUF(3) = 0
      RBUF(4) = NY
      NBUF = 4
      RETURN
C
C--- IFUNC = 7, Return misc defaults. ----------------------------------
C
   70 RBUF(1) = 1
      NBUF = 1
      RETURN
C
C--- IFUNC = 8, Select plot. -------------------------------------------
C
   80 CONTINUE
      RETURN
C
C--- IFUNC = 9, Open workstation. --------------------------------------
C
   90 CONTINUE
      APPEND = RBUF(3).NE.0.0
      CALL GRGLUN(UNIT)
      RBUF(1) = UNIT
      OPEN (UNIT=UNIT, STATUS='NEW', FILE=CHR(1:LCHR), IOSTAT=IER,
     1      CARRIAGECONTROL='NONE')
      IF (IER.NE.0) THEN
          CALL GRWARN('Cannot open output file for Tek 4510 plot')
          RBUF(2) = 0
          CALL GRFLUN(UNIT)
      ELSE
          INQUIRE (UNIT=UNIT, NAME=CHR)
          LCHR = LEN(CHR)
   91     IF (CHR(LCHR:LCHR).EQ.' ') THEN
              LCHR = LCHR-1
              GOTO 91
          END IF
          RBUF(2) = 1
      END IF
      RETURN
C
C--- IFUNC=10, Close workstation. --------------------------------------
C
  100 CONTINUE
C     -- close file
      CLOSE (UNIT)
      CALL GRFLUN(UNIT)
      RETURN
C
C--- IFUNC=11, Begin picture. ------------------------------------------
C
  110 CONTINUE
C Erase screen (4014 method)
      WRITE (UNIT, '(A)') CHAR(27)//CHAR(12)
      WRITE (UNIT, '(2A)') CHAR(27), 'RU1;6'
C     -- set default color representation
      DO 111 I=0,ncol
C Convert the RBG values to HLS
          R = CTABLE(1,I)/100.
	  G = CTABLE(2,I)/100.
          B = CTABLE(3,I)/100.
          call GRXHLS (R,G,B,H,L,S)
C encode the values
          IH = IFIX(H)
          IL = IFIX(L*100.0)
          IS = IFIX(S*100.0)
          CALL GRTK01(I,  C1, NC1)
          CALL GRTK01(IH, C2, NC2)
          CALL GRTK01(IL, C3, NC3)
          CALL GRTK01(IS, C4, NC4)
          WRITE (UNIT, '(6A)') CHAR(27), 'TG14', C1(:NC1), C2(:NC2),
     1                     C3(:NC3), C4(:NC4)
  111 CONTINUE
C     -- set color index 1
      WRITE (UNIT, '(3A)') CHAR(27), 'ML', '1'
C     -- set line width 2
      WRITE (UNIT, '(3A)') CHAR(27), 'MW', '2'
      LASTI=-1
      RETURN
C
C--- IFUNC=12, Draw line. ----------------------------------------------
C
  120 CONTINUE
      I0 = MIN(MAX(0,NINT(RBUF(1)*4096.0/maxpix)),4095)
      J0 = MIN(MAX(0,NINT(RBUF(2)*4096.0/maxpix)),4095)
      I1 = MIN(MAX(0,NINT(RBUF(3)*4096.0/maxpix)),4095)
      J1 = MIN(MAX(0,NINT(RBUF(4)*4096.0/maxpix)),4095)
      IF (I0.NE.LASTI .OR. J0.NE.LASTJ) THEN
C         -- move to (I0,J0)
          CALL GRTK00(I0, J0, C1)
          WRITE (UNIT, '(3A)') CHAR(27), 'LF', C1
      END IF
C     -- draw to (I1,J1)
      CALL GRTK00(I1, J1, C1)
      WRITE (UNIT, '(3A)') CHAR(27), 'LG', C1
C     -- save current point
      LASTI = I1
      LASTJ = J1
      RETURN
C
C--- IFUNC=13, Draw dot. -----------------------------------------------
C
  130 CONTINUE
      I0 = MIN(MAX(0,NINT(RBUF(1)*4096.0/maxpix)),4095)
      J0 = MIN(MAX(0,NINT(RBUF(2)*4096.0/maxpix)),4095)
      I1 = I0
      J1 = J0
      IF (I0.NE.LASTI .OR. J0.NE.LASTJ) THEN
C         -- move to (I0,J0)
          CALL GRTK00(I0, J0, C1)
          WRITE (UNIT, '(3A)') CHAR(27), 'LF', C1
      END IF
C     -- draw to (I1,J1)
      CALL GRTK00(I1, J1, C1)
      WRITE (UNIT, '(3A)') CHAR(27), 'LG', C1
C     -- save current point
      LASTI = I1
      LASTJ = J1
      RETURN
C
C--- IFUNC=14, End picture. --------------------------------------------
C
  140 CONTINUE
      WRITE (UNIT, '(3A)') CHAR(27), 'KH'
      RETURN
C
C--- IFUNC=15, Select color index. -------------------------------------
C
  150 CONTINUE
      CI = NINT(RBUF(1))
      IF (CI.GT.NCOL .OR. CI.LT.0) CI = 1
      CALL GRTK01(CI, C1, NC1)
      WRITE (UNIT, '(3A)') CHAR(27), 'ML', C1(:NC1)
      RETURN
C
C--- IFUNC=16, Flush buffer. -------------------------------------------
C
  160 CONTINUE
      RETURN
C
C--- IFUNC=17, Read cursor. --------------------------------------------
C           RBUF(1)   in/out : cursor x coordinate.
C           RBUF(2)   in/out : cursor y coordinate.
C           CHR(1:1)  output : keystroke.
C
  170 CONTINUE
      RETURN
C
C--- IFUNC=18, Erase alpha screen. -------------------------------------
C
  180 CONTINUE
      RETURN
C
C--- IFUNC=19, Set line style. -----------------------------------------
C    (Not implemented: should not be called.)
C
  190 GOTO 900
C
C--- IFUNC=20, Polygon fill. -------------------------------------------
C    (Not implemented: should not be called.)
C
  200 GOTO 900
C
C--- IFUNC=21, Set color representation. -------------------------------
C
  210 CONTINUE
      CI = RBUF(1)
C Convert the RBG values to HLS
      call GRXHLS (RBUF(2),RBUF(3),RBUF(4),H,L,S)
C encode the values
      IH = IFIX(H)
      IL = IFIX(L*100.0)
      IS = IFIX(S*100.0)
      CALL GRTK01(CI, C1, NC1)
      CALL GRTK01(IH, C2, NC2)
      CALL GRTK01(IL, C3, NC3)
      CALL GRTK01(IS, C4, NC4)
      WRITE (UNIT, '(6A)') CHAR(27), 'TG14', C1(:NC1), C2(:NC2),
     1                     C3(:NC3), C4(:NC4)
      RETURN
C
C--- IFUNC=22, Set line width. -----------------------------------------
C    (Not implemented: should not be called.)
C
  220 GOTO 900
C
C--- IFUNC=23, Escape. -------------------------------------------------
C
  230 CONTINUE
      RETURN
C
C--- IFUNC=24, Rectangle fill. -----------------------------------------
C
  240 CONTINUE
      I0 = NINT(RBUF(1))
      J0 = NINT(RBUF(2))
      I1 = NINT(RBUF(3))
      J1 = NINT(RBUF(4))
      CALL GRTK00(I0, J0, C1)
      CALL GRTK00(I1, J1, C2)
      CALL GRTK01(CI, C3, NC3)
      WRITE (UNIT, '(5A)') CHAR(27), 'RR', C1, C2, C3(:NC3)
      RETURN
C-----------------------------------------------------------------------
      END
C*GRTK00 -- PGPLOT Tektronix 4100 driver, encode coordinate pair
C+
      SUBROUTINE GRTK00(IX, IY, C)
      INTEGER IX, IY
      CHARACTER*(*) C
C
C Encode XY coordinate pair in host syntax. Input integers IX, IY; 
C output string C, containing 5 characters. The valid range of
C XY coordinates is (0,4095). The output string contains characters
C with ASCII values in the range 32-127. NB the 'delete' character
C (127) can occur in LOY or EXTRA byte; it can be replaced by
C escape-? if desired.
C-----------------------------------------------------------------------
      INTEGER EX1, EX2, LOX, HIX, LOY, HIY
C
      EX2 = MOD(IX, 4)
      LOX = MOD(IX/4, 32)
      HIX = IX/128
      EX1 = MOD(IY, 4)
      LOY = MOD(IY/4, 32)
      HIY = IY/128
      C(1:1) = CHAR(32+HIY)
      C(2:2) = CHAR(96+4*EX1+EX2)
      C(3:3) = CHAR(96+LOY)
      C(4:4) = CHAR(32+HIX)
      C(5:5) = CHAR(64+LOX)
C
      END
C*GRTK01 -- PGPLOT Tektronix 4100 driver, encode integer
C+
      SUBROUTINE GRTK01(I, C, NC)
      INTEGER I
      CHARACTER*(*) C
      INTEGER NC
C
C Encode integer in host syntax. Input integer I; output encoded string
C C, containing NC characters (1, 2, or 3).  This version encodes
C integers up to 1023, which fit in two characters.
C-----------------------------------------------------------------------
      INTEGER J
C
      J = IABS(I)
      IF (J.LT.16) THEN
          IF (I.LT.0) THEN
              C(1:1) = CHAR(J+32)
          ELSE
              C(1:1) = CHAR(J+48)
          END IF
          NC = 1
      ELSE
          C(1:1) = CHAR(J/16+64)
          IF (I.LT.0) THEN
              C(2:2) = CHAR(MOD(J,16)+32)
          ELSE
              C(2:2) = CHAR(MOD(J,16)+48)
          END IF
          NC = 2
      END IF
C
      END
