home *** CD-ROM | disk | FTP | other *** search
/ The Datafile PD-CD 3 / PDCD_3.iso / utilities / utilsp / pgplot / SYS_ARC / f77 / ACDriver next >
Encoding:
Text File  |  1994-10-08  |  7.6 KB  |  296 lines

  1. C*ACDRIV -- PGPLOT device driver for Acorn Archimedes machines
  2. C+
  3.       SUBROUTINE ACDRIV (IFUNC, RBUF, NBUF, CHR, LCHR)
  4.       INTEGER IFUNC, NBUF, LCHR
  5.       REAL    RBUF(*)
  6.       CHARACTER*(*) CHR
  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 Fortran release 2,
  13. C and linked with the Fortran Friends graphics and utils libraries.
  14. C
  15. C 15 February 1994 : Version 1.00
  16. C
  17. C Resolution: Depends on graphics mode. Ensure that the current mode is
  18. C suitable before running the PGPLOT program.
  19. C
  20. C
  21. C---
  22.       INTEGER MODES,NXPIX,NYPIX,MULTX,MULTY,MAXX,MAXY
  23.       SAVE    MODES,NXPIX,NYPIX,MULTX,MULTY,MAXX,MAXY
  24.       INTEGER NCOLR,KOLOUR(0:255),MBUF(2),IREGS(0:7)
  25.       SAVE    NCOLR,KOLOUR
  26.       LOGICAL APPEND
  27.       SAVE    APPEND
  28.       CHARACTER*4 ANS
  29.       DATA    MODES/0/
  30.       DATA    KOLOUR/?I00000000,?IFFFFFF00,?I0000FF00,?I00FF0000,
  31.      1               ?IFF000000,?IFFFF0000,?IFF00FF00,?I00FFFF00,
  32.      2               ?I0080FF00,?I00FF8000,?I80FF0000,?IFF800000,
  33.      3               ?IFF008000,?I8000FF00,?I50505000,?IA0A0A000,
  34.      4                240*0/
  35.       IF(MODES.EQ.0 .AND. IFUNC.GT.0) THEN
  36. C            check for 16-colour mode
  37.         NCOLR = MODEVAR(-1,3)
  38.         IF(NCOLR.GT.15) NCOLR = 255
  39.         IF(NCOLR.LT.15) THEN
  40.           PRINT *,'Archimedes driver only works in 16-colour mode'
  41.           NBUF = -1
  42.           RETURN
  43.         ENDIF
  44. C           get screen mode
  45.         CALL OSBYTE2(135,0,0,I,MODES)
  46. C           get screen characteristics
  47.         NXPIX = MODEVAR(-1,11)+1
  48.         NYPIX = MODEVAR(-1,12)+1
  49.         MULTX = MODEVAR(-1,4)
  50.         MULTY = MODEVAR(-1,5)
  51.         MAXX = ISHFT(NXPIX,MULTX)
  52.         MAXY = ISHFT(NYPIX,MULTY)
  53.       ENDIF
  54.       GOTO( 10, 20, 30, 40, 50, 60, 70, 80, 90,100,
  55.      1     110,120,130,140,150,160,170,180,190,200,
  56.      2     210,220,230,240,250,260) IFUNC
  57. C            unknown driver function, so just return
  58.       NBUF = -1
  59.       RETURN
  60. C
  61. C--- IFUNC = 1, Return device name.-------------------------------------
  62. C
  63.    10 CHR = 'ARC (for Acorn Archimedes machines)'
  64.       LCHR = LNBLNK(CHR)
  65.       NBUF = 0
  66.       RETURN
  67. C
  68. C--- IFUNC = 2, Return physical min and max for plot device, and range
  69. C               of color indices.---------------------------------------
  70. C
  71.    20 CONTINUE
  72.       RBUF(1) = 0
  73.       RBUF(2) = MAXX
  74.       RBUF(3) = 0
  75.       RBUF(4) = MAXY
  76.       RBUF(5) = 0
  77.       RBUF(6) = NCOLR
  78.       NBUF = 6
  79.       LCHR = 0
  80.       RETURN
  81. C
  82. C--- IFUNC = 3, Return device resolution. ------------------------------
  83. C Divide the number of pixels on screen by a typical screen size in
  84. C inches.
  85. C
  86.    30 continue
  87.       RBUF(1) = MAXX/10.0
  88.       RBUF(2) = MAXY/8.0
  89.       RBUF(3) = FLOAT(ISHFT(1,MULTX))
  90.       NBUF = 3
  91.       LCHR = 0
  92.       RETURN
  93. C
  94. C--- IFUNC = 4, Return misc device info. -------------------------------
  95. C    (This device is Interactive, cursor, No dashed lines, No area fill,
  96. C    No thick lines, rectangle fill)
  97. C
  98.    40 CHR = 'ICNNNRNNNN'
  99.       LCHR = 10
  100.       NBUF = 0
  101.       RETURN
  102. C
  103. C--- IFUNC = 5, Return default file name. ------------------------------
  104. C
  105.    50 CHR = ' '
  106.       LCHR = 1
  107.       NBUF = 0
  108.       RETURN
  109. C
  110. C--- IFUNC = 6, Return default physical size of plot. ------------------
  111. C
  112.    60 CONTINUE
  113.       RBUF(1) = 0
  114.       RBUF(2) = MAXX
  115.       RBUF(3) = 0
  116.       RBUF(4) = MAXY
  117.       NBUF = 4
  118.       LCHR = 0
  119.       RETURN
  120. C
  121. C--- IFUNC = 7, Return misc defaults. ----------------------------------
  122. C
  123.    70 RBUF(1) = 1
  124.       NBUF = 1
  125.       LCHR = 0
  126.       RETURN
  127. C
  128. C--- IFUNC = 8, Select plot. -------------------------------------------
  129. C
  130.    80 CONTINUE
  131.       LCHR = 0
  132.       NBUF = 0
  133.       RETURN
  134. C
  135. C--- IFUNC = 9, Open workstation. --------------------------------------
  136. C
  137.    90 CONTINUE
  138.       CALL MODE(MODES)
  139. C            set append flag to suppress screen clearing
  140.       APPEND = RBUF(3).NE.0.
  141.       RBUF(1) = 0
  142.       RBUF(2) = 1
  143.       NBUF = 2
  144.       RETURN
  145. C
  146. C--- IFUNC=10, Close workstation. --------------------------------------
  147. C
  148.   100 CONTINUE
  149. C      CALL GRGCOM(ANS,'Close Workstation',LREAD)
  150.       RETURN
  151. C
  152. C--- IFUNC=11, Begin picture. ------------------------------------------
  153. C
  154.   110 CONTINUE
  155.       IF(.NOT.APPEND) CALL CLS
  156. C            set up colours
  157.       IF(NCOLR.EQ.15) THEN
  158.         DO 112 I = 0, 15
  159.           CALL VDU19(I, 16, 
  160.      1    IAND(ISHFT(KOLOUR(I),-8),255),
  161.      2    IAND(ISHFT(KOLOUR(I),-16),255),
  162.      3    ISHFT(KOLOUR(I),-24))
  163.   112   CONTINUE
  164.       ENDIF
  165.       RETURN
  166. C
  167. C--- IFUNC=12, Draw line. ----------------------------------------------
  168. C
  169.   120 CONTINUE
  170.       CALL LINE(NINT(RBUF(1)),NINT(RBUF(2)),NINT(RBUF(3)),NINT(RBUF(4)))
  171.       RETURN
  172. C
  173. C--- IFUNC=13, Draw dot. -----------------------------------------------
  174. C
  175.   130 CONTINUE
  176.       CALL SPOT(NINT(RBUF(1)),NINT(RBUF(2)))
  177.       RETURN
  178. C
  179. C--- IFUNC=14, End picture. --------------------------------------------
  180. C
  181.   140 CONTINUE
  182. C      IF(RBUF(1).NE.0.0) CALL CLS
  183.       RETURN
  184. C
  185. C--- IFUNC=15, Select color index. -------------------------------------
  186.   150 CONTINUE
  187.       IF(NCOLR.EQ.15) THEN
  188.         CALL GCOL(0,NINT(RBUF(1)))
  189.       ELSE
  190.         IREGS(0) = KOLOUR(NINT(RBUF(1)))
  191.         IREGS(3) = 0
  192.         IREGS(4) = 0
  193. C              do ColourTrans_SetGCOL
  194.         CALL SWIF77(?I040743,IREGS,IFLAG)
  195.       ENDIF
  196.       RETURN
  197. C
  198. C--- IFUNC=16, Flush buffer. -------------------------------------------
  199. C
  200.   160 CONTINUE
  201.       RETURN
  202. C
  203. C--- IFUNC=17, Read cursor. --------------------------------------------
  204. C
  205. C
  206.   170 CONTINUE
  207. C             display pointer
  208.       CALL OSCLI('Pointer')
  209. C             move to desired place
  210.       I2X0 = NINT(RBUF(1))
  211.       I2Y0 = NINT(RBUF(2))          
  212.       MBUF(1) = 5 + IOR(ISHFT(I2X0,8),ISHFT(I2Y0,24))
  213.       MBUF(2) = ISHFT(I2Y0,-8)
  214.       CALL OSWORD(21,MBUF)
  215. C             loop and wait for keystroke
  216. C      CALL VDU(5)
  217.   172 CONTINUE
  218.         CALL MOUSE(I2X0,I2Y0,I2B0)
  219.         KEY = INKEY(0)
  220.         IF(I2B0.EQ.4) KEY = 32
  221.       IF(KEY.LE.0) GO TO 172
  222. C      CALL MOVE(I2X0,I2Y0)
  223.       RBUF(1) = FLOAT(I2X0)
  224.       RBUF(2) = FLOAT(I2Y0)
  225.       NBUF = 2
  226.       CHR(1:1)  = CHAR(KEY)
  227. C      PRINT 101,CHR(1:1)
  228. C  101 FORMAT(A1,$)
  229.       LCHR = 1
  230.   174 IF(I2B0.NE.0) THEN
  231.         CALL MOUSE(I2X0,I2Y0,I2B0)
  232.         GO TO 174
  233.       ENDIF
  234.       RETURN
  235. C
  236. C--- IFUNC=18, Erase alpha screen. -------------------------------------
  237. C
  238.   180 CONTINUE
  239.       RETURN
  240. C
  241. C--- IFUNC=19, Set line style. -----------------------------------------
  242. C
  243.   190 CONTINUE
  244.       RETURN
  245. C
  246. C--- IFUNC=20, Polygon fill. -------------------------------------------
  247. C
  248.   200 CONTINUE
  249.       RETURN
  250. C
  251. C--- IFUNC=21, Set color representation. -------------------------------
  252. C
  253.   210 CONTINUE
  254.       ICOL = NINT(RBUF(1))
  255.       IRED = NINT(RBUF(2)*255.)
  256.       IGRN = NINT(RBUF(3)*255.)
  257.       IBLU = NINT(RBUF(4)*255.)
  258.       IF(NCOLR.EQ.15) THEN
  259.         CALL VDU19(ICOL,16,IRED,IGRN,IBLU)
  260.       ELSE
  261.         KOLOUR(ICOL)=ISHFT(IBLU,24)+ISHFT(IGRN,16)+ISHFT(IRED,8)
  262.       ENDIF
  263.       RETURN
  264. C
  265. C--- IFUNC=22, Set line width. -----------------------------------------
  266. C
  267.   220 CONTINUE
  268.       RETURN
  269. C
  270. C--- IFUNC=23, Escape. -------------------------------------------------
  271. C
  272.   230 CONTINUE
  273.       RETURN
  274. C
  275. C--- IFUNC=24, Rectangle fill. -----------------------------------------
  276. C
  277.   240 CONTINUE
  278.       IX0 = NINT(RBUF(1))
  279.       IY0 = NINT(RBUF(2))
  280.       IX1 = NINT(RBUF(3))
  281.       IY1 = NINT(RBUF(4))
  282.       CALL RECTAN(IX0,IY0,IX1,IY1,.TRUE.)
  283.       RETURN
  284. C
  285. C--- IFUNC=25, Set fill pattern. ---------------------------------------
  286. C
  287.   250 CONTINUE
  288.       RETURN
  289. C
  290. C--- IFUNC=26, Line of pixels. -----------------------------------------
  291. C
  292.   260 CONTINUE
  293.       RETURN
  294. C-----------------------------------------------------------------------
  295.       END
  296.