home *** CD-ROM | disk | FTP | other *** search
- C*ACDRIV -- PGPLOT device driver for Acorn Archimedes machines
- C+
- SUBROUTINE ACDRIV (IFUNC, RBUF, NBUF, CHR, LCHR)
- INTEGER IFUNC, NBUF, LCHR
- REAL RBUF(*)
- CHARACTER*(*) CHR
- 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 Fortran release 2,
- C and linked with the Fortran Friends graphics and utils libraries.
- C
- C 15 February 1994 : Version 1.00
- C
- C Resolution: Depends on graphics mode. Ensure that the current mode is
- C suitable before running the PGPLOT program.
- C
- C
- C---
- INTEGER MODES,NXPIX,NYPIX,MULTX,MULTY,MAXX,MAXY
- SAVE MODES,NXPIX,NYPIX,MULTX,MULTY,MAXX,MAXY
- INTEGER NCOLR,KOLOUR(0:255),MBUF(2),IREGS(0:7)
- SAVE NCOLR,KOLOUR
- LOGICAL APPEND
- SAVE APPEND
- CHARACTER*4 ANS
- DATA MODES/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(MODES.EQ.0 .AND. IFUNC.GT.0) THEN
- C check for 16-colour mode
- NCOLR = MODEVAR(-1,3)
- IF(NCOLR.GT.15) NCOLR = 255
- IF(NCOLR.LT.15) THEN
- PRINT *,'Archimedes driver only works in 16-colour mode'
- NBUF = -1
- RETURN
- ENDIF
- C get screen mode
- CALL OSBYTE2(135,0,0,I,MODES)
- C get screen characteristics
- NXPIX = MODEVAR(-1,11)+1
- NYPIX = MODEVAR(-1,12)+1
- MULTX = MODEVAR(-1,4)
- MULTY = MODEVAR(-1,5)
- MAXX = ISHFT(NXPIX,MULTX)
- MAXY = ISHFT(NYPIX,MULTY)
- 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) IFUNC
- C unknown driver function, so just return
- NBUF = -1
- RETURN
- C
- C--- IFUNC = 1, Return device name.-------------------------------------
- C
- 10 CHR = 'ARC (for Acorn Archimedes machines)'
- LCHR = LNBLNK(CHR)
- NBUF = 0
- 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
- RBUF(3) = 0
- RBUF(4) = MAXY
- RBUF(5) = 0
- RBUF(6) = NCOLR
- NBUF = 6
- LCHR = 0
- 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/10.0
- RBUF(2) = MAXY/8.0
- RBUF(3) = FLOAT(ISHFT(1,MULTX))
- NBUF = 3
- LCHR = 0
- RETURN
- C
- C--- IFUNC = 4, Return misc device info. -------------------------------
- C (This device is Interactive, cursor, No dashed lines, No area fill,
- C No thick lines, rectangle fill)
- C
- 40 CHR = 'ICNNNRNNNN'
- LCHR = 10
- NBUF = 0
- RETURN
- C
- C--- IFUNC = 5, Return default file name. ------------------------------
- C
- 50 CHR = ' '
- LCHR = 1
- NBUF = 0
- RETURN
- C
- C--- IFUNC = 6, Return default physical size of plot. ------------------
- C
- 60 CONTINUE
- RBUF(1) = 0
- RBUF(2) = MAXX
- RBUF(3) = 0
- RBUF(4) = MAXY
- NBUF = 4
- LCHR = 0
- RETURN
- C
- C--- IFUNC = 7, Return misc defaults. ----------------------------------
- C
- 70 RBUF(1) = 1
- NBUF = 1
- LCHR = 0
- RETURN
- C
- C--- IFUNC = 8, Select plot. -------------------------------------------
- C
- 80 CONTINUE
- LCHR = 0
- NBUF = 0
- RETURN
- C
- C--- IFUNC = 9, Open workstation. --------------------------------------
- C
- 90 CONTINUE
- CALL MODE(MODES)
- C set append flag to suppress screen clearing
- APPEND = RBUF(3).NE.0.
- RBUF(1) = 0
- RBUF(2) = 1
- NBUF = 2
- RETURN
- C
- C--- IFUNC=10, Close workstation. --------------------------------------
- C
- 100 CONTINUE
- C CALL GRGCOM(ANS,'Close Workstation',LREAD)
- RETURN
- C
- C--- IFUNC=11, Begin picture. ------------------------------------------
- C
- 110 CONTINUE
- IF(.NOT.APPEND) CALL CLS
- C set up colours
- IF(NCOLR.EQ.15) THEN
- DO 112 I = 0, 15
- CALL VDU19(I, 16,
- 1 IAND(ISHFT(KOLOUR(I),-8),255),
- 2 IAND(ISHFT(KOLOUR(I),-16),255),
- 3 ISHFT(KOLOUR(I),-24))
- 112 CONTINUE
- ENDIF
- RETURN
- C
- C--- IFUNC=12, Draw line. ----------------------------------------------
- C
- 120 CONTINUE
- CALL LINE(NINT(RBUF(1)),NINT(RBUF(2)),NINT(RBUF(3)),NINT(RBUF(4)))
- RETURN
- C
- C--- IFUNC=13, Draw dot. -----------------------------------------------
- C
- 130 CONTINUE
- CALL SPOT(NINT(RBUF(1)),NINT(RBUF(2)))
- RETURN
- C
- C--- IFUNC=14, End picture. --------------------------------------------
- C
- 140 CONTINUE
- C IF(RBUF(1).NE.0.0) CALL CLS
- RETURN
- C
- C--- IFUNC=15, Select color index. -------------------------------------
- 150 CONTINUE
- IF(NCOLR.EQ.15) THEN
- CALL GCOL(0,NINT(RBUF(1)))
- ELSE
- IREGS(0) = KOLOUR(NINT(RBUF(1)))
- IREGS(3) = 0
- IREGS(4) = 0
- C do ColourTrans_SetGCOL
- CALL SWIF77(?I040743,IREGS,IFLAG)
- ENDIF
- RETURN
- C
- C--- IFUNC=16, Flush buffer. -------------------------------------------
- C
- 160 CONTINUE
- RETURN
- C
- C--- IFUNC=17, Read cursor. --------------------------------------------
- C
- C
- 170 CONTINUE
- C display pointer
- CALL OSCLI('Pointer')
- C move to desired place
- I2X0 = NINT(RBUF(1))
- I2Y0 = NINT(RBUF(2))
- MBUF(1) = 5 + IOR(ISHFT(I2X0,8),ISHFT(I2Y0,24))
- MBUF(2) = ISHFT(I2Y0,-8)
- CALL OSWORD(21,MBUF)
- C loop and wait for keystroke
- C CALL VDU(5)
- 172 CONTINUE
- CALL MOUSE(I2X0,I2Y0,I2B0)
- KEY = INKEY(0)
- IF(I2B0.EQ.4) KEY = 32
- IF(KEY.LE.0) GO TO 172
- C CALL MOVE(I2X0,I2Y0)
- RBUF(1) = FLOAT(I2X0)
- RBUF(2) = FLOAT(I2Y0)
- NBUF = 2
- CHR(1:1) = CHAR(KEY)
- C PRINT 101,CHR(1:1)
- C 101 FORMAT(A1,$)
- LCHR = 1
- 174 IF(I2B0.NE.0) THEN
- CALL MOUSE(I2X0,I2Y0,I2B0)
- GO TO 174
- ENDIF
- RETURN
- C
- C--- IFUNC=18, Erase alpha screen. -------------------------------------
- C
- 180 CONTINUE
- RETURN
- C
- C--- IFUNC=19, Set line style. -----------------------------------------
- C
- 190 CONTINUE
- RETURN
- C
- C--- IFUNC=20, Polygon fill. -------------------------------------------
- C
- 200 CONTINUE
- 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.)
- IF(NCOLR.EQ.15) THEN
- CALL VDU19(ICOL,16,IRED,IGRN,IBLU)
- ELSE
- KOLOUR(ICOL)=ISHFT(IBLU,24)+ISHFT(IGRN,16)+ISHFT(IRED,8)
- ENDIF
- RETURN
- C
- C--- IFUNC=22, Set line width. -----------------------------------------
- C
- 220 CONTINUE
- RETURN
- C
- C--- IFUNC=23, Escape. -------------------------------------------------
- C
- 230 CONTINUE
- RETURN
- C
- C--- IFUNC=24, Rectangle fill. -----------------------------------------
- C
- 240 CONTINUE
- IX0 = NINT(RBUF(1))
- IY0 = NINT(RBUF(2))
- IX1 = NINT(RBUF(3))
- IY1 = NINT(RBUF(4))
- CALL RECTAN(IX0,IY0,IX1,IY1,.TRUE.)
- RETURN
- C
- C--- IFUNC=25, Set fill pattern. ---------------------------------------
- C
- 250 CONTINUE
- RETURN
- C
- C--- IFUNC=26, Line of pixels. -----------------------------------------
- C
- 260 CONTINUE
- RETURN
- C-----------------------------------------------------------------------
- END
-