1 SUBROUTINE IKDRIV(IFUNC, RBUF, NBUF, CHR, LCHR) 2 INTEGER IFUNC, NBUF, LCHR 3 REAL RBUF(*) 4 CHARACTER CHR*(*) 5C 6C PGPLOT driver for Ikon devices. 7C--- 8C Supported device: Digisolve Ikon Pixel Engine 9C 10C Device type code: /IKon. 11C 12C Default device name: IKON_DEFAULT (a logical name). 13C 14C Default view surface dimensions: Depends on monitor. 15C 16C Resolution: The full view surface is 1024 by 780 pixels. 17C 18C Color capability: Color indices 0-255 are supported. The default 19C representation is listed in Chapter 5 of the PGPLOT manual. The 20C representation of all color indices can be changed. 21C 22C Input capability: 23C 24C File format: It is not possible to send IKON plots to a disk file. 25C 26C Obtaining hardcopy: Not possible. 27C--- 28C 30-Jan-1988 - [AFT]. 29C----------------------------------------------------------------------- 30 INCLUDE '($IODEF)' 31C 32 CHARACTER MSG*10 33 INTEGER GRIK00, SYS$DASSGN, GRGMEM, SYS$QIOW 34 INTEGER I0, J0, ISTAT 35 INTEGER*2 ITMP(9), INIT(51), IOSB(4) 36 INTEGER IREM, ICHAN, MXCNT, ICNT, IBADR, ICOL, NPTS, INEWP 37 SAVE IREM, ICHAN, MXCNT, ICNT, IBADR, ICOL, NPTS, INEWP 38 LOGICAL APPEND 39 SAVE APPEND 40 DATA INIT/82,15,0, 0, 0, 0, 255,255,255, 255, 0, 0, 41 : 0,255, 0, 0, 0,255, 0,255,255, 255, 0,255, 42 : 255,255, 0, 255,127, 0, 127,255, 0, 0,255,127, 43 : 0,127,255, 127, 0,255, 255, 0,127, 85, 85, 85, 44 : 170,170,170/ 45C--- 46 GOTO( 10, 20, 30, 40, 50, 60, 70, 80, 90,100, 47 & 110,120,130,140,150,160,170,180,900,200, 48 & 210,900,230) IFUNC 49 900 WRITE (MSG,'(I10)') IFUNC 50 CALL GRWARN('Unimplemented function in IK device driver: '//MSG) 51 NBUF = -1 52 RETURN 53C 54C--- IFUNC= 1, Return device name. ------------------------------------- 5510 CHR='IKON' 56 LCHR=LEN(CHR) 57 RETURN 58C 59C--- IFUNC= 2, Return Physical min and max for plot device. ------------ 6020 RBUF(1)=0 61 RBUF(2)=1023 62 RBUF(3)=0 63 RBUF(4)=779 64 RBUF(5)=0 65 RBUF(6)=255 66 NBUF=6 67 RETURN 68C 69C--- IFUNC= 3, Return device resolution. ------------------------------- 7030 RBUF(1)=50.0 71 RBUF(2)=50.0 72 RBUF(3)=1 73 NBUF=3 74 RETURN 75C 76C--- IFUNC= 4, Return misc device info. -------------------------------- 77C I= Interactive device 78C C= Cursor 79C N= No hard dash 80C A= Area fill 81C N= No hard thick lines 8240 CHR='ICNANNNNNN' 83 LCHR=10 84 RETURN 85C 86C--- IFUNC= 5, Return default file name. ------------------------------- 8750 CHR='IKON_DEFAULT' 88 LCHR=LEN(CHR) 89 NBUF=1 90 RETURN 91C 92C--- IFUNC= 6, Return default physical size of plot. ------------------- 9360 RBUF(1)=0 94 RBUF(2)=1023 95 RBUF(3)=0 96 RBUF(4)=779 97 RETURN 98C 99C--- IFUNC= 7, Return misc defaults. ----------------------------------- 10070 RBUF(1)=1 101 NBUF=1 102 RETURN 103C 104C--- IFUNC= 8, Select plot. -------------------------------------------- 10580 CALL INIK03(NINT(RBUF(2))) 106 RETURN 107C 108C--- IFUNC= 9, Open workstation. --------------------------------------- 10990 APPEND=RBUF(3).NE.0.0 110 RBUF(2)=GRIK00(ICHAN,CHR,LCHR) 111 RBUF(1)=ICHAN 112C--- 113C- Allocate a buffer. 114 MXCNT=8192 115 ISTAT=GRGMEM(MXCNT,IBADR) 116 IF(ISTAT.NE.1) THEN 117 CALL GRWARN('Unable to allocate virtual memory.') 118C- Error return 11992 CALL GRGMSG(ISTAT) 120 RBUF(2)=0 121 CALL SYS$DASSGN(%val(ICHAN)) 122 RETURN 123 END IF 124C- MXCNT is the number of INTEGER*2 125 MXCNT=MXCNT/2 126 ICNT=0 127C- Define channel for use by GRIK03. 128 CALL INIK03(ICHAN) 129C--- 130C- If device opened remotely, set remote flag. Note, current 131C- driver does not support remote access. 132C--- 133 IF(NINT(RBUF(2)).EQ.1) THEN 134 IREM=0 135 ELSE IF(NINT(RBUF(2)).EQ.3) THEN 136 IREM=1 137 RBUF(2)=1 138 ELSE 139C- Error condition. 140 RETURN 141 END IF 142C- Set last (x,y) to be invalid 143 CALL INIK01 144C--- 145C- Reset. 146 IF(.NOT.APPEND) THEN 147C- Reset interface. 148 ISTAT=SYS$QIOW(,%val(ICHAN), 149 : %val(IO$_WRITEVBLK.OR.IO$M_RESET), 150 : ,,,%val(0),%val(0),,,,) 151C- Wait for status line A to go low (about 2.2 sec) 15294 ISTAT=SYS$QIOW(,%VAL(ICHAN), 153 : %val(IO$_WRITEVBLK),IOSB, 154 : ,,%val(0),%val(0),,,,) 155 IF(ISTAT.NE.1) GOTO 92 156 IF((IOSB(3).AND.'800'x) .NE. 0) THEN 157 CALL LIB$WAIT(0.25) 158 GOTO 94 159 END IF 160 END IF 161C- Set 8-bit register $3F (set mode) to 32 (non-buffered mode) 162 ITMP(1)=96*256+63 163 ITMP(2)=32 164 CALL GRIK02(ITMP,2,%val(IBADR),ICNT,MXCNT) 165 CALL GRIK03(%val(IBADR),ICNT) 166C- Set 8-bit register $00 (Background color) to 0. 167 ITMP(1)=96*256+0 168 ITMP(2)=0 169 CALL GRIK02(ITMP,2,%val(IBADR),ICNT,MXCNT) 170C- Select frame buffer 0 to write 171 ITMP(1)=125*256+0 172C- Select frame buffer 0 to read 173 ITMP(2)=124*256+0 174C- Load reg. 74=xA4, AUX port setup (0 trans, rel. mouse, 19200 baud). 175 ITMP(3)=96*256+74 176 ITMP(4)=227 177C- Disable clipping (useful if APPENDing to a GKS plot). 178 ITMP(5)=203 179 CALL GRIK02(ITMP,5,%val(IBADR),ICNT,MXCNT) 180 IF(.NOT.APPEND) THEN 181C- Load default lookup table (if not appending). 182 CALL GRIK02(INIT,51,%val(IBADR),ICNT,MXCNT) 183 END IF 184 RETURN 185C 186C--- IFUNC=10, Close workstation. -------------------------------------- 187100 CALL SYS$DASSGN(%val(ICHAN)) 188 CALL GRFMEM(MXCNT,IBADR) 189 RETURN 190C 191C--- IFUNC=11, Begin Picture. ------------------------------------------ 192110 IF(.NOT.APPEND) THEN 193C- Set frame buffer to background color. 194 ITMP(1)=161 195 CALL GRIK02(ITMP,1,%val(IBADR),ICNT,MXCNT) 196 END IF 197 APPEND=.FALSE. 198 RETURN 199C 200C--- IFUNC=12, Draw line. ---------------------------------------------- 201120 CALL GRIK01(RBUF,%val(IBADR),ICNT,MXCNT) 202 RETURN 203C 204C--- IFUNC=13, Draw dot. ----------------------------------------------- 205130 CALL GRIK05(RBUF,%val(IBADR),ICNT,MXCNT) 206 RETURN 207C 208C--- IFUNC=14, End Picture. -------------------------------------------- 209140 RETURN 210C 211C--- IFUNC=15, Select color index. ------------------------------------- 212150 ICOL=MAX(0,MIN(NINT(RBUF(1)),255)) 213 RBUF(1)=ICOL 214 ITMP(1)=65*256+ICOL 215 CALL GRIK02(ITMP,1,%val(IBADR),ICNT,MXCNT) 216 RETURN 217C 218C--- IFUNC=16, Flush buffer. ------------------------------------------- 219160 CALL GRIK03(%val(IBADR),ICNT) 220 RETURN 221C 222C--- IFUNC=17, Read cursor. -------------------------------------------- 223170 I0=RBUF(1) 224 J0=RBUF(2) 225 CALL GRIK04(ICHAN,I0,J0,CHR,%val(IBADR),ICNT,MXCNT) 226 RBUF(1)=I0 227 RBUF(2)=J0 228 NBUF=2 229 LCHR=1 230 RETURN 231C 232C--- IFUNC=18, Erase alpha screen. ------------------------------------- 233180 RETURN 234C 235C--- IFUNC=20, Polygon fill. ------------------------------------------- 236C- Requires Ikon firmware revision V1.2 (or greater) 237200 IF(NPTS.EQ.0) THEN 238 NPTS=RBUF(1) 239C- Set fill drawing color register (p. 59) 240 ITMP(1)=69*256+ICOL 241C- Set fill area style to solid (p. 186) 242 ITMP(2)=97*256+52 243 ITMP(3)=0 244 CALL GRIK02(ITMP,3,%val(IBADR),ICNT,MXCNT) 245 INEWP=1 246 ELSE 247 NPTS=NPTS-1 248 IF(INEWP.NE.0) THEN 249 INEWP=0 250C- Draw filled polygon 251 ITMP(1)=188 252 ITMP(2)=0 253 ITMP(3)=NPTS 254 ITMP(4)=RBUF(1) 255 ITMP(5)=RBUF(2) 256 CALL GRIK02(ITMP,5,%val(IBADR),ICNT,MXCNT) 257 ELSE 258 ITMP(1)=RBUF(1) 259 ITMP(2)=RBUF(2) 260 CALL GRIK02(ITMP,2,%val(IBADR),ICNT,MXCNT) 261 END IF 262 END IF 263 RETURN 264C 265C--- IFUNC=21, Set color representation. ------------------------------- 266210 ITMP(1)=81 267 ITMP(2)=NINT(RBUF(1)) 268 ITMP(3)=IAND(255,INT(RBUF(2)*255.999)) 269 ITMP(4)=IAND(255,INT(RBUF(3)*255.999)) 270 ITMP(5)=IAND(255,INT(RBUF(4)*255.999)) 271 CALL GRIK02(ITMP,5,%val(IBADR),ICNT,MXCNT) 272 RETURN 273C 274C--- IFUNC=23, Escape. ------------------------------------------------- 275C- Send CHR array directly to Ikon (user better know what he is doing!) 276230 CALL GRIK02(%ref(CHR),LCHR/2,%val(IBADR),ICNT,MXCNT) 277 RETURN 278C----------------------------------------------------------------------- 279 END 280 281 INTEGER FUNCTION GRIK00(LUN,CHR,LCHR) 282C----------------------------------------------------------------------- 283C Open a channel to the IKON device. 284C 285C GRIK00 (returns integer): Opens a channel to the IKON device. 286C 287C 9-Dec-1987 - [AFT]. 288C----------------------------------------------------------------------- 289 INCLUDE '($IODEF)' 290 INCLUDE '($SSDEF)' 291 INTEGER LUN, LCHR 292 CHARACTER CHR*(*) 293 INTEGER IER, ITEMP, ISTAT, LENGTH 294 INTEGER SYS$ASSIGN, SYS$QIOW 295 INTEGER*2 IOSB(4) 296C--- 297C- Assign an i/o channel 298C--- 299 IER = SYS$ASSIGN(CHR(:LCHR), LUN,,) 300 IF(IER.NE.SS$_NORMAL .AND. IER.NE.SS$_REMOTE) GOTO 800 301C--- 302C- Poll the interface waiting for status line A to go low. 303C--- 304100 CALL LIB$WAIT(0.5) 305 ISTAT = SYS$QIOW(,%val(LUN), 306 : %val(IO$_WRITEVBLK),IOSB, 307 : ,,%val(0),%val(0),,,,) 308 IF( (IOSB(3).AND.'800'X) .NE. 0) GOTO 100 309C--- 310 IF(IER .EQ. SS$_REMOTE) THEN 311C--- 312C Cannot check device characteristics easily if network device being used 313C so just check whether we opened the device successfully and return 314C Read back the status from assign to plotting device over network 315C--- 316 IER=SYS$QIOW(,%VAL(LUN),%VAL(IO$_READVBLK), 317 : IOSB,,,ISTAT,LENGTH,,,,) 318 IF(IOSB(1) .NE. SS$_NORMAL) THEN 319 CALL GRWARN ('Unable to read status from ASSIGN to' // 320 : ' graphics device on remote node') 321 WRITE(6,*) IOSB(2), ' bytes read' 322 ITEMP=IOSB(1) 323 CALL GRGMSG(ITEMP) 324 GRIK00=0 325 RETURN 326 END IF 327 IF(ISTAT .NE. SS$_NORMAL) THEN 328 IER=ISTAT 329 GOTO 800 330 ELSE 331 GRIK00=3 332 RETURN 333 END IF 334 END IF 335C--- 336C- Successful completion 337C--- 338 GRIK00 = 1 339 RETURN 340C--- 341C- Error exit 342C--- 343 800 CALL GRWARN('Cannot open graphics device '//CHR(:LCHR)) 344 CALL GRGMSG(IER) 345 GRIK00 = 0 346 END 347 348 SUBROUTINE GRIK01(RBUF,IBUF,ICNT,MXCNT) 349 REAL RBUF(4) 350 INTEGER ICNT, MXCNT 351 INTEGER*2 IBUF 352C----------------------------------------------------------------------- 353C Part of PGPLOT device driver for IKON 354C Draw a line segment. 355C 356C Arguments: 357C RBUF(*) (input) Draw line from (RBUF(1),RBUF(2)) to (RBUF(3),RBUF(4)) 358C IBUF (input) Address of a buffer area 359C ICNT (in/out) Number of bytes in use in buffer 360C MXCNT (input) Maximum size of buffer in bytes 361C 362C 30-Jan-1988 - [AFT] 363C----------------------------------------------------------------------- 364 INTEGER IPTR 365 INTEGER*2 ITMP(4) 366 INTEGER*2 I0, J0, I1, J1 367 INTEGER*2 LASTI, LASTJ 368 SAVE LASTI, LASTJ 369C 370 I0=NINT(RBUF(1)) 371 J0=NINT(RBUF(2)) 372 I1=NINT(RBUF(3)) 373 J1=NINT(RBUF(4)) 374 IF(I0.NE.LASTI .OR. J0.NE.LASTJ) THEN 375 ITMP(1)=164 376 ITMP(2)=I0 377 ITMP(3)=J0 378 IPTR=3 379 ELSE 380 IPTR=0 381 END IF 382 ITMP(IPTR+1)=178*256 383 ITMP(IPTR+2)=I1 384 ITMP(IPTR+3)=J1 385 IPTR=IPTR+3 386 LASTI=I1 387 LASTJ=J1 388 CALL GRIK02(ITMP,IPTR,IBUF,ICNT,MXCNT) 389 RETURN 390C 391 ENTRY INIK01 392 LASTI=-1 393 LASTJ=-1 394 RETURN 395 END 396 397 SUBROUTINE GRIK02(ITMP, N, IBUF, ICNT, MXCNT) 398C----------------------------------------------------------------------- 399C GRPCKG (internal routine for IKON driver): Transfer N words to 400C the output buffer, flushing the buffer as necessary with the 401C GRIK03 routine. If the N bytes will not fit into the current 402C buffer, then the buffer is first dumped. This is to to cause 403C STR to be transferred as a complete unit. 404C Based on early versions of GRxx02 routines, this version does not 405C use any common blocks. 406C ***NOTE*** INIK03 must be called before any calls to GRIK02 to 407C set the LUN/Channel to which the buffer should be dumped. 408C 409C Arguments: 410C 411C ITMP(N) I I*2 Data to be written. 412C N I I The number of words to transfer. 413C IBUF I/O I*2 The output buffer. 414C ICNT I/O I Current number of words used in QBUF. 415C MXCNT I/O I Maximum number of words that can be stored 416C -in IBUF. 417C 418C 9-Dec-1987 - [AFT]. 419C----------------------------------------------------------------------- 420 INTEGER N, ICNT, MXCNT, I 421 INTEGER*2 ITMP(N), IBUF(MXCNT) 422C--- 423 IF(ICNT+N.GE.MXCNT) CALL GRIK03(IBUF,ICNT) 424 DO I=1,N 425 IF(ICNT.GE.MXCNT) CALL GRIK03(IBUF,ICNT) 426 ICNT=ICNT+1 427 IBUF(ICNT)=ITMP(I) 428 END DO 429 RETURN 430 END 431 432 SUBROUTINE GRIK03(IBUF,ICNT) 433 INTEGER ICNT 434 INTEGER*2 IBUF(*) 435C----------------------------------------------------------------------- 436C GRPCKG(internal routine, IKON): 437C set the channal to which the buffer should be dumped. 438C This subroutine contains the entry point INIK03 that defines 439C the variables ICHAN. 440C 441C Arguments: 442C 443C IBUF I/O I*2 The output buffer. 444C ICNT I/O I Current number of words used in QBUF. 445C 446C 9-Dec-1987 - [AFT]. 447C----------------------------------------------------------------------- 448 INCLUDE '($IODEF)' 449 INTEGER SYS$QIOW 450 INTEGER ISTAT 451 INTEGER*2 IOSB(4) 452 INTEGER INCHAN 453 INTEGER ICHAN 454 SAVE ICHAN 455C 456 IF(ICNT.GT.0) THEN 457 ISTAT = sys$qiow(,%val(ICHAN), 458 : %val(IO$_WRITEVBLK.OR.IO$M_SETFNCT.OR.IO$M_TIMED), 459 : IOSB,,,IBUF,%val(2*ICNT),%val(15),%val(0),,) 460 END IF 461 ICNT=0 462 RETURN 463C--- 464 ENTRY INIK03(INCHAN) 465C- Save info needed to dump buffer. 466 ICHAN=INCHAN 467 RETURN 468 END 469 470 SUBROUTINE GRIK04(ICHAN,IX,IY,CHR,IBUF,ICNT,MXCNT) 471C 472 INTEGER ICHAN, IX, IY, IBUF, ICNT, MXCNT 473 CHARACTER CHR 474C 475C Arguments 476C ICHAN (input) QIO channel assigned to Args 477C IX,IY (in/out) The cursor position 478C CHR (output) The keyboard character pressed 479C IBUF (input) Address of a buffer area 480C ICNT (in/out) Number of bytes in use in buffer 481C MXCNT (input) Maximum size of buffer in bytes 482C--- 483C Read the cursor position on the Ikon. The cursor can be moved 484C by either rolling the tracker ball. 485C The cursor can also be moved by using the cursor keys on the 486C terminal associated with SYS$COMMAND in which case the cursor 487C "speed" (step size) is controlled by the PF1 (smallest step) to 488C PF4 (largest step) keys. The numeric keys on the keypad can be 489C used in place of the arrow keys, with the addition of diagonal 490C motion: 491C UP 492C 7 8 9 493C LEFT 4 6 RIGHT 494C 1 2 3 495C DOWN 496C--- 497C- 21-Jan-1988 - Based on ARDRIVER [AFT]. 498C--- 499 INCLUDE '($IODEF)' 500C- 501 INTEGER SYS$QIOW 502 INTEGER SMG$CREATE_VIRTUAL_KEYBOARD, SMG$READ_KEYSTROKE 503 INTEGER ISTAT, IDSMG 504 INTEGER ISTEP, IXWAS, IYWAS, IVAL 505 INTEGER*2 ITMP(9), IOSB(4), ICURS(9) 506 LOGICAL QKEY 507C--- 508 ISTAT=SMG$CREATE_VIRTUAL_KEYBOARD(IDSMG,'SYS$COMMAND') 509 IF(ISTAT.NE.1) THEN 510 CALL GRGMSG(ISTAT) 511 CALL GRQUIT('Fatal error.') 512 END IF 513C--- 514C- Load 32-bit reg. 26=x1A GID max position 515 ITMP(1)=99*256+26 516 ITMP(2)= 779 517 ITMP(3)=1023 518C- Load 32-bit reg. 28=x1C GID size. 519 ITMP(4)=99*256+28 520 ITMP(5)= 779 521 ITMP(6)=1023 522 CALL GRIK02(ITMP,6,IBUF,ICNT,MXCNT) 523C- Load reg. 74=xA4, AUX port setup (0 trans, rel. mouse, 19200 baud). 524 ITMP(1)=96*256+74 525 ITMP(2)=227 526C- Set up zone to constrain cursor 527 ITMP(3)=99*256+44 528 ITMP(4)= 779 529 ITMP(5)=1023 530 CALL GRIK02(ITMP,5,IBUF,ICNT,MXCNT) 531C--- 532C- Cursor on. 533 ITMP(1)=193 534C- Load 8-bit reg. 24=x18 with Enable GID 535 ITMP(2)=96*256+24 536 ITMP(3)=128 537 CALL GRIK02(ITMP,3,IBUF,ICNT,MXCNT) 538C- Defaults. 539 ISTEP=2 540 QKEY=.FALSE. 541C--- 542C- Position cursor. 543200 ITMP(1)=164 544 ITMP(2)=IX 545 ITMP(3)=IY 546C- Anchor GID to current position (i.e., keep cursor on screen). 547 ITMP(4)=86 548 CALL GRIK02(ITMP,4,IBUF,ICNT,MXCNT) 549 CALL GRIK03(IBUF,ICNT) 550 IXWAS=IX 551 IYWAS=IY 552C- See if user has typed something at keyboard. 553 ISTAT=SMG$READ_KEYSTROKE(IDSMG,IVAL,,0) 554 IF(ISTAT.NE.1) IVAL=0 555 IF(IVAL.EQ.259) THEN 556C- PF4=large step 557 ISTEP=64 558 ELSE IF(IVAL.EQ.258) THEN 559 ISTEP=8 560 ELSE IF(IVAL.EQ.257) THEN 561 ISTEP=4 562 ELSE IF(IVAL.EQ.256) THEN 563C- PF1=small step 564 ISTEP=1 565 ELSE IF(IVAL.EQ.49 .OR. IVAL.EQ.261) THEN 566C- key 1 or KP1 567 IX=IX-ISTEP 568 IY=IY-ISTEP 569 ELSE IF(IVAL.EQ.50 .OR. IVAL.EQ.262 .OR. IVAL.EQ.275) THEN 570C- key 2, KP2 or DOWN 571 IY=IY-ISTEP 572 ELSE IF(IVAL.EQ.51 .OR. IVAL.EQ.263) THEN 573C- key 3 or KP3 574 IX=IX+ISTEP 575 IY=IY-ISTEP 576 ELSE IF(IVAL.EQ.52 .OR. IVAL.EQ.264 .OR. IVAL.EQ.276) THEN 577C- key 4, KP4 or LEFT 578 IX=IX-ISTEP 579 ELSE IF(IVAL.EQ.54 .OR. IVAL.EQ.266 .OR. IVAL.EQ.277) THEN 580C- key 6, KP6 or RIGHT 581 IX=IX+ISTEP 582 ELSE IF(IVAL.EQ.55 .OR. IVAL.EQ.267) THEN 583C- key 7 or KP7 584 IX=IX-ISTEP 585 IY=IY+ISTEP 586 ELSE IF(IVAL.EQ.56 .OR. IVAL.EQ.268 .OR. IVAL.EQ.274) THEN 587C- key 8, KP8 or UP 588 IY=IY+ISTEP 589 ELSE IF(IVAL.EQ.57 .OR. IVAL.EQ.269) THEN 590C- key 9 or KP9 591 IX=IX+ISTEP 592 IY=IY+ISTEP 593 ELSE IF((IVAL.GT.0 .AND. IVAL.LT.48) .OR. 594 & (IVAL.GT.57 .AND. IVAL.LT.255)) THEN 595 QKEY=.TRUE. 596 END IF 597C--- 598C- Read current cursor position 599C**** Due to possible hardware fault the following code will 600C**** sometimes reset the IKON. 601 ITMP(1)=165 602 CALL GRIK02(ITMP,1,IBUF,ICNT,MXCNT) 603 CALL GRIK03(IBUF,ICNT) 604C- Read 4 bytes, timing out in 2 sec. 605 ISTAT = sys$qiow(,%val(ICHAN), 606 : %val(IO$_READVBLK.OR.IO$M_SETFNCT.OR.IO$M_TIMED), 607 : IOSB,,,ICURS,%val(4),%val(2),%val(1),,) 608 IF(ISTAT.EQ.1 .AND. IOSB(1).EQ.1) THEN 609 IX=IX+ICURS(1)-IXWAS 610 IY=IY+ICURS(2)-IYWAS 611 END IF 612 IX=MAX(IX, 0) 613 IX=MIN(IX,1023) 614 IY=MAX(IY, 0) 615 IY=MIN(IY, 779) 616 IF(IX.EQ.IXWAS .AND. IY.EQ.IYWAS) THEN 617 CALL LIB$WAIT(0.05) 618 END IF 619 IF(.NOT.QKEY) GOTO 200 620 CHR=CHAR(IVAL) 621C--- 622C- Turn cursor off 623 ITMP(1)=192 624 CALL GRIK02(ITMP,1,IBUF,ICNT,MXCNT) 625 CALL GRIK03(IBUF,ICNT) 626C--- 627C- Free resources. 628 CALL SMG$DELETE_VIRTUAL_KEYBOARD(IDSMG) 629 RETURN 630 END 631 632 SUBROUTINE GRIK05(RBUF,IBUF,ICNT,MXCNT) 633 REAL RBUF(2) 634 INTEGER ICNT, MXCNT 635 INTEGER*2 IBUF 636C----------------------------------------------------------------------- 637C Part of PGPLOT device driver for IKON 638C Draw a dot. 639C 640C Arguments: 641C RBUF(*) (input) (RBUF(1),RBUF(2)) is the (x,y) position of the dot. 642C IBUF (input) Address of a buffer area 643C ICNT (in/out) Number of bytes in use in buffer 644C MXCNT (input) Maximum size of buffer in bytes 645C 646C 30-Jan-1988 - [AFT] 647C----------------------------------------------------------------------- 648 INTEGER*2 ITMP(3) 649C 650C- Move and draw pixel. 651 ITMP(1)=166 652 ITMP(2)=RBUF(1) 653 ITMP(3)=RBUF(2) 654 CALL GRIK02(ITMP,3,IBUF,ICNT,MXCNT) 655 CALL INIK01 656 RETURN 657 END 658