1C*GRQM00 -- PGPLOT QMS/QUIC driver
2
3      SUBROUTINE    QMDRIV (IFUNC, RBUF, NBUF, CHR, LCHR, MODE)
4      INTEGER       IFUNC, NBUF, LCHR, MODE
5      REAL          RBUF(*)
6      CHARACTER*(*) CHR
7C-----------------------------------------------------------------------
8C PGPLOT driver for QUIC devices (QMS and Talaris 800/1200/1500/2400)
9C-----------------------------------------------------------------------
10C Version 0.1  - 1987 Oct 22 - Patrick P. Murphy, NRAO/VLA [PPM]
11C Version 0.2  - 1987 Oct 28 - [PPM] Fix backwards and scale bugs
12C Version 1.0  - 1987 Nov 03 - [PPM] Don't form feed if nothing drawn.
13C Version 1.1  - 1987 Nov 03 - [PPM] No formfeed at very end of file
14C Version 2.0  - 1987 Nov 18 - [PPM] Get scaling done right.
15C Version 2.1  - 1991 Jun 28 - [TJP] Standardization.
16C Version 2.2  - 1991 Nov  6 - [TJP] Standardization.
17C Version 3.0  - 1994 Feb 25 - [TJP] Combine portrait and landscape
18C                                    modes in one file.
19C-----------------------------------------------------------------------
20C
21C Supported device: Any QMS or Talaris printer that accepts the QUIC
22C                   page description language.  4-bit mode is used.
23C
24C Device type code: /QMS (landscape mode 1)
25C                   /VQMS (portrait mode 2)
26C
27C Default file name: PGPLOT.QMPLOT.
28C
29C Default view surface dimensions:
30C      10.25 inches horizontal x  7.75 inches vertical (landscape mode),
31C       7.75 inches horizontal x 10.25 inches vertical (portrait mode),
32C      margins of 0.5 inches on top and left of page.
33C
34C Resolution: The driver uses coordinate increments of 1/1000 inch.
35C             The true resolution is device-dependent; at time of
36C             writing, it is typically 300 dots per inch.
37C
38C Color capability: Color indices 0 (erase), and 1 (black) are
39C                   supported.  Requests for other color indices are
40C                   converted to 1.  It is not possible to change color
41C                   representation.
42C
43C Input capability: None.
44C
45C File format: Ascii, variable length records (max 130 bytes); carriage
46C              return ("LIST") carriage control.  This length can be
47C              easily changed if needed.
48C
49C Obtaining hardcopy:  send the file to an appropriate printer.
50C-----------------------------------------------------------------------
51C
52      CHARACTER*(*) DEVTPL, DEVTPP, DEFNAM
53      PARAMETER    (DEFNAM='PGPLOT.QMPLOT')
54      PARAMETER (DEVTPL='QMS   (QUIC/QMS file, landscape orientation)')
55      PARAMETER (DEVTPP='VQMS  (QUIC/QMS file, portrait orientation)')
56C
57      CHARACTER*130 BUFFER
58      CHARACTER*16  HEXSTR
59      CHARACTER*10  MSG
60      CHARACTER*40  TEMP
61      INTEGER       UNIT, IER, BUFLEN, MAXLEN, I0, J0, I1, J1, NPTS, IC,
62     :              ISTYLE, LINWID, GROPTX
63      REAL          QXSIZE, QYSIZE, QXSCAL, QYSCAL
64      LOGICAL       NOTHIN, ENDFIL
65C
66C ---- Change MAXLEN if you want a shorter or longer max output line
67C ---- length.  Also change the declared length of BUFFER too!  The
68C ---- Q*SIZE parameters are the physical size of the plot (used more
69C ---- than once here) in resolution units (1/1000 inch).  The Q*SCAL
70C ---- parameters are PGPLOT-modifiable scale factors.
71C
72      PARAMETER    (MAXLEN = 130,
73     :              QXSIZE = 10250.0,
74     :              QYSIZE = 7750.00)
75C
76      SAVE UNIT, IC, BUFFER, BUFLEN, NPTS, QXSCAL, QYSCAL, NOTHIN,
77     :     ENDFIL
78C
79      DATA HEXSTR /'0123456789ABCDEF'/
80C
81C=======================================================================
82C
83C ---- Do the best one can in F77 for a "case" statement. --------------
84C
85      GOTO( 10, 20, 30, 40, 50, 60, 70, 80, 90,100,
86     1     110,120,130,140,150,160,170,180,190,200,
87     2     210,220,230), IFUNC
88C
89C ---- Unknown opcode/function; most likely a logic error somewhere ----
90C
91  900 WRITE (MSG,'(I10)') IFUNC
92      CALL GRWARN('Unimplemented function in QMS'//
93     :            ' device driver:'//MSG)
94      NBUF = -1
95      RETURN
96C
97C--- IFUNC = 1, Return device name -------------------------------------
98C
99   10 IF (MODE.EQ.1) THEN
100          CHR = DEVTPL
101          LCHR = LEN(DEVTPL)
102      ELSE IF (MODE.EQ.2) THEN
103          CHR = DEVTPP
104          LCHR = LEN(DEVTPP)
105      ELSE
106          CALL GRWARN('Internal error in QMDRIV')
107      END IF
108      RETURN
109C
110C--- IFUNC = 2, Return physical min and max for plot device, and range
111C               of color indices ---------------------------------------
112C               Units are in device co-ordinates (1/1000 inches)
113C
114   20 IF (MODE.EQ.1) THEN
115          RBUF(2) = QXSIZE
116          RBUF(4) = QYSIZE
117      ELSE
118          RBUF(2) = QYSIZE
119          RBUF(4) = QXSIZE
120      END IF
121      RBUF(1) = 0.0
122      RBUF(3) = 0.0
123      RBUF(5) = 0.0
124      RBUF(6) = 1.0
125      NBUF = 6
126      RETURN
127C
128C--- IFUNC = 3, Return device resolution -------------------------------
129C    (Nominal values)
130C
131   30 RBUF(1) = 1000.0
132      RBUF(2) = 1000.0
133C
134C      (multiple strokes are spaced by 3.333 pixels, or 1/300 inch)
135C
136      RBUF(3) = 3.333
137      NBUF = 3
138      RETURN
139C
140C--- IFUNC = 4, Return misc device info --------------------------------
141C    (Hardcopy, No cursor, Dashed lines, Area fill, Thick lines)
142C
143   40 CHR = 'HNDATNNNNN'
144      LCHR = 10
145      RETURN
146C
147C--- IFUNC = 5, Return default file name -------------------------------
148C
149   50 CHR  = DEFNAM
150      LCHR = LEN(DEFNAM)
151      RETURN
152C
153C--- IFUNC = 6, Return default physical size of plot -------------------
154C    (in device coordinates).
155C
156   60 IF (MODE.EQ.1) THEN
157          RBUF(2) = QXSIZE
158          RBUF(4) = QYSIZE
159      ELSE
160          RBUF(2) = QYSIZE
161          RBUF(4) = QXSIZE
162      END IF
163      RBUF(1) = 0.0
164      RBUF(3) = 0.0
165      NBUF = 4
166      RETURN
167C
168C--- IFUNC = 7, Return misc defaults -----------------------------------
169C    Currently scale factor for "obsolete" character set of old GRPCKG
170C    routines (not used by PGPLOT routines).  Value copied from IMAGEN
171C    driver -- I assume this is a good value (PPM 871026).
172C
173   70 RBUF(1) = 8.0
174      NBUF=1
175      RETURN
176C
177C--- IFUNC = 8, Select plot --------------------------------------------
178C    Future option, nothing done yet.  (Multiple devices open at one
179C    time will be allowed later; this opcode will select active device).
180C
181   80 CONTINUE
182      RETURN
183C
184C--- IFUNC = 9, Open workstation ---------------------------------------
185C
186   90 CONTINUE
187C
188C     -- Get a Unit number.
189C
190      CALL GRGLUN(UNIT)
191C
192C     -- Open the file.
193C
194      NBUF = 2
195      RBUF(1) = UNIT
196      IER = GROPTX(UNIT, CHR(1:LCHR), DEFNAM, 1)
197      IF (IER.NE.0) THEN
198          TEMP = CHR(1:LCHR)
199          CALL GRWARN('Cannot open output file for QMS'//
200     :                ' plot: '//TEMP)
201          RBUF(2) = 0
202          CALL GRFLUN(UNIT)
203          RETURN
204      ELSE
205          INQUIRE (UNIT=UNIT, NAME=CHR)
206          LCHR = LEN(CHR)
207   91     IF (CHR(LCHR:LCHR).EQ.' ') THEN
208              LCHR = LCHR-1
209              GOTO 91
210          END IF
211          RBUF(2) = 1
212      END IF
213C
214C     -- initialization
215C
216      IC = 1
217      BUFFER = ' '
218      BUFLEN = 0
219      NPTS = 0
220      QXSCAL = 1.0
221      QYSCAL = 1.0
222      NOTHIN = .TRUE.
223C
224C     -- Initialize QUIC, get into free format, out of other possible
225C     -- modes (vector graphics, word processing), reset interpretation:
226C     -- Set landscape/portrait mode, set margins, enter vector
227C        graphics mode
228C
229      BUFLEN = 1
230      CALL GRQM00 (UNIT, BUFFER, BUFLEN)
231      BUFFER = '^PY^-'
232      BUFLEN = 5
233      CALL GRQM00 (UNIT, BUFFER, BUFLEN)
234      BUFFER(1:38)  = '^F^IGE^G^IWE^G^IP0000^G^ISYNTAX00000^G'
235      IF (MODE.EQ.1) THEN
236          BUFFER(39:80) = '^IOL^G^IMH0050010750^G^IMV0050008250^G^IGV'
237      ELSE
238          BUFFER(39:80) = '^IOP^G^IMH0050008250^G^IMV0050010750^G^IGV'
239      END IF
240      BUFLEN = 80
241      CALL GRQM00 (UNIT, BUFFER, BUFLEN)
242      RETURN
243C
244C--- IFUNC=10, Close workstation ---------------------------------------
245C
246  100 CONTINUE
247      IF (NOTHIN) THEN
248C
249C        -- Nothing was plotted so no need to keep the file around.
250C
251         CLOSE (UNIT)
252C
253      ELSE
254C
255C        -- see if the last call was end picture; if so, remove formfeed
256C           (this assumes the printer/queue combination will supply the
257C            form feeds; if not, comment out this next line).
258C
259         IF (ENDFIL) BUFLEN = BUFLEN - 2
260C
261C        -- Flush out anything left in the buffer
262C
263         IF (BUFLEN .GT. 0) CALL GRQM00 (UNIT, BUFFER, BUFLEN)
264C
265C        -- Don't need to formfeed; end picture will do that.
266C
267         BUFFER = '^IGE^G^O^-'
268         BUFLEN = 10
269         CALL GRQM00 (UNIT, BUFFER, BUFLEN)
270         BUFFER = '^PN^-'
271         BUFLEN = 5
272         CALL GRQM00 (UNIT, BUFFER, BUFLEN)
273         CLOSE (UNIT, STATUS='KEEP')
274      ENDIF
275C
276C     -- Return UNIT to free pool.
277C
278      CALL GRFLUN(UNIT)
279      RETURN
280C
281C--- IFUNC=11, Begin picture and possibly rescale -----------------------
282C
283  110 CONTINUE
284      ENDFIL = .FALSE.
285      IF (MODE.EQ.1) THEN
286          QXSCAL = MIN (1., RBUF(1) / QXSIZE)
287          QYSCAL = MIN (1., RBUF(2) / QYSIZE)
288      ELSE
289          QXSCAL = MIN (1., RBUF(2) / QXSIZE)
290          QYSCAL = MIN (1., RBUF(1) / QYSIZE)
291      END IF
292      RETURN
293C
294C--- IFUNC=12, Draw line -----------------------------------------------
295C    When I copied the Imagen driver, I got output backwards in the
296C    X direction (mirrored).  Hence I mirror it back now.
297C
298  120 CONTINUE
299      IF (NOTHIN) NOTHIN = .FALSE.
300      IF (IC.EQ.0) RETURN
301      IF (MODE.EQ.1) THEN
302          I0 = NINT((QXSIZE - RBUF(1)) * QXSCAL)
303          J0 = NINT(RBUF(2) * QYSCAL)
304          I1 = NINT((QXSIZE - RBUF(3)) * QXSCAL)
305          J1 = NINT(RBUF(4) * QYSCAL)
306      ELSE
307          I0 = NINT(RBUF(1) * QYSCAL)
308          J0 = NINT((QXSIZE - RBUF(2)) * QXSCAL)
309          I1 = NINT(RBUF(3) * QYSCAL)
310          J1 = NINT((QXSIZE - RBUF(4)) * QXSCAL)
311      END IF
312  125 CONTINUE
313      IF (BUFLEN+13 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN)
314      BUFFER(BUFLEN+1:BUFLEN+2) = '^U'
315      WRITE (BUFFER(BUFLEN+3:BUFLEN+13), '(I5.5,1H:,I5.5)') I0, J0
316      BUFLEN = BUFLEN + 13
317      IF (BUFLEN+13 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN)
318      BUFFER(BUFLEN+1:BUFLEN+2) = '^D'
319      WRITE (BUFFER(BUFLEN+3:BUFLEN+13), '(I5.5,1H:,I5.5)') I1, J1
320      BUFLEN = BUFLEN + 13
321      RETURN
322C
323C--- IFUNC=13, Draw dot ------------------------------------------------
324C    QUIC takes care of dot size by the ^PW (pen width) command so we
325C    don't have to worry about it here.  Just draw to same point and
326C    let the "draw line" code handle it.
327C
328  130 CONTINUE
329      IF (NOTHIN) NOTHIN = .FALSE.
330      IF (IC.EQ.0) RETURN
331      IF (MODE.EQ.1) THEN
332          I0 = NINT((QXSIZE - RBUF(1)) * QXSCAL)
333          J0 = NINT(RBUF(2) * QYSCAL)
334      ELSE
335          I0 = NINT(RBUF(1) * QYSCAL)
336          J0 = NINT((QXSIZE - RBUF(2)) * QXSCAL)
337      END IF
338      I1 = I0
339      J1 = J0
340      GOTO 125
341C
342C--- IFUNC=14, End picture ---------------------------------------------
343C    This means do a form feed.  QUIC allows form feeds within vector
344C    graphics mode so just put it in the stream.
345C    Changed 871103 [PPM] so that no formfeed done if "NOTHIN" is true.
346C    That means there is nothing on the paper.
347C    Changed again (same date, person): set flag for end workstation
348C
349  140 CONTINUE
350      ENDFIL = .TRUE.
351      IF (.NOT. NOTHIN) THEN
352         IF (BUFLEN+2 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN)
353         BUFFER(BUFLEN+1:BUFLEN+2) = '^,'
354         BUFLEN = BUFLEN + 2
355      ENDIF
356      RETURN
357C
358C--- IFUNC=15, Select color index --------------------------------------
359C
360  150 CONTINUE
361      IC = RBUF(1)
362      IF (IC.LT.0 .OR. IC.GT.1) THEN
363          IC = 1
364          RBUF(1) = IC
365      END IF
366      RETURN
367C
368C--- IFUNC=16, Flush buffer. -------------------------------------------
369C    Hardcopy so ignore it
370C
371  160 CONTINUE
372C     CALL GRQM00 (UNIT, BUFFER, BUFLEN) Not needed!
373      RETURN
374C
375C--- IFUNC=17, Read cursor. --------------------------------------------
376C           Not implemented, hardcopy device.  Return error code.
377C
378  170 CONTINUE
379      GOTO 900
380C
381C--- IFUNC=18, Erase alpha screen. -------------------------------------
382C    (Not implemented: no alpha screen so ignore it).
383C
384  180 CONTINUE
385      RETURN
386C
387C--- IFUNC=19, Set line style. -----------------------------------------
388C
389  190 CONTINUE
390      ISTYLE = NINT(RBUF(1))
391      IF (ISTYLE .LT. 1) ISTYLE = 1
392      IF (ISTYLE .GT. 5) ISTYLE = 5
393C
394C     -- Convert PGPLOT line styles 1 thru 5 to QUIC equivalents
395C
396      GOTO (191,192,193,194,195) ISTYLE
397C
398C     Select ISTYLE in CASE:
399C     Full line
400  191    ISTYLE = 0
401         GOTO 196
402C     Long dashes
403  192    ISTYLE = 1
404         GOTO 196
405C     Dash-dot
406  193    ISTYLE = 7
407         GOTO 196
408C     Dotted
409  194    ISTYLE = 2
410         GOTO 196
411C     Dash-dot-dot-dot
412  195    ISTYLE = 9
413         GOTO 196
414C     End SELECT/CASE on ISTYLE
415  196 CONTINUE
416C
417C     -- I use HEXSTR here for system-independence and also in case the
418C     -- PGPLOT package ever adds more line styles.
419C
420      IF (BUFLEN+3 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN)
421      BUFFER(BUFLEN+1:BUFLEN+2) = '^V'
422      ISTYLE = ISTYLE + 1
423      BUFFER(BUFLEN+3:BUFLEN+3) = HEXSTR(ISTYLE:ISTYLE)
424      BUFLEN = BUFLEN + 3
425      RETURN
426C
427C--- IFUNC=20, Polygon fill. -------------------------------------------
428C
429  200 CONTINUE
430      IF (IC .EQ. 0) RETURN
431C
432C     -- Use NPTS as our indicator of whether this is first time or not
433C
434      IF (NPTS.EQ.0) THEN
435C
436C        -- First time so set number of points in polygon
437C
438         NPTS = RBUF(1)
439         IF (BUFLEN+8 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN)
440C
441C        -- Use black fill, no border (in case PGPLOT doesn't go back to
442C           the last point) --------------------------------------------
443C
444         BUFFER (BUFLEN+1:BUFLEN+8) = '^PF020^U'
445         BUFLEN = BUFLEN + 8
446      ELSE
447C
448C        -- Second or other time so bump NPTS and draw to next vertex
449C
450         IF (NOTHIN) NOTHIN = .FALSE.
451         NPTS = NPTS - 1
452         IF (MODE.EQ.1) THEN
453             I0 = NINT((QXSIZE - RBUF(1)) * QXSCAL)
454             J0 = NINT(RBUF(2) * QYSCAL)
455         ELSE
456             I0 = NINT(RBUF(1) * QYSCAL)
457             J0 = NINT((QXSIZE - RBUF(2)) * QXSCAL)
458         END IF
459         IF (BUFLEN+13 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN)
460         WRITE (BUFFER(BUFLEN+1:BUFLEN+11), '(I5.5,1H:,I5.5)') I0, J0
461         BUFFER(BUFLEN+12:BUFLEN+13) = '^D'
462         BUFLEN = BUFLEN + 13
463         IF (NPTS .EQ. 0) THEN
464C
465C           -- get rid of last ^D and give the Polygon fill command
466C
467            BUFLEN = BUFLEN - 2
468            BUFFER(BUFLEN+1:BUFLEN+2) = '  '
469            IF (BUFLEN+3 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN)
470            BUFFER(BUFLEN+1:BUFLEN+3) = '^PS'
471            BUFLEN = BUFLEN + 3
472         END IF
473      END IF
474      RETURN
475C
476C--- IFUNC=21, Set color representation. -------------------------------
477C    (Not implemented: ignored.  Will we ever get color laser printers?)
478C
479  210 CONTINUE
480      RETURN
481C
482C--- IFUNC=22, Set line width. -----------------------------------------
483C
484  220 CONTINUE
485C
486C     -- QUIC pen width is in dots (1/300 inch) so convert from 1/200's.
487C
488      LINWID = NINT(RBUF(1) * 1.5)
489      IF (LINWID .LT. 1) LINWID = 1
490      IF (LINWID .GT. 31) LINWID = 31
491      IF (BUFLEN+5 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN)
492      BUFFER(BUFLEN+1:BUFLEN+3) = '^PW'
493      WRITE (BUFFER(BUFLEN+4:BUFLEN+5), '(I2.2)') LINWID
494      BUFLEN = BUFLEN + 5
495      RETURN
496C
497C--- IFUNC=23, Escape --------------------------------------------------
498C    Note that the NOTHIN flag which indicates if there is anything
499C    written on the paper is set here regardless of the content of
500C    the escape characters.
501C
502  230 CONTINUE
503      IF (NOTHIN) NOTHIN = .FALSE.
504      IF (LCHR .GT. MAXLEN) THEN
505         WRITE (MSG(1:4), '(I4)') MAXLEN
506         CALL GRWARN('Sorry, maximum line size ('//MSG(1:4)//
507     :               ') exceeded for device type QMS')
508         NBUF = -1
509      ELSE
510C
511C        -- WARNING!  Anyone using the escape mechanism to send stuff
512C           to the QMS had better remember (a) the QMS is ASSUMED by
513C           the driver to be in vector graphics mode, and (b) you better
514C           darn well put it back in the same vector mode!!!  If not,
515C           well, you get what you deserve then.
516C
517         IF (BUFLEN+LCHR .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN)
518         BUFFER(BUFLEN+1:BUFLEN+LCHR) = CHR(1:LCHR)
519         BUFLEN = BUFLEN + LCHR
520      ENDIF
521C
522      RETURN
523C-----------------------------------------------------------------------
524      END
525
526C*GRQM00 -- PGPLOT QMS/QUIC driver, flush buffer
527C+
528      SUBROUTINE GRQM00 (LUN, BUF, SIZ)
529      CHARACTER*(*) BUF
530      INTEGER LUN, SIZ
531C--
532      WRITE (LUN, '(A)') BUF(1:SIZ)
533      BUF(1:LEN(BUF)) = ' '
534      SIZ = 0
535      END
536