C*LADRIV -- PGPLOT Driver for SIXEL code
C+ (tested on DEC LA50, should in practice work on a LA100 or LN03)
      SUBROUTINE LADRIV (IFUNC, RBUF, NBUF, CHR, LCHR)
      INTEGER IFUNC, NBUF, LCHR
      REAL    RBUF(*)
      CHARACTER*(*) CHR
      BYTE ESC/27/,FF/12/
      LOGICAL ALLERR
C
C PGPLOT driver for LA50 (SIXEL) device.
C
C Version 1.0  - 1988 Dec - B. H. Toby
C=======================================================================
C
C Supported device: DEC LA50
C
C Device type code: /LA50
C
C Default device name: LA50:PGPLOT.LAPLOT
C
C Default view surface dimensions: 9.5 in (horizontal) by  6 in (vertical).
C Maximum view surface dimensions: (none) (horizontal) by 7.9 in (vertical).
C Note: the 11 inch limit is software imposed.
C
C Resolution: 72 (x) x 144 (y) pixels/inch.
C
C Color capability: Color indices 0 (erase, white) and 1 (black) are
C supported. It is not possible to change color representation.
C
C Input capability: None.
C
C File format: Variable-length records, maximum 80 bytes, with
C "list" carriage-control.
C
C Obtaining hardcopy:
C   if the LA50 is connected to the user's VT2xx or VT3xx terminal
C    then the printer can be accessed by sending the file
C      directly to the terminal: use PGPLOT device TT:/LA50
C    or DEFINE PGPLOT_LA50 TT: (be sure to do a SET TERM/FORM if
C    page spacing is important)
C   if the LA50 is attached to a different terminal port, e.g. TXZ99:,
C    which preferably has been set spooled, use PGPLOT device TXZ99:/LA50
C    or DEFINE PGPLOT_LA50 TXZ99: (be sure that TXZ99 has been set
C    /FORM if page spacing is important)
C-----------------------------------------------------------------------
      CHARACTER*(*) TYPE, DEFNAM
      PARAMETER (TYPE='LA50 (DEC LA50 printer)')
      PARAMETER (DEFNAM='PGPLOT_LA50:PGPLOT.LAPLOT')
C
      INTEGER UNIT, IER, IC, BX, BY, NPICT
      INTEGER GRGMEM, GRFMEM
      CHARACTER*10 MSG
C define pointers for dynamically allocated arrays (used with same names)
      INTEGER BITMAP,buf
C-----------------------------------------------------------------------
C
      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), IFUNC
  900 WRITE (MSG,'(I10)') IFUNC
      CALL GRWARN('Unimplemented function in '//TYPE//' device driver:'
     1    //MSG)
      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) = -1
      RBUF(3) = 0
      RBUF(4) = 1140
      RBUF(5) = 0
      RBUF(6) = 1
      NBUF = 6
      RETURN
C
C--- IFUNC = 3, Return device resolution -------------------------------
C
   30 RBUF(1) = 72.0
      RBUF(2) = 144.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 fill,
C    no thick lines)
C
   40 CHR = 'HNNNNNNNNN'
      LCHR = 10
      RETURN
C
C--- IFUNC = 5, Return default file name -------------------------------
C
   50 CHR = DEFNAM
      LCHR = LEN(DEFNAM) + 1
      RETURN
C
C--- IFUNC = 6, Return default physical size of plot -------------------
C
   60 RBUF(1) = 0
      RBUF(2) = 720    !   10 inch
      RBUF(3) = 0
      RBUF(4) = 1008    !   7 inch
      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
      ALLERR = .TRUE.
      CALL GRGLUN(UNIT)
      RBUF(1) = UNIT
      NPICT = 0
      IC = 1
      OPEN (UNIT=UNIT, FILE=CHR(:LCHR), CARRIAGECONTROL='LIST',
     1      DEFAULTFILE=DEFNAM, STATUS='NEW',
     3      FORM='FORMATTED', RECORDTYPE='VARIABLE', IOSTAT=IER)
      IF (IER.NE.0) THEN
          CALL GRWARN('Cannot open output file for '//TYPE//' plot: '//
     1                CHR(:LCHR))
          RBUF(2) = 0
          CALL GRFLUN(UNIT)
          RETURN
      ENDIF
     
      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
      RETURN
     
C
C--- IFUNC=10, Close workstation ---------------------------------------
C
  100 CONTINUE
      CLOSE (UNIT=UNIT, STATUS='KEEP')
      CALL GRFLUN(UNIT)
      RETURN
C
C--- IFUNC=11, Begin picture -------------------------------------------
C
  110 CONTINUE
C Allocate space based on the actual size of the plot, since there is no
C way to signal an error, if it is not possible to allocate the space
C set a flag which prevents plotting
C
C dynamically allocate memory for the plot bitmap
C     -- dimensions of plot buffer
      BX = 2. + (RBUF(1)+5.)/6.    ! (six bits encoded in each byte)
      BY = 2. + RBUF(2)
      IER = GRGMEM(BX*BY, BITMAP)
      IF (IER.NE.1) then
        CALL GRGMSG(IER)
        CALL GRWARN('Failed to allocate plot bitmap.')
        GOTO 92
      ENDIF
C allocate space for a buffer
      IER = GRGMEM(BY, BUF)
      IF (IER.NE.1) then
        CALL GRGMSG(IER)
        CALL GRWARN('Failed to allocate plot buffer.')
        IER = GRFMEM(BX*BY, BITMAP)
        IF (IER.NE.1) CALL GRWARN('Failed to deallocate plot bitmap.')
        GOTO 92
      ENDIF
     
      ALLERR = .FALSE.
      IC = 1
      NPICT = NPICT+1
C%    type *,'Begin picture',NPICT
C initialize the buffer
      CALL GRLA03(BX*BY, %val(BITMAP))
      RETURN
C error in space allocation
92    CALL GRWARN('Plot type has been set to /NULL.')
      CLOSE (UNIT=UNIT, STATUS='DELETE')
      CALL GRFLUN(UNIT)
      RETURN
C
C--- IFUNC=12, Draw line -----------------------------------------------
C
  120 CONTINUE
      IF (ALLERR) RETURN
C note: the following routine is shared with the PRINTRONIX driver
      CALL GRLA02(1, RBUF, IC, BX, BY, %val(BITMAP))
      RETURN
C
C--- IFUNC=13, Draw dot ------------------------------------------------
C
  130 CONTINUE
      IF (ALLERR) RETURN
C note: the following routine is shared with the PRINTRONIX driver
      CALL GRLA02(0, RBUF, IC, BX, BY, %val(BITMAP))
      RETURN
C
C--- IFUNC=14, End picture ---------------------------------------------
C
  140 CONTINUE
C%    type *,'End picture  ',NPICT
C
      IF (ALLERR) RETURN
C Assume the LA50 is attached to a terminal, if so send the terminal
C into CONTROLLER mode while sending the plot. The extra escape sequences
C should not cause any problems if the LA50 is directly connected.
C Put terminal into controller mode, then enter graphics mode.
      IF (NPICT.EQ.1) THEN
        WRITE (UNIT,'(5a)') ESC,'[5i',ESC,'Pq'
      ELSE
C     if this is not the first plot, insert a form feed to advance the page
        WRITE (UNIT,'(5a)') ESC,'[5i',FF,ESC,'Pq'
      ENDIF
      CALL GRLA01(UNIT, BX, BY, %val(BITMAP),%val(BUF))
C leave graphics mode; put terminal into normal mode
      WRITE (UNIT,'(4a)') ESC,CHAR(92),ESC,'[4i'
C deallocate space for bitmap and buffer
      IER = GRFMEM(BX*BY, BITMAP)
      IF (IER.NE.1) THEN
          CALL GRGMSG(IER)
          CALL GRWARN('Failed to deallocate plot bitmap.')
      END IF
      IER = GRFMEM(BY, BUF)
      IF (IER.NE.1) THEN
          CALL GRGMSG(IER)
          CALL GRWARN('Failed to deallocate plot buffer.')
      END IF
      ALLERR = .true.
      RETURN
C
C--- IFUNC=15, Select color index --------------------------------------
C
  150 CONTINUE
      IC = RBUF(1)
      IF (IC.LT.0 .OR. IC.GT.1) THEN
          IC = 1
          RBUF(1) = IC
      END IF
      RETURN
C
C--- IFUNC=16, Flush buffer. -------------------------------------------
C    (Not used.)
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: no alpha screen)
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    (Not implemented: ignored)
C
  210 CONTINUE
      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-----------------------------------------------------------------------
      END
     
C*GRLA01 -- PGPLOT LA50 driver, copy bitmap to output file
C+
      SUBROUTINE GRLA01 (UNIT, BX, BY, BITMAP, BUF)
      INTEGER UNIT, BX, BY
      BYTE BITMAP(BX,BY), BUF(BY)
C
C Arguments:
C  UNIT   (input)  Fortran unit number for output
C  BX, BY (input)  dimensions of BITMAP
C  BITMAP (input)  the bitmap array
C  BUF    (temp.)  buffer used to compress line of print
C-----------------------------------------------------------------------
      INTEGER I, J, K, JMAX, M, ndup, jj, XMAX
C
C Create SIXEL code and write bitmap to LA50, line by line.
C
C   The x-axis is the direction that paper advances, each line
C   that is sent contains six rows of bits
C
C find last non-zero line
      DO K=BX,1,-1
      XMAX = K
        DO J=1,by
          if (BITMAP(K,J) .ne. '00'X) goto 1
      ENDDO
      ENDDO
C  process each line
1     DO K=1,XMAX
C    copy each column of the bitmap to the buffer, reversing the order
C    also find the last non-zero array element
        JMAX = 1
        jj = 0
        DO J=by,1,-1
          jj = jj + 1
          BUF(jj) = BITMAP(K,J)
          IF (BUF(jj) .NE.'00'X) JMAX = jj
        END DO
C compress the line and send it to the printer
        M = 0
        ndup = 1
        do 10 i=1,JMAX
C   can the current character be compressed with the next?
        if (i .ne. JMAX) THEN
C   if the next character the same as current increment the counter and go on
          IF (BUF(i) .eq. BUF(i+1)) then
             ndup = ndup + 1
             goto 10
          ENDIF
        ENDIF
C   The next character is different from current or this is the last character.
C     How many characters are repeated?
       if (ndup .le. 4) then
C       if less than five, don't bother to compress
         do j = 1,ndup
           M = M + 1
           BUF(M) = BUF(i)+63
         enddo
         ndup = 1
         goto 10
       elseif (ndup .le. 9) then
         BUF(M+1) = 33
         encode(1,31,BUF(M+2)) ndup
31         format(i1)
         M = M + 2 + 1
       elseif (ndup .le. 99) then
         BUF(M+1) = 33
         encode(2,32,BUF(M+2)) ndup
32         format(i2)
         M = M + 2 + 2
       elseif (ndup .le. 999) then
         BUF(M+1) = 33
         encode(3,33,BUF(M+2)) ndup
33         format(i3)
         M = M + 2 + 3
       else
         BUF(M+1) = 33
         encode(4,34,BUF(M+2)) ndup
34         format(i4)
         M = M + 2 +  4
       endif
       BUF(M) = BUF(i)+63
       ndup = 1
10     continue
     
      WRITE (UNIT,'(80a1)') (BUF(j),j=1,M),'-'
      END DO
      END
     
C*GRLA02 -- PGPLOT Printronix driver, draw line
C+
      SUBROUTINE GRLA02 (LINE,RBUF,ICOL, BX, BY, BITMAP)
      INTEGER LINE
      REAL RBUF(4)
      INTEGER ICOL, BX, BY
      BYTE BITMAP(BX,BY)
C
C Draw a straight-line segment from absolute pixel coordinates
C (RBUF(1),RBUF(2)) to (RBUF(3),RBUF(4)).  The line either overwrites
C (sets to black) or erases (sets to white) the previous contents
C of the bitmap, depending on the current color index. Setting bits
C is accomplished with a VMS BISB2 instruction, expressed in
C Fortran as .OR.; clearing bits is accomplished with a VMS BICB2
C instruction, expressed in Fortran as .AND..NOT.. The line is
C generated with a Simple Digital Differential Analyser (ref:
C Newman & 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      End point of line.
C ICOL            I I      =0 for erase, =1 for write.
C BITMAP        I/O B      (address of) the frame buffer.
C
C-----------------------------------------------------------------------
      BYTE    QMASK(0:5)
      INTEGER LENGTH, KX, KY, K
      REAL    D, XINC, YINC, XP, YP
      DATA    QMASK /'01'x,'02'x,'04'x,'08'x,'10'x,'20'x/
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.
              YINC = 0.
          ELSE
              XINC = (RBUF(3)-RBUF(1))/D
              YINC = (RBUF(4)-RBUF(2))/D
          END IF
      ELSE
          LENGTH = 0
          XINC = 0.
          YINC = 0.
      END IF
      XP = RBUF(1)+0.5
      YP = RBUF(2)+0.5
      IF (ICOL.NE.0) THEN
          DO K=0,LENGTH
              KX = XP
              KY = (BY-1)-INT(YP)
              BITMAP(KX/6+1,KY+1) = BITMAP(KX/6+1,KY+1) .OR.
     1                              QMASK(MOD(KX,6))
              XP = XP + XINC
              YP = YP + YINC
          END DO
      ELSE
          DO K=0,LENGTH
              KX = XP
              KY = (BY-1)-INT(YP)
              BITMAP(KX/6+1,KY+1) = BITMAP(KX/6+1,KY+1) .AND.
     1                              (.NOT.QMASK(MOD(KX,6)))
              XP = XP + XINC
              YP = YP + YINC
          END DO
      END IF
      END

C*GRLA03 -- zero fill buffer
C+
      SUBROUTINE GRLA03 (BUFSIZ,BUFFER)
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