C*TODRIV -- PGPLOT Toshiba driver
C+
      SUBROUTINE TODRIV (IFUNC, RBUF, NBUF, CHR, LCHR)
      INTEGER IFUNC, NBUF, LCHR
      REAL    RBUF(*)
      CHARACTER*(*) CHR
C-----------------------------------------------------------------------
C PGPLOT driver for Toshiba device.
C-----------------------------------------------------------------------
C Version 1.0  - 1987 Jun 11 - T. J. Pearson.
C-----------------------------------------------------------------------
C
C Supported device: Toshiba "3-in-one" printer, model P351.
C
C Device type code: /TOSHIBA.
C
C Default device name: PGPLOT.TOPLOT.
C
C Default view surface dimensions: 10.5in (horizontal) by 8.0in
C (vertical).
C
C Resolution: 180 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 132 bytes, with
C embedded carriage-control characters. A full-page plot occupies
C 901 512-byte blocks.
C
C Obtaining hardcopy: Use the command PRINT/PASSALL.
C-----------------------------------------------------------------------
      CHARACTER*(*) TYPE, DEFNAM
      PARAMETER (TYPE='TOSHIBA (Toshiba P351 "3-in-one" printer)')
      PARAMETER (DEFNAM='PGPLOT.TOPLOT')
      BYTE FF
      PARAMETER (FF=12)
C
      INTEGER UNIT, IER, IC, BX, BY, NPICT
      INTEGER GRGMEM, GRFMEM
      CHARACTER*10 MSG
      INTEGER BITMAP, OUTREC
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) = 1889
      RBUF(3) = 0
      RBUF(4) = 1439
      RBUF(5) = 0
      RBUF(6) = 1
      NBUF = 6
      RETURN
C
C--- IFUNC = 3, Return device resolution -------------------------------
C
   30 RBUF(1) = 180.0
      RBUF(2) = 180.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)
      RETURN
C
C--- IFUNC = 6, Return default physical size of plot -------------------
C
   60 RBUF(1) = 0
      RBUF(2) = 1889
      RBUF(3) = 0
      RBUF(4) = 1439
      NBUF = 4
      RETURN
C
C--- IFUNC = 7, Return misc defaults -----------------------------------
C
   70 RBUF(1) = 3
      NBUF=1
      RETURN
C
C--- IFUNC = 8, Select plot --------------------------------------------
C
   80 CONTINUE
      RETURN
C
C--- IFUNC = 9, Open workstation ---------------------------------------
C
   90 CONTINUE
C     -- dimensions of plot buffer
      BX = 1890
      BY = 240
      CALL GRGLUN(UNIT)
      RBUF(1) = UNIT
      NPICT = 0
      OPEN (UNIT=UNIT, FILE=CHR(:LCHR), CARRIAGECONTROL='NONE',
     1      DEFAULTFILE=DEFNAM, STATUS='NEW',
     2      FORM='UNFORMATTED', 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)
      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
      IER = GRGMEM(BX*BY, BITMAP)
      IF (IER.EQ.1) IER = GRGMEM(4*BX+8, OUTREC)
      IF (IER.NE.1) THEN
          CALL GRGMSG(IER)
          CALL GRWARN('Failed to allocate plot buffer.')
          RBUF(2) = IER
          CLOSE (UNIT=UNIT, STATUS='DELETE')
          CALL GRFLUN(UNIT)
      END IF
      RETURN
C
C--- IFUNC=10, Close workstation ---------------------------------------
C
  100 CONTINUE
      CLOSE (UNIT=UNIT, STATUS='KEEP')
      CALL GRFLUN(UNIT)
      IER = GRFMEM(BX*BY, BITMAP)
      IF (IER.NE.1) THEN
          CALL GRGMSG(IER)
          CALL GRWARN('Failed to deallocate plot buffer.')
      END IF
      RETURN
C
C--- IFUNC=11, Begin picture -------------------------------------------
C
  110 CONTINUE
      NPICT = NPICT+1
C%    type *,'Begin picture',NPICT
      IF (NPICT.GT.1) WRITE (UNIT=UNIT) FF
      CALL GRTO03(BX*BY, %val(BITMAP))
      RETURN
C
C--- IFUNC=12, Draw line -----------------------------------------------
C
  120 CONTINUE
      CALL GRTO01(1, RBUF, IC, BX, BY, %val(BITMAP))
      RETURN
C
C--- IFUNC=13, Draw dot ------------------------------------------------
C
  130 CONTINUE
      CALL GRTO01(0, RBUF, IC, BX, BY, %val(BITMAP))
      RETURN
C
C--- IFUNC=14, End picture ---------------------------------------------
C
  140 CONTINUE
C%    type *,'End picture  ',NPICT
      CALL GRTO02(UNIT, BX, BY, %val(BITMAP), 4*BX+8, %val(OUTREC))
      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*GRTO01 -- PGPLOT Toshiba driver, draw line
C+
      SUBROUTINE GRTO01 (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 /'20'x,'10'x,'08'x,'04'x,'02'x,'01'x/
C
      IF (LINE.GT.0) THEN
          D = MAX(ABS(RBUF(3)-RBUF(1)), ABS(RBUF(4)-RBUF(2)))
          LENGTH = NINT(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 = (6*BY-1)-INT(YP)
              BITMAP(KX+1,KY/6+1) = BITMAP(KX+1,KY/6+1) .OR. 
     1                              QMASK(MOD(KY,6))
              XP = XP + XINC
              YP = YP + YINC
          END DO
      ELSE
          DO K=0,LENGTH
              KX = XP
              KY = (6*BY-1)-INT(YP)
              BITMAP(KX+1,KY/6+1) = BITMAP(KX+1,KY/6+1) .AND.
     1                              (.NOT.QMASK(MOD(KY,6)))
              XP = XP + XINC
              YP = YP + YINC
          END DO
      END IF
      END

C*GRTO02 -- PGPLOT Toshiba driver, copy bitmap to output file
C+
      SUBROUTINE GRTO02 (UNIT, BX, BY, BITMAP, BUFSIZ, OUTREC)
      INTEGER UNIT, BX, BY, BUFSIZ
      BYTE BITMAP(BX,BY), OUTREC(BUFSIZ)
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  BUFSIZ (input)  dimension of OUTREC (at least 4*BX+8)
C  OUTREC (work)   output buffer
C
C N.B. BX is the number of columns in the bitmap, and 6*BY is the
C number of rows; the bitmap must have a multiple of 24 rows (24 rows
C printed simultaneously by printhead), so BY must be a multiple of 4.
C
C The output consists of:
C    (1) an initialization string (INIT); this sets the vertical spacing
C increment to 2/15 inch [ESC RS 8] and turns off automatic 
C bidirectional print [ESC >];
C    (2) the bitmap, expressed as a series of image data transfer
C commands [ESC ; ...];
C    (3) a reset string (RESET); this resets vertical spacing [ESC RS 9]
C and bidirectional printing [ESC <].
C-----------------------------------------------------------------------
      BYTE ESC, CR, LF, RS
      PARAMETER (ESC=27, CR=13, LF=10, RS=30)
      INTEGER I, J, K, I2
      BYTE INIT(5), RESET(5)
      DATA INIT  / ESC, RS, 8, ESC, '>' /
      DATA RESET / ESC, RS, 9, ESC, '<' /
      CHARACTER*4 D
C
C Check preconditions (internal check).
C
      IF (MOD(BY,4).NE.0) CALL GRQUIT('Internal error 1 in TODRIVER')
      IF (4*BX+8.GT.BUFSIZ) CALL GRQUIT('Internal error 2 in TODRIVER')
C
C Write bitmap.
C
      WRITE (UNIT=UNIT) INIT
      OUTREC(1) = ESC
      OUTREC(2) = ICHAR(';')
      WRITE (D, '(I4.4)') BX
      OUTREC(3) = ICHAR(D(1:1))
      OUTREC(4) = ICHAR(D(2:2))
      OUTREC(5) = ICHAR(D(3:3))
      OUTREC(6) = ICHAR(D(4:4))
      OUTREC(4*BX+7) = CR
      OUTREC(4*BX+8) = LF
      DO J=1,BY,4
          K = 7
          DO I=1,BX
              OUTREC(K)   = BITMAP(I,J)
              OUTREC(K+1) = BITMAP(I,J+1)
              OUTREC(K+2) = BITMAP(I,J+2)
              OUTREC(K+3) = BITMAP(I,J+3)
              K = K+4
          END DO
          DO I=1,BUFSIZ,132
              I2 = MIN(I+131,BUFSIZ)
              WRITE (UNIT=UNIT) (OUTREC(K),K=I,I2)
          END DO
      END DO
      WRITE (UNIT=UNIT) RESET
      END

C*GRTO03 -- initialize buffer
C+
      SUBROUTINE GRTO03 (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/'40'X/
C
      DO 10 I=1,BUFSIZ
          BUFFER(I) = FILL
   10 CONTINUE
      END