1C*TODRIV -- PGPLOT Toshiba driver
2C+
3      SUBROUTINE TODRIV (IFUNC, RBUF, NBUF, CHR, LCHR)
4      INTEGER IFUNC, NBUF, LCHR
5      REAL    RBUF(*)
6      CHARACTER*(*) CHR
7C-----------------------------------------------------------------------
8C PGPLOT driver for Toshiba device.
9C-----------------------------------------------------------------------
10C Version 1.0  - 1987 Jun 11 - T. J. Pearson.
11C-----------------------------------------------------------------------
12C
13C Supported device: Toshiba "3-in-one" printer, model P351.
14C
15C Device type code: /TOSHIBA.
16C
17C Default device name: PGPLOT.TOPLOT.
18C
19C Default view surface dimensions: 10.5in (horizontal) by 8.0in
20C (vertical).
21C
22C Resolution: 180 pixels/inch.
23C
24C Color capability: Color indices 0 (erase, white) and 1 (black) are
25C supported. It is not possible to change color representation.
26C
27C Input capability: None.
28C
29C File format: Variable-length records, maximum 132 bytes, with
30C embedded carriage-control characters. A full-page plot occupies
31C 901 512-byte blocks.
32C
33C Obtaining hardcopy: Use the command PRINT/PASSALL.
34C-----------------------------------------------------------------------
35      CHARACTER*(*) TYPE, DEFNAM
36      PARAMETER (TYPE='TOSHIBA (Toshiba P351 "3-in-one" printer)')
37      PARAMETER (DEFNAM='PGPLOT.TOPLOT')
38      BYTE FF
39      PARAMETER (FF=12)
40C
41      INTEGER UNIT, IER, IC, BX, BY, NPICT
42      INTEGER GRGMEM, GRFMEM
43      CHARACTER*10 MSG
44      INTEGER BITMAP, OUTREC
45C-----------------------------------------------------------------------
46C
47      GOTO( 10, 20, 30, 40, 50, 60, 70, 80, 90,100,
48     1     110,120,130,140,150,160,170,180,190,200,
49     2     210,220,230), IFUNC
50  900 WRITE (MSG,'(I10)') IFUNC
51      CALL GRWARN('Unimplemented function in '//TYPE//' device driver:'
52     1    //MSG)
53      NBUF = -1
54      RETURN
55C
56C--- IFUNC = 1, Return device name -------------------------------------
57C
58   10 CHR = TYPE
59      LCHR = LEN(TYPE)
60      RETURN
61C
62C--- IFUNC = 2, Return physical min and max for plot device, and range
63C               of color indices ---------------------------------------
64C
65   20 RBUF(1) = 0
66      RBUF(2) = 1889
67      RBUF(3) = 0
68      RBUF(4) = 1439
69      RBUF(5) = 0
70      RBUF(6) = 1
71      NBUF = 6
72      RETURN
73C
74C--- IFUNC = 3, Return device resolution -------------------------------
75C
76   30 RBUF(1) = 180.0
77      RBUF(2) = 180.0
78      RBUF(3) = 1
79      NBUF = 3
80      RETURN
81C
82C--- IFUNC = 4, Return misc device info --------------------------------
83C    (This device is Hardcopy, No cursor, No dashed lines, No area fill,
84C    no thick lines)
85C
86   40 CHR = 'HNNNNNNNNN'
87      LCHR = 10
88      RETURN
89C
90C--- IFUNC = 5, Return default file name -------------------------------
91C
92   50 CHR = DEFNAM
93      LCHR = LEN(DEFNAM)
94      RETURN
95C
96C--- IFUNC = 6, Return default physical size of plot -------------------
97C
98   60 RBUF(1) = 0
99      RBUF(2) = 1889
100      RBUF(3) = 0
101      RBUF(4) = 1439
102      NBUF = 4
103      RETURN
104C
105C--- IFUNC = 7, Return misc defaults -----------------------------------
106C
107   70 RBUF(1) = 3
108      NBUF=1
109      RETURN
110C
111C--- IFUNC = 8, Select plot --------------------------------------------
112C
113   80 CONTINUE
114      RETURN
115C
116C--- IFUNC = 9, Open workstation ---------------------------------------
117C
118   90 CONTINUE
119C     -- dimensions of plot buffer
120      BX = 1890
121      BY = 240
122      CALL GRGLUN(UNIT)
123      RBUF(1) = UNIT
124      NPICT = 0
125      OPEN (UNIT=UNIT, FILE=CHR(:LCHR), CARRIAGECONTROL='NONE',
126     1      DEFAULTFILE=DEFNAM, STATUS='NEW',
127     2      FORM='UNFORMATTED', RECORDTYPE='VARIABLE', IOSTAT=IER)
128      IF (IER.NE.0) THEN
129          CALL GRWARN('Cannot open output file for '//TYPE//' plot: '//
130     1                CHR(:LCHR))
131          RBUF(2) = 0
132          CALL GRFLUN(UNIT)
133      ELSE
134          INQUIRE (UNIT=UNIT, NAME=CHR)
135          LCHR = LEN(CHR)
136   91     IF (CHR(LCHR:LCHR).EQ.' ') THEN
137              LCHR = LCHR-1
138              GOTO 91
139          END IF
140          RBUF(2) = 1
141      END IF
142      IER = GRGMEM(BX*BY, BITMAP)
143      IF (IER.EQ.1) IER = GRGMEM(4*BX+8, OUTREC)
144      IF (IER.NE.1) THEN
145          CALL GRGMSG(IER)
146          CALL GRWARN('Failed to allocate plot buffer.')
147          RBUF(2) = IER
148          CLOSE (UNIT=UNIT, STATUS='DELETE')
149          CALL GRFLUN(UNIT)
150      END IF
151      RETURN
152C
153C--- IFUNC=10, Close workstation ---------------------------------------
154C
155  100 CONTINUE
156      CLOSE (UNIT=UNIT, STATUS='KEEP')
157      CALL GRFLUN(UNIT)
158      IER = GRFMEM(BX*BY, BITMAP)
159      IF (IER.NE.1) THEN
160          CALL GRGMSG(IER)
161          CALL GRWARN('Failed to deallocate plot buffer.')
162      END IF
163      RETURN
164C
165C--- IFUNC=11, Begin picture -------------------------------------------
166C
167  110 CONTINUE
168      NPICT = NPICT+1
169C%    type *,'Begin picture',NPICT
170      IF (NPICT.GT.1) WRITE (UNIT=UNIT) FF
171      CALL GRTO03(BX*BY, %val(BITMAP))
172      RETURN
173C
174C--- IFUNC=12, Draw line -----------------------------------------------
175C
176  120 CONTINUE
177      CALL GRTO01(1, RBUF, IC, BX, BY, %val(BITMAP))
178      RETURN
179C
180C--- IFUNC=13, Draw dot ------------------------------------------------
181C
182  130 CONTINUE
183      CALL GRTO01(0, RBUF, IC, BX, BY, %val(BITMAP))
184      RETURN
185C
186C--- IFUNC=14, End picture ---------------------------------------------
187C
188  140 CONTINUE
189C%    type *,'End picture  ',NPICT
190      CALL GRTO02(UNIT, BX, BY, %val(BITMAP), 4*BX+8, %val(OUTREC))
191      RETURN
192C
193C--- IFUNC=15, Select color index --------------------------------------
194C
195  150 CONTINUE
196      IC = RBUF(1)
197      IF (IC.LT.0 .OR. IC.GT.1) THEN
198          IC = 1
199          RBUF(1) = IC
200      END IF
201      RETURN
202C
203C--- IFUNC=16, Flush buffer. -------------------------------------------
204C    (Not used.)
205C
206  160 CONTINUE
207      RETURN
208C
209C--- IFUNC=17, Read cursor. --------------------------------------------
210C    (Not implemented: should not be called)
211C
212  170 CONTINUE
213      GOTO 900
214C
215C--- IFUNC=18, Erase alpha screen. -------------------------------------
216C    (Not implemented: no alpha screen)
217C
218  180 CONTINUE
219      RETURN
220C
221C--- IFUNC=19, Set line style. -----------------------------------------
222C    (Not implemented: should not be called)
223C
224  190 CONTINUE
225      GOTO 900
226C
227C--- IFUNC=20, Polygon fill. -------------------------------------------
228C    (Not implemented: should not be called)
229C
230  200 CONTINUE
231      GOTO 900
232C
233C--- IFUNC=21, Set color representation. -------------------------------
234C    (Not implemented: ignored)
235C
236  210 CONTINUE
237      RETURN
238C
239C--- IFUNC=22, Set line width. -----------------------------------------
240C    (Not implemented: should not be called)
241C
242  220 CONTINUE
243      GOTO 900
244C
245C--- IFUNC=23, Escape --------------------------------------------------
246C    (Not implemented: ignored)
247C
248  230 CONTINUE
249      RETURN
250C-----------------------------------------------------------------------
251      END
252
253C*GRTO01 -- PGPLOT Toshiba driver, draw line
254C+
255      SUBROUTINE GRTO01 (LINE,RBUF,ICOL, BX, BY, BITMAP)
256      INTEGER LINE
257      REAL RBUF(4)
258      INTEGER ICOL, BX, BY
259      BYTE BITMAP(BX,BY)
260C
261C Draw a straight-line segment from absolute pixel coordinates
262C (RBUF(1),RBUF(2)) to (RBUF(3),RBUF(4)).  The line either overwrites
263C (sets to black) or erases (sets to white) the previous contents
264C of the bitmap, depending on the current color index. Setting bits
265C is accomplished with a VMS BISB2 instruction, expressed in
266C Fortran as .OR.; clearing bits is accomplished with a VMS BICB2
267C instruction, expressed in Fortran as .AND..NOT.. The line is
268C generated with a Simple Digital Differential Analyser (ref:
269C Newman & Sproull).
270C
271C Arguments:
272C
273C LINE            I I      =0 for dot, =1 for line.
274C RBUF(1),RBUF(2) I R      Starting point of line.
275C RBUF(3),RBUF(4) I R      End point of line.
276C ICOL            I I      =0 for erase, =1 for write.
277C BITMAP        I/O B      (address of) the frame buffer.
278C
279C-----------------------------------------------------------------------
280      BYTE    QMASK(0:5)
281      INTEGER LENGTH, KX, KY, K
282      REAL    D, XINC, YINC, XP, YP
283      DATA    QMASK /'20'x,'10'x,'08'x,'04'x,'02'x,'01'x/
284C
285      IF (LINE.GT.0) THEN
286          D = MAX(ABS(RBUF(3)-RBUF(1)), ABS(RBUF(4)-RBUF(2)))
287          LENGTH = NINT(D)
288          IF (LENGTH.EQ.0) THEN
289              XINC = 0.
290              YINC = 0.
291          ELSE
292              XINC = (RBUF(3)-RBUF(1))/D
293              YINC = (RBUF(4)-RBUF(2))/D
294          END IF
295      ELSE
296          LENGTH = 0
297          XINC = 0.
298          YINC = 0.
299      END IF
300      XP = RBUF(1)+0.5
301      YP = RBUF(2)+0.5
302      IF (ICOL.NE.0) THEN
303          DO K=0,LENGTH
304              KX = XP
305              KY = (6*BY-1)-INT(YP)
306              BITMAP(KX+1,KY/6+1) = BITMAP(KX+1,KY/6+1) .OR.
307     1                              QMASK(MOD(KY,6))
308              XP = XP + XINC
309              YP = YP + YINC
310          END DO
311      ELSE
312          DO K=0,LENGTH
313              KX = XP
314              KY = (6*BY-1)-INT(YP)
315              BITMAP(KX+1,KY/6+1) = BITMAP(KX+1,KY/6+1) .AND.
316     1                              (.NOT.QMASK(MOD(KY,6)))
317              XP = XP + XINC
318              YP = YP + YINC
319          END DO
320      END IF
321      END
322
323C*GRTO02 -- PGPLOT Toshiba driver, copy bitmap to output file
324C+
325      SUBROUTINE GRTO02 (UNIT, BX, BY, BITMAP, BUFSIZ, OUTREC)
326      INTEGER UNIT, BX, BY, BUFSIZ
327      BYTE BITMAP(BX,BY), OUTREC(BUFSIZ)
328C
329C Arguments:
330C  UNIT   (input)  Fortran unit number for output
331C  BX, BY (input)  dimensions of BITMAP
332C  BITMAP (input)  the bitmap array
333C  BUFSIZ (input)  dimension of OUTREC (at least 4*BX+8)
334C  OUTREC (work)   output buffer
335C
336C N.B. BX is the number of columns in the bitmap, and 6*BY is the
337C number of rows; the bitmap must have a multiple of 24 rows (24 rows
338C printed simultaneously by printhead), so BY must be a multiple of 4.
339C
340C The output consists of:
341C    (1) an initialization string (INIT); this sets the vertical spacing
342C increment to 2/15 inch [ESC RS 8] and turns off automatic
343C bidirectional print [ESC >];
344C    (2) the bitmap, expressed as a series of image data transfer
345C commands [ESC ; ...];
346C    (3) a reset string (RESET); this resets vertical spacing [ESC RS 9]
347C and bidirectional printing [ESC <].
348C-----------------------------------------------------------------------
349      BYTE ESC, CR, LF, RS
350      PARAMETER (ESC=27, CR=13, LF=10, RS=30)
351      INTEGER I, J, K, I2
352      BYTE INIT(5), RESET(5)
353      DATA INIT  / ESC, RS, 8, ESC, '>' /
354      DATA RESET / ESC, RS, 9, ESC, '<' /
355      CHARACTER*4 D
356C
357C Check preconditions (internal check).
358C
359      IF (MOD(BY,4).NE.0) CALL GRQUIT('Internal error 1 in TODRIVER')
360      IF (4*BX+8.GT.BUFSIZ) CALL GRQUIT('Internal error 2 in TODRIVER')
361C
362C Write bitmap.
363C
364      WRITE (UNIT=UNIT) INIT
365      OUTREC(1) = ESC
366      OUTREC(2) = ICHAR(';')
367      WRITE (D, '(I4.4)') BX
368      OUTREC(3) = ICHAR(D(1:1))
369      OUTREC(4) = ICHAR(D(2:2))
370      OUTREC(5) = ICHAR(D(3:3))
371      OUTREC(6) = ICHAR(D(4:4))
372      OUTREC(4*BX+7) = CR
373      OUTREC(4*BX+8) = LF
374      DO J=1,BY,4
375          K = 7
376          DO I=1,BX
377              OUTREC(K)   = BITMAP(I,J)
378              OUTREC(K+1) = BITMAP(I,J+1)
379              OUTREC(K+2) = BITMAP(I,J+2)
380              OUTREC(K+3) = BITMAP(I,J+3)
381              K = K+4
382          END DO
383          DO I=1,BUFSIZ,132
384              I2 = MIN(I+131,BUFSIZ)
385              WRITE (UNIT=UNIT) (OUTREC(K),K=I,I2)
386          END DO
387      END DO
388      WRITE (UNIT=UNIT) RESET
389      END
390
391C*GRTO03 -- initialize buffer
392C+
393      SUBROUTINE GRTO03 (BUFSIZ,BUFFER)
394C
395C Arguments:
396C
397C BUFFER (byte array, input): (address of) the buffer.
398C BUFSIZ (integer, input): number of bytes in BUFFER.
399C-----------------------------------------------------------------------
400      INTEGER  BUFSIZ, I
401      BYTE     BUFFER(BUFSIZ), FILL
402      DATA     FILL/'40'X/
403C
404      DO 10 I=1,BUFSIZ
405          BUFFER(I) = FILL
406   10 CONTINUE
407      END
408