C*CCDRIV -- PGPLOT DEC LJ250 Color Companion driver
C+
      SUBROUTINE CCDRIV (IFUNC, RBUF, NBUF, CHR, LCHR)
      IMPLICIT NONE
      INTEGER IFUNC, NBUF, LCHR
      REAL    RBUF(*)
      CHARACTER*(*) CHR
C
C PGPLOT driver for DEC LJ250 Color Companion device.
C
C Version 1.0  - 1989 Jun 04 - S. C. Allendorf
C=======================================================================
C
C Supported device: DEC LJ250 Color Companion printer.
C
C Device type code: /CCP (portrait) or /CCL (landscape).
C
C Default device name: PGPLOT.CCPLT.
C
C Default view surface dimensions: 8.0 inches by 10.5 inches.
C
C Resolution: 90 dots/inch.
C
C Color capability: Color indices 0-15 are supported. It is not (yet)
C possible to change color representation.
C
C Input capability: None.
C
C File format: DEC color sixel format.
C
C Obtaining hardcopy: Use the VMS PRINT command.
C-----------------------------------------------------------------------
C 
C To choose portrait mode, you must execute a DCL command of the 
C following form before executing your program:
C
C $ DEFINE PGPLOT_CC_MODE PORTRAIT
C-----------------------------------------------------------------------
      BYTE       CTAB(3, 256), FF
      LOGICAL    HIRES, INIT, LANDSCAPE
      INTEGER*4  BUFFER, BX, BY, I, IC, IER, GRFMEM, GRGMEM
      INTEGER*4  LUN, MAXCOL, NPICT
      REAL*4     XBUF(4)
      CHARACTER  DEFNAM*12, MODE*20, MSG*10
      PARAMETER  (FF = 12)
      PARAMETER  (DEFNAM = 'PGPLOT.CCPLT')
      DATA INIT  /.TRUE./
      DATA CTAB  /100, 100, 100,      0,   0,   0,    100,   0,   0,
     1              0, 100,   0,      0,   0, 100,      0, 100, 100,
     2            100,   0, 100,    100, 100,   0,    100,  50,   0,
     3             50, 100,   0,      0, 100,  50,      0,  50, 100,
     4             50,   0, 100,    100,   0,  50,     33,  33,  33,
     5             67,  67,  67,    720 * 0/
C-----------------------------------------------------------------------
C                                       First time, do some one-time
C                                       initialization.
      IF (INIT) THEN
C                                       Make sure we only do this once.
         INIT = .FALSE.
C                                       Initialize the maximum color
C                                       index currently used.
         MAXCOL = 0
C                                       The default is low resolution,
C                                       landscape orientation.
         LANDSCAPE = .TRUE.
         HIRES = .FALSE.
C                                       Select mode based on logical.
         CALL GRGENV ('CC_MODE', MODE, I)
         IF (MODE(1:1) .EQ. 'P') LANDSCAPE = .FALSE.
         IF (MODE(2:2) .EQ. 'H') HIRES = .TRUE.
      END IF
C                                       Branch on opcode.
      GOTO ( 10,  20,  30,  40,  50,  60,  70,  80,  90, 100,
     1      110, 120, 130, 140, 150, 160, 170, 180, 190, 200,
     2      210, 220, 230, 240, 250, 260), IFUNC
C                                       Signal an error.
  900 WRITE (MSG, '(I10)') IFUNC
      CALL GRWARN ('Unimplemented function in LJ250 device driver:' 
     1             // MSG)
      NBUF = -1
      RETURN
C
C--- IFUNC = 1, Return device name -------------------------------------
C
   10 CONTINUE
      CHR = 'CC'
      NBUF = 0
      LCHR = 2
      RETURN
C
C--- IFUNC = 2, Return physical min and max for plot device, and range
C               of color indices ---------------------------------------
C
   20 CONTINUE
      RBUF(1) = 0.0
      IF (HIRES .AND. LANDSCAPE)             RBUF(2) = 1889.0
      IF (HIRES .AND. .NOT. LANDSCAPE)       RBUF(2) = 1439.0
      IF (.NOT. HIRES .AND. LANDSCAPE)       RBUF(2) = 944.0
      IF (.NOT. HIRES .AND. .NOT. LANDSCAPE) RBUF(2) = 719.0
      RBUF(3) = 0.0
      IF (HIRES .AND. LANDSCAPE)             RBUF(4) = 1439.0
      IF (HIRES .AND. .NOT. LANDSCAPE)       RBUF(4) = 1889.0
      IF (.NOT. HIRES .AND. LANDSCAPE)       RBUF(4) = 719.0
      IF (.NOT. HIRES .AND. .NOT. LANDSCAPE) RBUF(4) = 944.0
      RBUF(5) = 0.0
      IF (HIRES) THEN
         RBUF(6) = 7.0
      ELSE
         RBUF(6) = 255.0
      END IF
      NBUF = 6
      LCHR = 0
      RETURN
C
C--- IFUNC = 3, Return device resolution -------------------------------
C
   30 CONTINUE
      IF (HIRES) THEN
         RBUF(1) = 180.0
      ELSE
         RBUF(1) = 90.0
      END IF
      RBUF(2) = RBUF(1)
      RBUF(3) = 1.0
      NBUF = 3
      LCHR = 0
      RETURN
C
C--- IFUNC = 4, Return misc device info --------------------------------
C    (This device is Hardcopy, No cursor, No dashed lines, No area fill,
C    no thick lines)
C
   40 CONTINUE
      CHR = 'HNNNNNNNNN'
      NBUF = 0
      LCHR = 10
      RETURN
C
C--- IFUNC = 5, Return default file name -------------------------------
C
   50 CONTINUE
      CHR = DEFNAM
      NBUF = 0
      LCHR = LEN(DEFNAM)
      RETURN
C
C--- IFUNC = 6, Return default physical size of plot -------------------
C
   60 CONTINUE
      RBUF(1) = 0.0
      IF (HIRES .AND. LANDSCAPE)             RBUF(2) = 1889.0
      IF (HIRES .AND. .NOT. LANDSCAPE)       RBUF(2) = 1439.0
      IF (.NOT. HIRES .AND. LANDSCAPE)       RBUF(2) = 944.0
      IF (.NOT. HIRES .AND. .NOT. LANDSCAPE) RBUF(2) = 719.0
      RBUF(3) = 0.0
      IF (HIRES .AND. LANDSCAPE)             RBUF(4) = 1439.0
      IF (HIRES .AND. .NOT. LANDSCAPE)       RBUF(4) = 1889.0
      IF (.NOT. HIRES .AND. LANDSCAPE)       RBUF(4) = 719.0
      IF (.NOT. HIRES .AND. .NOT. LANDSCAPE) RBUF(4) = 944.0
      NBUF = 4
      LCHR = 0
      RETURN
C
C--- IFUNC = 7, Return misc defaults -----------------------------------
C
   70 CONTINUE
      RBUF(1) = 1.0
      NBUF = 1
      LCHR = 0
      RETURN
C
C--- IFUNC = 8, Select plot --------------------------------------------
C
   80 CONTINUE
      RETURN
C
C--- IFUNC = 9, Open workstation ---------------------------------------
C
   90 CONTINUE
C                                       Assume success.
      RBUF(2) = 1.0
C                                       Obtain a logical unit number.
      CALL GRGLUN (LUN)
C                                       Check for an error.
      IF (LUN .EQ. -1) THEN
          CALL GRWARN ('Cannot allocate a logical unit.')
          RBUF(2) = 0
          RETURN
      ELSE
         RBUF(1) = LUN
      END IF
C                                       Open the output file.
      OPEN (UNIT = LUN, FILE = CHR(:LCHR), CARRIAGECONTROL = 'NONE',
     1      DEFAULTFILE = DEFNAM, STATUS = 'NEW',
     2      RECL = 362, FORM = 'UNFORMATTED', RECORDTYPE = 'VARIABLE', 
     3      IOSTAT = IER)
C                                       Check for an error and cleanup if
C                                       one occurred.
      IF (IER .NE. 0) THEN
          CALL GRWARN ('Cannot open output file for LJ250 plot: ' //
     1                 CHR(:LCHR))
          RBUF(2) = 0
          CALL GRFLUN (LUN)
          RETURN
      ELSE
C                                       Get the full file specification
C                                       and calculate the length of the 
C                                       string
          INQUIRE (UNIT = LUN, NAME = CHR)
          LCHR = LEN (CHR)
   91     IF (CHR (LCHR:LCHR) .EQ. ' ') THEN
              LCHR = LCHR - 1
              GOTO 91
          END IF
      END IF
C                                       Initialize the page counter.
      NPICT = 0
      RETURN
C
C--- IFUNC = 10, Close workstation -------------------------------------
C
  100 CONTINUE
C                                       Close the file.
      CLOSE (LUN, STATUS = 'KEEP')
C                                       Deallocate the logical unit.
      CALL GRFLUN (LUN)
C
      RETURN
C
C--- IFUNC = 11, Begin picture -----------------------------------------
C
  110 CONTINUE
C                                       Calculate the dimensions of the
C                                       plot buffer.
      IF (LANDSCAPE) THEN
         XBUF(1) = RBUF(2)
         XBUF(2) = RBUF(1)
      ELSE
         XBUF(1) = RBUF(1)
         XBUF(2) = RBUF(2)
      END IF
      BX = INT (XBUF(1)) + 1
      BY = (INT (XBUF(2)) / 6 + 1) * 6
C                                       Allocate a plot buffer.      
      IER = GRGMEM (BX * BY, BUFFER)
C                                       Check for error and clean up
C                                       if one was found.
      IF (IER .NE. 1) THEN
          CALL GRGMSG (IER)
          CALL GRQUIT ('Failed to allocate a plot buffer.')
      END IF
C                                       Increment the page number.
      NPICT = NPICT + 1
C                                       Eject the page from the printer.
      IF (NPICT .GT. 1) WRITE (LUN) FF
C                                       Zero out the plot buffer.
      CALL GRCC04 (BX * BY, %VAL(BUFFER))
      RETURN
C
C--- IFUNC = 12, Draw line ---------------------------------------------
C
  120 CONTINUE
C                                       Apply any needed tranformation.
      IF (LANDSCAPE) THEN
         XBUF(1) = RBUF(2)
         XBUF(2) = (BY - 1) - RBUF(1)
         XBUF(3) = RBUF(4)
         XBUF(4) = (BY - 1) - RBUF(3)
      ELSE
         XBUF(1) = RBUF(1)
         XBUF(2) = RBUF(2)
         XBUF(3) = RBUF(3)
         XBUF(4) = RBUF(4)
      END IF
C                                       Draw the point into the bitmap.
      CALL GRCC00 (1, XBUF, IC, BX, BY, %VAL (BUFFER))
      RETURN
C
C--- IFUNC = 13, Draw dot ----------------------------------------------
C
  130 CONTINUE
C                                       Apply any needed tranformation.
      IF (LANDSCAPE) THEN
         XBUF(1) = RBUF(2)
         XBUF(2) = (BY - 1) - RBUF(1)
      ELSE
         XBUF(1) = RBUF(1)
         XBUF(2) = RBUF(2)
      END IF
C                                       Draw the point into the bitmap.
      CALL GRCC00 (0, XBUF, IC, BX, BY, %VAL(BUFFER))
      RETURN
C
C--- IFUNC = 14, End picture -------------------------------------------
C
  140 CONTINUE
C                                       Write out the bitmap.
      CALL GRCC01 (LUN, BX, BY, %VAL (BUFFER), MAXCOL, HIRES, CTAB)
C                                       Deallocate the plot buffer.
      IER = GRFMEM (BX * BY, BUFFER)
C                                       Check for an error.
      IF (IER .NE. 1) THEN
          CALL GRGMSG (IER)
          CALL GRWARN ('Failed to deallocate plot buffer.')
      END IF
      RETURN
C
C--- IFUNC = 15, Select color index ------------------------------------
C
  150 CONTINUE
C                                       Save the requested color index.
      IC = RBUF(1)
      MAXCOL = MAX (IC, MAXCOL)
      RETURN
C
C--- IFUNC = 16, Flush buffer. -----------------------------------------
C    (Not implemented: ignored.)
C
  160 CONTINUE
      RETURN
C
C--- IFUNC = 17, Read cursor. ------------------------------------------
C    (Not implemented: should not be called.)
C
  170 CONTINUE
      GOTO 900
C
C--- IFUNC = 18, Erase alpha screen. -----------------------------------
C    (Not implemented: ignored.)
C
  180 CONTINUE
      RETURN
C
C--- IFUNC = 19, Set line style. ---------------------------------------
C    (Not implemented: should not be called.)
C
  190 CONTINUE
      GOTO 900
C
C--- IFUNC = 20, Polygon fill. -----------------------------------------
C    (Not implemented: should not be called.)
C
  200 CONTINUE
      GOTO 900
C
C--- IFUNC = 21, Set color representation. -----------------------------
C
  210 CONTINUE
      I = INT (RBUF(1) + 1.5)
      CTAB(1, I) = INT (RBUF(2) * 100.0 + 0.5)
      CTAB(2, I) = INT (RBUF(3) * 100.0 + 0.5)
      CTAB(3, I) = INT (RBUF(4) * 100.0 + 0.5)
      RETURN
C
C--- IFUNC = 22, Set line width. ---------------------------------------
C    (Not implemented: should not be called.)
C
  220 CONTINUE
      GOTO 900
C
C--- IFUNC = 23, Escape ------------------------------------------------
C    (Not implemented: ignored.)
C
  230 CONTINUE
      RETURN
C
C--- IFUNC = 24, Rectangle fill. ---------------------------------------
C    (Not implemented: should not be called.)
C
  240 CONTINUE
      GOTO 900
C
C--- IFUNC = 25, -------------------------------------------------------
C    (Not implemented: should not be called.)
C
  250 CONTINUE
      GOTO 900
C
C--- IFUNC = 26, Line of pixels. ---------------------------------------
C    (Not implemented: should not be called.)
C
  260 CONTINUE
      GOTO 900
C-----------------------------------------------------------------------
      END

C*GRCC00 -- PGPLOT LJ250 driver, draw a colored line
C+
      SUBROUTINE GRCC00 (LINE, RBUF, ICOL, BX, BY, BITMAP)
      IMPLICIT NONE
      INTEGER*4  BX, BY, ICOL, LINE
      BYTE       BITMAP(BX, BY)
      REAL*4     RBUF(4)
C
C Draw a straight line segment from absolute pixel coordinates (RBUF(1),
C RBUF(2)) to (RBUF(3), RBUF(4)).  The line overwrites the previous 
C contents of the bitmap with the current color index.  The line is 
C generated with a Simple Digital Differential Analyser (ref: Newman & 
C Sproull). 
C
C Arguments:
C
C LINE            I I      =0 for dot, =1 for line.
C RBUF(1),RBUF(2) I R      Starting point of line.
C RBUF(3),RBUF(4) I R      Ending point of line.
C ICOL            I I      Color index
C BITMAP        I/O B      (address of) the frame buffer.
C
C-----------------------------------------------------------------------
      INTEGER*4  K, KX, KY, LENGTH
      REAL*4     D, XINC, XP, YINC, YP
C-----------------------------------------------------------------------
      IF (LINE .GT. 0) THEN
         D = MAX (ABS (RBUF(3) - RBUF(1)), ABS (RBUF(4) - RBUF(2)))
         LENGTH = D
         IF (LENGTH .EQ. 0) THEN
            XINC = 0.0
            YINC = 0.0
         ELSE
            XINC = (RBUF(3) - RBUF(1)) / D
            YINC = (RBUF(4) - RBUF(2)) / D
         END IF
      ELSE
         LENGTH = 0
         XINC = 0.0
         YINC = 0.0
      END IF
      XP = RBUF(1) + 0.5
      YP = RBUF(2) + 0.5
      DO K = 0, LENGTH
         KX = XP
         KY = (BY - 1) - INT (YP)
         BITMAP(KX + 1, KY + 1) = ICOL
         XP = XP + XINC
         YP = YP + YINC
      END DO
C-----------------------------------------------------------------------
      RETURN
      END

C*GRCC01 -- PGPLOT LJ250 driver, copy bitmap to Sixel output file
C+
      SUBROUTINE GRCC01 (LUN, BX, BY, BITMAP, NC, HIRES, CTAB)
      IMPLICIT NONE
      LOGICAL  HIRES
      INTEGER  BX, BY, LUN, NC
      BYTE     BITMAP(BX, BY), CTAB(3, 256)
C
C Arguments:
C
C  LUN    (input)  Fortran unit number for output
C  BX, BY (input)  dimensions of BITMAP (BY MUST be a multiple of 6)
C  BITMAP (input)  the bitmap array
C  NC     (input)  the maximum color index used in the bitmap
C  CTAB   (input)  the color table
C-----------------------------------------------------------------------
      BYTE       ESC
      INTEGER*4  BUFF, GRCC03, I, IER, J, K, L, GRGMEM, M
      CHARACTER  BLUE*3, COL*3, GREEN*3, RED*3
      PARAMETER  (ESC = 27)
C-----------------------------------------------------------------------
C                                       Start Sixel graphics mode.
      IF (HIRES) THEN
         WRITE (LUN) ESC, 'P;1;;q"1;1;;-------'
      ELSE
         WRITE (LUN) ESC, 'P;1;8;q"1;1;;---'
      END IF
C                                       Write out the color table.
      DO I = 1, NC + 1
         J = GRCC03 (I - 1)
         K = CTAB(1, I)
         K = GRCC03 (K)
         L = CTAB(2, I)
         L = GRCC03 (L)
         M = CTAB(3, I)
         M = GRCC03 (M)
         WRITE (COL,   '(I3)') I - 1
         WRITE (RED,   '(I3)') CTAB(1, I)
         WRITE (GREEN, '(I3)') CTAB(2, I)
         WRITE (BLUE,  '(I3)') CTAB(3, I)
         WRITE (LUN) '#', COL(4 - J : 3), ';2;', RED(4 - K : 3), ';',
     1                    GREEN(4 - L : 3), ';', BLUE(4 - M : 3)
      END DO
C                                       Allocate a work array.
      IER = GRGMEM (BX * (NC + 1), BUFF)
C                                       Check for an error.
      IF (IER .NE. 1) THEN
         CALL GRGMSG (IER)
         CALL GRQUIT ('Failed to allocate temporary buffer.')
      END IF
C                                       Output the Sixel data.
      CALL GRCC02 (LUN, BX, BY, BITMAP, NC + 1, %VAL (BUFF))
C                                       Turn off Sixel graphics mode.
      WRITE (LUN) ESC, CHAR(92)
C-----------------------------------------------------------------------
      RETURN
      END

C*GRCC02 -- PGPLOT LJ250 driver, output the bitmap
C+
      SUBROUTINE GRCC02 (LUN, BX, BY, BITMAP, NC, SIXEL)
      IMPLICIT NONE
      INTEGER  BX, BY, LUN, NC
      BYTE     BITMAP(BX, BY), SIXEL(BX, NC)
C
C Version 1.0  18-Jun-1989  S. C. Allendorf
C-----------------------------------------------------------------------
      BYTE       CH, QMASK(6)
      LOGICAL    OUTPUT
      INTEGER*4  GRCC03, I, J, K, L, M, N, REPCNT
      CHARACTER  COL*3, OUTLINE*1445, REP*4
      DATA QMASK /'01'X, '02'X, '04'X, '08'X, '10'X, '20'X/
C-----------------------------------------------------------------------
C                                       Output the Sixel data.
      DO I = 1, BY / 6
C                                       Zero out the work array.
         CALL GRCC04 (BX * NC, SIXEL)
C                                       Create a Sixel line.
         DO J = 1, 6
            DO K = 1, BX
               L = BITMAP(K, (I - 1) * 6 + J) + 1
               SIXEL(K, L) = SIXEL(K, L) .OR. QMASK(J)
            END DO
         END DO
C                                       Loop through each color plane.
         DO J = 1, NC
C                                       Add the Sixel offset.
            DO K = 1, BX
               SIXEL(K, J) = SIXEL(K, J) + 63
            END DO
C                                       Initialize some variables for
C                                       run-length encoding.
            K = 1
            L = 1
            M = 1
            OUTPUT = .FALSE.
C                                       Stop if we are at the end of the
C                                       line.
   10       IF (K .LE. BX) THEN
C                                       Find the next character.
               CH = SIXEL(K, J)
C                                       Count the repeats.
   20          IF (M .LE. BX .AND. CH .EQ. SIXEL(M, J)) THEN
                  M = M + 1
                  GOTO 20
               END IF
C                                       Determine the length.
               REPCNT = M - K
C                                       See if there is any printable
C                                       data in this buffer.
               IF (REPCNT .NE. BX .OR. SIXEL(M - 1, J) .NE. 63) THEN
C                                       Mark the buffer as containing
C                                       printable data.
                  OUTPUT = .TRUE.
C                                       Fill the output buffer.               
                  IF (REPCNT .GE. 3) THEN
                     WRITE (REP, '(I4)') REPCNT
                     N = GRCC03 (REPCNT)
                     OUTLINE(L : L) = '!'
                     OUTLINE(L + 1 : L + N) = REP (5 - N : 4)
                     OUTLINE(L + N + 1 : L + N + 1) = 
     1                                            CHAR (SIXEL(M - 1, J))
                     L = L + N + 2
                  ELSE
                     DO N = 0, REPCNT - 1
                        OUTLINE(L + N : L + N) = CHAR (SIXEL(M - 1, J))
                     END DO
                     L = L + REPCNT
                  END IF
               END IF
C                                       Reinitialize the starting point
C                                       for the next string and jump to 
C                                       start of run length encoding. 
               K = M
               GOTO 10
            END IF
C                                       Write out the buffer if there is
C                                       any data in it.
            IF (OUTPUT) THEN
               WRITE (COL, '(I3)') J - 1
               N = GRCC03 (J - 1)
               WRITE (LUN) '#', COL(4 - N : 3), OUTLINE(1 : L - 1), '$'
            END IF
         END DO
C                                       Output a graphics linefeed.
         WRITE (LUN) '-'
      END DO
C------------------------------------------------------------------------
      RETURN
      END

C*GRCC03 -- PGPLOT LJ250 driver, calculate length of an integer
C+
      INTEGER FUNCTION GRCC03 (I)
      INTEGER I
C
C This function calculates the number of digits in a supplied integer.
C
C Arguments:
C
C I               I I      Integer value of number
C GRCC03          O I      Length of printed representation of I
C
C Version 1.0  10-Feb-1988  S. C. Allendorf
C-----------------------------------------------------------------------
      IF (I .GE. 10) THEN
         IF (I .GE. 100) THEN
            IF (I .GE. 1000) THEN
               GRCC03 = 4
            ELSE
               GRCC03 = 3
            END IF
         ELSE
            GRCC03 = 2
         END IF
      ELSE
         GRCC03 = 1
      END IF
C-----------------------------------------------------------------------
      RETURN
      END

C*GRCC04 -- zero fill buffer
C+
      SUBROUTINE GRCC04 (BUFSIZ,BUFFER)
C
C GRPCKG (internal routine): fill a buffer with a given character.
C
C Arguments:
C
C BUFFER (byte array, input): (address of) the buffer.
C BUFSIZ (integer, input): number of bytes in BUFFER.
C-----------------------------------------------------------------------
      INTEGER  BUFSIZ, I
      BYTE     BUFFER(BUFSIZ), FILL
      DATA     FILL /0/
C
      DO 10 I=1,BUFSIZ
          BUFFER(I) = FILL
   10 CONTINUE
      END
