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