1C*LNDRIV   PGPLOT DRIVER FOR DIGITAL LN03 (LANDSCAPE)
2	SUBROUTINE LNDRIV (IFUNC, RBUF, NBUF, CHR, LCHR)
3	INTEGER IFUNC, NBUF, LCHR
4	REAL    RBUF(*)
5	CHARACTER*(*) CHR
6C-----------------------------------------------------------------------
7C PGPLOT driver for Digital LN03 Laser Printer (landscape)
8C File : LNDRIVER.FOR
9C-----------------------------------------------------------------------
10C Version 1.0  - 1989 Nov. Sid Penstone, Queen's University
11C Last Revision Dec.1,1989, added direct code for vertical lines,
12C now do dots as a case of a zero length vector
13C-----------------------------------------------------------------------
14C	This routine has been written specifically for the LN03-PLUS
15C	Laser Printer
16C
17C	Name: '/LN03'
18C 	In all case, the initialization sequences are written out,
19C	whether or not the plotter is connected as a terminal,
20C	or driven from an intermediate file.
21C
22C	If there is more than one plot
23C	the page is ejected before the next one
24C
25C	ref: Digital LN03 Programmer Reference Manual, P/N EK-OLN03-002,
26C	  and Digital LN03-Plus "      "          "    P/N EK-LN03S-001
27C
28C	We end up with a 9" by 7" display area.
29C
30C-----------------------------------------------------------------------
31	CHARACTER*(*) TYPE
32	PARAMETER (TYPE='LN03 (Digital LN03 Laser Printer, landscape)')
33C
34	INTEGER MARGIN, NXPIX, NYPIX, NSIXROWS, NSIXCOLS
35	PARAMETER(MARGIN=150)
36	PARAMETER(NXPIX=3000)
37	PARAMETER(NYPIX=2400)
38	PARAMETER(NSIXROWS=(NYPIX/6)+2)
39	PARAMETER(NSIXCOLS=NXPIX)
40	CHARACTER*10 MSG
41	INTEGER WIDTH,XLEFT,XRIGHT,YBOT,YTOP, INTENS, XMAX, YMAX, XMIN
42	INTEGER UNIT, IER
43	INTEGER I0, J0, I1, J1
44	INTEGER IK1, IK2, IK3, IK4, IK5, PLOTNO
45	CHARACTER*1 ESC
46	DATA XLEFT,XRIGHT,YTOP,YBOT/0,NXPIX,0,NYPIX/
47	DATA ESC /27/
48	DATA WIDTH /2/
49	LOGICAL ACTIVE(0:NSIXROWS)
50C Data for the allocation routines
51	INTEGER GRGMEM, GRFMEM
52	INTEGER BUFLEN, IPOINTS, IERR
53	LOGICAL ALLOC
54	SAVE BUFLEN, IPOINTS, ALLOC
55	DATA ALLOC /.FALSE./
56	DATA IPOINTS /-1/
57C for debugging
58	LOGICAL DEBUG
59	DATA DEBUG/.FALSE./
60
61C-----------------------------------------------------------------------
62C
63	GOTO( 10, 20, 30, 40, 50, 60, 70, 80, 90,100,
64     1     110,120,130,140,150,160,170,180,190,200,
65     2     210,220,230), IFUNC
66	GOTO 900
67C
68C--- IFUNC = 1, Return device name.-------------------------------------
69C
7010	CHR = TYPE
71	LCHR = LEN(TYPE)
72	RETURN
73C
74C--- IFUNC = 2, Return physical min and max for plot device, and range
75C               of color indices.---------------------------------------
76C
7720	RBUF(1) = 0
78	RBUF(2) = NXPIX - 2*MARGIN
79	RBUF(3) = 0
80	RBUF(4) = NYPIX - 2*MARGIN
81	RBUF(5) = 0
82	RBUF(6) = 1
83	NBUF = 6
84	RETURN
85C
86C--- IFUNC = 3, Return device resolution. ------------------------------
87C
8830	RBUF(1) = 300.0
89	RBUF(2) = 300.0
90	RBUF(3) = WIDTH
91	NBUF = 3
92	RETURN
93C
94C--- IFUNC = 4, Return misc device info. -------------------------------
95C    (This device is Hardcopy, No cursor, No dashed lines, No area fill,
96C    No thick lines)
97C
9840	CHR = 'HNNNNNNNNN'
99	LCHR = 10
100	RETURN
101C
102C--- IFUNC = 5, Return default file name. ------------------------------
103C
10450	CHR = 'PGPLOT.LN3'
105	LCHR = 11
106	RETURN
107C
108C--- IFUNC = 6, Return default physical size of plot. ------------------
109C
11060	RBUF(1) = 0
111	RBUF(2) = NXPIX-2*MARGIN
112	RBUF(3) = 0
113	RBUF(4) = NYPIX-2*MARGIN
114	NBUF = 4
115	RETURN
116C
117C--- IFUNC = 7, Return misc defaults. ----------------------------------
118C
11970	RBUF(1) = 10
120	NBUF = 1
121	RETURN
122C
123C--- IFUNC = 8, Select plot. -------------------------------------------
124C
12580	CONTINUE
126	RETURN
127C
128C--- IFUNC = 9, Open workstation. --------------------------------------
129C
13090	CONTINUE
131C Try to open the graphics device
132	CALL GRGLUN(UNIT)
133	OPEN (UNIT=UNIT,FILE=CHR(:LCHR),STATUS='NEW',
134	1		FORM='FORMATTED', CARRIAGECONTROL='LIST',
135	1		RECL=512,IOSTAT=IER)
136	IF (IER.NE.0) THEN
137	  CALL ERRSNS(IK1,IK2,IK3,IK4,IK5)
138	  CALL GRWARN('Cannot open graphics device '
139	1				//CHR(1:LCHR))
140	  IF (IK2.NE.0 .AND. IK2.NE.1) CALL GRGMSG(IK2)
141	  IF (IK5.NE.0 .AND. IK5.NE.1) CALL GRGMSG(IK5)
142	  RBUF(2) = 0
143	  RETURN
144	ENDIF
145	RBUF(1) = UNIT
146	RBUF(2) = 1
147	NBUF = 2
148C Now allocate the bitmap buffers (Assume integer*2)
149	IF (.NOT. ALLOC) THEN
150	    BUFLEN = NSIXROWS * NSIXCOLS
151	    IERR = GRGMEM(2*BUFLEN, IPOINTS)
152	    IF (IERR .NE. 1 ) THEN
153	        CALL GRGMSG(IERR)
154	        CALL GRWARN('Memory allocation failure')
155	        RETURN
156	    ENDIF
157	    ALLOC = .TRUE.
158	ENDIF
159C Digital says that the allocated memory may not be zeroed:
160C Clear the row flags (and the bit map)
161	CALL LN03_CLEAR(%VAL(IPOINTS),BUFLEN,ACTIVE,NSIXROWS)
162C
163C always write the preamble
164C this resets the plotter
165	WRITE (UNIT, '(A)') ESC//'c'
166C this sets it for landscape, origin at corner
167	WRITE (UNIT, '(A)') ESC//'[?21 J'
168	PLOTNO = 0
169	RETURN
170C
171C--- IFUNC=10, Close workstation. --------------------------------------
172  100	CONTINUE
173C always turn it off
174	CLOSE (UNIT)
175	CALL GRFLUN(UNIT)
176C Deallocate the buffer
177	IF (ALLOC .OR. IPOINTS .GE. 0) THEN
178	    IERR = GRFMEM(2*BUFLEN, IPOINTS)
179	    IF (IERR .NE. 1 ) THEN
180	        CALL GRGMSG(IERR)
181	        CALL GRWARN('Deallocation failure')
182	        RETURN
183	    ENDIF
184	    ALLOC = .FALSE.
185	    IPOINTS = -1
186	ENDIF
187	RETURN
188C
189C--- IFUNC=11, Begin picture. ------------------------------------------
190C
191  110	CONTINUE
192C WE COULD GET THE VALUE OF XMAX AND YMAX HERE
193	YMAX = YBOT - 2*MARGIN
194	XMIN = XLEFT + MARGIN
195	XMAX = XRIGHT - MARGIN
196	PLOTNO = PLOTNO + 1
197	RETURN
198C
199C--- IFUNC=12, Draw line. ----------------------------------------------
200C
201  120	CONTINUE
202	I0 = XMIN + NINT(RBUF(1))
203	J0 = YMAX - NINT(RBUF(2))
204	I1 = XMIN + NINT(RBUF(3))
205	J1 = YMAX - NINT(RBUF(4))
206	CALL LN03_VECTOR(I0,J0,I1,J1,WIDTH,XLEFT,XRIGHT,
207	1 YTOP,YBOT,%val(IPOINTS),ACTIVE,NSIXROWS,NSIXCOLS,INTENS)
208	RETURN
209C
210C--- IFUNC=13, Draw dot. -----------------------------------------------
211C
212  130	CONTINUE
213	I0 = XMIN + NINT(RBUF(1))
214	J0 = YMAX - NINT(RBUF(2))
215	CALL LN03_VECTOR(I0,J0,I0,J0,WIDTH,XLEFT,XRIGHT,
216	1 YTOP,YBOT,%VAL(IPOINTS),ACTIVE,NSIXROWS,NSIXCOLS,INTENS)
217	RETURN
218C
219C--- IFUNC=14, End picture. --------------------------------------------
220C
221  140	CONTINUE
222        CALL LN03_DUMP(UNIT,XLEFT,XMAX+WIDTH,YTOP+MARGIN,YMAX+WIDTH,
223	1%val(IPOINTS),ACTIVE,NSIXROWS,NSIXCOLS)
224C Clear the bitmap buffer
225	IF (ALLOC) THEN
226	    CALL LN03_CLEAR(%val(IPOINTS),BUFLEN,ACTIVE,NSIXROWS)
227	ENDIF
228C  Eject the paper with a form feed
229C	WRITE (UNIT, '(A)') CHAR(12)
230	RETURN
231C
232C--- IFUNC=15, Select color index. -------------------------------------
233C
234  150	INTENS = NINT(RBUF(1))
235	IF (INTENS .GT.1) INTENS = 1
236	if (debug) write(0,'(A,G13.7,I6)')'Intens= ',RBUF(1),INTENS
237	RETURN
238C
239C--- IFUNC=16, Flush buffer. -------------------------------------------
240C    (Null operation: buffering is not implemented.)
241C
242160	CONTINUE
243	RETURN
244C
245C--- IFUNC=17, Read cursor. --------------------------------------------
246C    (Not implemented: should not be called.)
247C
248170	GOTO 900
249C
250C--- IFUNC=18, Erase alpha screen. -------------------------------------
251C    (Null operation: there is no alpha screen.)
252C
253180	CONTINUE
254	RETURN
255C
256C--- IFUNC=19, Set line style. -----------------------------------------
257C    (Not implemented: should not be called.)
258C
259190	GOTO 900
260C
261C--- IFUNC=20, Polygon fill. -------------------------------------------
262C    (Not implemented: should not be called.)
263C
264200	GOTO 900
265C
266C--- IFUNC=21, Set color representation. -------------------------------
267C
268210	RETURN
269C	Other colors are not implemented
270C
271C
272C--- IFUNC=22, Set line width. -----------------------------------------
273C    (Not implemented: should not be called.)
274C
275220	GOTO 900
276C
277C--- IFUNC=23, Escape. -------------------------------------------------
278C
279230	CONTINUE
280	WRITE (UNIT, '(A)') CHR(:LCHR)
281	RETURN
282C-----------------------------------------------------------------------
283C Error: unimplemented function.
284C
285  900	WRITE (MSG,'(I10)') IFUNC
286	CALL GRWARN('Unimplemented function in LN03 device driver: '//MSG)
287	NBUF = -1
288	RETURN
289C-----------------------------------------------------------------------
290	END
291
292C------------------- PRIMITIVE LN03 FUNCTIONS -------------------
293C
294C----------------------------------------------------------------
295C       CLEAR THE BITMAP IF IT WAS USED BEFORE
296C
297	SUBROUTINE LN03_CLEAR(BUFF,N,BUSY,NR)
298	INTEGER*2 BUFF(0:*)
299	LOGICAL BUSY(0:*)
300	INTEGER N, I , NR
301	DO 1 I = 0, N-1
3021	BUFF(I) = 0
303	DO 2 I = 0, NR-1
3042	BUSY(I) = .FALSE.
305	RETURN
306	END
307
308
309C---------------------------------------------------------------------
310	CHARACTER*10 FUNCTION LN03_PACK(IARG,IP)
311C-----------------------------------------------------------------------
312C       (Internal routine, LN): Identical to the grgl00() routine
313C       This subroutine translates the argument IARG into a character
314C	string and then returns the position of the first non-blank
315C	character in the string
316C Arguments:    IARG
317C               IP (returned)
318C-----------------------------------------------------------------------
319	INTEGER IARG, IP
320C
321	LN03_PACK = ' '
322	IP = 10
323	WRITE(LN03_PACK,'(I10)') IARG
324	DO IP=1,10
325	  IF (LN03_PACK(IP:IP) .NE. ' ') RETURN
326	ENDDO
327	END
328
329
330C---------------------------- VECTOR DRAWING --------------------------
331	SUBROUTINE LN03_VECTOR(X1,Y1,X2,Y2,WIDTH,XLEFT,XRIGHT,
332	1 YTOP,YBOT,POINTS,ACTIVE,NSIXROWS,NSIXCOLS,INTENS)
333C----------------------------------------------------------------------
334C
335C	Based on Bresenham's algorithm, and a C version written by
336C	Paul Demone, Canadian Microelectronics Corporation
337C
338C	 We enter with the values x,y converted to internal values
339C	That is, we have reflected the direction of Y
340C
341
342	INTEGER X1,Y1,X2,Y2,WIDTH,XLEFT,XRIGHT,YBOT,YTOP,NSIXCOLS,
343	1 NSIXROWS, INTENS
344	INTEGER X, Y, DX, DY, ADX, ADY, E, DA, DB, D1X, D1Y, D2X, D2Y
345	INTEGER XX, YY, INDX, ITEMP
346	INTEGER*2 SHIFT
347	INTEGER*2 POINTS(0:*)
348	LOGICAL ACTIVE(0:*)
349	logical debug
350	data debug /.false./
351
352C 	if (debug) write(0,'(A,I6,I6)')'INTENS= ',INTENS
353C Start at X1, Y1
354	if(debug)write(0, '(A,4(I6),A,I3,A,2(I10))')'LINE: ',
355	1x1,y1,x2,y2,'INTENS=',INTENS,' ROW,COL: ',
356	1 (Y1/6),((Y1/6)*NSIXCOLS+X1)
357C Note that we always try to move the X index inside the loops, since they
358C are adjacent in the bitmap array
359C If this is a horizontal line, then we can do it faster
360	IF (Y2 .EQ. Y1) THEN
361	    IF(X2 .LT. X1) THEN
362		ITEMP = X1
363		X1 = X2
364		X2 = ITEMP
365	    ENDIF
366	    YY = Y1
367	    DO WHILE (YY .LT. Y1 + WIDTH .AND. YY .LT. YBOT)
368		INDX = (YY/6)*NSIXCOLS
369		SHIFT = JMOD(YY, 6)
370		XX = X1
371		DO WHILE ( XX .LT. X2 + WIDTH .AND. XX .LT. XRIGHT)
372		    IF (INTENS .EQ. 0) THEN
373			POINTS(INDX + XX) = IIBCLR(POINTS(INDX +XX), SHIFT)
374		    ELSE
375			POINTS(INDX + XX) = IIBSET(POINTS(INDX +XX), SHIFT)
376		ENDIF
377		    XX = XX + 1
378		ENDDO
379	        IF (INTENS .NE. 0) ACTIVE(YY/6) = .TRUE.
380	        YY = YY + 1
381	    ENDDO
382	    RETURN
383C		Might be a vertical line:
384	ELSEIF (X2. EQ. X1) THEN
385	    IF (Y2 .LT. Y1) THEN
386		ITEMP = Y1
387		Y1 = Y2
388		Y2 = ITEMP
389	    ENDIF
390	    YY = Y1
391	    DO WHILE (YY .LT. Y2 + WIDTH .AND. YY .LT. YBOT)
392		INDX = (YY/6)*NSIXCOLS
393		SHIFT = JMOD(YY, 6)
394		XX = X1
395		DO WHILE ( XX .LT. X1 + WIDTH .AND. XX .LT. XRIGHT)
396		    IF (INTENS .EQ. 0) THEN
397			POINTS(INDX + XX) = IIBCLR(POINTS(INDX +XX), SHIFT)
398		    ELSE
399			POINTS(INDX + XX) = IIBSET(POINTS(INDX +XX), SHIFT)
400		ENDIF
401		    XX = XX + 1
402		ENDDO
403	        IF (INTENS .NE. 0) ACTIVE(YY/6) = .TRUE.
404	        YY = YY + 1
405	    ENDDO
406	    RETURN
407	ENDIF
408C		 It is a vector : Use the algorithm
409
410	DX = X2 - X1
411	DY = Y2 - Y1
412	D2X = ISIGN(1,DX)
413	D2Y = ISIGN(1,DY)
414	ADX = IABS(DX)
415	ADY = IABS(DY)
416C Check for the maximum number of steps: X or Y ?
417	IF (ADX .GT. ADY) THEN
418		DA = ADX
419		DB = ADY
420		D1Y = 0
421		D1X = ISIGN(1,DX)
422	ELSE
423		DA = ADY
424		DB = ADX
425		D1X = 0
426		D1Y = ISIGN(1,DY)
427	ENDIF
428	DB = 2*DB
429	E = DB - DA
430	DA = 2*DA
431	X = X1
432	Y = Y1
433C Here we will be using some VAX Fortran extensions .......
434  800   CONTINUE
435C	DO WHILE (.TRUE.)
436	    IF (X .GE. XLEFT  .AND. Y .GE. YTOP .AND.
437	1       X .LT. XRIGHT .AND. Y .LT. YBOT) THEN
438C Don't come in here if we are already off scale !
439C If it is ok, then add a cluster of pixels of size width by width
440C	if(debug)write(0, '(4(I6))')x,y
441		XX = X
442		DO WHILE (XX .LT. X+WIDTH .AND. XX .LT. XRIGHT)
443		    YY = Y
444		    DO WHILE(YY .LT. Y+WIDTH .AND. YY .LT. YBOT)
445			INDX = (YY/6)*NSIXCOLS + XX
446			SHIFT = JMOD(YY,6)
447C	IF(DEBUG)WRITE(UNIT,'(2(I6),I10,6(I6))')
448C	1   XX,YY,INDX,POINTS(INDX),INTENS,SHIFT
449			IF (INTENS .EQ. 0) THEN
450			    POINTS(INDX) = IIBCLR(POINTS(INDX),SHIFT)
451		        ELSE
452			    POINTS(INDX) = IIBSET(POINTS(INDX),SHIFT)
453			    ACTIVE(YY/6) = .TRUE.
454			ENDIF
455		        YY = YY + 1
456		    ENDDO
457		    XX = XX +1
458		ENDDO
459	    ENDIF
460C  Are we finished ?
461	    IF (X .EQ. X2 .AND. Y .EQ. Y2) RETURN
462C  Else move to the next point
463	    IF ( E .GT. 0) THEN
464	        X = X + D2X
465	        Y = Y + D2Y
466	        E = E + DB - DA
467	    ELSE
468	        X = X + D1X
469	        Y = Y + D1Y
470	        E = E + DB
471	    ENDIF
472	GOTO 800
473C	ENDDO
474	END
475
476
477C ------------------------------------------------------------
478	SUBROUTINE LN03_DUMP(UNIT,XLEFT,XRIGHT,YTOP,YBOT,
479	1 POINTS,ACTIVE,NSIXROWS,NSIXCOLS)
480C-------------------------------------------------------------
481C Dump the bitmap to the printer
482C Only write active sixel rows, and do run length encoding, too
483C
484C
485C Parameters:
486C	XLEFT: starting column in map, and initial x position
487C	XRIGHT: last active column in map
488C	YTOP: starting row in map, and initial y position
489C	YBOT: last active row in the map
490
491	INTEGER XLEFT, XRIGHT, YTOP, YBOT, NSIXROWS, NSIXCOLS, UNIT
492	LOGICAL ACTIVE(0:*)
493	INTEGER*2 POINTS(0:*)
494
495	INTEGER*2 SXL
496	INTEGER IROW, JCOL, K, PTR, RPT, INDX, N, MAXLEN
497	CHARACTER*10 RUN, LN03_PACK
498	CHARACTER*256 BUFFER
499	CHARACTER*1 PAT, ESC
500	DATA ESC /27/
501	DATA MAXLEN /75/
502	LOGICAL DEBUG
503	DATA DEBUG /.false./
504	INTEGER IOFFSET
505	PARAMETER(IOFFSET = 34)
506
507	CHARACTER*10 NEWX,NEWY
508	INTEGER N1,N2
509
510	NEWX = LN03_PACK(XLEFT,N1)
511	NEWY = LN03_PACK(YTOP+IOFFSET,N2)
512C Start at the top of the paper, down one line plus offset
513C The pixels start 70 decipoints above the first line
514C Set up the sixel modes
515	WRITE(UNIT, '(A)') ESC//'[7 I'//ESC//'[11h'
516	WRITE (UNIT, '(A)')
517	1 ESC//'['//NEWX(N1:)//'`'//ESC//'['//NEWY(N2:)//'d'
518	1//ESC//'P0;0;1q"100;100'
519C Now scan the bitmap
520	PTR = 1
521	DO 1000 IROW = 0, NSIXROWS-2
522	IF (ACTIVE(IROW)) THEN
523	if(debug)write(0,'(a,4(i6))')'row = ',irow
524	    JCOL = XLEFT
525	    DO WHILE (JCOL .LT. XRIGHT)
526		INDX = IROW*NSIXCOLS
527		SXL = POINTS(INDX + JCOL)
528	        PAT = CHAR(IIAND(SXL,63) + 63)
529		RPT = 0
530C Look for repeated values on the rest of the line
531		K = JCOL + 1
532		DO WHILE( K .LT. XRIGHT .AND.
533	1	    SXL .EQ. POINTS(INDX + K))
534		    RPT = RPT +1
535		    K = K + 1
536		ENDDO
537C	    IF (DEBUG) WRITE(1, '(2I10,2I6,1X,A,I5,I5)')
538C	1 indx,indx+jcol, IROW, JCOL, PAT,ICHAR(PAT),SXL
539C	Now check if there were any repeats
540		IF (RPT .GT. 0) THEN
541	            RUN = LN03_PACK(RPT +1, N)
542	            BUFFER(PTR:) = '!'//RUN(N:)//PAT
543		    PTR = PTR + LEN(RUN(N:)) + 2
544		    JCOL = JCOL + RPT + 1
545	        ELSE
546	            BUFFER(PTR:PTR) = PAT
547		    PTR = PTR + 1
548		    JCOL = JCOL + 1
549	        ENDIF
550	        IF (PTR .GE. MAXLEN) THEN
551		    WRITE (UNIT, '(A)') BUFFER(:PTR-1)
552	            PTR = 1
553	        ENDIF
554	    ENDDO
555	ENDIF
556C Terminate each scan with a graphic newline character
557        BUFFER(PTR:PTR) = '-'
558	IF (PTR .GE. MAXLEN) THEN
559	    WRITE (UNIT, '(A)') BUFFER(:PTR)
560	    PTR = 1
561	ELSE
562	    PTR = PTR + 1
563        ENDIF
5641000	CONTINUE
565	IF(PTR .GT. 1) WRITE (UNIT, '(A)') BUFFER(:PTR-1)
566	WRITE(UNIT, '(A)') ESC//CHAR(92)
567	RETURN
568	END
569