C       Acorn Archimedes specific code
C  17 February 1994 version 1.00
C
C*GRSY00 -- initialize font definition
C+
      SUBROUTINE GRSY00
C
C This routine must be called once in order to initialize the tables
C defining the symbol numbers to be used for ASCII characters in each
C font, and to read the character digitization from a file.
C
C Arguments: none.
C
C Implicit input:
C  The file with name specified in environment variable PGPLOT_FONT
C  is read, if it is available.
C  This is a binary file containing two arrays INDEX and BUFFER.
C  The digitization of each symbol occupies a number of words in
C  the INTEGER*2 array BUFFER; the start of the digitization
C  for symbol number N is in BUFFER(INDEX(N)), where INDEX is an
C  integer array of 3000 elements. Not all symbols 1...3000 have
C  a representation; if INDEX(N) = 0, the symbol is undefined.
C
*  PGPLOT uses the Hershey symbols for two `primitive' operations:
*  graph markers and text.  The Hershey symbol set includes several
*  hundred different symbols in a digitized form that allows them to
*  be drawn with a series of vectors (polylines).
*
*  The digital representation of all the symbols is stored in common
*  block /GRSYMB/.  This is read from a disk file at run time. The
*  name of the disk file is specified in environment variable
*  PGPLOT_FONT.
*
* Modules:
*
* GRSY00 -- initialize font definition
* GRSYDS -- decode character string into list of symbol numbers
* GRSYMK -- convert marker number into symbol number
* GRSYXD -- obtain the polyline representation of a given symbol
*
* PGPLOT calls these routines as follows:
*
* Routine          Called by
*
* GRSY00          GROPEN
* GRSYDS          GRTEXT, GRLEN
* GRSYMK          GRMKER,
* GRSYXD          GRTEXT, GRLEN, GRMKER
***********************************************************************
C--
C (2-Jan-1984)
C 22-Jul-1984 - revise to use DATA statements [TJP].
C  5-Jan-1985 - make missing font file non-fatal [TJP].
C  9-Feb-1988 - change default file name to Unix name; overridden
C               by environment variable PGPLOT_FONT [TJP].
C 29-Nov-1990 - move font assignment to GRSYMK.
C  7-Nov-1994 - look for font file in PGPLOT_DIR if PGPLOT_FONT is
C               undefined [TJP].
C-----------------------------------------------------------------------
      INTEGER*2  BUFFER(27000)
      INTEGER    FNTFIL, IER, INDEX(3000), NC1, NC2, NC3
      INTEGER    L, GRTRIM
      COMMON     /GRSYMB/ NC1, NC2, INDEX, BUFFER
      CHARACTER*128 FF
C
C Read the font file. If an I/O error occurs, it is ignored; the
C effect will be that all symbols will be undefined (treated as
C blank spaces).
C
      CALL GRGFIL('FONT', FF)
      L = GRTRIM(FF)
      IF (L.LT.1) L = 1
      CALL GRGLUN(FNTFIL)
      OPEN (UNIT=FNTFIL, FILE=FF(1:L), FORM='UNFORMATTED',
     2      STATUS='OLD', IOSTAT=IER)
      IF (IER.EQ.0) READ (UNIT=FNTFIL, IOSTAT=IER)
     1            NC1,NC2,NC3,INDEX,BUFFER
      IF (IER.EQ.0) CLOSE (UNIT=FNTFIL, IOSTAT=IER)
      CALL GRFLUN(FNTFIL)
      IF (IER.NE.0) THEN
          CALL GRWARN('Unable to read font file: '//FF(:L))
          CALL GRWARN('Use environment variable PGPLOT_FONT to specify '
     :          //'the location of the PGPLOT grfont.dat file.')
      END IF
      RETURN
      END
C
C*GRFLUN -- free a Fortran logical unit number
C+
      SUBROUTINE GRFLUN(LUN)
      INTEGER LUN
C
C Free a Fortran logical unit number allocated by GRGLUN. [This version
C is pretty stupid; GRGLUN allocates units starting at 81, and GRFLUN
C does not free units.]
C
C Arguments:
C  LUN    : the logical unit number to free.
C--
C 25-Nov-1988
C-----------------------------------------------------------------------
      RETURN
      END
C*GRDATE -- get date and time as character string Archimedes
C+
      SUBROUTINE GRDATE(CDATE, LDATE)
      CHARACTER CDATE*(*), TEMP*18, FORM*23
      INTEGER   LDATE,IREGS(0:9),ITIME(2)
C                next card changed for Y2K   29 Aug 2000
      DATA FORM(1:22)/'%DY-%M3-%CE%YR %24:%MI'/
C
C Return the current date and time, in format 'dd-Mmm-yyyy hh:mm'.
C To receive the whole string, the CDATE should be declared
C CHARACTER*17.
C
C Arguments:
C  CDATE : receives date and time, truncated or extended with
C           blanks as necessary.
C  L      : receives the number of characters in STRING, excluding
C           trailing blanks. This will always be 17, unless the length
C           of the string supplied is shorter.
C--
C 1989-Mar-17 - [AFT]
C-----------------------------------------------------------------------
      FORM(23:23)=CHAR(0)
      ITIME(1) = 3
      CALL OSWORD(14,ITIME)
      IREGS(0)=LOC(ITIME)
      IREGS(1)=LOC(TEMP)
      IREGS(2)=18
      IREGS(3)=LOC(FORM)
      CALL ARCSWI('OS_ConvertDateAndTime',IREGS,IDUM,' ')
      CDATE=TEMP(1:17)
      LDATE=17
      RETURN
      END
C*GREXEC -- PGPLOT device handler dispatch routine
C+
      SUBROUTINE GREXEC(IDEV,IFUNC,RBUF,NBUF,CHR,LCHR)
      INTEGER IDEV, IFUNC, NBUF, LCHR
      REAL    RBUF(*)
      CHARACTER*(*) CHR
C
C---
      INTEGER NDEV
C            change the value of NDEV to reflect the number of
C            devices defined below by the 'computed GOTO'
C
C     February 1994   Version 1.00 has only NU, AC and PS drivers.
C                                  (The PS driver comes with 4 modes)
C
      PARAMETER (NDEV=3)
C      PARAMETER (NDEV=7)
      CHARACTER*10 MSG
C---
      GOTO(1,2,3,4,5,6,7) IDEV
      IF (IDEV.EQ.0) THEN
          RBUF(1) = NDEV
          NBUF = 1
      ELSE
          WRITE (MSG,'(I10)') IDEV
          CALL GRQUIT('Unknown device code in GREXEC: '//MSG)
      END IF
      RETURN
C---
    1 CALL NUDRIV(IFUNC,RBUF,NBUF,CHR,LCHR)
      RETURN
    2 CALL ACDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,1)
      RETURN
    3 CALL ACDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,2)
      RETURN
C    4 CALL PSDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,1)
C      RETURN
C    5 CALL PSDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,2)
C      RETURN
C    6 CALL PSDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,3)
C      RETURN
C    7 CALL PSDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,4)
C      RETURN
C
      END
C*GRGENV -- for Archimedes
      SUBROUTINE GRGENV(CNAME, CVALUE, LVALUE)
      CHARACTER CNAME*(*), CVALUE*(*)
      INTEGER   LVALUE
C
C Return the value of a PGPLOT environment parameter.
C
C Arguments:
C CNAME   : (input) the name of the parameter to evaluate.
C CVALUE  : receives the value of the parameter, truncated or extended
C           with blanks as necessary. If the parameter is undefined,
C           a blank string is returned.
C LVALUE  : receives the number of characters in CVALUE, excluding
C           trailing blanks. If the parameter is undefined, zero is
C           returned.
C--
C 1990-Mar-19 - [AFT]
C-----------------------------------------------------------------------
C
      CHARACTER*64 CTIN,CTOUT,ERTEXT
      INTEGER   I, LTMP,IREGS(0:9)
C
C         WRITE(*,*)' call to GRGENV looking for ',CNAME
      CTIN = 'PGPLOT_'//CNAME
      LTMP = INDEX(CTIN,' ')
      IF(LTMP.EQ.0) LTMP=LEN(CTIN)-1
C         WRITE(*,*)' CTIN=(',CTIN(1:LTMP),') length=',LTMP
      CTIN(LTMP:LTMP)=CHAR(0)
      IREGS(0)=LOC(CTIN)
      IREGS(1)=LOC(CTOUT)
      IREGS(2)=64
      IREGS(3)=0
      IREGS(4)=0
      CALL ARCSWI('OS_ReadVarVal',IREGS,IERR,ERTEXT)
      IF(IERR.NE.0) THEN
        LVALUE = 0
C         WRITE(*,*)' fail*** L=',IREGS(2),' CTOUT(1:4)=',CTOUT(1:4)
      ELSE
        LVALUE = IREGS(2)
        CVALUE = CTOUT(1:LVALUE)
C        WRITE(*,*)' LVALUE=',LVALUE,' CTOUT=',CTOUT(1:LVALUE)
      ENDIF
C      I=IGET()
C         L=IREGS(2)
C         IF(L.LT.1.OR.L.GT.4)L=4
C         WRITE(*,*)' LVALUE=',LVALUE,' CTOUT=',CTOUT(1:L)
      RETURN
      END
C*NUDRIV -- PGPLOT Null device driver
C+
      SUBROUTINE NUDRIV (IFUNC, RBUF, NBUF, CHR, LCHR)
      INTEGER IFUNC, NBUF, LCHR
      REAL    RBUF(*)
      CHARACTER*(*) CHR
C
C PGPLOT driver for Null device (no graphical output)
C
C Version 1.0  - 1987 May 26 - T. J. Pearson.
C Version 1.1  - 1988 Mar 23 - add rectangle fill.
C Version 1.2  - 1992 Sep  3 - add line-of-pixels.
C Version 1.3  - 1992 Sep 21 - add markers.
C Version 1.4  - 1993 Apr 22 - add optional debugging.
C Version 1.5  - 1994 Aug 31 - use image primitives.
C Version 2.0  - 1996 Jan 22 - allow multiple active devices;
C                              add QCR primitive.
C
C Supported device: The ``null'' device can be used to suppress
C all graphic output from a program.  If environment variable
C PGPLOT_DEBUG is defined, some debugging information is
C reported on standard output.
C
C Device type code: /NULL.
C
C Default device name: None (the device name, if specified, is 
C ignored).
C
C Default view surface dimensions: Undefined (The device pretends to
C be a hardcopy device with 1000 pixels/inch and a view surface 8in 
C high by 10.5in wide.)
C
C Resolution: Undefined.
C
C Color capability: Color indices 0--255 are accepted.
C
C Input capability: None.
C
C File format: None.
C
C Obtaining hardcopy: Not possible.
C-----------------------------------------------------------------------
C Notes:
C  Up to MAXDEV "devices" may be open at once. ACTIVE is the number
C  of the currently selected device, or 0 if no devices are open.
C  STATE(i) is 0 if device i is not open, 1 if it is open but with
C  no current picture, or 2 if it is open with a current picture.
C
C  When debugging is enabled, open/close device and begin/end picture
C  calls are reported on stdout, and a cumulative count of all
C  driver calls is kept.
C-----------------------------------------------------------------------
      CHARACTER*(*) DEVICE
      PARAMETER (DEVICE='NULL  (Null device, no output)')
      INTEGER MAXDEV
      PARAMETER (MAXDEV=8)
      INTEGER NOPCOD
      PARAMETER (NOPCOD=29)
      CHARACTER*10 MSG
      CHARACTER*32 TEXT
      CHARACTER*8  LAB(NOPCOD)
      INTEGER COUNT(NOPCOD), I, STATE(0:MAXDEV), L, NPIC(MAXDEV)
      INTEGER ACTIVE
      LOGICAL DEBUG
      INTEGER CTABLE(3,0:255), CDEFLT(3,0:15)
      SAVE COUNT, STATE, NPIC, DEBUG, CTABLE, CDEFLT, ACTIVE
C
      DATA ACTIVE/-1/
      DATA COUNT/NOPCOD*0/
      DATA DEBUG/.FALSE./
      DATA LAB  /'qdev    ', 'qmaxsize', 'qscale  ', 'qcapab  ',
     1           'qdefnam ', 'qdefsize', 'qmisc   ', 'select  ',
     2           'open    ', 'close   ', 'beginpic', 'line    ',
     3           'dot     ', 'endpic  ', 'set CI  ', 'flush   ',
     4           'cursor  ', 'eralpha ', 'set LS  ', 'polygon ',
     5           'set CR  ', 'set LW  ', 'escape  ', 'rectangl',
     6           'set patt', 'pix/imag', 'scaling ', 'marker  ',
     7           'query CR'/
      DATA CDEFLT /000,000,000, 255,255,255, 255,000,000, 000,255,000,
     1             000,000,255, 000,255,255, 255,000,255, 255,255,000,
     2             255,128,000, 128,255,000, 000,255,128, 000,128,255,
     3             128,000,255, 255,000,128, 085,085,085, 170,170,170/
C-----------------------------------------------------------------------
C
      IF (ACTIVE.EQ.-1) THEN
           CALL GRGENV('DEBUG', TEXT, L)
           DEBUG = L.GT.0
           ACTIVE = 0
           STATE(ACTIVE) = 0
      END IF
C
      IF (IFUNC.LT.1 .OR. IFUNC.GT.NOPCOD) GOTO 900
      COUNT(IFUNC) = COUNT(IFUNC) + 1
      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,240,250,260,270,280,290), IFUNC
  900 WRITE (MSG, '(I10)') IFUNC
      CALL GRWARN('Unimplemented function in NULL device driver: '//MSG)
      NBUF = -1
      RETURN
C
C--- IFUNC = 1, Return device name.-------------------------------------
C
   10 CHR = DEVICE
      LCHR = LEN(DEVICE)
      RETURN
C
C--- IFUNC = 2, Return physical min and max for plot device, and range
C               of color indices.---------------------------------------
C
   20 RBUF(1) = 0
      RBUF(2) = 65535
      RBUF(3) = 0
      RBUF(4) = 65535
      RBUF(5) = 0
      RBUF(6) = 255
      NBUF = 6
      RETURN
C
C--- IFUNC = 3, Return device resolution. ------------------------------
C
   30 RBUF(1) = 1000.0
      RBUF(2) = 1000.0
      RBUF(3) = 1
      NBUF = 3
      RETURN
C
C--- IFUNC = 4, Return misc device info. -------------------------------
C    (This device is Hardcopy, No cursor, Dashed lines, Area fill, Thick
C    lines, Rectangle fill, Images, , , Markers, query color rep)
C
   40 CHR = 'HNDATRQNYM'
      LCHR = 10
      RETURN
C
C--- IFUNC = 5, Return default file name. ------------------------------
C
   50 CHR = 'NL:'
      LCHR = 3
      RETURN
C
C--- IFUNC = 6, Return default physical size of plot. ------------------
C
   60 RBUF(1) = 0
      RBUF(2) = 10499
      RBUF(3) = 0
      RBUF(4) = 7999
      NBUF = 4
      RETURN
C
C--- IFUNC = 7, Return misc defaults. ----------------------------------
C
   70 RBUF(1) = 1
      NBUF = 1
      RETURN
C
C--- IFUNC = 8, Select plot. -------------------------------------------
C
   80 CONTINUE
      I = RBUF(2) - 67890
      IF (I.LT.1 .OR. I.GT.MAXDEV) THEN
         CALL GRWARN('internal error: NULL opcode 8')
      ELSE IF (STATE(I).GT.0) THEN
         ACTIVE = I
      ELSE
         CALL GRNU00(IFUNC,0)
      END IF
      RETURN
C
C--- IFUNC = 9, Open workstation. --------------------------------------
C
   90 CONTINUE
C     -- Find an inactive device, and select it
      DO 91 I=1,MAXDEV
         IF (STATE(I).EQ.0) THEN
            ACTIVE = I
            STATE(ACTIVE) = 1
            GOTO 92
         END IF
 91   CONTINUE
      IF (DEBUG) CALL GRWARN ('09 Open workstation')
      CALL GRWARN('maximum number of devices of type NULL exceeded')
      RBUF(1) = 0
      RBUF(2) = 0 
      NBUF = 2
      RETURN
C     -- Initialize the new device
 92   CONTINUE
      RBUF(1) = ACTIVE + 67890
      RBUF(2) = 1
      NBUF = 2
      NPIC(ACTIVE) = 0
C     -- Initialize color table
      DO 95 I=0,15
         CTABLE(1,I) = CDEFLT(1,I)
         CTABLE(2,I) = CDEFLT(2,I)
         CTABLE(3,I) = CDEFLT(3,I)
 95   CONTINUE
      DO 96 I=16,255
         CTABLE(1,I) = 128
         CTABLE(2,I) = 128
         CTABLE(3,I) = 128
 96   CONTINUE
      IF (DEBUG) THEN
         CALL GRFAO('09 Open workstation: device #',
     :        L, TEXT, ACTIVE, 0, 0, 0)
         CALL GRWARN(TEXT(1:L))
      END IF
      RETURN
C
C--- IFUNC=10, Close workstation. --------------------------------------
C
  100 CONTINUE
      IF (STATE(ACTIVE).NE.1) CALL GRNU00(IFUNC,STATE(ACTIVE))
      STATE(ACTIVE) = 0
      IF (DEBUG) THEN
         CALL GRFAO('10 Close workstation: device #',
     :        L, TEXT, ACTIVE, 0, 0, 0)
         CALL GRWARN(TEXT(1:L))
         CALL GRWARN('Device driver calls:')
         DO 101 I=1,NOPCOD
            IF (COUNT(I).GT.0) THEN
               WRITE (TEXT,'(3X,I2,1X,A8,I10)') I, LAB(I), COUNT(I)
               CALL GRWARN(TEXT)
            END IF
 101     CONTINUE
      END IF
      RETURN
C
C--- IFUNC=11, Begin picture. ------------------------------------------
C
  110 CONTINUE
      IF (STATE(ACTIVE).NE.1) CALL GRNU00(IFUNC,STATE(ACTIVE))
      STATE(ACTIVE) = 2
      NPIC(ACTIVE) = NPIC(ACTIVE)+1
      IF (DEBUG) THEN
         CALL GRFAO('11   Begin picture # on device #',
     :        L, TEXT, NPIC(ACTIVE), ACTIVE, 0,0)
         CALL GRWARN(TEXT(:L))
      END IF
      RETURN
C
C--- IFUNC=12, Draw line. ----------------------------------------------
C
  120 CONTINUE
      IF (STATE(ACTIVE).NE.2) CALL GRNU00(IFUNC,STATE(ACTIVE))
      RETURN
C
C--- IFUNC=13, Draw dot. -----------------------------------------------
C
  130 CONTINUE
      IF (STATE(ACTIVE).NE.2) CALL GRNU00(IFUNC,STATE(ACTIVE))
      RETURN
C
C--- IFUNC=14, End picture. --------------------------------------------
C
  140 CONTINUE
      IF (STATE(ACTIVE).NE.2) CALL GRNU00(IFUNC,STATE(ACTIVE))
      STATE(ACTIVE) = 1
      IF (DEBUG) THEN
         CALL GRFAO('14   End picture   # on device #',
     :        L, TEXT, NPIC(ACTIVE), ACTIVE, 0,0)
         CALL GRWARN(TEXT(:L))
      END IF
      RETURN
C
C--- IFUNC=15, Select color index. -------------------------------------
C
  150 CONTINUE
      IF (STATE(ACTIVE).NE.2) CALL GRNU00(IFUNC,STATE(ACTIVE))
      RETURN
C
C--- IFUNC=16, Flush buffer. -------------------------------------------
C
  160 CONTINUE
      IF (STATE(ACTIVE).LT.1) CALL GRNU00(IFUNC,STATE(ACTIVE))
      RETURN
C
C--- IFUNC=17, Read cursor. --------------------------------------------
C    (Not implemented: should not be called.)
C
  170 GOTO 900
C
C--- IFUNC=18, Erase alpha screen. -------------------------------------
C
  180 CONTINUE
      IF (STATE(ACTIVE).LT.1) CALL GRNU00(IFUNC,STATE(ACTIVE))
      RETURN
C
C--- IFUNC=19, Set line style. -----------------------------------------
C
  190 CONTINUE
      IF (STATE(ACTIVE).NE.2) CALL GRNU00(IFUNC,STATE(ACTIVE))
      RETURN
C
C--- IFUNC=20, Polygon fill. -------------------------------------------
C
  200 CONTINUE
      IF (STATE(ACTIVE).NE.2) CALL GRNU00(IFUNC,STATE(ACTIVE))
      RETURN
C
C--- IFUNC=21, Set color representation. -------------------------------
C
  210 CONTINUE
      IF (STATE(ACTIVE).LT.1) CALL GRNU00(IFUNC,STATE(ACTIVE))
      I = RBUF(1)
      CTABLE(1, I) = NINT(RBUF(2)*255)
      CTABLE(2, I) = NINT(RBUF(3)*255)
      CTABLE(3, I) = NINT(RBUF(4)*255)
      RETURN
C
C--- IFUNC=22, Set line width. -----------------------------------------
C
  220 CONTINUE
      IF (STATE(ACTIVE).NE.2) CALL GRNU00(IFUNC,STATE(ACTIVE))
      RETURN
C
C--- IFUNC=23, Escape. -------------------------------------------------
C
  230 CONTINUE
      RETURN
C
C--- IFUNC=24, Rectangle fill. -----------------------------------------
C
  240 CONTINUE
      IF (DEBUG.AND.STATE(ACTIVE).NE.2) CALL GRNU00(IFUNC,STATE(ACTIVE))
      RETURN
C
C--- IFUNC=25, Not implemented -----------------------------------------
C
  250 CONTINUE
      RETURN
C
C--- IFUNC=26, Line of pixels ------------------------------------------
C
  260 CONTINUE
      IF (STATE(ACTIVE).NE.2) CALL GRNU00(IFUNC,STATE(ACTIVE))
      RETURN
C
C--- IFUNC=27, Scaling info -- -----------------------------------------
C
  270 CONTINUE
      IF (STATE(ACTIVE).NE.2) CALL GRNU00(IFUNC,STATE(ACTIVE))
      RETURN
C
C--- IFUNC=28, Draw marker ---------------------------------------------
C
  280 CONTINUE
      IF (STATE(ACTIVE).NE.2) CALL GRNU00(IFUNC,STATE(ACTIVE))
C     WRITE (*,'(1X,A,I4,1X,3F10.1)') 'MARKER', NINT(RBUF(1)), RBUF(2),
C    1      RBUF(3), RBUF(4)
      RETURN
C
C--- IFUNC=29, Query color representation. -----------------------------
C
  290 CONTINUE
      IF (STATE(ACTIVE).LT.1) CALL GRNU00(IFUNC,STATE(ACTIVE))
      I = RBUF(1)
      RBUF(2) = CTABLE(1,I)/255.0
      RBUF(3) = CTABLE(2,I)/255.0
      RBUF(4) = CTABLE(3,I)/255.0
      NBUF = 4
      RETURN
C-----------------------------------------------------------------------
      END

      SUBROUTINE GRNU00(IFUNC, STATE)
      INTEGER IFUNC, STATE
C
C PGPLOT NULL device driver: report error
C-----------------------------------------------------------------------
      INTEGER L
      CHARACTER*80 MSG
C
      CALL GRFAO('++ internal error: driver in state # for opcode #',
     :           L, MSG, STATE, IFUNC, 0, 0)
      CALL GRWARN(MSG(1:L))
      RETURN
      END
C*ACDRIV -- PGPLOT device driver for Acorn Archimedes machines
C+
      SUBROUTINE ACDRIV (IFUNC, RBUF, NBUF, CHR, LCHR, MTYPE)
      INTEGER IFUNC, NBUF, LCHR, MTYPE
      REAL    RBUF(*)
      CHARACTER*(*) CHR, DEFNAM
C
C PGPLOT driver for Acorn Archimedes
C This driver will cause the system to leave the Desktop, but leave the 
C screen mode provided it has the normal 16 colours
C
C This routine must be compiled with Acorn Fortran release 2
C and linked with the Fortran Friends graphics, utils and spriteop libraries.
C
C 26 January 1996 : Version 1.10
C 16 May 1996     : Version 1.11 allows concurrent /ARCF and ARCV
C
C Resolution: Depends on graphics mode. Ensure that the current mode is
C suitable before running the PGPLOT program.
C
C version 1.10 also allows the making of the pictures into sprite files
C the default sprite size is the screen size but you may alter the
C number of pixels in x and y with the variables:
C PGPLOT_ARC_WIDTH and PGPLOT_ARC_HEIGHT
C the file names will be sprite/01, sprite/02 etc.
      PARAMETER (DEFNAM='sprite/')
C
C 26 April 1996 : Version 1.11 (changes to /ARCV)
C               - small corrections to the initial screen clearing
C               - allows standard PGPLOT rubber-banded cursors
C---
C             common for communicating with rubber banding GRARC3
      COMMON /GRARCC/ MAXX(2), MAXY(2), I4X0, I4Y0, I4X1, I4Y1, I4MODE
      INTEGER         MAXX,    MAXY,    I4X0, I4Y0, I4X1, I4Y1, I4MODE
C
      INTEGER NXPIX(2), NYPIX(2), MULTX(2), MULTY(2), IXSTEP(2)
      SAVE    NXPIX,    NYPIX,    MULTX,    MULTY,    IXSTEP
      INTEGER NCOLR, NEEDSP, KOLNOW(2), KOLOUR(0:255)
      INTEGER ISTR,  NPTFIL, IPTFIL
      SAVE    NCOLR, NEEDSP, KOLNOW,    KOLOUR
      SAVE    ISTR,  NPTFIL, IPTFIL
      LOGICAL INIT, APPEND, FIRSTO, INPICT(2), STATE(2)
      SAVE    INIT, APPEND, FIRSTO, INPICT, STATE, SPRNAM
      INTEGER IERR, I4X2, I4Y2, MBUF(2), IREGS(0:9), ISCRR(4)
      CHARACTER ANS*4, INSTR*10, SPRNAM*9, DPATTN(2:5)*24
      LOGICAL SPGOOD, SPRESV
      INTEGER STROKE(0:9), PATH(7), CAP, FILL(0:9), THICK, IDASH
      SAVE    STROKE,      PATH,    CAP, FILL,      IDASH
      EQUIVALENCE (THICK,STROKE(4))
      INTEGER DPATTD(9,2:5), SCLPAT(10), LTHICK
      SAVE    DPATTD,        SCLPAT,     LTHICK
      DATA    DPATTD/2,6,6,6*0, 4,1,3,5,3,4*0, 2,2,2,6*0,
     +               8,6,3,2,3,2,3,2,3/
      DATA    SCLPAT/10*0/
      DATA    STROKE/0,?I38,8*0/,PATH/2,0,0,8,0,0,0/,CAP/?I010101/
      DATA    FILL/0,?I32,8*0/,IDASH/1/
      DATA    DPATTN/'111111000000111111000000',
     3               '100011111000100011111000',
     4               '110011001100110011001100',
     5               '111111000110001100011000'/
      DATA    INIT/.TRUE./, STATE/2*.FALSE./,NPTFIL,IPTFIL/2*0/
      DATA    KOLOUR/?I00000000, ?IFFFFFF00, ?I0000FF00, ?I00FF0000,
     1               ?IFF000000, ?IFFFF0000, ?IFF00FF00, ?I00FFFF00,
     2               ?I0080FF00, ?I00FF8000, ?I80FF0000, ?IFF800000,
     3               ?IFF008000, ?I8000FF00, ?I50505000, ?IA0A0A000,
     4                240*0/
      IF(NPTFIL.NE.0 .AND. IFUNC.NE.20) THEN
C            lost sequence of polygon fill
        STOP 'illegal polygon fill'
      ENDIF
      IF(INIT .AND. IFUNC.GT.1) THEN
C            check for 16-colour mode
C!!        NCOLR = MODEVAR(-1,3)
        CALL GRRMV(-1,3,NCOLR)
        IF(NCOLR.EQ.63) NCOLR = 255
        IF(NCOLR.EQ.-1) NCOLR = ?IFFFFFF
        IF(NCOLR.LT.15) THEN
        CALL GRWARN('Archimedes driver needs at least 16 colours')
          NBUF = -1
          RETURN
        ENDIF
        INIT = .FALSE.
C           set address of CAP
        STROKE(5) = LOC(CAP)
C           get screen characteristics
        DO 8 MTP = 1, 2
          CALL GRRMV(-1,11,N)
          NXPIX(MTP) = N+1
          CALL GRRMV(-1,12,N)
          NYPIX(MTP) = N+1
C!!          NXPIX(MTP) = MODEVAR(-1, 11) + 1
C!!          NYPIX(MTP) = MODEVAR(-1, 12) + 1
          IF(MTP.EQ.1) THEN
            CALL GRRMV(-1,4,MULTX)
            CALL GRRMV(-1,5,MULTY)
C!!            MULTX(1) = MODEVAR(-1, 4)
C!!            MULTY(1) = MODEVAR(-1, 5)
          ELSE
            CALL GRGENV('ARC_WIDTH', INSTR, L)
            IF(L.GT.0) READ(INSTR, 4)NXPIX(2)
    4       FORMAT(BN, I10)
            CALL GRGENV('ARC_HEIGHT', INSTR, L)
            IF(L.GT.0) READ(INSTR, 4)NYPIX(2)
            MULTX(2) = 1
            MULTY(2) = 1
          ENDIF
          IXSTEP(MTP) = ISHFT(1, MULTX(MTP))
          MAXX(MTP) = ISHFT(NXPIX(MTP), MULTX(MTP))
          MAXY(MTP) = ISHFT(NYPIX(MTP), MULTY(MTP))
          INPICT(MTP) = .FALSE.
    8   CONTINUE
      ENDIF
      IF(IFUNC.GT.9 .AND. .NOT.STATE(MTYPE)) THEN
        CALL GRWARN('Device is not open')
        NBUF = -1
        RETURN
      ENDIF
      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,240,250,260,270,280,290) IFUNC
C            unknown driver function, so just return
      NBUF = -1
      RETURN
C
C--- IFUNC = 1, Return device name.-------------------------------------
C
   10 IF(MTYPE.EQ.1) THEN
        CHR = 'ARCV (screen viewer for Acorn Archimedes machines)'
        LCHR = LNBLNK(CHR)
      ELSEIF(MTYPE.EQ.2) THEN
        CHR = 'ARCF (sprite file for Acorn Archimedes machines)'
        LCHR = LNBLNK(CHR)
      ELSE
        CALL GRWARN('Requested MODE not implemented in Archi driver')
        LCHR = 0
        NBUF = -1
      ENDIF
      RETURN
C
C--- IFUNC = 2, Return physical min and max for plot device, and range
C               of color indices.---------------------------------------
C
   20 CONTINUE
      RBUF(1) = 0
      RBUF(2) = MAXX(MTYPE)
      RBUF(3) = 0
      RBUF(4) = MAXY(MTYPE)
      RBUF(5) = 0
      RBUF(6) = MIN(255, NCOLR)
      NBUF = 6
      RETURN
C
C--- IFUNC = 3, Return device resolution. ------------------------------
C Divide the number of pixels on screen by a typical screen size in
C inches.
C
   30 continue
      RBUF(1) = MAXX(MTYPE)/10.0
      RBUF(2) = RBUF(1)
      RBUF(3) = FLOAT(ISHFT(1, MULTX(MTYPE)))
      NBUF = 3
      RETURN
C
C--- IFUNC = 4, Return misc device info. -------------------------------
C    (This device is Interactive, cursor, No dashed lines, Area fill,
C    Thick lines, rectangle fill)
C
   40 IF(MTYPE.EQ.1) THEN
        CHR = 'ICDATRPVYN'
      ELSE
        CHR = 'HNDATRPNYN'
      ENDIF
      LCHR = 10
      NBUF = 0
      RETURN
C
C--- IFUNC = 5, Return default file name. ------------------------------
C
   50 IF(MTYPE.EQ.1) THEN
        CHR = ' '
        LCHR = 1
      ELSE
        CHR = DEFNAM//"00"
        LCHR = 9
      ENDIF
      RETURN
C
C--- IFUNC = 6, Return default physical size of plot. ------------------
C
   60 CONTINUE
      RBUF(1) = 0
      RBUF(2) = MAXX(MTYPE)
      RBUF(3) = 0
      RBUF(4) = MAXY(MTYPE)
      NBUF = 4
      RETURN
C
C--- IFUNC = 7, Return misc defaults. ----------------------------------
C
   70 RBUF(1) = 1
      NBUF = 1
      RETURN
C
C--- IFUNC = 8, Select plot. -------------------------------------------
C
   80 CONTINUE
      RETURN
C
C--- IFUNC = 9, Open workstation. --------------------------------------
C
   90 CONTINUE
C     -- check for concurrent access
      IF (STATE(MTYPE)) THEN
        CALL GRWARN('Device is already open')
        RBUF(2) = 0
      ELSE
        IF(MTYPE.EQ.1) THEN
C         flag to erase screen on next picture
          FIRSTO = .TRUE.
C         set append flag to suppress screen clearing on subsequent pictures
          APPEND = RBUF(3).NE.0.
        ENDIF
C         flag the workstation active
        STATE(MTYPE) = .TRUE.
C         but not generating picture yet
        INPICT(MTYPE) = .FALSE.
C
        RBUF(2) = 1
      END IF
      RBUF(1) = 0
      NBUF = 2
      RETURN
C
C--- IFUNC = 10, Close workstation. ------------------------------------
C
  100 CONTINUE
C          flag the workstation inactive
      STATE(MTYPE) = .FALSE.
      IF(MTYPE.EQ.1) THEN
C          reset the 16 colour palette
        IF(NCOLR.EQ.15)  CALL GRVDU(20) 
C          clear the screen
        CALL GRCLRT
      ENDIF
      RETURN
C
C--- IFUNC = 11, Begin picture. ----------------------------------------
C
  110 CONTINUE
      IF(MTYPE.EQ.1 .AND. (.NOT.APPEND .OR. FIRSTO)) THEN
        CALL GRARC2(0, 0, -NCOLR, KOLOUR)
C         remove viewports and clear screen to background colour
        CALL GRVDU(26)
        CALL GRCLRG
C         home the text cursor
        CALL GRVDU(30)
C         set foreground text colour
        IF(NCOLR.EQ.15) CALL GRTCOL(1)
C         remove pointer
        CALL OSCLI('Pointer 0')
      ENDIF
      FIRSTO = .FALSE.
      IERR=0
      IF(MTYPE.EQ.2) THEN
C          create sprite
        CALL GRRMV(-1,9,LBPPIX)
C!!        LBPPIX = MODEVAR(-1, 9)
        NBYTES = ISHFT(NXPIX(2)*NYPIX(2), LBPPIX)/8 + 64
C            first ensure there is space in system sprite area
C!!        IF(.NOT.SPOP08(0, ISPSIZ, NSPRIT, ISPR1, IFREE)) THEN
        CALL SPASIZ(0,NSPRIT,ISPSIZ,JFREE)
        IF(ISPSIZ.EQ.0) THEN
C         case 1, no system sprite area yet
          NEEDSP = NBYTES + 16 + 44
        ELSE
C         case 2, system sprite area exists
C         remove any of our sprites which may have been left by accident
  112     DO 114 ISPRIT = 1, NSPRIT
C!!            CALL SPOP13(0, ISPRIT, INSTR,LENG)
            CALL SPNAME(0,ISPRIT,INSTR)
            LENG = LNBLNK(INSTR)
            IF(INSTR(1:7).EQ.'sprite/'.AND.LENG.EQ.9) THEN
C!!              CALL SPOP25(0, INSTR(1:9))
              CALL SPDELS(0, INSTR(1:9))
              NSPRIT = NSPRIT -1
              GO TO 112
            ENDIF
  114     CONTINUE
C!!          LOGDUM = SPOP08(0, ISPSIZ, NSPRIT, ISPR1, IFREE)
C!!          NEEDSP = NBYTES + 44 - ISPSIZ + IFREE
          CALL SPASIZ(0,NSPRIT,ISPSIZ,JFREE)
          NEEDSP = NBYTES + 44 - JFREE
        ENDIF
        IERR = 0
        IF(NEEDSP.GT.0) THEN
          IREGS(0) = 3
          IREGS(1) = NEEDSP
C!!          IF(SWIF77(?I2A, IREGS, IFLAG)) IERR = 100
          CALL ARCSWI(?I2A, IREGS,IERR,'N')
          IF(IERR.EQ.0) THEN
            IF(IREGS(1).GE.NEEDSP) THEN
C              successfully assigned memory  
              NEEDSP = IREGS(1)
            ELSE
              IERR = 101
            ENDIF
          ELSE
            IERR = 100
          ENDIF
        ENDIF
C            create sprite      
        IF(IERR.EQ.0) THEN
          DO 116 I=1,99
            WRITE(SPRNAM,'(A,I2.2)')DEFNAM,I
            CALL FLTYPE(.FALSE.,SPRNAM,I1,I2)
            IF(I2.EQ.-1) GO TO 117
  116     CONTINUE
  117     IF(NCOLR.EQ.15) THEN
C                       create it with palette in 16 colour mode
C!!            SWIERR = SPOP15(0, SPRNAM, 1, NXPIX(2), NYPIX(2), 27)
            SPGOOD = SPRESV(0, SPRNAM, 1, NXPIX(2), NYPIX(2), 27)
          ELSEIF(NCOLR.EQ.255) THEN
C!!            SWIERR = SPOP15(0, SPRNAM, 0, NXPIX(2), NYPIX(2), 28)
            SPGOOD = SPRESV(0, SPRNAM, 0, NXPIX(2), NYPIX(2), 28)
          ELSE
C             create sprite 'mode word' (PRM 5-87)
            MODEW = IOR(?I1680B5, ISHFT(LBPPIX + 1, 27))
C!!            SWIERR = SPOP15(0, SPRNAM, 0, NXPIX(2), NYPIX(2), MODEW)
            SPGOOD = SPRESV(0, SPRNAM, 0, NXPIX(2), NYPIX(2), MODEW)
          ENDIF
          IF(.NOT.SPGOOD) IERR = 103
          IF(IERR.EQ.0) CALL GRWARN('creating sprite '//SPRNAM)
        ENDIF
        IF(IERR.NE.0) THEN
          CALL GRGMSG(IERR)
          CALL GRWARN('Failed to allocate plot buffer.')
C              failed to get enough memory so return it 
          IF(IERR.GT.100) THEN
            IREGS(1) = -IREGS(1)
C!!            IF(SWIF77(?I2A, IREGS, IFLAG)) THEN
            CALL ARCSWI(?I2A, IREGS,IERR,'N')
            IF(IERR.EQ.0) THEN
              IERR = 101
            ELSE
              IERR = 102
            ENDIF
          ENDIF
        ENDIF
      ENDIF
C            set up colours
      IF(IERR.EQ.0) THEN
        IF(NCOLR.EQ.15) THEN
          DO 118 I = 0, 15
            IF(MTYPE.EQ.2) THEN
              CALL GRARC1(SPRNAM, I, KOLOUR(I))
            ELSE
C!!              CALL VDU19(I, 16, 
              CALL GRPAL(I, 
     1        IAND(ISHFT(KOLOUR(I), -8), 255),
     2        IAND(ISHFT(KOLOUR(I), -16), 255),
     3        ISHFT(KOLOUR(I), -24))
            ENDIF
  118     CONTINUE
        ELSEIF(MTYPE.EQ.2) THEN
C             clear 255 colour sprite to background colour
C!!          CALL SPOP60(0, SPRNAM, 0, ISCRR)
          CALL SP2SPR(0,SPRNAM)
          CALL GRARC2(0, 0, -NCOLR, KOLOUR)
          CALL GRCLRG
C!!          CALL NPOP60(ISCRR)
          CALL SP2SCR
        ENDIF
      ENDIF
      IF(IERR.EQ.0) INPICT(MTYPE) = .TRUE.
      RETURN
C
C--- IFUNC = 12, Draw line. --------------------------------------------
C
  120 CONTINUE
      IF(INPICT(MTYPE)) THEN
C!!        IF(MTYPE.EQ.2) CALL SPOP60(0, SPRNAM, 0, ISCRR)
        IF(MTYPE.EQ.2) CALL SP2SPR(0, SPRNAM)
        CALL GRARC2(0, KOLNOW(MTYPE), NCOLR, KOLOUR)
        IF(THICK.EQ.0) THEN
          IF(IDASH.LE.1) THEN
            CALL GRLINE(NINT(RBUF(1)), NINT(RBUF(2)),
     1                  NINT(RBUF(3)), NINT(RBUF(4)))
          ELSE
            CALL GRMOVE(   NINT(RBUF(1)), NINT(RBUF(2)))
            CALL GRDEFD(DPATTN(IDASH))
            CALL GRPLOT(21,NINT(RBUF(3)), NINT(RBUF(4)))
          ENDIF
        ELSE
          PATH(2) = RBUF(1)*256.
          PATH(3) = RBUF(2)*256.
          PATH(5) = RBUF(3)*256.
          PATH(6) = RBUF(4)*256.
          STROKE(0) = LOC(PATH)
          IF(IDASH.LE.1) THEN
            STROKE(6) = 0
          ELSE
            STROKE(6) = LOC(SCLPAT)
          ENDIF
          CALL ARCSWI(?I40704,STROKE,IERR,'N')
        ENDIF
C!!        IF(MTYPE.EQ.2) CALL NPOP60(ISCRR)
        IF(MTYPE.EQ.2) CALL SP2SCR
      ENDIF
      RETURN
C
C--- IFUNC = 13, Draw dot. ---------------------------------------------
C
  130 CONTINUE
      IF(INPICT(MTYPE)) THEN
C!!        IF(MTYPE.EQ.2) CALL SPOP60(0, SPRNAM, 0, ISCRR)
        IF(MTYPE.EQ.2) CALL SP2SPR(0, SPRNAM)
        CALL GRARC2(0, KOLNOW(MTYPE), NCOLR, KOLOUR)
        IF(THICK.LT.512) THEN
          CALL GRSPOT(NINT(RBUF(1)), NINT(RBUF(2)))
        ELSE
          CALL GRCIRC(NINT(RBUF(1)), NINT(RBUF(2)), ISHFT(THICK,-9),
     +       .TRUE.)
        ENDIF
C!!        IF(MTYPE.EQ.2) CALL NPOP60(ISCRR)
        IF(MTYPE.EQ.2) CALL SP2SCR
      ENDIF
      RETURN
C
C--- IFUNC = 14, End picture. ------------------------------------------
C
  140 CONTINUE
      IF(INPICT(MTYPE).AND.MTYPE.EQ.2) THEN
C              write out sprite
C!!        CALL SPOP12(0, SPRNAM)
        CALL SPASAV(0, SPRNAM)
C              delete sprite
C!!        CALL SPOP25(0, SPRNAM)
        CALL SPDELS(0, SPRNAM)
C                give back memory
        IF(NEEDSP.GT.0) THEN
          IREGS(0) = 3
          IREGS(1) = -NEEDSP
C!!          IF(SWIF77(?I2A, IREGS, IFLAG)) THEN
          CALL ARCSWI(?I2A, IREGS,IERR,'N')
          IF(IERR.NE.0) THEN
            CALL GRGMSG(104)
            CALL GRWARN('Failed to deallocate plot buffer.')
          ENDIF
        ENDIF
      ENDIF
      INPICT(MTYPE) = .FALSE.
      RETURN
C
C--- IFUNC = 15, Select color index. -----------------------------------
  150 CONTINUE
      KOLNOW(MTYPE) = NINT(RBUF(1))
      RETURN
C
C--- IFUNC = 16, Flush buffer. -----------------------------------------
C
  160 CONTINUE
      RETURN
C
C--- IFUNC = 17, Read cursor. ------------------------------------------
C
  170 CONTINUE
      IF(MTYPE.EQ.2) RETURN
C             display pointer
      CALL OSCLI('Pointer')
C             wait until button(s) and keys are released
  172 CALL MOUSE(I4X0, I4Y0, I4B)
      IF(I4B.NE.0 .OR. INKEY(0).GT.0) GO TO 172
C             move to desired place
      I4X0 = NINT(RBUF(1))
      I4Y0 = NINT(RBUF(2))
      MBUF(1) = 5 + IOR(ISHFT(I4X0, 8), ISHFT(I4Y0, 24))
      MBUF(2) = ISHFT(I4Y0, -8)
      CALL OSWORD(21, MBUF)
C             anchor position
      I4X1 = NINT(RBUF(3))
      I4Y1 = NINT(RBUF(4))
C             band mode
      I4MODE = NINT(RBUF(5))
C             initial band
      IF(I4MODE.GT.0) THEN
C             set colour of banding
        CALL GRARC2(3, KOLNOW(MTYPE), NCOLR, KOLOUR)
        CALL GRARC3
      ENDIF
C             loop and wait for keystroke/button click
  174 CONTINUE
C             get mouse pointer status
      CALL MOUSE(I4X2, I4Y2, I4B)
C             check for key press
      KEY = INKEY(0)
C             'select' = 'A'
      IF(I4B.EQ.4) KEY = 65
C             'menu'   = 'D'
      IF(I4B.EQ.2) KEY = 68
C             'adjust' = 'X'
      IF(I4B.EQ.1) KEY = 88
      IF(I4MODE.GT.0) THEN
        IF(I4X2.NE.I4X0 .OR. I4Y2.NE.I4Y0) THEN
C            wait for frame scan
          CALL OSBYTE(19,0,0)
C            clear the old band
          CALL GRARC3
C            move the band
          I4X0 = I4X2
          I4Y0 = I4Y2
C            draw the new band
          CALL GRARC3
        ENDIF
      ENDIF
      IF(KEY.LE.0) GO TO 174
C             erase final band
      IF(I4MODE.GT.0) CALL GRARC3
C             return current position
      RBUF(1) = FLOAT(I4X2)
      RBUF(2) = FLOAT(I4Y2)
      NBUF = 2
C             and character
      CHR(1:1)  = CHAR(KEY)
      LCHR = 1
      RETURN
C
C--- IFUNC = 18, Erase alpha screen. -----------------------------------
C
  180 CONTINUE
      RETURN
C
C--- IFUNC = 19, Set line style. ---------------------------------------
C
  190 CONTINUE
      IDASH = NINT(RBUF(1))
      IF(IDASH.GT.5) IDASH = 1
      IF(IDASH.GT.1 .AND. THICK.GT.0) THEN
        SCLPAT(2) = DPATTD(1,IDASH)
        DO 192 I=1,SCLPAT(2)
          SCLPAT(I+2) = DPATTD(I+1,IDASH)*LTHICK
  192   CONTINUE
      ENDIF
      RETURN
C
C--- IFUNC = 20, Polygon fill. -----------------------------------------
C
  200 CONTINUE
      IF(NPTFIL.EQ.0) THEN
        NPTFIL = NINT(RBUF(1))
        IPTFIL = 0
        CALL RSVMEM(3*NPTFIL+1,MAXX,ISTR)
        IF(ISTR.EQ.0) STOP 'Unable to reserve memory'
        MAXX(ISTR+1) = 2
      ELSE
        IPTFIL = IPTFIL + 1
        MAXX(ISTR+3*IPTFIL+1) = 8
        MAXX(ISTR+3*IPTFIL-1) = RBUF(1)*256.0
        MAXX(ISTR+3*IPTFIL)   = RBUF(2)*256.0
        IF(IPTFIL.EQ.NPTFIL) THEN
          IF(INPICT(MTYPE)) THEN
            IF(MTYPE.EQ.2) CALL SP2SPR(0, SPRNAM)
            CALL GRARC2(0, KOLNOW(MTYPE), NCOLR, KOLOUR)
            MAXX(ISTR+3*IPTFIL+1) = 0
            FILL(0) = LOC(MAXX(ISTR+1))
            CALL ARCSWI(?I40702,FILL,IERR,'N')
            IF(IERR.NE.0) STOP 'Draw_Fill fails'
            IF(MTYPE.EQ.2) CALL SP2SCR
          ENDIF
          CALL RSVMEM(0)
          NPTFIL = 0
        ENDIF
      ENDIF
      RETURN
C
C--- IFUNC = 21, Set color representation. -----------------------------
C
  210 CONTINUE
      ICOL = NINT(RBUF(1))
      IRED = NINT(RBUF(2)*255.)
      IGRN = NINT(RBUF(3)*255.)
      IBLU = NINT(RBUF(4)*255.)
      KOLOUR(ICOL) = ISHFT(IBLU, 24) + ISHFT(IGRN, 16) + ISHFT(IRED, 8)
      IF(NCOLR.EQ.15.AND.INPICT(MTYPE)) THEN
        IF(MTYPE.EQ.2) THEN
          CALL GRARC1(SPRNAM, ICOL, KOLOUR(ICOL))
        ELSE 
C!!          CALL VDU19(ICOL, 16, IRED, IGRN, IBLU)
          CALL GRPAL(ICOL, IRED, IGRN, IBLU)
        ENDIF
      ENDIF
      RETURN
C
C--- IFUNC = 22, Set line width. ---------------------------------------
C
  220 CONTINUE
      IF(RBUF(1).LE.1.0) THEN
        THICK=0
      ELSE
        THICK = NINT(RBUF(1)*MAXX(MTYPE)*0.128)
        LTHICK = NINT(SQRT(FLOAT(THICK))*36.)
        IF(IDASH.GT.1) THEN
          SCLPAT(2) = DPATTD(1,IDASH)
          DO 222 I=1,SCLPAT(2)
            SCLPAT(I+2) = DPATTD(I+1,IDASH)*LTHICK
  222     CONTINUE
        ENDIF
      ENDIF
      RETURN
C
C--- IFUNC = 23, Escape. -----------------------------------------------
C
  230 CONTINUE
      RETURN
C
C--- IFUNC = 24, Rectangle fill. ---------------------------------------
C
  240 CONTINUE
      IF(INPICT(MTYPE)) THEN
C!!       IF(MTYPE.EQ.2) CALL SPOP60(0, SPRNAM, 0, ISCRR)
        IF(MTYPE.EQ.2) CALL SP2SPR(0, SPRNAM)
        CALL GRARC2(0, KOLNOW(MTYPE), NCOLR, KOLOUR)
        CALL GRRECT(NINT(RBUF(1)), NINT(RBUF(2)),
     1              NINT(RBUF(3)), NINT(RBUF(4)), .TRUE.)
C!!       IF(MTYPE.EQ.2) CALL NPOP60(ISCRR)
        IF(MTYPE.EQ.2) CALL SP2SCR
      ENDIF
      RETURN
C
C--- IFUNC = 25, Set fill pattern. -------------------------------------
C
  250 CONTINUE
      RETURN
C
C--- IFUNC = 26, Line of pixels. ---------------------------------------
C
  260 CONTINUE
      IF(.NOT.INPICT(MTYPE)) RETURN
C!!     IF(MTYPE.EQ.2) CALL SPOP60(0, SPRNAM, 0, ISCRR)
      IF(MTYPE.EQ.2) CALL SP2SPR(0, SPRNAM)
      IX = NINT(RBUF(1))
      IY = NINT(RBUF(2))
      K1 = NINT(RBUF(3))
      IX1 = IX
      DO 264 I = 3 + IXSTEP(MTYPE), NBUF, IXSTEP(MTYPE)
        K2 = NINT(RBUF(I))
        IF(K1.NE.K2) THEN
          CALL GRARC2(0, K1, NCOLR, KOLOUR)
          IF(IX.EQ.IX1) THEN
            CALL GRSPOT(IX, IY)
          ELSE
            CALL GRLINE(IX1, IY, IX, IY)
          ENDIF
          K1 = K2
          IX1 = IX + IXSTEP(MTYPE)
        ENDIF
        IX = IX + IXSTEP(MTYPE)
  264 CONTINUE
      CALL GRARC2(0, K2, NCOLR, KOLOUR)
      IF(IX.EQ.IX1) THEN
        CALL GRSPOT(IX, IY)
      ELSE
        CALL GRLINE(IX1, IY, IX, IY)
      ENDIF
C!!     IF(MTYPE.EQ.2) CALL NPOP60(ISCRR)
      IF(MTYPE.EQ.2) CALL SP2SCR
      RETURN
C
C--- IFUNC = 27, Not implemented ---------------------------------------
C
  270 CONTINUE
      RETURN
C
C--- IFUNC = 28, Not implemented ---------------------------------------
C
  280 CONTINUE
      RETURN
C
C--- IFUNC = 29, Query color representation. ---------------------------
C
  290 CONTINUE
      I = RBUF(1)
      RBUF(2) = IAND(ISHFT(KOLOUR(I),  -8), 255)/255.0
      RBUF(3) = IAND(ISHFT(KOLOUR(I), -16), 255)/255.0
      RBUF(4) = IAND(ISHFT(KOLOUR(I), -24), 255)/255.0
      NBUF = 4
      RETURN
C-----------------------------------------------------------------------
      END
C
      SUBROUTINE GRARC1(SPRNAM, I, KOL)
      DIMENSION IREGS(0:9)
      CHARACTER *(*) SPRNAM, NAME*12
      EQUIVALENCE(IPP, IREGS(4))
C           set sprite palette I to KOL (Only in RISC-OS 3)
      NAME = SPRNAM
      L = LNBLNK(NAME)
      NAME(L+1:L+1) = CHAR(0)
      IREGS(0) = 37
      IREGS(1) = 0
      IREGS(2) = LOCC(NAME)
      IREGS(3) = -1
C          do SpriteOp 37
C!!      IF(SWIF77(?I2E, IREGS, IFLAG))RETURN
      CALL ARCSWI(?I2E, IREGS, IERR,'N')
      IF(IERR.NE.0 .OR. IPP.EQ.0) RETURN
      IOFF = (IPP - LOC(IREGS))/4
C         address of palette is now IREGS(IOFF)
      KK = IOR(16, IAND(KOL, ?IFFFFFF00))
      IREGS(IOFF+I+I) = KK
      IREGS(IOFF+I+I+1) = KK
      RETURN
      END
C
      SUBROUTINE GRARC2(IACT, KOLNOW, NCOLR, KOLOUR)
C              set up currrent graphics colour and action
      DIMENSION IREGS(0:9), KOLOUR(0:255)
      IF(IABS(NCOLR).EQ.15) THEN
        IF(NCOLR.GT.0) THEN
          CALL GRGCOL(IACT, KOLNOW)
        ELSE
          CALL GRGCOL(IACT, KOLNOW + 128)
        ENDIF
      ELSE
        IREGS(0) = KOLOUR(KOLNOW)
        IREGS(3) = 0
        IF(NCOLR.LT.0) IREGS(3)=128
        IREGS(4) = IACT
C              do ColourTrans_SetGCOL
C!!        CALL SWIF77(?I040743, IREGS, IFLAG)
        CALL ARCSWI(?I040743, IREGS, IERR,'N')
      ENDIF
      RETURN
      END
C
      SUBROUTINE GRARC3
C             common for communicating with rubber banding GRARC3
      COMMON /GRARCC/ MAXX(2), MAXY(2), I4X0, I4Y0, I4X1, I4Y1, I4MODE
      INTEGER         MAXX,    MAXY,    I4X0, I4Y0, I4X1, I4Y1, I4MODE
C             only used for MTYPE=1, i.e. MAXX(1) and MAXY(1)
C
C             draw band of type I4MODE from (I4X1,I4Y1) to (I4X0,I4Y0)
C     I4MODE = 1: ordinary rubber band
C              2: rectangular box
C              3: horizontal lines
C              4: vertical lines
C              5: horizontal line through (I4X0,I4Y0) only
C              6: vertical line through (I4X0,I4Y0) only
C              7: vertical and horizontal lines through (I4X0,I4Y0) only
C
      GO TO (10, 20, 30, 40, 32, 42, 70), I4MODE
      RETURN
C               ordinary rubber band
   10 CALL GRLINE(I4X1, I4Y1, I4X0, I4Y0)
      RETURN
C               rectangular box
   20 CALL GRRECT(I4X1, I4Y1, I4X0, I4Y0, .FALSE.)
      RETURN
C               horizontal lines
   30 CALL GRLINE(0, I4Y1, MAXX, I4Y1)
   32 CALL GRLINE(0, I4Y0, MAXX, I4Y0)
      RETURN
C               vertical lines
   40 CALL GRLINE(I4X1, 0, I4X1, MAXY)
   42 CALL GRLINE(I4X0, 0, I4X0, MAXY)
      RETURN
C               vertical and horizontal lines through (I4X0,I4Y0) only
   70 CALL GRLINE(0, I4Y0, MAXX, I4Y0)
      GO TO 42
      END
