C Date: 3-FEB-1988 15:08:50 GMT C From: AFT@AST-STAR.CAM.AC.UK C To: TJP@CITPHOBO C Subject: ARDRIVER.FOR SUBROUTINE ARDRIV(IFUNC, RBUF, NBUF, CHR, LCHR) INTEGER IFUNC, NBUF, LCHR REAL RBUF(*) CHARACTER CHR*(*) C C PGPLOT driver for Args image device. C--- C Supported device: Sigma Args, 7000 series. C C Device type code: /ARgs. C C Default device name: ARGS_DEVICE (a logical name). C C Default view surface dimensions: Depends on monitor. C C Resolution: The full view surface is 512 by 512 pixels. C C Color capability: Color indices 0-255 are supported. The default C representation is listed in Chapter 5 of the PGPLOT manual. The C representation of all color indices can be changed. C C Input capability: A cursor routine is provided that works on C Starlink Args devices. It is possible to move the cursor with C either the tracker ball or by using the arrow keys on the terminal C (SYS$COMMAND); the PF1 to PF4 keys can be used to control the rate C at which the arrow keys move the cursor. Terminate the cursor (in C all cases) by typing any printable character on the keyboard. C C File format: It is not possible to send ARGS plots to a disk file. C C Obtaining hardcopy: Not possible. C--- C 17-Jan-1988 - No longer requires GESUPPORT routines [AFT]. C 21-Sep-1986 - [AFT]. C 15-Oct-1986 - Modified to work on a Q-bus [AFT]. C 16-Jan-1988 - [AFT] C----------------------------------------------------------------------- INCLUDE '($IODEF)' INCLUDE '($PRDEF)' INCLUDE '($SSDEF)' INCLUDE '($SYIDEF)' C CHARACTER MSG*10 INTEGER GRAR00, SYS$DASSGN, GRGMEM, IER INTEGER IOCODE, I, I0, J0, I1, J1, ICPU INTEGER*2 ITMP(10), ILEV, IOSB(4) INTEGER IREM, IWRT, IRD, ICHAN, MXCNT, ICNT, IBADR, ICOL SAVE IREM, IWRT, IRD, ICHAN, MXCNT, ICNT, IBADR, ICOL INTEGER MICRO, ITYPE SAVE MICRO, ITYPE LOGICAL APPEND SAVE APPEND C--- GOTO( 10, 20, 30, 40, 50, 60, 70, 80, 90,100, & 110,120,130,140,150,160,170,180,900,900, & 210,900,230) IFUNC 900 WRITE (MSG,'(I10)') IFUNC CALL GRWARN('Unimplemented function in AR device driver: '//MSG) NBUF = -1 RETURN C C--- IFUNC= 1, Return device name. ------------------------------------- 10 CHR='ARGS' LCHR=LEN(CHR) RETURN C C--- IFUNC= 2, Return Physical min and max for plot device. ------------ 20 RBUF(1)=0 RBUF(2)=511 RBUF(3)=0 RBUF(4)=511 RBUF(5)=0 RBUF(6)=255 NBUF=6 RETURN C C--- IFUNC= 3, Return device resolution. ------------------------------- 30 RBUF(1)=50.0 RBUF(2)=50.0 RBUF(3)=1 NBUF=3 RETURN C C--- IFUNC= 4, Return misc device info. -------------------------------- C I= Interactive device C C= Cursor C N= No hard dash C A= No area fill (not implemented) C N= No hard thick lines 40 CHR='ICNNNNNNNN' LCHR=10 RETURN C C--- IFUNC= 5, Return default file name. ------------------------------- 50 CHR='ARGS_DEVICE' LCHR=LEN(CHR) NBUF=1 RETURN C C--- IFUNC= 6, Return default physical size of plot. ------------------- 60 RBUF(1)=0 RBUF(2)=511 RBUF(3)=0 RBUF(4)=511 RETURN C C--- IFUNC= 7, Return misc defaults. ----------------------------------- 70 RBUF(1)=1 NBUF=1 RETURN C C--- IFUNC= 8, Select plot. -------------------------------------------- 80 CALL INAR03(ICHAN,IWRT) RETURN C C--- IFUNC= 9, Open workstation. --------------------------------------- 90 APPEND=RBUF(3).NE.0.0 RBUF(2)=GRAR00(ICHAN,CHR,LCHR) RBUF(1)=ICHAN C--- C- Allocate a buffer. Note, there could be a hardware interface C- bug for the ID driver which will cause the QIO to fail if the C- buffer starts on the last two words of a page. Since the address C- returned by GRGMEM begins on a quadword boundary, this C- condition can never arise. However, some care is required C- to make sure that the QIO to the Args only uses the buffer C- allocated with GRGMEM. C--- MXCNT=8192 IER=GRGMEM(MXCNT,IBADR) IF(IER .NE. SS$_NORMAL) THEN CALL GRGMSG(IER) CALL GRWARN('Unable to allocate virtual memory.') RBUF(2)=0 CALL SYS$DASSGN(%val(ICHAN)) RETURN END IF C--- C- If device opened remotely, set remote flag. Note, current C- driver does not support remote access. C--- IF(NINT(RBUF(2)).EQ.1) THEN IREM=0 ELSE IF(NINT(RBUF(2)).EQ.3) THEN IREM=1 RBUF(2)=1 ELSE C- Error condition. RETURN END IF C--- C- The QIO function is different for Unibus and Q-bus machines so C- detect CPU type. C--- CALL LIB$GETSYI(SYI$_CPU,ICPU) IF(ICPU.EQ.PR$_SID_TYPUV1 .OR. ICPU.EQ.PR$_SID_TYPUV2) THEN MICRO=1 ITYPE=1 IWRT=IO$_WRITEVBLK IRD =IO$_READVBLK ELSE MICRO=0 ITYPE=2 IWRT=IO$_WRITEVBLK IRD =IO$_READVBLK END IF C--- C- Init the buffer routine. C--- CALL INAR03(ICHAN,IWRT) CALL INAR01 C--- C- Cancel any outstanding I/O requests C--- CALL SYS$CANCEL(%val(ICHAN)) CALL SYS$WAITFR() C--- C- Reset interface. C--- IF(MICRO.EQ.0) THEN I=1 IOCODE=IOR(IWRT,I*'0040'x) CALL SYS$QIOW(,%val(ICHAN),%val(IOCODE),IOSB,,, & I,%val(I),,,,) ELSE I=2 IOCODE=IOR(IWRT,'2800'x) CALL SYS$QIOW(,%val(ICHAN),%val(IOCODE),IOSB,,, & %val(I),,,,,) END IF C--- C- Load default lookup table (if not appending). C--- IF(.NOT.APPEND) CALL GRAR10(%val(IBADR),ICNT,MXCNT) RETURN C C--- IFUNC=10, Close workstation. -------------------------------------- 100 CALL SYS$DASSGN(%val(ICHAN)) CALL GRFMEM(MXCNT,IBADR) RETURN C C--- IFUNC=11, Begin Picture. ------------------------------------------ 110 CALL INAR01 IF(.NOT.APPEND) THEN ITMP(1)='3501'x ITMP(2)='FFFF'x ITMP(3)='0003'x ITMP(4)='0003'x ITMP(5)='0003'x ITMP(6)='3501'x ITMP(7)='FFFF'x CALL GRAR02(ITMP,14,%val(IBADR),ICNT,MXCNT) CALL GRAR03(%val(IBADR),ICNT) END IF APPEND=.FALSE. RETURN C C--- IFUNC=12, Draw line. ---------------------------------------------- 120 I0=NINT(RBUF(1)) J0=NINT(RBUF(2)) I1=NINT(RBUF(3)) J1=NINT(RBUF(4)) CALL GRAR01(I0,J0,I1,J1,%val(IBADR),ICNT,MXCNT) RETURN C C--- IFUNC=13, Draw dot. ----------------------------------------------- 130 I0=NINT(RBUF(1)) J0=NINT(RBUF(2)) CALL GRAR01(I0,J0,I0,J0,%val(IBADR),ICNT,MXCNT) RETURN C C--- IFUNC=14, End Picture. -------------------------------------------- 140 RETURN C C--- IFUNC=15, Select color index. ------------------------------------- 150 ICOL=MAX(0,MIN(NINT(RBUF(1)),255)) ITMP(1)='2901'x ITMP(2)=ICOL CALL GRAR02(ITMP,4,%val(IBADR),ICNT,MXCNT) RETURN C C--- IFUNC=16, Flush buffer. ------------------------------------------- 160 CALL GRAR03(%val(IBADR),ICNT) RETURN C C--- IFUNC=17, Read cursor. -------------------------------------------- 170 I0=RBUF(1) J0=RBUF(2) CALL GRAR11(ICHAN,I0,J0,CHR,%val(IBADR),ICNT,MXCNT) RBUF(1)=I0 RBUF(2)=J0 NBUF=2 LCHR=1 RETURN C C--- IFUNC=18, Erase alpha screen. ------------------------------------- 180 RETURN C C--- IFUNC=21, Set color representation. ------------------------------- 210 ITMP(1)=IOR('1800'x,0) ITMP(2)=NINT(RBUF(1)) ILEV=IAND(255,INT(RBUF(2)*255.999)) ITMP(3)=ILEV ILEV=IAND(255,INT(RBUF(3)*255.999)) ITMP(3)=ISHFT(ILEV,8)+ITMP(3) ILEV=IAND(255,INT(RBUF(4)*255.999)) ITMP(4)='FF00'x+ILEV CALL GRAR02(ITMP, 8, %val(IBADR), ICNT, MXCNT) RETURN C C--- IFUNC=23, Escape. ------------------------------------------------- C- Send CHR array directly to Args (user better know what he is doing!) 230 CALL GRAR02(%ref(CHR),LCHR,%val(IBADR),ICNT,MXCNT) RETURN C----------------------------------------------------------------------- END INTEGER FUNCTION GRAR00(LUN,CHR,LCHR) C----------------------------------------------------------------------- C GRPCKG (Args internal routine): Opens a QIO channel to the Args. C C GRAR00 (returns integer): 0 if the channel could not be opened C 1 if the channel was opened successfully on a local device, C 3 for a successful open of a channel over a network, C (the remote status of the C device must be flagged since, the QIO functions codes are C different when writting to a physical device or to the C network). C C 16-Jan-1988 - Modified from GESUPPORT routine [AFT]. C----------------------------------------------------------------------- INCLUDE '($IODEF)' INCLUDE '($SSDEF)' INTEGER DVI$_DEVCLASS, DVI$_DEVNAM PARAMETER (DVI$_DEVCLASS=4) PARAMETER (DVI$_DEVNAM=32) INTEGER LUN,LCHR CHARACTER CHR*(*) INTEGER IER, ITEMP INTEGER DEVCLASS, ITMLIST(7), MOSB(2), ISTAT, LENGTH INTEGER SYS$ASSIGN, SYS$QIOW INTEGER SYS$GETDVI, SYS$DASSGN, SYS$WAITFR INTEGER*2 IOSB(4) LOGICAL WRONG C--- C- Assign an i/o channel C--- IER=SYS$ASSIGN(CHR(:LCHR), LUN,,) IF(IER.NE.SS$_NORMAL .AND. IER.NE.SS$_REMOTE) GOTO 900 IF(IER.EQ.SS$_REMOTE) THEN C--- C- Cannot check device characteristics easily if network device being used C- so just check whether we opened the device successfully and return C- Read back the status from assign to plotting device over network C--- IER=SYS$QIOW(,%VAL(LUN),%VAL(IO$_READVBLK), : IOSB,,,ISTAT,LENGTH,,,,) IF(IOSB(1) .NE. SS$_NORMAL) THEN CALL GRWARN ('Unable to read status from ASSIGN to' // : ' graphics device on remote node') WRITE(6,*) IOSB(2), ' bytes read' ITEMP=IOSB(1) CALL GRGMSG(ITEMP) GRAR00=0 RETURN END IF IF(ISTAT .NE. SS$_NORMAL) THEN IER=ISTAT GOTO 900 ELSE GRAR00=3 RETURN END IF END IF C--- C- Check that device has correct characteristics, C- and obtain true device name. C--- ITMLIST(1)=DVI$_DEVCLASS*2**16+4 ITMLIST(2)=%LOC(DEVCLASS) ITMLIST(3)=0 ITMLIST(4)=DVI$_DEVNAM*2**16+LEN(CHR) ITMLIST(5)=%LOC(CHR) ITMLIST(6)=%LOC(LCHR) ITMLIST(7)=0 IER=SYS$GETDVI(%VAL(0),,CHR(:LCHR), 1 ITMLIST,MOSB,,,) IF(.NOT.IER) GOTO 900 IER=SYS$WAITFR(%VAL(0)) IF(.NOT.IER) GOTO 900 IF(.NOT.MOSB(1)) THEN IER=MOSB(1) GOTO 900 END IF WRONG=DEVCLASS.NE.96 IF(WRONG) THEN CALL GRWARN( CHR(:LCHR)// 2 ' is the wrong sort of device for plot type.') IER=SYS$DASSGN(%VAL(LUN)) GOTO 990 END IF C--- C- Successful completion C--- GRAR00=1 RETURN C--- C- Error exit C--- 900 CALL GRWARN('Cannot open graphics device '//CHR(:LCHR)) CALL GRGMSG(IER) 990 GRAR00=0 END C********* SUBROUTINE GRAR01(I0,J0,I1,J1,IBUF,ICNT,MXCNT) C----------------------------------------------------------------------- C GRPCKG(internal routine, ARGS): draw a line segment. C C Arguments: C C I0,J0(integer*2, input): the column and row numbers of the starting C point. C I1,J1(integer*2, input): the column and row numbers of the end point. C C Note: the arguments are specified as integer*2, but(on the VAX at C least) integer*4 values may be used. The values should be in the C range defined by the hardware:(0...511). C C 11-Apr-1983 C 7-Nov-1984 - KS/AAO) Some optimisation based on last position added. C----------------------------------------------------------------------- INTEGER I0, J0, I1, J1, ICNT, MXCNT INTEGER*2 IBUF INTEGER*2 CLIP511 INTEGER IPTR,X INTEGER*2 IC0, JC0, IC1, JC1, ITMP(4) INTEGER*2 LASTI, LASTJ SAVE LASTI, LASTJ C CLIP511(X)=X .AND. '1FF'x C IC0=CLIP511(I0) JC0=CLIP511(J0) IC1=CLIP511(I1) JC1=CLIP511(J1) C IF(IC0.NE.LASTI .OR. JC0.NE.LASTJ) THEN ITMP(1)=IOR(IC0,'C000'x) ITMP(2)=IOR(JC0,'A000'x) IPTR=3 ELSE IPTR=1 END IF ITMP(IPTR) =IOR(IC1,'C000'x) ITMP(IPTR+1)=IOR(JC1,'E000'x) LASTI=IC1 LASTJ=JC1 CALL GRAR02(ITMP,2*(IPTR+1),IBUF,ICNT,MXCNT) RETURN C ENTRY INAR01 LASTI=-1 LASTJ=-1 RETURN END C********* SUBROUTINE GRAR02(STR, N, QBUF, ICNT, MXCNT) C----------------------------------------------------------------------- C GRPCKG (Args internal routine): Transfer N bytes to C the output buffer, flushing the buffer as necessary with the C GRAR03 routine. If the N bytes will not fit into the current C buffer, then the buffer is first dumped. This is to to cause C STR to be transferred as a complete unit. C Based on early versions of GRxx02 routines, this version does not C use any common blocks. C ***NOTE*** INAR03 must be called before any calls to GRAR02 to C set the LUN/Channel to which the buffer should be dumped. C C Arguments: C C STR(N) I Byte Characters to be written. C N I I The number of bytes to transfer. C QBUF I/O Byte The output buffer. C ICNT I/O I Current number of bytes used in QBUF. C MXCNT I/O I Maximum number of bytes that can be stored C -in QBUF. C C 16-Jan-1988 - Based on GESUPPORT routine [AFT]. C----------------------------------------------------------------------- INTEGER ICNT,MXCNT,I,N BYTE QBUF(N), STR(N) C--- IF(ICNT+N.GE.MXCNT) CALL GRAR03(QBUF,ICNT) DO 100 I=1,N ICNT=ICNT+1 QBUF(ICNT)=STR(I) 100 CONTINUE RETURN END C********* SUBROUTINE GRAR03(QBUF,ICNT) C----------------------------------------------------------------------- C GRPCKG (Args internal routine): Write ICNT bytes in QBUF to the device C Reset ICNT to zero. C ***NOTE*** INAR03 must be called before any calls to GRAR02 to C set the correct Channel number. C This subroutine contains the entry point INAR03 that defines C the variables ICHAN and IFUNC. C C Arguments: C C QBUF I/O Byte The output buffer. C ICNT I/O I Current number of bytes used in QBUF. C C 16-Jan-1988 - Modified from GESUPPORT routines [AFT]. C----------------------------------------------------------------------- INCLUDE '($SSDEF)' INTEGER SYS$QIOW INTEGER ICNT BYTE QBUF(*) INTEGER RESULT, N INTEGER*2 IOSB(4) INTEGER INCHAN,INFUNC INTEGER ICHAN,IFUNC SAVE ICHAN,IFUNC C N=ICNT ICNT=0 IF(N.LT.1) RETURN C--- RESULT=SYS$QIOW(,%val(ICHAN),%val(IFUNC),IOSB,,, 1 QBUF(N+1),%val(4), 2 QBUF,%val(N/2),%val(8),) C--- IF(RESULT.NE.SS$_NORMAL) THEN CALL GRGMSG(RESULT) CALL GRWARN('SYS$QIOW error writing to device.') END IF IF(IOSB(1).NE.SS$_NORMAL) THEN CALL GRGMSG(IOSB(1)) CALL GRWARN('SYS$QIOW (IOSB) status writing to device.') END IF RETURN C--- ENTRY INAR03(INCHAN,INFUNC) C- Save info needed to dump buffer. ICHAN=INCHAN IFUNC=INFUNC RETURN END SUBROUTINE GRAR10(IBUF,ICNT,MXCNT) C----------------------------------------------------------------------- C GRPCKG(internal routine, ARGS): advance the plotting area to a C new page. This routine is called for ARGS devices by GRPAGE to C reinitialize the display. C C 11-Apr-1983 C 7-Nov-1984 - Colour table code modified [KS/AAO]. C 21-Sep-1986 - Modified for use with GEDRIVER [AFT]. C----------------------------------------------------------------------- INTEGER MXCOL PARAMETER (MXCOL=16) C INTEGER ICNT, MXCNT INTEGER*2 IBUF C INTEGER IPTR, ICLR INTEGER*2 ITMP(257) C INTEGER*2 IRED(MXCOL), IBLUE(MXCOL), IGREEN(MXCOL) DATA IRED / 0,255,255, 0, 0, 0,255,255, & 255,127, 0, 0,127,255, 85,170/ DATA IGREEN/ 0,255, 0,255, 0,255, 0,255, & 127,255,255,127, 0, 0, 85,170/ DATA IBLUE / 0,255, 0, 0,255,255,255, 0, & 0, 0,127,255,255,127, 85,170/ C C Reset GSW to drawing mode,size and direction all zero, autoincrement on, C background overlay off, backwash off, cursor scroll disabled C ITMP(1)='0E00'x ! Load status word ITMP(2)='2000'x C C Reset Z status register to 32 bits and 0 offset. C ITMP(3)='0700'x ITMP(4)='1F00'x CALL GRAR02(ITMP,8,IBUF,ICNT,MXCNT) C C Reset VSR to display graphics and overlay C ITMP(1)='2401'x ITMP(2)='01C0'x ITMP(3)=0 ITMP(4)='0007'x CALL GRAR02(ITMP,8,IBUF,ICNT,MXCNT) C C Set origin to 0,0 C ITMP(1)='1000'x ! X Origin to 0 ITMP(2)=0 ITMP(3)='1100'x ! Y Origin to 0 ITMP(4)=0 C C Put pen at origin C ITMP(5)='C000'x ITMP(6)='A000'x C C Unzoom C ITMP(7)='5000'x ITMP(8)=0 CALL GRAR02(ITMP,16,IBUF,ICNT,MXCNT) C C No scroll C ITMP(1)='3901'x ITMP(2)='FFFF'x ITMP(3)=0 ITMP(4)='3B01'x ITMP(5)='FFFF'x ITMP(6)=0 CALL GRAR02(ITMP,12,IBUF,ICNT,MXCNT) C C Set write enable for lower 8 bit planes only C ITMP(1)='2D01'x ITMP(2)='00FF'x C C Turn on all planes C ITMP(3)='2B01'x ITMP(4)='FFFF'x CALL GRAR02(ITMP,8,IBUF,ICNT,MXCNT) C C Turn off lamps C ITMP(1)='3C40'x ITMP(2)='3C45'x ITMP(3)=0 CALL GRAR02(ITMP,6,IBUF,ICNT,MXCNT) C C Set colour table C IPTR=2 DO ICLR=1,MXCOL IPTR=IPTR+2 ITMP(IPTR-1)=IOR(ISHFT(IGREEN(ICLR),8),IRED(ICLR)) ITMP(IPTR) =IOR('FF00'x,IBLUE(ICLR)) END DO ITMP(1)=IOR('1800'x,MXCOL-1) ITMP(2)=0 CALL GRAR02(ITMP,2*IPTR,IBUF,ICNT,MXCNT) C C Flush ARGS Buffer C CALL GRAR03(IBUF,ICNT) C RETURN END SUBROUTINE GRAR11(ICHAN, IX, IY, CHR, IBUF, ICNT, MXCNT) INTEGER ICHAN, IX, IY, IBUF, ICNT, MXCNT CHARACTER CHR C C Arguments C ICHAN (input) QIO channel assigned to Args C IX,IY (in/out) The cursor position C CHR (output) The keyboard character pressed C IBUF (input) Address of a buffer area C ICNT (in/out) Number of bytes in use in buffer C MXCNT (input) Maximum size of buffer in bytes C--- C Read the cursor position on the Args. The cursor can be moved C by either rolling the tracker ball. C The cursor can also be moved by using the cursor keys on the C terminal associated with SYS$COMMAND in which case the cursor C "speed" (step size) is controlled by the PF1 (smallest step) to C PF4 (largest step) keys. The numeric keys on the keypad can be C used in place of the arrow keys, with the addition of diagonal C motion: C UP C 7 8 9 C LEFT 4 6 RIGHT C 1 2 3 C DOWN C--- C- 19-Jan-1988 - Modified to track VTDRIVER [AFT]. C--- INTEGER SMG$CREATE_VIRTUAL_KEYBOARD, SMG$READ_KEYSTROKE INTEGER IXWAS, IYWAS, ISTEP, IER, IVAL, IXINC, IYINC INTEGER SWITCH, IDSMG INTEGER*2 ITMP(10) LOGICAL QKEY C--- IER=SMG$CREATE_VIRTUAL_KEYBOARD(IDSMG,'SYS$COMMAND') IF(IER.NE.1) THEN CALL GRGMSG(IER) CALL GRQUIT('Fatal error.') END IF ITMP(1)='3C40'x CALL GRAR02(ITMP,2,IBUF,ICNT,MXCNT) CALL GRAR03(IBUF,ICNT) CALL GRAR21(IX,IY,.TRUE.,.FALSE.,IBUF,ICNT,MXCNT) IXWAS=IX IYWAS=IY QKEY=.FALSE. ISTEP=2 DO WHILE (.NOT.QKEY) C- See if user has typed something at keyboard. IER=SMG$READ_KEYSTROKE(IDSMG,IVAL,,0) IF(IER.NE.1) IVAL=0 IF(IVAL.EQ.259) THEN C- PF4=large step ISTEP=64 ELSE IF(IVAL.EQ.258) THEN ISTEP=8 ELSE IF(IVAL.EQ.257) THEN ISTEP=4 ELSE IF(IVAL.EQ.256) THEN C- PF1=small step ISTEP=1 ELSE IF(IVAL.EQ.49 .OR. IVAL.EQ.261) THEN C- key 1 or KP1 IX=IX-ISTEP IY=IY-ISTEP ELSE IF(IVAL.EQ.50 .OR. IVAL.EQ.262 .OR. IVAL.EQ.275) THEN C- key 2, KP2 or DOWN IY=IY-ISTEP ELSE IF(IVAL.EQ.51 .OR. IVAL.EQ.263) THEN C- key 3 or KP3 IX=IX+ISTEP IY=IY-ISTEP ELSE IF(IVAL.EQ.52 .OR. IVAL.EQ.264 .OR. IVAL.EQ.276) THEN C- key 4, KP4 or LEFT IX=IX-ISTEP ELSE IF(IVAL.EQ.54 .OR. IVAL.EQ.266 .OR. IVAL.EQ.277) THEN C- key 6, KP6 or RIGHT IX=IX+ISTEP ELSE IF(IVAL.EQ.55 .OR. IVAL.EQ.267) THEN C- key 7 or KP7 IX=IX-ISTEP IY=IY+ISTEP ELSE IF(IVAL.EQ.56 .OR. IVAL.EQ.268 .OR. IVAL.EQ.274) THEN C- key 8, KP8 or UP IY=IY+ISTEP ELSE IF(IVAL.EQ.57 .OR. IVAL.EQ.269) THEN C- key 9 or KP9 IX=IX+ISTEP IY=IY+ISTEP ELSE IF((IVAL.GT.0 .AND. IVAL.LT.48) .OR. & (IVAL.GT.57 .AND. IVAL.LT.255)) THEN QKEY=.TRUE. END IF CALL GRAR22(ICHAN,IXINC,IYINC,SWITCH,IBUF,ICNT) IX=IX+IXINC IY=IY+IYINC IY=MAX(IY,0) IY=MIN(IY,511) IX=MAX(IX,0) IX=MIN(IX,511) CALL GRAR21(IX,IY,.FALSE.,.FALSE.,IBUF,ICNT,MXCNT) IF(IX.NE.IXWAS.OR.IY.NE.IYWAS) THEN IXWAS=IX IYWAS=IY ELSE CALL LIB$WAIT(0.05) END IF END DO CHR=CHAR(IVAL) CALL GRAR21(IX,IY,.FALSE.,.TRUE.,IBUF,ICNT,MXCNT) C--- C- Free resources. CALL SMG$DELETE_VIRTUAL_KEYBOARD(IDSMG) RETURN END SUBROUTINE GRAR21(IX,IY,ON,OFF,IBUF,ICNT,MXCNT) C----------------------------------------------------------------------- C GRPCKG (Internal routine, ARGS) Control position of ARGS cursor C C Arguments: C C IX,IY (Integer, input) Position to which cursor is to be moved. C ON (Logical, input) True if cursor is to be switched on. C OFF (Logical, input) True if cursor is to be switched off. C C If ON and OFF are both false, the cursor is positioned, but C is switched neither on nor off. If both are true, it is switched C on and then off. C C (08-Nov-1984 KS / AAO) C----------------------------------------------------------------------- LOGICAL ON,OFF INTEGER IX,IY,IBUF,ICNT,MXCNT C INTEGER*2 CURON(4),CUROFF(4),CURPOS(4) INTEGER NWORDS DATA CURON /'2401'X,'01F8'X,'0008'X,'0000'X/ DATA CUROFF/'2401'X,'01C0'X,'0000'X,'0000'X/ DATA CURPOS/'1700'X,'0000'X,'2700'X,'0000'X/ C CURPOS(2)=IX CURPOS(4)=IY CALL GRAR02(CURPOS,8,IBUF,ICNT,MXCNT) NWORDS=4 IF(ON) THEN CALL GRAR02(CURON,8,IBUF,ICNT,MXCNT) NWORDS=NWORDS+4 END IF IF(OFF) THEN CALL GRAR02(CUROFF,8,IBUF,ICNT,MXCNT) NWORDS=NWORDS+4 END IF CALL GRAR03(IBUF,ICNT) C END SUBROUTINE GRAR22(ICHAN,IX,IY,SWITCH,IBUF,ICNT) C-------------------------------------------------------------------- C GRPCKG (Internal routine, ARGS) Read trackerball values C C Arguments - C C IX,IY (Integer, output) Change in trackerball position in X and Y C since this routine was last called. C SWITCH (Integer, output) Switch status word. Bits 3 through 6 C indicate switch operations since last C read. C C Note: the trackerball must have been reset at some point before C the first call to this routine. C C 13-Dec-1984 - [KS/AAO] C 21-Mar-1987 - Should now work on micro-VAX [PWH/AFT] C---------------------------------------------------------------------- INCLUDE '($PRDEF)' INCLUDE '($SYIDEF)' C INTEGER ICHAN, IX, IY, SWITCH, IBUF, ICNT C INCLUDE '($IODEF)' C INTEGER ICPU, IOSTAT, IER, SYS$QIOW INTEGER*2 IOSB(4), SBUFF(7) INTEGER*2 READC(5) DATA READC/0,0,0,0,'3C44'X/ C C- Read trackerball. C CALL GRAR03(IBUF,ICNT) CALL LIB$GETSYI(SYI$_CPU,ICPU) IF(ICPU.EQ.PR$_SID_TYPUV1 .OR. ICPU.EQ.PR$_SID_TYPUV2) THEN C--- C- On Micro-VAX (Q-bus). IER=SYS$QIOW(,%val(ICHAN),%val(IO$_WRITEVBLK),IOSB,,, & READC(5), %val(2), %val(5),,,) IER=SYS$QIOW(,%val(ICHAN),%val(IO$_READVBLK),IOSB,,, & SBUFF(5), %val(6), %val(5),,,) ELSE C--- C- On Unibus. IER=SYS$QIOW(,%val(ICHAN),%val(IO$_READVBLK),IOSB,,, & READC, %val(5),SBUFF,%val(7),,) END IF IOSTAT=IOSB(1) IF(.NOT.IER) IOSTAT=IER IF(.NOT.IOSTAT) THEN CALL GRGMSG(IOSTAT) CALL GRQUIT('SYS$QIOW failure reading from ARGS') END IF C IX=SBUFF(5) IY=SBUFF(6) SWITCH=SBUFF(7) C END