1C*LJDRIV -- PGPLOT Hewlett Packard LaserJet driver
2C+
3      SUBROUTINE LJDRIV (IFUNC, RBUF, NBUF, CHR, LCHR)
4      INTEGER IFUNC, NBUF, LCHR
5      REAL    RBUF(*)
6      CHARACTER*(*) CHR
7C
8C PGPLOT driver for Hewlett packard Laserjet device.
9C
10C Version 1.0  - 1989 Apr 09 - S. C. Allendorf
11C                              Combined all drivers into one driver that
12C                              uses a logical name to choose the format.
13C TJP 1997-Jul-24: replaced ENCODE with WRITE, but still VMS-specific.
14C=======================================================================
15C
16C Supported device: Hewlett Packard LaserJet, LaserJet+, or LaserJet II.
17C
18C Device type code: /LJnn where nn is a number 1 - NDEV inclusive.
19C
20C Default device name: PGPLOT.LJPLT.
21C
22C Default view surface dimensions: Depends on which version of the driver
23C is chosen via the logical name PGPLOT_LJ_MODE.
24C
25C       Driver  Equivalence         Size (H x V)
26C       ------  -----------     ---------------------
27C        LJ01       LHOR        10.50 by  8.00 inches
28C        LJ02       PHOR         8.00 by 10.50 inches
29C        LJ03       PHOT         8.00 by 10.50 inches
30C        LJ04       LHBR         6.54 by  4.91 inches
31C        LJ05       PHBS         5.65 by  5.65 inches
32C        LJ06       LMBR        10.50 by  8.00 inches
33C        LJ07       PMBR         8.00 by 10.50 inches
34C        LJ08       PMBS         4.48 by  4.48 inches
35C        LJ09       PLBS         6.00 by  6.00 inches
36C
37C Resolution: Depends on which version of the driver is chosen via the
38C logical name PGPLOT_LJ_MODE.
39C
40C       Driver  Equivalence     Resolution
41C       ------  -----------     ----------
42C        LJ01       LHOR          300 DPI
43C        LJ02       PHOR          300 DPI
44C        LJ03       PHOT          300 DPI
45C        LJ04       LHBR          300 DPI
46C        LJ05       PHBS          300 DPI
47C        LJ06       LMBR          150 DPI
48C        LJ07       PMBR          150 DPI
49C        LJ08       PMBS          150 DPI
50C        LJ09       PLBS          100 DPI
51C
52C Color capability: Color indices 0 (erase, white) and 1 (black) are
53C supported. It is not possible to change color representation.
54C
55C Input capability: None.
56C
57C File format: See the LaserJet Printer Technical Reference Manual for
58C details of the file format.
59C
60C Obtaining hardcopy: Use the command PRINT/PASSALL.
61C-----------------------------------------------------------------------
62C
63C To choose one of the specific LaserJet drivers, you must execute a DCL
64C command of the following form before executing your program:
65C
66C $ DEFINE PGPLOT_LJ_MODE LJnn
67C
68C where nn is a number 1 - NDEV inclusive.  You may also use one of the
69C equivalent names listed above.  These equivalent names are an attempt
70C to make the driver names make sense.  They are decoded as follows:
71C
72C    1st character: P for protrait orientation or
73C                   L for landscape orientation.
74C    2nd character: H for high resolution (300 dpi) or
75C                   M for medium resolution (150 dpi) or
76C                   L for low resolution (100 dpi).
77C    3rd character: B for a straight bitmap dump (subroutine GRLJ01) or
78C                   O for an optimized bitmap dump (subroutine GRLJ02).
79C    4th character: R for a rectangular view surface or
80C                   S for a square view surface.
81C
82C A few notes are in order.  First, not all of the possible combinations
83C above are supported (currently).  The driver that goes by the name of
84C PHOT is a driver that puts out bitmaps suitable for inclusion in TeX
85C output if you are using the Arbortext DVIHP program.  The only drivers
86C that will work with unexpanded LaserJet are LJ08 and LJ09.  The other
87C seven drivers require a LaserJet Plus or LaserJet II.  Finally, do NOT
88C attempt to send grayscale plots to the drivers that use the optimized
89C bitmap dumps.  Terrible things will happen.
90C
91C If you add a driver to this file, please try to use the naming
92C convention outlined above and send me a copy of the revisions.  I may
93C be reached at sca@iowa.physics.uiowa.edu on the Internet or IOWA::SCA
94C on SPAN.
95C-----------------------------------------------------------------------
96C                                       This is the number of currently
97C                                       installed devices.
98      INTEGER*4  NDEV
99      PARAMETER  (NDEV = 9)
100C
101      BYTE       ESC, FF
102      LOGICAL    BITMAP(NDEV), INIT, PORTRAIT(NDEV), TEX
103      INTEGER    BUFFER, BX, BY, DEVICE, HC(NDEV), I, IC, IER
104      INTEGER    GRFMEM, GRGMEM, LUN, NPICT
105      INTEGER    VC(NDEV)
106      REAL       MAXX(NDEV), MAXY(NDEV), RESOL(NDEV), XBUF(4)
107      REAL       XMAX, YMAX
108      CHARACTER  ALTTYP(NDEV)*3, DEFNAM*12, MODE*20, MSG*10
109      CHARACTER  TYPE(NDEV)*4
110      PARAMETER  (ESC = 27)
111      PARAMETER  (FF = 12)
112      PARAMETER  (DEFNAM = 'pgplot.ljplt')
113      SAVE
114      DATA INIT  /.TRUE./
115C                                       These are the NDEV sets of
116C                                       device characteristics.
117      DATA BITMAP   /.FALSE., .FALSE., .FALSE.,  .TRUE.,  .TRUE.,
118     1                .TRUE.,  .TRUE.,  .TRUE.,  .TRUE./
119      DATA PORTRAIT /.FALSE.,  .TRUE.,  .TRUE., .FALSE.,  .TRUE.,
120     1               .FALSE.,  .TRUE.,  .TRUE.,  .TRUE./
121      DATA HC       /      0,       0,       0,    1139,     878,
122     1                     0,       0,    1300,     754/
123      DATA VC       /      0,       0,       0,    1411,    1743,
124     1                     0,       0,    2156,    1605/
125      DATA MAXX     / 3149.0,  2399.0,  2399.0,  1962.0,  1695.0,
126     1                1574.0,  1199.0,   671.0,   599.0/
127      DATA MAXY     / 2399.0,  3149.0,  3149.0,  1471.0,  1695.0,
128     1                1199.0,  1574.0,   671.0,   599.0/
129      DATA RESOL    /  300.0,   300.0,   300.0,   300.0,   300.0,
130     1                 150.0,   150.0,   150.0,   100.0/
131C                                       These are around only for
132C                                       (pre)historical reasons.
133      DATA ALTTYP   /  'HPN',   'HPV',   'TEX',   'HPR',   'HPE',
134     1                 'HPF',   'HPT',   'HPH',   'HPM'/
135      DATA TYPE     / 'LHOR',  'PHOR',  'PHOT',  'LHBR',  'PHBS',
136     1                'LMBR',  'PMBR',  'PMBS',  'PLBS'/
137C-----------------------------------------------------------------------
138C                                       First time, translate logical
139C                                       name PGPLOT_LJ_MODE and set
140C                                       device accordingly.
141      IF (INIT) THEN
142         CALL GRGENV ('LJ_MODE', MODE, I)
143         DO 1 I = 1, NDEV
144            WRITE (MSG, '(A2, I2.2)') 'LJ', I
145            IF (MODE(1:4) .EQ. TYPE(I) .OR.
146     1          MODE(1:3) .EQ. ALTTYP(I) .OR.
147     2          MODE(1:4) .EQ. MSG(1:4)) THEN
148               DEVICE = I
149               GOTO 2
150            END IF
151    1    CONTINUE
152C                                       If no match, choose LHBR
153         DEVICE = 4
154    2    INIT = .FALSE.
155C                                       See if user has chosen the
156C                                       TeX plotfile format.
157         TEX = .FALSE.
158         IF (DEVICE .EQ. 3) TEX = .TRUE.
159      END IF
160C                                       Branch on opcode.
161      GOTO ( 10,  20,  30,  40,  50,  60,  70,  80,  90, 100,
162     1      110, 120, 130, 140, 150, 160, 170, 180, 190, 200,
163     2      210, 220, 230, 240, 250, 260), IFUNC
164C                                       Signal an error.
165  900 WRITE (MSG, '(I10)') IFUNC
166      CALL GRWARN ('Unimplemented function in LaserJet device driver:'
167     1             // MSG)
168      NBUF = -1
169      RETURN
170C
171C--- IFUNC = 1, Return device name -------------------------------------
172C
173   10 CONTINUE
174      WRITE (MSG, '(I2.2)') DEVICE
175      CHR = 'LJ' // MSG(1 : 2) // ' (' // TYPE(DEVICE) // ')'
176      NBUF = 0
177      LCHR = 11
178      RETURN
179C
180C--- IFUNC = 2, Return physical min and max for plot device, and range
181C               of color indices ---------------------------------------
182C
183   20 CONTINUE
184      RBUF(1) = 0.0
185      RBUF(2) = MAXX(DEVICE)
186      RBUF(3) = 0.0
187      RBUF(4) = MAXY(DEVICE)
188      RBUF(5) = 0.0
189      RBUF(6) = 1.0
190      NBUF = 6
191      LCHR = 0
192      RETURN
193C
194C--- IFUNC = 3, Return device resolution -------------------------------
195C
196   30 CONTINUE
197      RBUF(1) = RESOL(DEVICE)
198      RBUF(2) = RESOL(DEVICE)
199      RBUF(3) = 1.0
200      NBUF = 3
201      LCHR = 0
202      RETURN
203C
204C--- IFUNC = 4, Return misc device info --------------------------------
205C    (This device is Hardcopy, No cursor, No dashed lines, No area fill,
206C    no thick lines)
207C
208   40 CONTINUE
209      CHR = 'HNNNNNNNNN'
210      NBUF = 0
211      LCHR = 10
212      RETURN
213C
214C--- IFUNC = 5, Return default file name -------------------------------
215C
216   50 CONTINUE
217      CHR = DEFNAM
218      NBUF = 0
219      LCHR = LEN(DEFNAM)
220      RETURN
221C
222C--- IFUNC = 6, Return default physical size of plot -------------------
223C
224   60 CONTINUE
225      RBUF(1) = 0.0
226      RBUF(2) = MAXX(DEVICE)
227      RBUF(3) = 0.0
228      RBUF(4) = MAXY(DEVICE)
229      NBUF = 4
230      LCHR = 0
231      RETURN
232C
233C--- IFUNC = 7, Return misc defaults -----------------------------------
234C
235   70 CONTINUE
236      IF (RESOL(DEVICE) .EQ. 300.0) THEN
237         RBUF(1) = 3.0
238      ELSE IF (RESOL(DEVICE) .EQ. 150.0) THEN
239         RBUF(1) = 2.0
240      ELSE
241         RBUF(1) = 1.0
242      END IF
243      NBUF = 1
244      LCHR = 0
245      RETURN
246C
247C--- IFUNC = 8, Select plot --------------------------------------------
248C
249   80 CONTINUE
250      RETURN
251C
252C--- IFUNC = 9, Open workstation ---------------------------------------
253C
254   90 CONTINUE
255C                                       Assume success.
256      RBUF(2) = 1.0
257C                                       Obtain a logical unit number.
258      CALL GRGLUN (LUN)
259C                                       Check for an error.
260      IF (LUN .EQ. -1) THEN
261          CALL GRWARN ('Cannot allocate a logical unit.')
262          RBUF(2) = 0
263          RETURN
264      ELSE
265         RBUF(1) = LUN
266      END IF
267C                                       Open the output file.
268      OPEN (UNIT = LUN, FILE = CHR(:LCHR), CARRIAGECONTROL = 'NONE',
269     1      DEFAULTFILE = DEFNAM, STATUS = 'NEW',
270     2      RECL = 128, FORM = 'UNFORMATTED', RECORDTYPE = 'VARIABLE',
271     3      IOSTAT = IER)
272C                                       Check for an error and cleanup if
273C                                       one occurred.
274      IF (IER .NE. 0) THEN
275          CALL GRWARN ('Cannot open output file for LaserJet plot: ' //
276     1                 CHR(:LCHR))
277          RBUF(2) = 0
278          CALL GRFLUN (LUN)
279          RETURN
280      ELSE
281C                                       Get the full file specification
282C                                       and calculate the length of the
283C                                       string
284          INQUIRE (UNIT = LUN, NAME = CHR)
285          LCHR = LEN (CHR)
286   91     IF (CHR (LCHR:LCHR) .EQ. ' ') THEN
287              LCHR = LCHR - 1
288              GOTO 91
289          END IF
290      END IF
291C                                       Initialize the plot file.
292
293      IF (.NOT. TEX) THEN
294C                                       Choose portrait orientation
295         WRITE (LUN) ESC, '&l0O'
296C                                       Set horizontal and vertical
297C                                       spacing
298         IF (BITMAP(DEVICE)) THEN
299            WRITE (LUN) ESC, '&l6C'
300            WRITE (LUN) ESC, '&k10H'
301         ELSE
302            WRITE (LUN) ESC, '&k.4H'
303            WRITE (LUN) ESC, '&l.16C'
304         END IF
305         WRITE (LUN) ESC, '&l2E'
306      END IF
307C                                       Set the graphics resolution
308      WRITE (MSG, '(I3)') INT (RESOL(DEVICE))
309      WRITE (LUN) ESC, '*t', MSG(1:3), 'R'
310C                                       Initialize the page counter.
311      NPICT = 0
312      RETURN
313C
314C--- IFUNC = 10, Close workstation -------------------------------------
315C
316  100 CONTINUE
317      IF (BITMAP(DEVICE)) THEN
318         WRITE (LUN) ESC, '&l8C'
319      ELSE IF (.NOT. TEX) THEN
320         WRITE (LUN) ESC, '&l6D'
321         WRITE (LUN) ESC, '&k10H'
322         WRITE (LUN) ESC, '&l2E'
323      END IF
324C                                       Close the file.
325      CLOSE (LUN, STATUS = 'KEEP')
326C                                       Deallocate the logical unit.
327      CALL GRFLUN (LUN)
328C
329      RETURN
330C
331C--- IFUNC = 11, Begin picture -----------------------------------------
332C
333  110 CONTINUE
334C                                       Set the bitmap size.
335      XMAX = RBUF(1)
336      YMAX = RBUF(2)
337C                                       Calculate the dimensions of the
338C                                       plot buffer.
339      IF (PORTRAIT(DEVICE)) THEN
340         BX = INT (XMAX) / 8 + 1
341         BY = INT (YMAX) + 1
342      ELSE
343         BX = INT (YMAX) / 8 + 1
344         BY = INT (XMAX) + 1
345      END IF
346C                                       Allocate a plot buffer.
347      IER = GRGMEM (BX * BY, BUFFER)
348C                                       Check for error and clean up
349C                                       if one was found.
350      IF (IER .NE. 1) THEN
351          CALL GRGMSG (IER)
352          CALL GRQUIT ('Failed to allocate a plot buffer.')
353      END IF
354C                                       Increment the page number.
355      NPICT = NPICT + 1
356C                                       Eject the page from the printer.
357      IF (NPICT .GT. 1) WRITE (LUN) FF
358C                                       Set the cursor position and
359C                                       start graphics mode.
360      IF (BITMAP(DEVICE)) THEN
361         WRITE (MSG(1:4), '(I4.4)') HC(DEVICE)
362         WRITE (MSG(5:8), '(I4.4)') VC(DEVICE)
363         WRITE (LUN) ESC, '&a', MSG(1:4), 'h', MSG(5:8), 'V'
364      END IF
365C                                       Zero out the plot buffer.
366      CALL GRLJ04 (BX * BY, %VAL(BUFFER))
367      RETURN
368C
369C--- IFUNC = 12, Draw line ---------------------------------------------
370C
371  120 CONTINUE
372C                                       Apply any needed tranformation.
373      IF (PORTRAIT(DEVICE)) THEN
374         DO 125 I = 1, 4
375            XBUF(I) = RBUF(I)
376  125    CONTINUE
377      ELSE
378         XBUF(1) = RBUF(2)
379         XBUF(2) = XMAX - RBUF(1)
380         XBUF(3) = RBUF(4)
381         XBUF(4) = XMAX - RBUF(3)
382      END IF
383C                                       Draw the point into the bitmap.
384      CALL GRLJ00 (1, XBUF, IC, BX, BY, %VAL (BUFFER))
385      RETURN
386C
387C--- IFUNC = 13, Draw dot ----------------------------------------------
388C
389  130 CONTINUE
390C                                       Apply any needed tranformation.
391      IF (PORTRAIT(DEVICE)) THEN
392         DO 135 I = 1, 2
393            XBUF(I) = RBUF(I)
394  135    CONTINUE
395      ELSE
396         XBUF(1) = RBUF(2)
397         XBUF(2) = XMAX - RBUF(1)
398      END IF
399C                                       Draw the point into the bitmap.
400      CALL GRLJ00 (0, XBUF, IC, BX, BY, %VAL(BUFFER))
401      RETURN
402C
403C--- IFUNC = 14, End picture -------------------------------------------
404C
405  140 CONTINUE
406C                                       Write out the bitmap.
407      IF (BITMAP(DEVICE)) THEN
408         CALL GRLJ01 (LUN, BX, BY, %VAL (BUFFER))
409      ELSE
410         CALL GRLJ02 (LUN, BX, BY, %VAL (BUFFER), TEX)
411      END IF
412C                                       Deallocate the plot buffer.
413      IER = GRFMEM (BX * BY, BUFFER)
414C                                       Check for an error.
415      IF (IER .NE. 1) THEN
416          CALL GRGMSG (IER)
417          CALL GRWARN ('Failed to deallocate plot buffer.')
418      END IF
419      RETURN
420C
421C--- IFUNC = 15, Select color index ------------------------------------
422C
423  150 CONTINUE
424C                                       Save the requested color index.
425      IC = RBUF(1)
426C                                       If out of range set to black.
427      IF (IC .LT. 0 .OR. IC .GT. 1) THEN
428          IC = 1
429          RBUF(1) = IC
430      END IF
431      RETURN
432C
433C--- IFUNC = 16, Flush buffer. -----------------------------------------
434C    (Not implemented: ignored.)
435C
436  160 CONTINUE
437      RETURN
438C
439C--- IFUNC = 17, Read cursor. ------------------------------------------
440C    (Not implemented: should not be called.)
441C
442  170 CONTINUE
443      GOTO 900
444C
445C--- IFUNC = 18, Erase alpha screen. -----------------------------------
446C    (Not implemented: ignored.)
447C
448  180 CONTINUE
449      RETURN
450C
451C--- IFUNC = 19, Set line style. ---------------------------------------
452C    (Not implemented: should not be called.)
453C
454  190 CONTINUE
455      GOTO 900
456C
457C--- IFUNC = 20, Polygon fill. -----------------------------------------
458C    (Not implemented: should not be called.)
459C
460  200 CONTINUE
461      GOTO 900
462C
463C--- IFUNC = 21, Set color representation. -----------------------------
464C    (Not implemented: ignored.)
465C
466  210 CONTINUE
467      RETURN
468C
469C--- IFUNC = 22, Set line width. ---------------------------------------
470C    (Not implemented: should not be called.)
471C
472  220 CONTINUE
473      GOTO 900
474C
475C--- IFUNC = 23, Escape ------------------------------------------------
476C    (Not implemented: ignored.)
477C
478  230 CONTINUE
479      RETURN
480C
481C--- IFUNC = 24, Rectangle fill. ---------------------------------------
482C    (Not implemented: should not be called.)
483C
484  240 CONTINUE
485      GOTO 900
486C
487C--- IFUNC = 25, -------------------------------------------------------
488C    (Not implemented: should not be called.)
489C
490  250 CONTINUE
491      GOTO 900
492C
493C--- IFUNC = 26, Line of pixels. ---------------------------------------
494C    (Not implemented: should not be called.)
495C
496  260 CONTINUE
497      GOTO 900
498C-----------------------------------------------------------------------
499      END
500
501C*GRLJ00 -- PGPLOT Hewlett Packard LaserJet driver, draw line
502C+
503      SUBROUTINE GRLJ00 (LINE, RBUF, ICOL, BX, BY, BITMAP)
504      INTEGER    BX, BY, ICOL, LINE
505      BYTE       BITMAP(BX, BY)
506      REAL       RBUF(4)
507C
508C Draw a straight line segment from absolute pixel coordinates (RBUF(1),
509C RBUF(2)) to (RBUF(3), RBUF(4)).  The line either overwrites (sets to
510C black) or erases (sets to white) the previous contents of the bitmap,
511C depending on the current color index. Setting bits is accomplished
512C with a VMS BISB2 instruction, expressed in Fortran as .OR.; clearing
513C bits is accomplished with a VMS BICB2 instruction, expressed in
514C Fortran as .AND. .NOT.. The line is generated with a Simple Digital
515C Differential Analyser (ref: Newman & Sproull).
516C
517C Arguments:
518C
519C LINE            I I      =0 for dot, =1 for line.
520C RBUF(1),RBUF(2) I R      Starting point of line.
521C RBUF(3),RBUF(4) I R      Ending point of line.
522C ICOL            I I      =0 for erase, =1 for write.
523C BITMAP        I/O B      (address of) the frame buffer.
524C
525C-----------------------------------------------------------------------
526      BYTE       QMASK(0 : 7)
527      INTEGER    K, KX, KY, LENGTH
528      REAL       D, XINC, XP, YINC, YP
529      DATA       QMASK /'80'X, '40'X, '20'X, '10'X,
530     1                  '08'X, '04'X, '02'X, '01'X/
531C-----------------------------------------------------------------------
532      IF (LINE .GT. 0) THEN
533         D = MAX (ABS (RBUF(3) - RBUF(1)), ABS (RBUF(4) - RBUF(2)))
534         LENGTH = D
535         IF (LENGTH .EQ. 0) THEN
536            XINC = 0.0
537            YINC = 0.0
538         ELSE
539            XINC = (RBUF(3) - RBUF(1)) / D
540            YINC = (RBUF(4) - RBUF(2)) / D
541         END IF
542      ELSE
543         LENGTH = 0
544         XINC = 0.0
545         YINC = 0.0
546      END IF
547      XP = RBUF(1) + 0.5
548      YP = RBUF(2) + 0.5
549      IF (ICOL .NE. 0) THEN
550         DO K = 0, LENGTH
551            KX = XP
552            KY = (BY - 1) - INT (YP)
553            BITMAP(KX / 8 + 1, KY + 1) = BITMAP(KX / 8 + 1, KY + 1) .OR.
554     1                                         QMASK(MOD (KX, 8))
555            XP = XP + XINC
556            YP = YP + YINC
557         END DO
558      ELSE
559         DO K = 0,LENGTH
560            KX = XP
561            KY = (BY - 1) - INT (YP)
562            BITMAP(KX / 8 + 1, KY + 1) = BITMAP(KX / 8 + 1, KY + 1)
563     1                                  .AND. (.NOT. QMASK(MOD (KX, 8)))
564            XP = XP + XINC
565            YP = YP + YINC
566         END DO
567      END IF
568C-----------------------------------------------------------------------
569      RETURN
570      END
571
572C*GRLJ01 -- PGPLOT LaserJet driver, copy bitmap to output file
573C+
574      SUBROUTINE GRLJ01 (LUN, BX, BY, BITMAP)
575      INTEGER  BX, BY, LUN
576      BYTE     BITMAP(BX, BY)
577C
578C Arguments:
579C
580C  LUN    (input)  Fortran unit number for output
581C  BX, BY (input)  dimensions of BITMAP
582C  BITMAP (input)  the bitmap array
583C-----------------------------------------------------------------------
584      BYTE      ESC
585      INTEGER   I, J, K
586      CHARACTER KSTR*3
587      PARAMETER (ESC = 27)
588C-----------------------------------------------------------------------
589C                                       Start graphics mode
590      WRITE (LUN) ESC, '*r1A'
591C                                       Loop through bitmap
592      DO J = 1, BY
593C                                       Search for last non-NUL
594         DO K = BX, 2, -1
595            IF (BITMAP(K, J) .NE. '00'X) GO TO 10
596         END DO
597C                                       Guarantee that we know what K
598C                                       is after loop.
599C                                       (Remember FORTRAN IV!?)
600         K = 1
601C                                       Encode length of line
602   10    WRITE (KSTR, '(I3.3)') K
603C                                       Write out the raster line
604         WRITE (LUN) ESC, '*b', KSTR, 'W', (BITMAP(I, J), I = 1, K)
605      END DO
606C                                       Turn off graphics mode.
607      WRITE (LUN) ESC, '*rB'
608C-----------------------------------------------------------------------
609      RETURN
610      END
611
612C*GRLJ02 -- PGPLOT LaserJet+ driver, dump bitmap to device
613C+
614      SUBROUTINE GRLJ02 (LUN, BX, BY, BITMAP, TEX)
615      LOGICAL TEX
616      INTEGER LUN, BX, BY
617      BYTE BITMAP(BX, BY)
618C
619C Output raster for this page.  This routine has been optimised to
620C minimize the memory usage in the LaserJet.  This sometimes leads to a
621C larger file than if a straight bitmap approach had been used.
622C
623C NOTE:  This subroutine is a kludge to make a 512K LaserJet produce
624C        full page plots at 300dpi.  It will not always produce the plot
625C        on one page.  If you overrun the memory restrictions, two pages
626C        will be printed, each containing parts of the plot.  One must
627C        then resort to cut and paste techniques to restore the plot.
628C        Most simple line graphs do not come close to the memory limit,
629C        but sometimes a messy contour plot will.  DON'T EVEN THINK
630C        ABOUT SENDING A GREYSCALE TO THIS SUBROUTINE!
631C
632C Arguments:
633C
634C LUN             I I      Logical unit number of output file
635C BX, BY          I I      Dimensions of frame buffer
636C BITMAP        I/O B      (address of) the frame buffer.
637C
638C Version 1.0  03-Sep-1986  S. C. Allendorf
639C Version 2.0  08-Dec-1986  S. C. Allendorf  Use relative positioning
640C Version 2.1  28-Dec-1986  S. C. Allendorf  Optimize positioning code
641C Version 3.0  02-Jan-1987  S. C. Allendorf  Add code for rules
642C VERSION 3.1  10-FEB-1988  S. C. Allendorf  Attempt to speed up code
643C-----------------------------------------------------------------------
644      BYTE       ESC, N0
645      LOGICAL    NOBIT
646      INTEGER    CNUM, CONUM, CURCOL, CURROW, FB(35), FB2(25), I, IPOS
647      INTEGER    IYOFF, J, K, L, M, N, NB(35), NBNUM, NBTOT, NBNUM2
648      INTEGER    NB2(25), RNUM, RONUM, GRLJ03
649      CHARACTER  ALLONE*300, COL*5, NBYTE*4, NULLS*(10), ROW*5, X*300
650      PARAMETER  (N0 = 0)
651      PARAMETER  (ESC = 27)
652C-----------------------------------------------------------------------
653C                                       Define some useful constants
654      IF (TEX) THEN
655         IYOFF = 0
656      ELSE
657         IYOFF = 75
658      END IF
659      DO J = 1, 10
660         NULLS(J:J) = CHAR (0)
661      END DO
662      DO J = 1, 300
663         ALLONE(J:J) = CHAR (255)
664      END DO
665C                                       Initialize some variables
666      CURCOL = 0
667      CURROW = 0
668C                                       Position the cursor
669      IF (.NOT. TEX) THEN
670         WRITE (LUN) ESC, '*p0y0X'
671      END IF
672C                                       Set up vertical rule height
673      WRITE (LUN) ESC, '*c1B'
674C                                       Write out each line on page
675      DO K = 1, BY
676C                                       Copy raster to buffer and find
677C                                       the beginning and end of the
678C                                       bitmap line
679         NOBIT = .TRUE.
680         NBTOT = 0
681         FB(1) = BX
682         DO J = 1, BX
683            X(J:J) = CHAR (BITMAP(J,K))
684            IF (X(J:J) .NE. NULLS(1:1)) THEN
685               NOBIT = .FALSE.
686               NBTOT = J
687               FB(1) = MIN (FB(1), J)
688            END IF
689         END DO
690C                                       Break line into pieces
691         IF (.NOT. NOBIT) THEN
692            L = 1
693            GO TO 20
694   10       NB(L) = FB(L) + IPOS - 2
695            L = L + 1
696C                                       Search for first non-null
697            DO J = NB(L-1) + 11, NBTOT
698               IF (X(J:J) .NE. NULLS(1:1)) THEN
699                  FB(L) = J
700                  GO TO 20
701               END IF
702            END DO
703C                                       Search for a string of nulls
704   20       IPOS = INDEX (X(FB(L):NBTOT), NULLS)
705            IF (IPOS .EQ. 0) THEN
706               NB(L) = NBTOT
707               GO TO 30
708            ELSE
709               GO TO 10
710            END IF
711C                                       Loop through each substring
712   30       DO J = 1, L
713C                                       Search for rules
714               M = 1
715               FB2(1) = FB(J)
716               GO TO 50
717   40          IF (IPOS .NE. 1) THEN
718                  NB2(M) = 0
719                  DO I = FB2(M), FB2(M) + IPOS - 2
720                     IF (X(I:I) .NE. NULLS(1:1)) THEN
721                        NB2(M) = MAX (FB2(M), I)
722                     END IF
723                  END DO
724                  M = M + 1
725                  FB2(M) = FB2(M-1) + IPOS - 1
726                  IF (NB2(M-1) .EQ. 0) THEN
727                     FB2(M-1) = FB2(M)
728                     M = M - 1
729                  END IF
730               END IF
731C                                       Search for first non-<XFF>
732               DO N = FB2(M) + 25, NB(J)
733                  IF (X(N:N) .NE. ALLONE(1:1)) THEN
734                     NB2(M) = N - 1
735                     M = M + 1
736                     FB2(M) = N
737                     GO TO 50
738                  END IF
739               END DO
740               NB2(M) = NB(J)
741               GO TO 60
742C                                       Search for a string of <XFF>s
743   50          IPOS = INDEX (X(FB2(M):NB(J)), ALLONE(1:25))
744               IF (IPOS .EQ. 0) THEN
745                  NB2(M) = NB(J)
746                  GO TO 60
747               ELSE
748                  GO TO 40
749               END IF
750C                                       Print each of the substrings
751   60          DO I = 1, M
752C                                       Get the number of bytes
753                  NBNUM = NB2(I) - FB2(I) + 1
754C                 ENCODE (4, 1000, NBYTE) NBNUM
755                  WRITE (NBYTE, 1000) NBNUM
756                  NBNUM2 = GRLJ03 (NBNUM)
757C                                       Calculate the row and column
758                  RONUM = K + IYOFF
759                  CONUM = (FB2(I) - 1) * 8
760C                                       Determine the positioning
761C                                       sequence and write it out
762                  IF (RONUM .NE. CURROW .AND. CONUM .NE. CURCOL) THEN
763                     RNUM = RONUM - CURROW
764                     CNUM = CONUM - CURCOL
765C                    ENCODE (5, 1010, ROW) RNUM
766C                    ENCODE (5, 1010, COL) CNUM
767                     WRITE (ROW, 1010) RNUM
768                     WRITE (COL, 1010) CNUM
769                     RNUM = GRLJ03 (ABS (RNUM)) + 1
770                     CNUM = GRLJ03 (ABS (CNUM)) + 1
771                     WRITE (LUN) ESC, '*p', ROW(6-RNUM:5), 'y',
772     +                                              COL(6-CNUM:5), 'X'
773                  ELSE IF (RONUM .NE. CURROW) THEN
774                     RNUM = RONUM - CURROW
775C                    ENCODE (5, 1010, ROW) RNUM
776                     WRITE (ROW, 1010) RNUM
777                     RNUM = GRLJ03 (ABS (RNUM)) + 1
778                     WRITE (LUN) ESC, '*p', ROW(6-RNUM:5), 'Y'
779                  ELSE IF (CONUM .NE. CURCOL) THEN
780                     CNUM = CONUM - CURCOL
781C                    ENCODE (5, 1010, COL) CNUM
782                     WRITE (COL, 1010) CNUM
783                     CNUM = GRLJ03 (ABS (CNUM)) + 1
784                     WRITE (LUN) ESC, '*p', COL(6-CNUM:5), 'X'
785                  END IF
786C                                       Check for all bits set in
787C                                       substring
788                  IF ((INDEX (X(FB2(I):NB2(I)), ALLONE(1:NBNUM)) .EQ. 1)
789     +                 .AND. NBNUM .GE. 5) THEN
790                     NBNUM = NBNUM * 8
791C                    ENCODE (4, 1000, NBYTE) NBNUM
792                     WRITE (NBYTE, 1000) NBNUM
793                     NBNUM2 = GRLJ03 (NBNUM)
794                     WRITE (LUN) ESC, '*c', NBYTE(5-NBNUM2:4), 'A'
795                     WRITE (LUN) ESC, '*c0P'
796                     CURROW = RONUM
797                     CURCOL = CONUM
798                  ELSE
799C                                       Write out raster line
800                     WRITE (LUN) ESC, '*r1A'
801                     WRITE (LUN) ESC, '*b', NBYTE(5-NBNUM2:4), 'W',
802     +                                                X(FB2(I):NB2(I))
803                     WRITE (LUN) ESC, '*rB'
804                     CURROW = RONUM + 1
805                     CURCOL = CONUM
806                  END IF
807               END DO
808            END DO
809         END IF
810      END DO
811C-----------------------------------------------------------------------
812 1000 FORMAT (I4.4)
813 1010 FORMAT (SP,I5)
814      RETURN
815      END
816
817C*GRLJ03 -- PGPLOT LaserJet+ driver, calculate length of an integer
818C+
819      INTEGER FUNCTION GRLJ03 (I)
820      INTEGER I
821C
822C This function calculates the number of digits in a supplied integer.
823C
824C Arguments:
825C
826C I               I I      Integer value of number
827C GRLJ03          O I      Length of printed representation of I
828C
829C Version 1.0  10-Feb-1988  S. C. Allendorf
830C-----------------------------------------------------------------------
831      IF (I .GE. 10) THEN
832         IF (I .GE. 100) THEN
833            IF (I .GE. 1000) THEN
834               GRLJ03 = 4
835            ELSE
836               GRLJ03 = 3
837            END IF
838         ELSE
839            GRLJ03 = 2
840         END IF
841      ELSE
842         GRLJ03 = 1
843      END IF
844C-----------------------------------------------------------------------
845      RETURN
846      END
847
848C*GRLJ04 -- zero fill buffer
849C+
850      SUBROUTINE GRLJ04 (BUFSIZ,BUFFER)
851C
852C Arguments:
853C
854C BUFFER (byte array, input): (address of) the buffer.
855C BUFSIZ (integer, input): number of bytes in BUFFER.
856C-----------------------------------------------------------------------
857      INTEGER  BUFSIZ, I
858      BYTE     BUFFER(BUFSIZ), FILL
859      DATA     FILL /0/
860C
861      DO 10 I=1,BUFSIZ
862          BUFFER(I) = FILL
863   10 CONTINUE
864      END
865