C*GRQM00 -- PGPLOT QMS/QUIC driver

      SUBROUTINE    QMDRIV (IFUNC, RBUF, NBUF, CHR, LCHR, MODE)
      INTEGER       IFUNC, NBUF, LCHR, MODE
      REAL          RBUF(*)
      CHARACTER*(*) CHR
C-----------------------------------------------------------------------
C PGPLOT driver for QUIC devices (QMS and Talaris 800/1200/1500/2400)
C-----------------------------------------------------------------------
C Version 0.1  - 1987 Oct 22 - Patrick P. Murphy, NRAO/VLA [PPM]
C Version 0.2  - 1987 Oct 28 - [PPM] Fix backwards and scale bugs
C Version 1.0  - 1987 Nov 03 - [PPM] Don't form feed if nothing drawn.
C Version 1.1  - 1987 Nov 03 - [PPM] No formfeed at very end of file
C Version 2.0  - 1987 Nov 18 - [PPM] Get scaling done right.
C Version 2.1  - 1991 Jun 28 - [TJP] Standardization.
C Version 2.2  - 1991 Nov  6 - [TJP] Standardization.
C Version 3.0  - 1994 Feb 25 - [TJP] Combine portrait and landscape
C                                    modes in one file.
C-----------------------------------------------------------------------
C
C Supported device: Any QMS or Talaris printer that accepts the QUIC 
C                   page description language.  4-bit mode is used.
C
C Device type code: /QMS (landscape mode 1)
C                   /VQMS (portrait mode 2)
C
C Default file name: PGPLOT.QMPLOT.
C
C Default view surface dimensions:
C      10.25 inches horizontal x  7.75 inches vertical (landscape mode), 
C       7.75 inches horizontal x 10.25 inches vertical (portrait mode),
C      margins of 0.5 inches on top and left of page.
C
C Resolution: The driver uses coordinate increments of 1/1000 inch.
C             The true resolution is device-dependent; at time of
C             writing, it is typically 300 dots per inch.
C
C Color capability: Color indices 0 (erase), and 1 (black) are 
C                   supported.  Requests for other color indices are
C                   converted to 1.  It is not possible to change color
C                   representation. 
C
C Input capability: None.
C
C File format: Ascii, variable length records (max 130 bytes); carriage
C              return ("LIST") carriage control.  This length can be
C              easily changed if needed.
C
C Obtaining hardcopy:  send the file to an appropriate printer.
C-----------------------------------------------------------------------
C
      CHARACTER*(*) DEVTPL, DEVTPP, DEFNAM
      PARAMETER    (DEFNAM='PGPLOT.QMPLOT')
      PARAMETER (DEVTPL='QMS   (QUIC/QMS file, landscape orientation)')
      PARAMETER (DEVTPP='VQMS  (QUIC/QMS file, portrait orientation)')
C
      CHARACTER*130 BUFFER
      CHARACTER*16  HEXSTR
      CHARACTER*10  MSG
      CHARACTER*40  TEMP
      INTEGER       UNIT, IER, BUFLEN, MAXLEN, I0, J0, I1, J1, NPTS, IC,
     :              ISTYLE, LINWID, GROPTX
      REAL          QXSIZE, QYSIZE, QXSCAL, QYSCAL
      LOGICAL       NOTHIN, ENDFIL
C
C ---- Change MAXLEN if you want a shorter or longer max output line 
C ---- length.  Also change the declared length of BUFFER too!  The
C ---- Q*SIZE parameters are the physical size of the plot (used more
C ---- than once here) in resolution units (1/1000 inch).  The Q*SCAL 
C ---- parameters are PGPLOT-modifiable scale factors.
C
      PARAMETER    (MAXLEN = 130,
     :              QXSIZE = 10250.0,
     :              QYSIZE = 7750.00)
C
      SAVE UNIT, IC, BUFFER, BUFLEN, NPTS, QXSCAL, QYSCAL, NOTHIN,
     :     ENDFIL
C
      DATA HEXSTR /'0123456789ABCDEF'/
C
C=======================================================================
C
C ---- Do the best one can in F77 for a "case" statement. --------------
C
      GOTO( 10, 20, 30, 40, 50, 60, 70, 80, 90,100,
     1     110,120,130,140,150,160,170,180,190,200,
     2     210,220,230), IFUNC
C
C ---- Unknown opcode/function; most likely a logic error somewhere ----
C
  900 WRITE (MSG,'(I10)') IFUNC
      CALL GRWARN('Unimplemented function in QMS'//
     :            ' device driver:'//MSG)
      NBUF = -1
      RETURN
C
C--- IFUNC = 1, Return device name -------------------------------------
C
   10 IF (MODE.EQ.1) THEN
          CHR = DEVTPL
          LCHR = LEN(DEVTPL)
      ELSE IF (MODE.EQ.2) THEN
          CHR = DEVTPP
          LCHR = LEN(DEVTPP)
      ELSE
          CALL GRWARN('Internal error in QMDRIV')
      END IF
      RETURN
C
C--- IFUNC = 2, Return physical min and max for plot device, and range
C               of color indices ---------------------------------------
C               Units are in device co-ordinates (1/1000 inches)
C
   20 IF (MODE.EQ.1) THEN
          RBUF(2) = QXSIZE
          RBUF(4) = QYSIZE
      ELSE
          RBUF(2) = QYSIZE
          RBUF(4) = QXSIZE
      END IF
      RBUF(1) = 0.0
      RBUF(3) = 0.0
      RBUF(5) = 0.0
      RBUF(6) = 1.0
      NBUF = 6
      RETURN
C
C--- IFUNC = 3, Return device resolution -------------------------------
C    (Nominal values)
C
   30 RBUF(1) = 1000.0
      RBUF(2) = 1000.0
C
C      (multiple strokes are spaced by 3.333 pixels, or 1/300 inch)
C
      RBUF(3) = 3.333
      NBUF = 3
      RETURN
C
C--- IFUNC = 4, Return misc device info --------------------------------
C    (Hardcopy, No cursor, Dashed lines, Area fill, Thick lines) 
C
   40 CHR = 'HNDATNNNNN'
      LCHR = 10
      RETURN
C
C--- IFUNC = 5, Return default file name -------------------------------
C
   50 CHR  = DEFNAM
      LCHR = LEN(DEFNAM)
      RETURN
C
C--- IFUNC = 6, Return default physical size of plot -------------------
C    (in device coordinates).
C
   60 IF (MODE.EQ.1) THEN
          RBUF(2) = QXSIZE
          RBUF(4) = QYSIZE
      ELSE
          RBUF(2) = QYSIZE
          RBUF(4) = QXSIZE
      END IF
      RBUF(1) = 0.0
      RBUF(3) = 0.0
      NBUF = 4
      RETURN
C
C--- IFUNC = 7, Return misc defaults -----------------------------------
C    Currently scale factor for "obsolete" character set of old GRPCKG
C    routines (not used by PGPLOT routines).  Value copied from IMAGEN
C    driver -- I assume this is a good value (PPM 871026).
C
   70 RBUF(1) = 8.0
      NBUF=1
      RETURN
C
C--- IFUNC = 8, Select plot --------------------------------------------
C    Future option, nothing done yet.  (Multiple devices open at one 
C    time will be allowed later; this opcode will select active device).
C
   80 CONTINUE
      RETURN
C
C--- IFUNC = 9, Open workstation ---------------------------------------
C
   90 CONTINUE
C
C     -- Get a Unit number.  
C
      CALL GRGLUN(UNIT)
C
C     -- Open the file.
C
      NBUF = 2
      RBUF(1) = UNIT
      IER = GROPTX(UNIT, CHR(1:LCHR), DEFNAM, 1)
      IF (IER.NE.0) THEN
          TEMP = CHR(1:LCHR)
          CALL GRWARN('Cannot open output file for QMS'//
     :                ' plot: '//TEMP)
          RBUF(2) = 0
          CALL GRFLUN(UNIT)
          RETURN
      ELSE
          INQUIRE (UNIT=UNIT, NAME=CHR)
          LCHR = LEN(CHR)
   91     IF (CHR(LCHR:LCHR).EQ.' ') THEN
              LCHR = LCHR-1
              GOTO 91
          END IF
          RBUF(2) = 1
      END IF
C
C     -- initialization
C
      IC = 1
      BUFFER = ' '
      BUFLEN = 0
      NPTS = 0
      QXSCAL = 1.0
      QYSCAL = 1.0
      NOTHIN = .TRUE.
C
C     -- Initialize QUIC, get into free format, out of other possible 
C     -- modes (vector graphics, word processing), reset interpretation:
C     -- Set landscape/portrait mode, set margins, enter vector
C        graphics mode
C
      BUFLEN = 1
      CALL GRQM00 (UNIT, BUFFER, BUFLEN)
      BUFFER = '^PY^-'
      BUFLEN = 5
      CALL GRQM00 (UNIT, BUFFER, BUFLEN)
      BUFFER(1:38)  = '^F^IGE^G^IWE^G^IP0000^G^ISYNTAX00000^G'
      IF (MODE.EQ.1) THEN
          BUFFER(39:80) = '^IOL^G^IMH0050010750^G^IMV0050008250^G^IGV'
      ELSE
          BUFFER(39:80) = '^IOP^G^IMH0050008250^G^IMV0050010750^G^IGV'
      END IF
      BUFLEN = 80
      CALL GRQM00 (UNIT, BUFFER, BUFLEN)
      RETURN
C
C--- IFUNC=10, Close workstation ---------------------------------------
C
  100 CONTINUE
      IF (NOTHIN) THEN
C
C        -- Nothing was plotted so no need to keep the file around.
C
         CLOSE (UNIT)
C
      ELSE
C
C        -- see if the last call was end picture; if so, remove formfeed
C           (this assumes the printer/queue combination will supply the
C            form feeds; if not, comment out this next line).
C
         IF (ENDFIL) BUFLEN = BUFLEN - 2
C
C        -- Flush out anything left in the buffer
C
         IF (BUFLEN .GT. 0) CALL GRQM00 (UNIT, BUFFER, BUFLEN)
C
C        -- Don't need to formfeed; end picture will do that.
C
         BUFFER = '^IGE^G^O^-'
         BUFLEN = 10
         CALL GRQM00 (UNIT, BUFFER, BUFLEN)
         BUFFER = '^PN^-'
         BUFLEN = 5
         CALL GRQM00 (UNIT, BUFFER, BUFLEN)
         CLOSE (UNIT, STATUS='KEEP')
      ENDIF
C
C     -- Return UNIT to free pool.
C
      CALL GRFLUN(UNIT)
      RETURN
C
C--- IFUNC=11, Begin picture and possibly rescale -----------------------
C
  110 CONTINUE
      ENDFIL = .FALSE.
      IF (MODE.EQ.1) THEN
          QXSCAL = MIN (1., RBUF(1) / QXSIZE)
          QYSCAL = MIN (1., RBUF(2) / QYSIZE)
      ELSE
          QXSCAL = MIN (1., RBUF(2) / QXSIZE)
          QYSCAL = MIN (1., RBUF(1) / QYSIZE)
      END IF
      RETURN
C
C--- IFUNC=12, Draw line -----------------------------------------------
C    When I copied the Imagen driver, I got output backwards in the
C    X direction (mirrored).  Hence I mirror it back now.
C
  120 CONTINUE
      IF (NOTHIN) NOTHIN = .FALSE.
      IF (IC.EQ.0) RETURN
      IF (MODE.EQ.1) THEN
          I0 = NINT((QXSIZE - RBUF(1)) * QXSCAL)
          J0 = NINT(RBUF(2) * QYSCAL)
          I1 = NINT((QXSIZE - RBUF(3)) * QXSCAL)
          J1 = NINT(RBUF(4) * QYSCAL)
      ELSE
          I0 = NINT(RBUF(1) * QYSCAL)
          J0 = NINT((QXSIZE - RBUF(2)) * QXSCAL)
          I1 = NINT(RBUF(3) * QYSCAL)
          J1 = NINT((QXSIZE - RBUF(4)) * QXSCAL)
      END IF
  125 CONTINUE
      IF (BUFLEN+13 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN)
      BUFFER(BUFLEN+1:BUFLEN+2) = '^U'
      WRITE (BUFFER(BUFLEN+3:BUFLEN+13), '(I5.5,1H:,I5.5)') I0, J0
      BUFLEN = BUFLEN + 13
      IF (BUFLEN+13 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN)
      BUFFER(BUFLEN+1:BUFLEN+2) = '^D'
      WRITE (BUFFER(BUFLEN+3:BUFLEN+13), '(I5.5,1H:,I5.5)') I1, J1
      BUFLEN = BUFLEN + 13
      RETURN
C
C--- IFUNC=13, Draw dot ------------------------------------------------
C    QUIC takes care of dot size by the ^PW (pen width) command so we 
C    don't have to worry about it here.  Just draw to same point and
C    let the "draw line" code handle it.
C
  130 CONTINUE
      IF (NOTHIN) NOTHIN = .FALSE.
      IF (IC.EQ.0) RETURN
      IF (MODE.EQ.1) THEN
          I0 = NINT((QXSIZE - RBUF(1)) * QXSCAL)
          J0 = NINT(RBUF(2) * QYSCAL)
      ELSE
          I0 = NINT(RBUF(1) * QYSCAL)
          J0 = NINT((QXSIZE - RBUF(2)) * QXSCAL)
      END IF
      I1 = I0
      J1 = J0
      GOTO 125
C
C--- IFUNC=14, End picture ---------------------------------------------
C    This means do a form feed.  QUIC allows form feeds within vector
C    graphics mode so just put it in the stream.
C    Changed 871103 [PPM] so that no formfeed done if "NOTHIN" is true.
C    That means there is nothing on the paper.
C    Changed again (same date, person): set flag for end workstation
C
  140 CONTINUE
      ENDFIL = .TRUE.
      IF (.NOT. NOTHIN) THEN
         IF (BUFLEN+2 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN)
         BUFFER(BUFLEN+1:BUFLEN+2) = '^,'
         BUFLEN = BUFLEN + 2
      ENDIF
      RETURN
C
C--- IFUNC=15, Select color index --------------------------------------
C
  150 CONTINUE
      IC = RBUF(1)
      IF (IC.LT.0 .OR. IC.GT.1) THEN
          IC = 1
          RBUF(1) = IC
      END IF
      RETURN
C
C--- IFUNC=16, Flush buffer. -------------------------------------------
C    Hardcopy so ignore it
C
  160 CONTINUE
C     CALL GRQM00 (UNIT, BUFFER, BUFLEN) Not needed!
      RETURN
C
C--- IFUNC=17, Read cursor. --------------------------------------------
C           Not implemented, hardcopy device.  Return error code.
C
  170 CONTINUE
      GOTO 900
C
C--- IFUNC=18, Erase alpha screen. -------------------------------------
C    (Not implemented: no alpha screen so ignore it).
C
  180 CONTINUE
      RETURN
C
C--- IFUNC=19, Set line style. -----------------------------------------
C
  190 CONTINUE
      ISTYLE = NINT(RBUF(1))
      IF (ISTYLE .LT. 1) ISTYLE = 1
      IF (ISTYLE .GT. 5) ISTYLE = 5
C
C     -- Convert PGPLOT line styles 1 thru 5 to QUIC equivalents
C
      GOTO (191,192,193,194,195) ISTYLE
C
C     Select ISTYLE in CASE:
C     Full line
  191    ISTYLE = 0
         GOTO 196
C     Long dashes
  192    ISTYLE = 1
         GOTO 196
C     Dash-dot
  193    ISTYLE = 7
         GOTO 196
C     Dotted
  194    ISTYLE = 2
         GOTO 196
C     Dash-dot-dot-dot
  195    ISTYLE = 9
         GOTO 196
C     End SELECT/CASE on ISTYLE
  196 CONTINUE
C
C     -- I use HEXSTR here for system-independence and also in case the
C     -- PGPLOT package ever adds more line styles.
C
      IF (BUFLEN+3 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN)
      BUFFER(BUFLEN+1:BUFLEN+2) = '^V'
      ISTYLE = ISTYLE + 1
      BUFFER(BUFLEN+3:BUFLEN+3) = HEXSTR(ISTYLE:ISTYLE)
      BUFLEN = BUFLEN + 3
      RETURN
C
C--- IFUNC=20, Polygon fill. -------------------------------------------
C
  200 CONTINUE
      IF (IC .EQ. 0) RETURN
C
C     -- Use NPTS as our indicator of whether this is first time or not
C
      IF (NPTS.EQ.0) THEN
C
C        -- First time so set number of points in polygon
C
         NPTS = RBUF(1)
         IF (BUFLEN+8 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN)
C
C        -- Use black fill, no border (in case PGPLOT doesn't go back to
C           the last point) --------------------------------------------
C
         BUFFER (BUFLEN+1:BUFLEN+8) = '^PF020^U'
         BUFLEN = BUFLEN + 8
      ELSE
C
C        -- Second or other time so bump NPTS and draw to next vertex
C
         IF (NOTHIN) NOTHIN = .FALSE.
         NPTS = NPTS - 1
         IF (MODE.EQ.1) THEN
             I0 = NINT((QXSIZE - RBUF(1)) * QXSCAL)
             J0 = NINT(RBUF(2) * QYSCAL)
         ELSE
             I0 = NINT(RBUF(1) * QYSCAL)
             J0 = NINT((QXSIZE - RBUF(2)) * QXSCAL)
         END IF
         IF (BUFLEN+13 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN)
         WRITE (BUFFER(BUFLEN+1:BUFLEN+11), '(I5.5,1H:,I5.5)') I0, J0
         BUFFER(BUFLEN+12:BUFLEN+13) = '^D'
         BUFLEN = BUFLEN + 13
         IF (NPTS .EQ. 0) THEN
C
C           -- get rid of last ^D and give the Polygon fill command
C
            BUFLEN = BUFLEN - 2
            BUFFER(BUFLEN+1:BUFLEN+2) = '  '
            IF (BUFLEN+3 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN)
            BUFFER(BUFLEN+1:BUFLEN+3) = '^PS'
            BUFLEN = BUFLEN + 3
         END IF
      END IF
      RETURN
C
C--- IFUNC=21, Set color representation. -------------------------------
C    (Not implemented: ignored.  Will we ever get color laser printers?)
C
  210 CONTINUE
      RETURN
C
C--- IFUNC=22, Set line width. -----------------------------------------
C
  220 CONTINUE
C
C     -- QUIC pen width is in dots (1/300 inch) so convert from 1/200's.
C
      LINWID = NINT(RBUF(1) * 1.5)
      IF (LINWID .LT. 1) LINWID = 1
      IF (LINWID .GT. 31) LINWID = 31
      IF (BUFLEN+5 .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN)
      BUFFER(BUFLEN+1:BUFLEN+3) = '^PW'
      WRITE (BUFFER(BUFLEN+4:BUFLEN+5), '(I2.2)') LINWID
      BUFLEN = BUFLEN + 5
      RETURN
C
C--- IFUNC=23, Escape --------------------------------------------------
C    Note that the NOTHIN flag which indicates if there is anything 
C    written on the paper is set here regardless of the content of
C    the escape characters.
C
  230 CONTINUE
      IF (NOTHIN) NOTHIN = .FALSE.
      IF (LCHR .GT. MAXLEN) THEN
         WRITE (MSG(1:4), '(I4)') MAXLEN
         CALL GRWARN('Sorry, maximum line size ('//MSG(1:4)//
     :               ') exceeded for device type QMS')
         NBUF = -1
      ELSE
C
C        -- WARNING!  Anyone using the escape mechanism to send stuff
C           to the QMS had better remember (a) the QMS is ASSUMED by 
C           the driver to be in vector graphics mode, and (b) you better
C           darn well put it back in the same vector mode!!!  If not, 
C           well, you get what you deserve then.
C
         IF (BUFLEN+LCHR .GE. MAXLEN) CALL GRQM00 (UNIT, BUFFER, BUFLEN)
         BUFFER(BUFLEN+1:BUFLEN+LCHR) = CHR(1:LCHR)
         BUFLEN = BUFLEN + LCHR
      ENDIF
C
      RETURN
C-----------------------------------------------------------------------
      END

C*GRQM00 -- PGPLOT QMS/QUIC driver, flush buffer
C+
      SUBROUTINE GRQM00 (LUN, BUF, SIZ)
      CHARACTER*(*) BUF
      INTEGER LUN, SIZ
C--
      WRITE (LUN, '(A)') BUF(1:SIZ)
      BUF(1:LEN(BUF)) = ' '
      SIZ = 0
      END