1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
|
C*GRDRIV -- PGPLOT Grinnell driver
C+
SUBROUTINE GRDRIV (IFUNC, RBUF, NBUF, CHR, LCHR)
INTEGER IFUNC, NBUF, LCHR
REAL RBUF(*)
CHARACTER*(*) CHR
C
C PGPLOT driver for Grinnell device.
C
C Version 1.0 - 1987 May 26 - T. J. Pearson.
C Version 1.1 - 1987 Jun 6 - dynamically allocate buffer (TJP).
C Version 1.2 - 1988 Jan 11 - use SMG$ routines for keyboard control
C of cursor (TJP).
C Version 1.3 - 1988 Mar 16 - test GR_TYPE environment variable (TJP).
C Version 1.4 - 1988 Mar 28 - correct bug in /APPEND (TJP).
C Version 1.5 - 1989 Feb 11 - add MONOCHROME option (TJP).
C
C
C Supported device: Grinnell GMR-270 Image Display System.
C
C Device type code: /GRINNELL.
C
C Default device name: TV_DEVICE (a logical name, usually
C defined by the system manager).
C
C Default view surface dimensions: Depends on monitor.
C
C Resolution: The full view surface is 512 x 512 pixels.
C
C Color capability: Color indices 0-255 are supported. The
C representation of all color indices can be changed.
C
C Input capability: The graphics cursor is a white cross-hair. The
C user positions the cursor using the arrow keys and PF1-PF4 keys on
C his terminal keyboard (SYS$COMMAND). The arrow keys move the cursor in
C the appropriate direction; the size of the step for each keystroke is
C controlled by the PF1-PF4 keys: PF1 -> 1 pixel, PF2 -> 4 pixels,
C PF3 -> 16 pixels, PF4 -> 64 pixels. The user indicates that the
C cursor has been positioned by typing any character other than an
C arrow or PF1-PF4 key [control characters, eg, ctrl-C, and other
C special characters should be avoided, as they may be intercepted by
C the operating system].
C
C File format: It is not possible to send Grinnell plots to a
C disk file.
C
C Obtaining hardcopy: Not possible.
C-----------------------------------------------------------------------
INTEGER BUFSIZ
PARAMETER (BUFSIZ=8192)
INTEGER BUFFER
INTEGER BUFLEV
INTEGER UNIT, IER, I0, I1, J0, J1, IX, IY, ICH, L
INTEGER GRGR00, GRGMEM, GRFMEM, SYS$DASSGN
INTEGER SMG$CREATE_VIRTUAL_KEYBOARD
INTEGER SMG$SET_KEYPAD_MODE
INTEGER KBID
LOGICAL APPEND, MONO
CHARACTER*10 MSG
INTEGER*2 GRNLBF(256), IC, IR, IG, IB, GCTABL(3,0:15), MONCOL
INTEGER NW, IW
DATA GCTABL /000,000,000, 255,255,255, 255,000,000, 000,255,000,
1 000,000,255, 000,255,255, 255,000,255, 255,255,000,
2 255,128,000, 128,255,000, 000,255,128, 000,128,255,
3 128,000,255, 255,000,128, 085,085,085, 170,170,170/
LOGICAL NEW, INIT
SAVE NEW, INIT, MONO
DATA INIT /.TRUE./
C-----------------------------------------------------------------------
C
C First call: determine type of Grinnell.
C
IF (INIT) THEN
INIT = .FALSE.
CALL GRGENV('GR_TYPE', MSG, L)
NEW = (MSG(1:1).EQ.'P')
C -- Phobos-type Grinnell (GR273)
C -- otherwise Deimos-type Grinnell (GR270)
CALL GRGENV('MONITOR', MSG, L)
MONO = (MSG(1:1).EQ.'M' .OR. MSG(1:1).EQ.'m')
C -- Monochrome monitor
C -- otherwise color monitor
IF (MONO) THEN
DO IW=0,15
MONCOL = NINT(0.30*GCTABL(1,IW) + 0.59*GCTABL(2,IW) +
1 0.11*GCTABL(3,IW))
GCTABL(1,IW) = MONCOL
GCTABL(2,IW) = MONCOL
GCTABL(3,IW) = MONCOL
END DO
END IF
END IF
C
C Branch on opcode.
C
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), IFUNC
900 WRITE (MSG,'(I10)') IFUNC
CALL GRWARN('Unimplemented function in GRINNELL device driver:'
1 //MSG)
NBUF = -1
RETURN
C
C--- IFUNC = 1, Return device name -------------------------------------
C
10 CHR = 'GRINNELL'
LCHR = 8
RETURN
C
C--- IFUNC = 2, Return physical min and max for plot device, and range
C of color indices ---------------------------------------
C
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 -------------------------------
C
30 RBUF(1) = 50.0
RBUF(2) = 50.0
RBUF(3) = 1
NBUF = 3
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)
C
40 CHR = 'ICNNNNNNNN'
LCHR = 10
RETURN
C
C--- IFUNC = 5, Return default file name -------------------------------
C
50 CHR = 'TV_DEVICE'
LCHR = 9
RETURN
C
C--- IFUNC = 6, Return default physical size of plot -------------------
C
60 RBUF(1) = 0
RBUF(2) = 511
RBUF(3) = 0
RBUF(4) = 511
NBUF = 4
RETURN
C
C--- IFUNC = 7, Return misc defaults -----------------------------------
C
70 RBUF(1) = 1
NBUF=1
RETURN
C
C--- IFUNC = 8, Select plot --------------------------------------------
C
80 CONTINUE
RETURN
C
C--- IFUNC = 9, Open workstation ---------------------------------------
C
90 CONTINUE
APPEND = RBUF(3).NE.0.0
C -- allocate buffer
IER = GRGMEM(BUFSIZ, BUFFER)
IF (IER.NE.1) THEN
CALL GRGMSG(IER)
CALL GRWARN('Failed to allocate plot buffer.')
RBUF(2) = IER
RETURN
END IF
C -- open device
IER = GRGR00(CHR, LCHR, UNIT)
RBUF(1) = UNIT
RBUF(2) = IER
NBUF = 2
IF (IER.NE.1) THEN
CALL GRFMEM(BUFSIZ, BUFFER)
RETURN
END IF
IC = 1
C -- create a virtual keyboard for cursor control
IER = SMG$CREATE_VIRTUAL_KEYBOARD(KBID, 'SYS$COMMAND')
IER = SMG$SET_KEYPAD_MODE(KBID, 1)
C -- skip initialization if "APPEND" requested
IF (APPEND) RETURN
C -- initialize device
DO IW=1,256
GRNLBF(IW) = 'F000'X ! NOP (cancel byte mode)
END DO
CALL GRGR02(GRNLBF,256,%val(BUFFER),BUFLEV,UNIT)
C
IF (NEW) THEN
GRNLBF(1) = 'A001'X ! SPD (image video driver)
GRNLBF(2) = 'C000'X ! LPR0 (split/togg/crop/intr)
GRNLBF(3) = 'C20F'X ! LPR1 (red overlays, cursors)
GRNLBF(4) = 'C40F'X ! LPR2 (grn overlays, cursors)
GRNLBF(5) = 'C60F'X ! LPR3 (blu overlays, cursors)
GRNLBF(6) = 'C824'X ! LPR4 (video routing)
GRNLBF(7) = 'CA00'X ! LPR5 (clamp, invert)
C
GRNLBF(8) = 'A002'X ! SPD (image function memory)
GRNLBF(9) = 'C000'X ! LPR0 (split/toggle/retrace)
GRNLBF(10) = 'C200'X ! LPR1 (input bits 8,9)
GRNLBF(11) = 'C8E4'X ! LPR4 (lookup table routing)
GRNLBF(12) = 'CA00'X ! LPR5 (bypass)
NW = 12
ELSE
GRNLBF(1) = 'A001'X ! SPD 1 (image function video)
GRNLBF(2) = 'C800'X ! LPR4 (select ABC channels)
GRNLBF(3) = 'CA00'X ! LPR5 (no bypass or invert)
NW = 3
END IF
CALL GRGR02(GRNLBF,NW,%val(BUFFER),BUFLEV,UNIT)
C
GRNLBF(1) = 'B000'X ! LPA (table A) (red)
DO IW=0,15
GRNLBF(IW+2) = 'D000'X.OR.GCTABL(1,IW)
END DO
GRNLBF(18) = 'B400'X ! LPA (table B) (green)
DO IW=0,15
GRNLBF(IW+19) = 'D000'X.OR.GCTABL(2,IW)
END DO
GRNLBF(35) = 'B800'X ! LPA (table C) (blue)
DO IW=0,15
GRNLBF(IW+36) = 'D000'X.OR.GCTABL(3,IW)
END DO
NW = 51
CALL GRGR02(GRNLBF,NW,%val(BUFFER),BUFLEV,UNIT)
C
IF (NEW) THEN
GRNLBF(1) = 'A100'X ! SPD (load PCR)
GRNLBF(2) = 'C005'X ! LPR (PCR bits 0,2)
GRNLBF(3) = 'A008'X ! SPD (zoom/pan)
GRNLBF(4) = 'C000'X ! LPR
GRNLBF(5) = 'B000'X ! LPA
GRNLBF(6) = 'D0FF'X ! LPD
GRNLBF(7) = 'D0FF'X ! LPD
C
GRNLBF(8) = 'A080'X ! SPD (quad cursor)
GRNLBF(9) = 'C000'X ! LPR (all cursors off)
C
GRNLBF(10) = 'A000'X ! SPD (none)
GRNLBF(11) = '800D'X ! LDC (channels 0,2,3)
GRNLBF(12) = '2830'X ! LWM (R0,A0,Z1,V1,H0,W0)
GRNLBF(13) = '1001'X ! LSM (color=1)
NW =13
ELSE
GRNLBF(1) = 'A008'X ! SPD 8 (zoom/pan)
GRNLBF(2) = 'B000'X
GRNLBF(3) = 'B000'X
GRNLBF(4) = 'D000'X
GRNLBF(5) = 'C004'X
C
GRNLBF(6) = 'A080'X ! SPD (quad cursor)
GRNLBF(7) = 'C000'X ! LPR (all cursors off)
C
GRNLBF(8) = 'A000'X ! SPD (none)
GRNLBF(9) = '8FFF'X ! LDC FFF
GRNLBF(10) = '2830'X ! LWM (R0,A0,Z1,V1,H0,W0)
GRNLBF(11) = '1001'X ! LSM (color=1)
NW = 11
END IF
GOTO 1000
C
C--- IFUNC=10, Close workstation ---------------------------------------
C
100 CONTINUE
IER = SYS$DASSGN(%val(UNIT))
IF (IER.NE.1) THEN
CALL GRWARN('Error closing graphics device.')
CALL GRGMSG(IER)
END IF
IER = GRFMEM(BUFSIZ, BUFFER)
IF (IER.NE.1) THEN
CALL GRWARN('Error deallocating plot buffer.')
CALL GRGMSG(IER)
END IF
C -- delete virtual keyboard
IER = SMG$CREATE_VIRTUAL_KEYBOARD(KBID)
RETURN
C
C--- IFUNC=11, Begin picture -------------------------------------------
C
110 CONTINUE
GRNLBF(1) = 'A000'X ! SPD 0
GRNLBF(2) = '1FFF'X ! LSM FFF
GRNLBF(3) = '8FFF'X ! LDC FFF
GRNLBF(4) = '2830'X ! LWM (R0,A0,Z1,V1,H0,W0)
IF (APPEND) THEN
GRNLBF(5) = '800D'X ! dummy
ELSE
GRNLBF(5) = '3000'X ! ERS
END IF
GRNLBF(6) = '800D'X ! LDC (channels 0,2,3)
GRNLBF(7) = '1000'X .OR. IC ! LSM <color>
NW = 7
GOTO 1000
C
C--- IFUNC=12, Draw line -----------------------------------------------
C
120 CONTINUE
I0 = NINT(RBUF(1))
J0 = NINT(RBUF(2))
I1 = NINT(RBUF(3))
J1 = NINT(RBUF(4))
CALL GRGR01(I0, J0, I1, J1, GRNLBF)
NW = 4
GOTO 1000
C
C--- IFUNC=13, Draw dot ------------------------------------------------
C
130 CONTINUE
I0 = NINT(RBUF(1))
J0 = NINT(RBUF(2))
CALL GRGR01(I0, J0, I0, J0, GRNLBF)
NW = 4
GOTO 1000
C
C--- IFUNC=14, End picture ---------------------------------------------
C
140 CONTINUE
RETURN
C
C--- IFUNC=15, Select color index --------------------------------------
C
150 CONTINUE
IC = RBUF(1)
IF (IC.LT.0 .OR. IC.GT.255) THEN
IC = 1
RBUF(1) = IC
END IF
GRNLBF(1) = '1000'X .OR. IC
NW = 1
GOTO 1000
C
C--- IFUNC=16, Flush buffer. -------------------------------------------
C
160 CONTINUE
CALL GRGR03(%val(BUFFER), UNIT, BUFLEV)
RETURN
C
C--- IFUNC=17, Read cursor. --------------------------------------------
C RBUF(1) in/out : cursor x coordinate.
C RBUF(2) in/out : cursor y coordinate.
C CHR(1:1) output : keystroke.
C
170 CONTINUE
C -- flush buffer
CALL GRGR03(%val(BUFFER), UNIT, BUFLEV)
C --
IX = NINT(RBUF(1))
IY = NINT(RBUF(2))
CALL GRGR04(IX, IY, ICH, IER, UNIT, KBID)
IF (IER.EQ.1) THEN
RBUF(1) = IX
RBUF(2) = IY
CHR = CHAR(ICH)
ELSE
CHR = CHAR(0)
END IF
NBUF = 2
LCHR = 1
RETURN
C
C--- IFUNC=18, Erase alpha screen. -------------------------------------
C (Not implemented: no alpha screen)
C
180 CONTINUE
RETURN
C
C--- IFUNC=19, Set line style. -----------------------------------------
C (Not implemented: should not be called)
C
190 CONTINUE
GOTO 900
C
C--- IFUNC=20, Polygon fill. -------------------------------------------
C (Not implemented: should not be called)
C
200 CONTINUE
GOTO 900
C
C--- IFUNC=21, Set color representation. -------------------------------
C
210 CONTINUE
IC = RBUF(1)
IR = MIN(255.,MAX(RBUF(2)*255.,0.))
IG = MIN(255.,MAX(RBUF(3)*255.,0.))
IB = MIN(255.,MAX(RBUF(4)*255.,0.))
IF (MONO) THEN
MONCOL = NINT(0.30*IR + 0.59*IG + 0.11*IB)
IR = MONCOL
IG = MONCOL
IB = MONCOL
END IF
IF (NEW) THEN
GRNLBF(1) = 'A002'X ! SPD 2 (image function video)
ELSE
GRNLBF(1) = 'A001'X ! SPD 1 (image function video)
END IF
GRNLBF(2) = 'B000'X .OR. IC ! LPA (table A) (red)
GRNLBF(3) = 'D000'X .OR. IR
GRNLBF(4) = 'B400'X .OR. IC ! LPA (table B) (green)
GRNLBF(5) = 'D000'X .OR. IG
GRNLBF(6) = 'B800'X .OR. IC ! LPA (table C) (blue)
GRNLBF(7) = 'D000'X. OR. IB
NW = 7
GOTO 1000
C
C--- IFUNC=22, Set line width. -----------------------------------------
C (Not implemented: should not be called)
C
220 CONTINUE
GOTO 900
C
C--- IFUNC=23, Escape --------------------------------------------------
C (Not implemented: ignored)
C
230 CONTINUE
RETURN
C
C--- Send the command. -------------------------------------------------
C
1000 CALL GRGR02(GRNLBF,NW,%val(BUFFER),BUFLEV,UNIT)
C-----------------------------------------------------------------------
END
C*GRGR00 -- PGPLOT Grinnell driver, open device
C+
INTEGER FUNCTION GRGR00 (GRFILE, GRFNLN, GRUNIT)
CHARACTER*(*) GRFILE
INTEGER GRFNLN, GRUNIT
C
C Returns:
C GRGR00 : 1 if the device was opened successfully. Any
C other value indicates that an error occurred.
C Usually the value is the VMS error code.
C
C Arguments:
C GRFILE (in/out) : requested device name (input); actual
C device assigned (output).
C GRFNLN (in/out) : length of device name.
C GRUNIT (output) : channel assigned by VMS.
C
C Subroutines called:
C GRWARN
C GRGMSG
C VMS system services
C-----------------------------------------------------------------------
INTEGER DVI$_DEVCLASS, DVI$_DEVNAM
PARAMETER (DVI$_DEVCLASS=4)
PARAMETER (DVI$_DEVNAM=32)
INTEGER DEVCLASS, ITMLIST(7), IOSB(2)
INTEGER IER, L, SYS$ASSIGN
INTEGER SYS$GETDVI, SYS$DASSGN, SYS$WAITFR
C
C Assign an i/o channel.
C
L = GRFNLN
IER = SYS$ASSIGN(GRFILE(1:L), GRUNIT,,)
IF (.NOT.IER) GOTO 100
C
C Check that device has correct characteristics, and obtain true
C device name.
C
ITMLIST(1) = DVI$_DEVCLASS*2**16 + 4
ITMLIST(2) = %LOC(DEVCLASS)
ITMLIST(3) = 0
ITMLIST(4) = DVI$_DEVNAM*2**16 + LEN(GRFILE)
ITMLIST(5) = %LOC(GRFILE)
ITMLIST(6) = %LOC(GRFNLN)
ITMLIST(7) = 0
IER = SYS$GETDVI(%VAL(0),,GRFILE(1:GRFNLN), ITMLIST,IOSB,,,)
IF (.NOT.IER) GOTO 100
IER = SYS$WAITFR(%VAL(0))
IF (.NOT.IER) GOTO 100
IF (.NOT.IOSB(1)) THEN
IER = IOSB(1)
GOTO 100
END IF
IF (DEVCLASS.NE.32 .AND. DEVCLASS.NE.96) THEN
CALL GRWARN( GRFILE(1:GRFNLN)//
2 ' is the wrong sort of device for plot type GRINNELL')
GRGR00 = 32767 ! indicate error
IER = SYS$DASSGN(%VAL(GRUNIT))
RETURN
END IF
C
C Successful completion.
C
GRGR00 = 1
RETURN
C
C Error exit.
C
100 CALL GRWARN('Cannot open graphics device '//GRFILE(1:L))
CALL GRGMSG(IER)
GRGR00 = IER
C-----------------------------------------------------------------------
END
C*GRGR01 -- PGPLOT Grinnell driver, line segment
C+
SUBROUTINE GRGR01 (I0, J0, I1, J1, GRNLBF)
INTEGER*2 I0, J0, I1, J1
INTEGER*2 GRNLBF(4)
C
C Arguments:
C I0, J0 (input) : device coordinates of the starting point.
C I1, J1 (input) : device coordinates of the end point.
C GRNLBF (output) : buffer for instruction.
C
C Subroutines called:
C GRGR02
C-----------------------------------------------------------------------
INTEGER*2 IC0, JC0, IC1, JC1, DX, DY, T
INTEGER*2 X, CLIP511
C
CLIP511(X) = X .AND. '1FF'X
C
IC0 = CLIP511(I0)
JC0 = CLIP511(J0)
IC1 = CLIP511(I1)
JC1 = CLIP511(J1)
T = IC1-IC0
DX = CLIP511(T)
T = JC1-JC0
DY = CLIP511(T)
C
C Assume Grinnell has already been initialized for vector drawing
C (LWM) and SPD 0 has been selected, and appropriate channels have
C been selected.
C
GRNLBF(1) = '4800'X .OR. IC0 ! LEA
GRNLBF(2) = '5000'X .OR. DX ! LEB
GRNLBF(3) = '6800'X .OR. JC0 ! LLA
GRNLBF(4) = '7400'X .OR. DY ! LLB (W=1)
C-----------------------------------------------------------------------
END
C*GRGR02 -- PGPLOT Grinnell driver, transfer data to buffer
C+
SUBROUTINE GRGR02 (INSTR, N, BUFFER, HWM, UNIT)
INTEGER N, HWM, UNIT
INTEGER*2 INSTR(*), BUFFER(*)
C
C Arguments:
C INSTR (input) : text of instruction (16-bit words).
C N (input) : number of 16-bit words to transfer.
C BUFFER (input) : output buffer.
C HWM (in/out) : number of bytes used in BUFFER.
C UNIT (input) : channel number for output (when buffer is full).
C
C Subroutines called:
C GRGR03
C-----------------------------------------------------------------------
INTEGER BUFSIZ
PARAMETER (BUFSIZ=8192)
INTEGER I
C-----------------------------------------------------------------------
DO 10 I=1,N
IF (HWM.GE.BUFSIZ) CALL GRGR03(BUFFER, UNIT, HWM)
HWM = HWM + 2
BUFFER(HWM/2) = INSTR(I)
10 CONTINUE
C-----------------------------------------------------------------------
END
C*GRGR03 -- PGPLOT Grinnell driver, copy buffer to device
C+
SUBROUTINE GRGR03 (BUFFER, UNIT, N)
BYTE BUFFER(*)
INTEGER UNIT, N
C
C Arguments:
C BUFFER (input) address of buffer to be output
C UNIT (input) channel number for output
C N (input) number of bytes to transfer
C (output) set to zero
C-----------------------------------------------------------------------
INCLUDE '($IODEF)'
C
INTEGER SYS$QIOW
C
INTEGER RESULT
INTEGER IOSB(2)
INTEGER*2 STBC(2), STATUS, COUNT
EQUIVALENCE (STBC, IOSB(1)), (STATUS, STBC(1)), (COUNT, STBC(2))
C-----------------------------------------------------------------------
IF (N.LT.1) RETURN
RESULT = SYS$QIOW(,%VAL(UNIT),
1 %VAL(IO$_WRITEVBLK.OR.IO$M_SETFNCT),IOSB,,
2 ,BUFFER,%VAL(N),,%VAL(0),,)
IF (RESULT.NE.1) THEN
CALL GRGMSG(RESULT)
CALL GRQUIT('SYS$QIOW failure writing to Grinnell')
END IF
IF (STATUS.NE.1) THEN
RESULT = STATUS
CALL GRGMSG(RESULT)
CALL GRQUIT('SYS$QIOW failure writing to Grinnell')
END IF
N = 0
C-----------------------------------------------------------------------
END
C*GRGR04 -- PGPLOT Grinnell driver, cursor routine
C+
SUBROUTINE GRGR04 (IX, IY, IC, IER, UNIT, KBID)
INTEGER IX, IY, IC, IER, UNIT, KBID
C
C Arguments:
C IX, IY (in/out) : initial/final coordinates of cursor (device
C coordinates).
C IC (output) : character code.
C IER (output) : error status (1 => OK).
C UNIT (input) : channel for output to device.
C KBID (input) : SMG keyboard identifier for control.
C
C This version uses the cursor on the zoom-pan card (peripheral
C device bit 3). The cursor is moved by using the arrow keys on the
C terminal; the cursor "speed" (step size) is controlled by the
C PF1 (smallest step) to PF4 (largest step) keys. The numeric keys
C on the keypad can be used in place of the arrow keys, with the
C addition of diagonal motion:
C ^
C 7 8 9
C < 4 6 >
C 1 2 3
C v
C
C The user indicates that the cursor has been positioned by
C typing any character on his keyboard (SYS$COMMAND), with the
C following exceptions: control characters (^C, ^O, ^Q, ^R, ^S,
C ^T, ^U, ^X, ^Y, DEL) are intercepted by the operating system
C and cannot be used; NUL, ESC (^[) and escape sequences (e.g.,
C arrow keys) are ignored by GRCURS.
C-----------------------------------------------------------------------
INTEGER*2 GRNLBF(5),IXG,IYG
INTEGER SMG$READ_KEYSTROKE
INTEGER STEP, NBYTES
DATA STEP/4/ ! initial step size
C-----------------------------------------------------------------------
10 IXG = IX
IYG = IY
GRNLBF(1) = 'A008'X ! SPD ZOOM/PAN
GRNLBF(2) = 'C020'X ! enable cursor
GRNLBF(3) = 'B000'X ! LPA 0
GRNLBF(4) = 'D000'X .OR. IXG ! load X coord
GRNLBF(5) = 'D000'X .OR. IYG ! load Y coord
NBYTES = 10
CALL GRGR03(GRNLBF,UNIT,NBYTES)
IER = SMG$READ_KEYSTROKE(KBID, IC)
IF (IER.NE.1) RETURN
IF (IC.EQ.274 .OR. IC.EQ.268) THEN
C key UP or KP8
IY = MIN(511,IY+STEP)
ELSE IF (IC.EQ.275 .OR. IC.EQ.262) THEN
C key DOWN or KP2
IY = MAX(0,IY-STEP)
ELSE IF (IC.EQ.276 .OR. IC.EQ.264) THEN
C key LEFT or KP4
IX = MAX(0,IX-STEP)
ELSE IF (IC.EQ.277 .OR. IC.EQ.266) THEN
C key RIGHT or KP6
IX = MIN(511,IX+STEP)
ELSE IF (IC.EQ.267) THEN
C key KP7
IX = MAX(0,IX-STEP)
IY = MIN(511,IY+STEP)
ELSE IF (IC.EQ.269) THEN
C key KP9
IX = MIN(511,IX+STEP)
IY = MIN(511,IY+STEP)
ELSE IF (IC.EQ.263) THEN
C key KP3
IX = MIN(511,IX+STEP)
IY = MAX(0,IY-STEP)
ELSE IF (IC.EQ.261) THEN
C key KP1
IX = MAX(0,IX-STEP)
IY = MAX(0,IY-STEP)
ELSE IF (IC.EQ.265) THEN
C key KP5 ("home")
IX = 255
IY = 255
ELSE IF (IC.EQ.256) THEN
C key PF1 or KP4
STEP = 1
ELSE IF (IC.EQ.257) THEN
C key PF2
STEP = 4
ELSE IF (IC.EQ.258) THEN
C key PF3
STEP = 16
ELSE IF (IC.EQ.259) THEN
C key PF4
STEP = 64
END IF
IF (IC.LE.0 .OR. IC.GT.255) GOTO 10
GRNLBF(1) = 'A008'X
GRNLBF(2) = 'C000'X ! disable all cursors
GRNLBF(3) = 'A000'X
NBYTES = 6
CALL GRGR03(GRNLBF,UNIT,NBYTES)
C-----------------------------------------------------------------------
END
|
