home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / maths / pgplot_1 / SYS_ARC / f77 / ACdriver next >
Text File  |  1996-05-22  |  20KB  |  641 lines
  1. C*ACDRIV -- PGPLOT device driver for Acorn Archimedes machines
  2. C+
  3.       SUBROUTINE ACDRIV (IFUNC, RBUF, NBUF, CHR, LCHR, MTYPE)
  4.       INTEGER IFUNC, NBUF, LCHR, MTYPE
  5.       REAL    RBUF(*)
  6.       CHARACTER*(*) CHR, DEFNAM
  7. C
  8. C PGPLOT driver for Acorn Archimedes
  9. C This driver will cause the system to leave the Desktop, but leave the 
  10. C screen mode provided it has the normal 16 colours
  11. C
  12. C This routine must be compiled with Acorn Fortran release 2
  13. C and linked with the Fortran Friends graphics, utils and spriteop libraries.
  14. C
  15. C 26 January 1996 : Version 1.10
  16. C 16 May 1996     : Version 1.11 allows concurrent /ARCF and ARCV
  17. C
  18. C Resolution: Depends on graphics mode. Ensure that the current mode is
  19. C suitable before running the PGPLOT program.
  20. C
  21. C version 1.10 also allows the making of the pictures into sprite files
  22. C the default sprite size is the screen size but you may alter the
  23. C number of pixels in x and y with the variables:
  24. C PGPLOT_ARC_WIDTH and PGPLOT_ARC_HEIGHT
  25. C the file names will be sprite/01, sprite/02 etc.
  26.       PARAMETER (DEFNAM = 'sprite/01')
  27. C
  28. C 26 April 1996 : Version 1.11 (changes to /ARCV)
  29. C               - small corrections to the initial screen clearing
  30. C               - allows standard PGPLOT rubber-banded cursors
  31. C---
  32. C             common for communicating with rubber banding GRARC3
  33.       COMMON /GRARCC/ MAXX(2), MAXY(2), I4X0, I4Y0, I4X1, I4Y1, I4MODE
  34.       INTEGER         MAXX,    MAXY,    I4X0, I4Y0, I4X1, I4Y1, I4MODE
  35. C
  36.       INTEGER NXPIX(2), NYPIX(2), MULTX(2), MULTY(2), IXSTEP(2)
  37.       SAVE    NXPIX,    NYPIX,    MULTX,    MULTY,    IXSTEP
  38.       INTEGER NCOLR, NEEDSP, KOLNOW(2), KOLOUR(0:255)
  39.       SAVE    NCOLR, NEEDSP, KOLNOW,    KOLOUR
  40.       LOGICAL INIT, APPEND, FIRSTO, INPICT(2), STATE(2)
  41.       SAVE    INIT, APPEND, FIRSTO, INPICT, STATE
  42.       INTEGER IERR, I4X2, I4Y2, MBUF(2), IREGS(0:9), ISCRR(4)
  43.       LOGICAL SWIERR, SWIF77, SPOP08, SPOP15, LOGDUM
  44.       CHARACTER ANS*4, INSTR*10, SPNAME*9
  45.       DATA    INIT/.TRUE./, STATE/2*.FALSE./
  46.       DATA    KOLOUR/?I00000000, ?IFFFFFF00, ?I0000FF00, ?I00FF0000,
  47.      1               ?IFF000000, ?IFFFF0000, ?IFF00FF00, ?I00FFFF00,
  48.      2               ?I0080FF00, ?I00FF8000, ?I80FF0000, ?IFF800000,
  49.      3               ?IFF008000, ?I8000FF00, ?I50505000, ?IA0A0A000,
  50.      4                240*0/
  51.       IF(INIT .AND. IFUNC.GT.1) THEN
  52. C            check for 16-colour mode
  53.         NCOLR = MODEVAR(-1, 3)
  54.         IF(NCOLR.EQ.63) NCOLR = 255
  55.         IF(NCOLR.EQ.-1) NCOLR = ?IFFFFFF
  56.         IF(NCOLR.LT.15) THEN
  57.         CALL GRWARN('Archimedes driver needs at least 16 colours')
  58.           NBUF = -1
  59.           RETURN
  60.         ENDIF
  61.         INIT = .FALSE.
  62. C           get screen characteristics
  63.         DO 8 MTP = 1, 2
  64.           NXPIX(MTP) = MODEVAR(-1, 11) + 1
  65.           NYPIX(MTP) = MODEVAR(-1, 12) + 1
  66.           IF(MTP.EQ.1) THEN
  67.             MULTX(1) = MODEVAR(-1, 4)
  68.             MULTY(1) = MODEVAR(-1, 5)
  69.           ELSE
  70.             SPNAME = DEFNAM
  71.             CALL GRGENV('ARC_WIDTH', INSTR, L)
  72.             IF(L.GT.0) READ(INSTR, 4)NXPIX(2)
  73.     4       FORMAT(BN, I10)
  74.             CALL GRGENV('ARC_HEIGHT', INSTR, L)
  75.             IF(L.GT.0) READ(INSTR, 4)NYPIX(2)
  76.             MULTX(2) = 1
  77.             MULTY(2) = 1
  78.           ENDIF
  79.           IXSTEP(MTP) = ISHFT(1, MULTX(MTP))
  80.           MAXX(MTP) = ISHFT(NXPIX(MTP), MULTX(MTP))
  81.           MAXY(MTP) = ISHFT(NYPIX(MTP), MULTY(MTP))
  82.           INPICT(MTP) = .FALSE.
  83.     8   CONTINUE
  84.       ENDIF
  85.       IF(IFUNC.GT.9 .AND. .NOT.STATE(MTYPE)) THEN
  86.         CALL GRWARN('Device is not open')
  87.         NBUF = -1
  88.         RETURN
  89.       ENDIF
  90.       GOTO( 10, 20, 30, 40, 50, 60, 70, 80, 90,100,
  91.      1     110,120,130,140,150,160,170,180,190,200,
  92.      2     210,220,230,240,250,260,270,280,290) IFUNC
  93. C            unknown driver function, so just return
  94.       NBUF = -1
  95.       RETURN
  96. C
  97. C--- IFUNC = 1, Return device name.-------------------------------------
  98. C
  99.    10 IF(MTYPE.EQ.1) THEN
  100.         CHR = 'ARCV (screen viewer for Acorn Archimedes machines)'
  101.         LCHR = LNBLNK(CHR)
  102.       ELSEIF(MTYPE.EQ.2) THEN
  103.         CHR = 'ARCF (sprite file for Acorn Archimedes machines)'
  104.         LCHR = LNBLNK(CHR)
  105.       ELSE
  106.         CALL GRWARN('Requested MODE not implemented in Archi driver')
  107.         LCHR = 0
  108.         NBUF = -1
  109.       ENDIF
  110.       RETURN
  111. C
  112. C--- IFUNC = 2, Return physical min and max for plot device, and range
  113. C               of color indices.---------------------------------------
  114. C
  115.    20 CONTINUE
  116.       RBUF(1) = 0
  117.       RBUF(2) = MAXX(MTYPE)
  118.       RBUF(3) = 0
  119.       RBUF(4) = MAXY(MTYPE)
  120.       RBUF(5) = 0
  121.       RBUF(6) = MIN(255, NCOLR)
  122.       NBUF = 6
  123.       RETURN
  124. C
  125. C--- IFUNC = 3, Return device resolution. ------------------------------
  126. C Divide the number of pixels on screen by a typical screen size in
  127. C inches.
  128. C
  129.    30 continue
  130.       RBUF(1) = MAXX(MTYPE)/10.0
  131.       RBUF(2) = RBUF(1)
  132.       RBUF(3) = FLOAT(ISHFT(1, MULTX(MTYPE)))
  133.       NBUF = 3
  134.       RETURN
  135. C
  136. C--- IFUNC = 4, Return misc device info. -------------------------------
  137. C    (This device is Interactive, cursor, No dashed lines, No area fill,
  138. C    No thick lines, rectangle fill)
  139. C
  140.    40 IF(MTYPE.EQ.1) THEN
  141.         CHR = 'ICNNNRPVYN'
  142.       ELSE
  143.         CHR = 'HNNNNRPNYN'
  144.       ENDIF
  145.       LCHR = 10
  146.       NBUF = 0
  147.       RETURN
  148. C
  149. C--- IFUNC = 5, Return default file name. ------------------------------
  150. C
  151.    50 IF(MTYPE.EQ.1) THEN
  152.         CHR = ' '
  153.         LCHR = 1
  154.       ELSE
  155.         CHR = SPNAME
  156.         LCHR = 9
  157.       ENDIF
  158.       RETURN
  159. C
  160. C--- IFUNC = 6, Return default physical size of plot. ------------------
  161. C
  162.    60 CONTINUE
  163.       RBUF(1) = 0
  164.       RBUF(2) = MAXX(MTYPE)
  165.       RBUF(3) = 0
  166.       RBUF(4) = MAXY(MTYPE)
  167.       NBUF = 4
  168.       RETURN
  169. C
  170. C--- IFUNC = 7, Return misc defaults. ----------------------------------
  171. C
  172.    70 RBUF(1) = 1
  173.       NBUF = 1
  174.       RETURN
  175. C
  176. C--- IFUNC = 8, Select plot. -------------------------------------------
  177. C
  178.    80 CONTINUE
  179.       RETURN
  180. C
  181. C--- IFUNC = 9, Open workstation. --------------------------------------
  182. C
  183.    90 CONTINUE
  184. C     -- check for concurrent access
  185.       IF (STATE(MTYPE)) THEN
  186.         CALL GRWARN('Device is already open')
  187.         RBUF(2) = 0
  188.       ELSE
  189.         IF(MTYPE.EQ.1) THEN
  190. C         flag to erase screen on next picture
  191.           FIRSTO = .TRUE.
  192. C         set append flag to suppress screen clearing on subsequent pictures
  193.           APPEND = RBUF(3).NE.0.
  194.         ENDIF
  195. C         flag the workstation active
  196.         STATE(MTYPE) = .TRUE.
  197. C         but not generating picture yet
  198.         INPICT(MTYPE) = .FALSE.
  199. C
  200.         RBUF(2) = 1
  201.       END IF
  202.       RBUF(1) = 0
  203.       NBUF = 2
  204.       RETURN
  205. C
  206. C--- IFUNC = 10, Close workstation. ------------------------------------
  207. C
  208.   100 CONTINUE
  209. C          flag the workstation inactive
  210.       STATE(MTYPE) = .FALSE.
  211.       IF(MTYPE.EQ.1) THEN
  212. C          reset the 16 colour palette
  213.         IF(NCOLR.EQ.15)  CALL VDU(20) 
  214. C          clear the screen
  215.         CALL CLS
  216.       ENDIF
  217.       RETURN
  218. C
  219. C--- IFUNC = 11, Begin picture. ----------------------------------------
  220. C
  221.   110 CONTINUE
  222.       IF(MTYPE.EQ.1 .AND. (.NOT.APPEND .OR. FIRSTO)) THEN
  223.         CALL GRARC2(0, 0, -NCOLR, KOLOUR)
  224. C         remove viewports and clear screen to background colour
  225.         CALL VDU(26)
  226.         CALL CLG
  227. C         home the text cursor
  228.         CALL VDU(30)
  229. C         set foreground text colour
  230.         IF(NCOLR.EQ.15) CALL COLOUR(1)
  231. C         remove pointer
  232.         CALL OSCLI('Pointer 0')
  233.       ENDIF
  234.       FIRSTO = .FALSE.
  235.       IERR=0
  236.       IF(MTYPE.EQ.2) THEN
  237. C          create sprite
  238.         LBPPIX = MODEVAR(-1, 9)
  239.         NBYTES = ISHFT(NXPIX(2)*NYPIX(2), LBPPIX)/8 + 64
  240. C            first ensure there is space in system sprite area
  241.         IF(.NOT.SPOP08(0, ISPSIZ, NSPRIT, ISPR1, IFREE)) THEN
  242. C         case 1, no system sprite area yet
  243.           NEEDSP = NBYTES + 16 + 44
  244.         ELSE
  245. C         case 2, system sprite area exists
  246. C         remove any of our sprites which may have been left by accident
  247.   112     DO 114 ISPRIT = 1, NSPRIT
  248.             CALL SPOP13(0, ISPRIT, INSTR,LENG)
  249.             IF(INSTR(1:7).EQ.'sprite/'.AND.LENG.EQ.9) THEN
  250.               CALL SPOP25(0, INSTR(1:9))
  251.               NSPRIT = NSPRIT -1
  252.               GO TO 112
  253.             ENDIF
  254.   114     CONTINUE
  255.           LOGDUM = SPOP08(0, ISPSIZ, NSPRIT, ISPR1, IFREE)
  256.           NEEDSP = NBYTES + 44 - ISPSIZ + IFREE
  257.         ENDIF
  258.         IERR = 0
  259.         IF(NEEDSP.GT.0) THEN
  260.           IREGS(0) = 3
  261.           IREGS(1) = NEEDSP
  262.           IF(SWIF77(?I2A, IREGS, IFLAG)) IERR = 100
  263.           IF(IERR.EQ.0) THEN
  264.             IF(IREGS(1).GE.NEEDSP) THEN
  265. C              successfully assigned memory
  266.               NEEDSP = IREGS(1)
  267.             ELSE
  268.               IERR = 101
  269.             ENDIF
  270.           ENDIF
  271.         ENDIF
  272. C            create sprite      
  273.         IF(IERR.EQ.0) THEN
  274.           IF(NCOLR.EQ.15) THEN
  275. C                       create it with palette in 16 colour mode
  276.             SWIERR = SPOP15(0, SPNAME, 1, NXPIX(2), NYPIX(2), 27)
  277.           ELSEIF(NCOLR.EQ.255) THEN
  278.             SWIERR = SPOP15(0, SPNAME, 0, NXPIX(2), NYPIX(2), 28)
  279.           ELSE
  280. C             create sprite 'mode word' (PRM 5-87)
  281.             MODEW = IOR(?I1680B5, ISHFT(LBPPIX + 1, 27))
  282.             SWIERR = SPOP15(0, SPNAME, 0, NXPIX(2), NYPIX(2), MODEW)
  283.           ENDIF
  284.           IF(SWIERR) IERR = 103
  285.           IF(IERR.EQ.0) CALL GRWARN('creating sprite '//SPNAME)
  286.         ENDIF
  287.         IF(IERR.NE.0) THEN
  288.           CALL GRGMSG(IERR)
  289.           CALL GRWARN('Failed to allocate plot buffer.')
  290. C              failed to get enough memory so return it 
  291.           IF(IERR.GT.100) THEN
  292.             IREGS(1) = -IREGS(1)
  293.             IF(SWIF77(?I2A, IREGS, IFLAG)) THEN
  294.               IERR = 101
  295.             ELSE
  296.               IERR = 102
  297.             ENDIF
  298.           ENDIF
  299.         ENDIF
  300.       ENDIF
  301. C            set up colours
  302.       IF(IERR.EQ.0) THEN
  303.         IF(NCOLR.EQ.15) THEN
  304.           DO 118 I = 0, 15
  305.             IF(MTYPE.EQ.2) THEN
  306.               CALL GRARC1(SPNAME, I, KOLOUR(I))
  307.             ELSE
  308.               CALL VDU19(I, 16, 
  309.      1        IAND(ISHFT(KOLOUR(I), -8), 255),
  310.      2        IAND(ISHFT(KOLOUR(I), -16), 255),
  311.      3        ISHFT(KOLOUR(I), -24))
  312.             ENDIF
  313.   118     CONTINUE
  314.         ELSEIF(MTYPE.EQ.2) THEN
  315. C             clear 255 colour sprite to background colour
  316.           CALL SPOP60(0, SPNAME, 0, ISCRR)
  317.           CALL GRARC2(0, 0, -NCOLR, KOLOUR)
  318.           CALL CLG
  319.           CALL NPOP60(ISCRR)
  320.         ENDIF
  321.       ENDIF
  322.       IF(IERR.EQ.0) INPICT(MTYPE) = .TRUE.
  323.       RETURN
  324. C
  325. C--- IFUNC = 12, Draw line. --------------------------------------------
  326. C
  327.   120 CONTINUE
  328.       IF(INPICT(MTYPE)) THEN
  329.         IF(MTYPE.EQ.2) CALL SPOP60(0, SPNAME, 0, ISCRR)
  330.         CALL GRARC2(0, KOLNOW(MTYPE), NCOLR, KOLOUR)
  331.         CALL LINE(NINT(RBUF(1)), NINT(RBUF(2)),
  332.      1            NINT(RBUF(3)), NINT(RBUF(4)))
  333.         IF(MTYPE.EQ.2) CALL NPOP60(ISCRR)
  334.       ENDIF
  335.       RETURN
  336. C
  337. C--- IFUNC = 13, Draw dot. ---------------------------------------------
  338. C
  339.   130 CONTINUE
  340.       IF(INPICT(MTYPE)) THEN
  341.         IF(MTYPE.EQ.2) CALL SPOP60(0, SPNAME, 0, ISCRR)
  342.         CALL GRARC2(0, KOLNOW(MTYPE), NCOLR, KOLOUR)
  343.         CALL SPOT(NINT(RBUF(1)), NINT(RBUF(2)))
  344.         IF(MTYPE.EQ.2) CALL NPOP60(ISCRR)
  345.       ENDIF
  346.       RETURN
  347. C
  348. C--- IFUNC = 14, End picture. ------------------------------------------
  349. C
  350.   140 CONTINUE
  351.       IF(INPICT(MTYPE).AND.MTYPE.EQ.2) THEN
  352. C              write out sprite
  353.         CALL SPOP12(0, SPNAME)
  354. C              delete sprite
  355.         CALL SPOP25(0, SPNAME)
  356. C              update sprite name
  357.         I = ICHAR(SPNAME(9:9)) + 1
  358.         IF(I.LT.58) THEN
  359.           SPNAME(9:9) = CHAR(I)
  360.         ELSE
  361.           SPNAME(8:9) = CHAR(ICHAR(SPNAME(8:8)) + 1)//'0'
  362.         ENDIF
  363. C                give back memory
  364.         IF(NEEDSP.GT.0) THEN
  365.           IREGS(0) = 3
  366.           IREGS(1) = -NEEDSP
  367.           IF(SWIF77(?I2A, IREGS, IFLAG)) THEN
  368.             CALL GRGMSG(104)
  369.             CALL GRWARN('Failed to deallocate plot buffer.')
  370.           ENDIF
  371.         ENDIF
  372.       ENDIF
  373.       INPICT(MTYPE) = .FALSE.
  374.       RETURN
  375. C
  376. C--- IFUNC = 15, Select color index. -----------------------------------
  377.   150 CONTINUE
  378.       KOLNOW(MTYPE) = NINT(RBUF(1))
  379.       RETURN
  380. C
  381. C--- IFUNC = 16, Flush buffer. -----------------------------------------
  382. C
  383.   160 CONTINUE
  384.       RETURN
  385. C
  386. C--- IFUNC = 17, Read cursor. ------------------------------------------
  387. C
  388.   170 CONTINUE
  389.       IF(MTYPE.EQ.2) RETURN
  390. C             display pointer
  391.       CALL OSCLI('Pointer')
  392. C             wait until button(s) and keys are released
  393.   172 CALL MOUSE(I4X0, I4Y0, I4B)
  394.       IF(I4B.NE.0 .OR. INKEY(0).GT.0) GO TO 172
  395. C             move to desired place
  396.       I4X0 = NINT(RBUF(1))
  397.       I4Y0 = NINT(RBUF(2))
  398.       MBUF(1) = 5 + IOR(ISHFT(I4X0, 8), ISHFT(I4Y0, 24))
  399.       MBUF(2) = ISHFT(I4Y0, -8)
  400.       CALL OSWORD(21, MBUF)
  401. C             anchor position
  402.       I4X1 = NINT(RBUF(3))
  403.       I4Y1 = NINT(RBUF(4))
  404. C             band mode
  405.       I4MODE = NINT(RBUF(5))
  406. C             initial band
  407.       IF(I4MODE.GT.0) THEN
  408. C             set colour of banding
  409.         CALL GRARC2(3, KOLNOW(MTYPE), NCOLR, KOLOUR)
  410.         CALL GRARC3
  411.       ENDIF
  412. C             loop and wait for keystroke/button click
  413.   174 CONTINUE
  414. C             get mouse pointer status
  415.       CALL MOUSE(I4X2, I4Y2, I4B)
  416. C             check for key press
  417.       KEY = INKEY(0)
  418. C             'select' = 'A'
  419.       IF(I4B.EQ.4) KEY = 65
  420. C             'menu'   = 'D'
  421.       IF(I4B.EQ.2) KEY = 68
  422. C             'adjust' = 'X'
  423.       IF(I4B.EQ.1) KEY = 88
  424.       IF(I4MODE.GT.0) THEN
  425.         IF(I4X2.NE.I4X0 .OR. I4Y2.NE.I4Y0) THEN
  426. C            wait for frame scan
  427.           CALL OSBYTE(19,0,0)
  428. C            clear the old band
  429.           CALL GRARC3
  430. C            move the band
  431.           I4X0 = I4X2
  432.           I4Y0 = I4Y2
  433. C            draw the new band
  434.           CALL GRARC3
  435.         ENDIF
  436.       ENDIF
  437.       IF(KEY.LE.0) GO TO 174
  438. C             erase final band
  439.       IF(I4MODE.GT.0) CALL GRARC3
  440. C             return current position
  441.       RBUF(1) = FLOAT(I4X2)
  442.       RBUF(2) = FLOAT(I4Y2)
  443.       NBUF = 2
  444. C             and character
  445.       CHR(1:1)  = CHAR(KEY)
  446.       LCHR = 1
  447.       RETURN
  448. C
  449. C--- IFUNC = 18, Erase alpha screen. -----------------------------------
  450. C
  451.   180 CONTINUE
  452.       RETURN
  453. C
  454. C--- IFUNC = 19, Set line style. ---------------------------------------
  455. C
  456.   190 CONTINUE
  457.       RETURN
  458. C
  459. C--- IFUNC = 20, Polygon fill. -----------------------------------------
  460. C
  461.   200 CONTINUE
  462.       RETURN
  463. C
  464. C--- IFUNC = 21, Set color representation. -----------------------------
  465. C
  466.   210 CONTINUE
  467.       ICOL = NINT(RBUF(1))
  468.       IRED = NINT(RBUF(2)*255.)
  469.       IGRN = NINT(RBUF(3)*255.)
  470.       IBLU = NINT(RBUF(4)*255.)
  471.       KOLOUR(ICOL) = ISHFT(IBLU, 24) + ISHFT(IGRN, 16) + ISHFT(IRED, 8)
  472.       IF(NCOLR.EQ.15.AND.INPICT(MTYPE)) THEN
  473.         IF(MTYPE.EQ.2) THEN
  474.           CALL GRARC1(SPNAME, ICOL, KOLOUR(ICOL))
  475.         ELSE 
  476.           CALL VDU19(ICOL, 16, IRED, IGRN, IBLU)
  477.         ENDIF
  478.       ENDIF
  479.       RETURN
  480. C
  481. C--- IFUNC = 22, Set line width. ---------------------------------------
  482. C
  483.   220 CONTINUE
  484.       RETURN
  485. C
  486. C--- IFUNC = 23, Escape. -----------------------------------------------
  487. C
  488.   230 CONTINUE
  489.       RETURN
  490. C
  491. C--- IFUNC = 24, Rectangle fill. ---------------------------------------
  492. C
  493.   240 CONTINUE
  494.       IF(INPICT(MTYPE)) THEN
  495.         IF(MTYPE.EQ.2) CALL SPOP60(0, SPNAME, 0, ISCRR)
  496.         CALL GRARC2(0, KOLNOW(MTYPE), NCOLR, KOLOUR)
  497.         CALL RECTAN(NINT(RBUF(1)), NINT(RBUF(2)),
  498.      1              NINT(RBUF(3)), NINT(RBUF(4)), .TRUE.)
  499.         IF(MTYPE.EQ.2) CALL NPOP60(ISCRR)
  500.       ENDIF
  501.       RETURN
  502. C
  503. C--- IFUNC = 25, Set fill pattern. -------------------------------------
  504. C
  505.   250 CONTINUE
  506.       RETURN
  507. C
  508. C--- IFUNC = 26, Line of pixels. ---------------------------------------
  509. C
  510.   260 CONTINUE
  511.       IF(.NOT.INPICT(MTYPE)) RETURN
  512.       IF(MTYPE.EQ.2) CALL SPOP60(0, SPNAME, 0, ISCRR)
  513.       IX = NINT(RBUF(1))
  514.       IY = NINT(RBUF(2))
  515.       K1 = NINT(RBUF(3))
  516.       IX1 = IX
  517.       DO 264 I = 3 + IXSTEP(MTYPE), NBUF, IXSTEP(MTYPE)
  518.         K2 = NINT(RBUF(I))
  519.         IF(K1.NE.K2) THEN
  520.           CALL GRARC2(0, K1, NCOLR, KOLOUR)
  521.           IF(IX.EQ.IX1) THEN
  522.             CALL SPOT(IX, IY)
  523.           ELSE
  524.             CALL LINE(IX1, IY, IX, IY)
  525.           ENDIF
  526.           K1 = K2
  527.           IX1 = IX + IXSTEP(MTYPE)
  528.         ENDIF
  529.         IX = IX + IXSTEP(MTYPE)
  530.   264 CONTINUE
  531.       CALL GRARC2(0, K2, NCOLR, KOLOUR)
  532.       IF(IX.EQ.IX1) THEN
  533.         CALL SPOT(IX, IY)
  534.       ELSE
  535.         CALL LINE(IX1, IY, IX, IY)
  536.       ENDIF
  537.       IF(MTYPE.EQ.2) CALL NPOP60(ISCRR)
  538.       RETURN
  539. C
  540. C--- IFUNC = 27, Not implemented ---------------------------------------
  541. C
  542.   270 CONTINUE
  543.       RETURN
  544. C
  545. C--- IFUNC = 28, Not implemented ---------------------------------------
  546. C
  547.   280 CONTINUE
  548.       RETURN
  549. C
  550. C--- IFUNC = 29, Query color representation. ---------------------------
  551. C
  552.   290 CONTINUE
  553.       I = RBUF(1)
  554.       RBUF(2) = IAND(ISHFT(KOLOUR(I),  -8), 255)/255.0
  555.       RBUF(3) = IAND(ISHFT(KOLOUR(I), -16), 255)/255.0
  556.       RBUF(4) = IAND(ISHFT(KOLOUR(I), -24), 255)/255.0
  557.       NBUF = 4
  558.       RETURN
  559. C-----------------------------------------------------------------------
  560.       END
  561. C
  562.       SUBROUTINE GRARC1(SPNAME, I, KOL)
  563.       DIMENSION IREGS(0:9)
  564.       CHARACTER *(*) SPNAME, NAME*12
  565.       EQUIVALENCE(IPP, IREGS(4))
  566.       LOGICAL SWIF77
  567. C           set sprite palette I to KOL (Only in RISC-OS 3)
  568.       NAME = SPNAME
  569.       L = LNBLNK(NAME)
  570.       NAME(L+1:L+1) = CHAR(0)
  571.       IREGS(0) = 37
  572.       IREGS(1) = 0
  573.       IREGS(2) = LOCC(NAME)
  574.       IREGS(3) = -1
  575. C          do SpriteOp 37
  576.       IF(SWIF77(?I2E, IREGS, IFLAG))RETURN
  577.       IF(IPP.EQ.0) RETURN
  578.       IOFF = (IPP - LOC(IREGS))/4
  579. C         address of palette is now IREGS(IOFF)
  580.       KK = IOR(16, IAND(KOL, ?IFFFFFF00))
  581.       IREGS(IOFF+I+I) = KK
  582.       IREGS(IOFF+I+I+1) = KK
  583.       RETURN
  584.       END
  585. C
  586.       SUBROUTINE GRARC2(IACT, KOLNOW, NCOLR, KOLOUR)
  587. C              set up currrent graphics colour and action
  588.       DIMENSION IREGS(0:9), KOLOUR(0:255)
  589.       IF(IABS(NCOLR).EQ.15) THEN
  590.         IF(NCOLR.GT.0) THEN
  591.           CALL GCOL(IACT, KOLNOW)
  592.         ELSE
  593.           CALL GCOL(IACT, KOLNOW + 128)
  594.         ENDIF
  595.       ELSE
  596.         IREGS(0) = KOLOUR(KOLNOW)
  597.         IREGS(3) = 0
  598.         IF(NCOLR.LT.0) IREGS(3)=128
  599.         IREGS(4) = IACT
  600. C              do ColourTrans_SetGCOL
  601.         CALL SWIF77(?I040743, IREGS, IFLAG)
  602.       ENDIF
  603.       RETURN
  604.       END
  605. C
  606.       SUBROUTINE GRARC3
  607. C             common for communicating with rubber banding GRARC3
  608.       COMMON /GRARCC/ MAXX(2), MAXY(2), I4X0, I4Y0, I4X1, I4Y1, I4MODE
  609.       INTEGER         MAXX,    MAXY,    I4X0, I4Y0, I4X1, I4Y1, I4MODE
  610. C             only used for MTYPE=1, i.e. MAXX(1) and MAXY(1)
  611. C
  612. C             draw band of type I4MODE from (I4X1,I4Y1) to (I4X0,I4Y0)
  613. C     I4MODE = 1: ordinary rubber band
  614. C              2: rectangular box
  615. C              3: horizontal lines
  616. C              4: vertical lines
  617. C              5: horizontal line through (I4X0,I4Y0) only
  618. C              6: vertical line through (I4X0,I4Y0) only
  619. C              7: vertical and horizontal lines through (I4X0,I4Y0) only
  620. C
  621.       GO TO (10, 20, 30, 40, 32, 42, 70), I4MODE
  622.       RETURN
  623. C               ordinary rubber band
  624.    10 CALL LINE(I4X1, I4Y1, I4X0, I4Y0)
  625.       RETURN
  626. C               rectangular box
  627.    20 CALL RECTAN(I4X1, I4Y1, I4X0, I4Y0, .FALSE.)
  628.       RETURN
  629. C               horizontal lines
  630.    30 CALL LINE(0, I4Y1, MAXX, I4Y1)
  631.    32 CALL LINE(0, I4Y0, MAXX, I4Y0)
  632.       RETURN
  633. C               vertical lines
  634.    40 CALL LINE(I4X1, 0, I4X1, MAXY)
  635.    42 CALL LINE(I4X0, 0, I4X0, MAXY)
  636.       RETURN
  637. C               vertical and horizontal lines through (I4X0,I4Y0) only
  638.    70 CALL LINE(0, I4Y0, MAXX, I4Y0)
  639.       GO TO 42
  640.       END
  641.