← Back to branch summary

~ubuntu-branches/debian/jessie/eso-midas/jessie

« back to all changes in this revision

Viewing changes to libsrc/idi/fidi/nodeanza/gd8aux.for

  • Committer: Package Import Robot
  • Author(s): Ole Streicher
  • Date: 2014-04-22 14:44:58 UTC
  • Revision ID: package-import@ubuntu.com-20140422144458-okiwi1assxkkiz39
Tags: upstream-13.09pl1.2+dfsg
Import upstream version 13.09pl1.2+dfsg

Show diffs side-by-side

added added

removed removed

Lines of Context:
libsrc/idi/fidi/nodeanza/gd8aux.for
 
1
C @(#)gd8aux.for        19.1 (ES0-DMD) 02/25/03 13:55:24
 
2
C===========================================================================
 
3
C Copyright (C) 1995 European Southern Observatory (ESO)
 
4
C
 
5
C This program is free software; you can redistribute it and/or 
 
6
C modify it under the terms of the GNU General Public License as 
 
7
C published by the Free Software Foundation; either version 2 of 
 
8
C the License, or (at your option) any later version.
 
9
C
 
10
C This program is distributed in the hope that it will be useful,
 
11
C but WITHOUT ANY WARRANTY; without even the implied warranty of
 
12
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
13
C GNU General Public License for more details.
 
14
C
 
15
C You should have received a copy of the GNU General Public 
 
16
C License along with this program; if not, write to the Free 
 
17
C Software Foundation, Inc., 675 Massachusetss Ave, Cambridge, 
 
18
C MA 02139, USA.
 
19
C
 
20
C Corresponding concerning ESO-MIDAS should be addressed as follows:
 
21
C       Internet e-mail: midas@eso.org
 
22
C       Postal address: European Southern Observatory
 
23
C                       Data Management Division 
 
24
C                       Karl-Schwarzschild-Strasse 2
 
25
C                       D 85748 Garching bei Muenchen 
 
26
C                       GERMANY
 
27
C===========================================================================
 
28
C
 
29
        SUBROUTINE KKCTAB(SHAPE,COLOUR,CURSAR,IDST)
 
30
C       
 
31
C             =  2   - use table CROSSA.CUR (or CROSSC.CUR)
 
32
C             =  3   - use table CROSSB.CUR (or CROSSD.CUR)
 
33
C             =  4   - use table SQUARE.CUR  [not implemented yet...]
 
34
C             =  5   - use table DIAMOND.CUR [not implemented yet...]
 
35
C             =  6   - use table CIRCLE.CUR
 
36
C             =  7   - use table ARROW.CUR
 
37
C             =  8   - use table SMALL.CUR  (small xhair)
 
38
C             =  0   - use table stored in keyword IN_A
 
39
C
 
40
        IMPLICIT NONE
 
41
C       
 
42
        INTEGER*4       SHAPE,COLOUR,IDST
 
43
        INTEGER*4       OLDSHAPE
 
44
        INTEGER*4       NCOLS,NROWS,N
 
45
        INTEGER*4       TABCOLNUM,TID
 
46
        INTEGER*4       E_C,E_D,E_L,LTAB
 
47
        INTEGER*4       KUNIT(1),NULLO
 
48
C       
 
49
        INTEGER*2       CURSAR(1)
 
50
C       
 
51
        CHARACTER       TABLEFILE*60,FILE*80
 
52
        CHARACTER       TABUNIT*16,MYLABEL*16
 
53
C       
 
54
        INTEGER*4       TABNULL
 
55
C 
 
56
        INCLUDE 'MID_INCLUDE:ST_DEF.INC'
 
57
C 
 
58
        DATA    MYLABEL   /'CURSOR '/
 
59
        DATA    OLDSHAPE  /-1/
 
60
C 
 
61
        INCLUDE 'MID_INCLUDE:ST_DAT.INC'
 
62
C
 
63
C
 
64
        IDST = 0
 
65
C 
 
66
C  check, if we already loaded that last time ...
 
67
        IF ( (OLDSHAPE.EQ.SHAPE) .AND. (COLOUR.NE.99) ) RETURN
 
68
        OLDSHAPE = SHAPE
 
69
C
 
70
        IF (SHAPE.EQ.3) THEN
 
71
           TABLEFILE(1:) = 'crossb.cur '
 
72
           IF (COLOUR.EQ.1) TABLEFILE(6:6) = 'd'
 
73
C
 
74
        ELSE IF (SHAPE.EQ.4) THEN
 
75
           TABLEFILE(1:) = 'square.cur '
 
76
C
 
77
        ELSE IF (SHAPE.EQ.5) THEN
 
78
           TABLEFILE(1:) = 'diamond.cur '
 
79
C
 
80
        ELSE IF (SHAPE.EQ.6) THEN
 
81
           TABLEFILE(1:) = 'circle.cur '
 
82
C
 
83
        ELSE IF (SHAPE.EQ.7) THEN
 
84
           TABLEFILE(1:) = 'arrow.cur '
 
85
C
 
86
        ELSE IF (SHAPE.EQ.8) THEN
 
87
           TABLEFILE(1:) = 'small.cur '
 
88
C
 
89
        ELSE IF (SHAPE.EQ.0) THEN
 
90
           CALL STKRDC('IN_A',1,1,60,N,TABLEFILE,KUNIT,NULLO,IDST)
 
91
           N = INDEX(TABLEFILE,' ')
 
92
           TABLEFILE(N:) = '.cur '
 
93
C
 
94
        ELSE                                            !default is cross
 
95
           TABLEFILE(1:) = 'crossa.cur '
 
96
           IF (COLOUR.EQ.1) TABLEFILE(6:6) = 'c'
 
97
        ENDIF
 
98
C       
 
99
C  first look for system table, then for own table
 
100
        FILE(1:) = 'MID_SYSTAB:'//TABLEFILE
 
101
        CALL STECNT('GET',E_C,E_L,E_D)
 
102
        CALL STECNT('PUT',1,0,0)
 
103
        CALL TBTOPN(FILE,F_I_MODE,TID,IDST)
 
104
        CALL STECNT('PUT',E_C,E_L,E_D)
 
105
        IF (IDST.NE.0) THEN
 
106
           IDST = 0
 
107
           FILE = TABLEFILE
 
108
           CALL TBTOPN(FILE,F_I_MODE,TID,IDST)
 
109
        ENDIF
 
110
        IF (IDST.NE.0) THEN
 
111
           IDST = 2
 
112
           RETURN
 
113
        ENDIF
 
114
C       
 
115
C  get info about table
 
116
        CALL TBIGET(TID,NCOLS,NROWS,N,N,N,IDST)
 
117
        CALL TBLSER(TID,MYLABEL,TABCOLNUM,IDST)
 
118
        IF (TABCOLNUM.LE.0) THEN                !incorrect columns...
 
119
           IDST = 1
 
120
           RETURN
 
121
        ENDIF
 
122
C       
 
123
C  now read cursor table
 
124
        DO N=1,1024
 
125
           CALL TBRRDI(TID,N,1,TABCOLNUM,CURSAR(N),TABNULL,IDST)
 
126
        ENDDO
 
127
C
 
128
C  release table file properly
 
129
        CALL TBTCLO(TID,IDST)
 
130
C
 
131
        RETURN
 
132
        END
 
133
 
 
134
        SUBROUTINE TRKBAL(UNIT)
 
135
C
 
136
C++++++++++++++++++++++++++++++++++++++++++++++++++
 
137
C
 
138
C.IDENTIFICATION
 
139
C  subroutine TRKBAL    version 1.00    861120
 
140
C  K. Banse             ESO - Garching
 
141
C
 
142
C.KEYWORDS
 
143
C  DeAnza unit, logical assignment
 
144
C
 
145
C.PURPOSE
 
146
C  init registers for use woth trackball
 
147
C
 
148
C.ALGORITHM
 
149
C  according to DeAnza manual
 
150
C
 
151
C.INPUT/OUTPUT
 
152
C  call as  TRKBAL(UNIT)
 
153
C
 
154
C  input par:
 
155
C  UNIT:        I*2             DeAnza unit no.
 
156
C                               currently always 0
 
157
C
 
158
C--------------------------------------------------
 
159
C
 
160
        IMPLICIT NONE
 
161
C       
 
162
        INTEGER*2       UNIT,TBGO,TMASK,NUL(4)
 
163
        INTEGER*2       LPR
 
164
C
 
165
        EXTERNAL        LPR
 
166
C
 
167
        INCLUDE 'MID_INCLUDE:DEANZAH.INC'
 
168
        INCLUDE 'MID_INCLUDE:DEANZAS.INC'
 
169
C
 
170
        DATA    TBGO    /'143'O/
 
171
        DATA    TMASK   /'103'O/
 
172
        DATA    NUL     /0,0,0,0/
 
173
C       
 
174
C  clear status reg. + X,Y position registers
 
175
        CALL IP8QW(LPR,UNIT,DZIOSB,,,NUL,8,0,0) 
 
176
C       
 
177
C  set tracking mode + GO flag (bit 5) in TKB control register (reg. 1)
 
178
        CALL IP8QW(LPR,UNIT,DZIOSB,,,TMASK,2,0,1)       !enable both cursors
 
179
        CALL IP8QW(LPR,UNIT,DZIOSB,,,TBGO,2,0,1)        !as above, but also set but 5 to 1
 
180
C       
 
181
        RETURN
 
182
        END
 
183
 
 
184
        SUBROUTINE BITS(IN,BIT)
 
185
C
 
186
C  the word array BIT(16) is set to 0 or 1
 
187
C  if the corresponding bit in word IN is set
 
188
C
 
189
        INTEGER*2       IN,BIT(16)
 
190
        INTEGER*2       MASK(16)
 
191
C
 
192
        DATA    MASK    /"1,"2,"4,"10,"20,"40,
 
193
     +                   "100,"200,"400,"1000,"2000,"4000,
 
194
     +                   "10000,"20000,"40000,"100000/
 
195
C
 
196
        DO N=1,16
 
197
           IF (IAND(MASK(N),IN).NE.0) THEN
 
198
              BIT(N) = 1
 
199
           ELSE
 
200
              BIT(N) = 0
 
201
           ENDIF
 
202
        ENDDO
 
203
C
 
204
        RETURN
 
205
        END
 
206
 
 
207
        SUBROUTINE KKGRA(DISPLAY,CHAN,STRING,LSTR,XPOS,YPOS,PATH,
 
208
     +                    ORIENT,INTENS,HT,IDST)
 
209
C
 
210
C++++++++++++++++++++++++++++++++++++++++++++++++++
 
211
C
 
212
C.IDENTIFICATION
 
213
C  subroutine KKGRA             version 1.00    880513
 
214
C  K. Banse                     ESO - Garching
 
215
C
 
216
C.KEYWORDS
 
217
C  DeAnza, overlay channel, alphabet
 
218
C
 
219
C.PURPOSE
 
220
C  support text plotting in the graphics memory
 
221
C
 
222
C.ALGORITHM
 
223
C  characters are built in a 7*8 matrix (x:0-6, y:0-7)
 
224
C  use IIGPLY to plot the stuff in the overlay plane
 
225
C
 
226
C.INPUT/OUTPUT
 
227
C call as  KKGRA(DISPLAY,CHAN,STRING,LSTR,XPOS,YPOS,PATH,ORIENT,INTENS,HT,IDST)
 
228
C
 
229
C  input par:
 
230
C  DISPLAY:     I*4             unit no.
 
231
C  CHAN:        I*4             memory id
 
232
C  STRING:      char. expr.     character string to be displayed
 
233
C  LSTR:        I*4             length of above
 
234
C  XPOS:        I*4             x-position
 
235
C  YPOS:        I*4             y-position
 
236
C  PATH:        I*4             text path:
 
237
C  INTENS:      I*4             intensity
 
238
C  HT:          I*4             text height, currently not supported
 
239
C                               characters are built in a 7*8 matrix
 
240
C                               or fixed in the alphanumerics memory
 
241
C       
 
242
C  output par:
 
243
C  IDST:        I*4             return status
 
244
C
 
245
C--------------------------------------------------
 
246
C
 
247
        IMPLICIT NONE
 
248
C       
 
249
        INTEGER*4       DISPLAY,CHAN,LSTR,ORIENT
 
250
        INTEGER*4       INTENS,XPOS,YPOS,PATH,HT,IDST
 
251
        INTEGER*4       N,NN,NNN,MM
 
252
        INTEGER*4       FCHARX(14),FCHARY(14)
 
253
        INTEGER*4       XXPOS,YYPOS,IX,IY
 
254
C       
 
255
        CHARACTER*(*)   STRING
 
256
C       
 
257
        REAL*4          ANGLE,CA,SA
 
258
C       
 
259
        INCLUDE 'MID_INCLUDE:DAZFONT.INC'
 
260
C
 
261
C       
 
262
        XXPOS = XPOS                            !save start coords.
 
263
        YYPOS = YPOS
 
264
C       
 
265
C  currently text path is always taken as = 0, (runs from left to right)
 
266
C       
 
267
C  compare each character with our alphabet
 
268
        IF (ORIENT.EQ.0) THEN
 
269
           DO N=1,LSTR
 
270
              DO NN=1,LALP
 
271
                 IF (STRING(N:N).EQ.ALPHA(NN:NN)) THEN
 
272
                    IF (NN.GT.45) THEN
 
273
                       MM = NN - 45             !take care of lowercase chars.
 
274
                    ELSE
 
275
                       MM = NN
 
276
                    ENDIF
 
277
C
 
278
                    DO NNN=1,ALPLEN(MM)
 
279
                       FCHARX(NNN) = ALPFIG(1,NNN,MM) + XXPOS
 
280
                       FCHARY(NNN) = ALPFIG(2,NNN,MM) + YYPOS
 
281
                    ENDDO
 
282
                    CALL GD8021(DISPLAY,CHAN,FCHARX,FCHARY,
 
283
     +                          ALPLEN(MM),INTENS,1,IDST)
 
284
                 ENDIF
 
285
              ENDDO
 
286
              XXPOS = XXPOS + 9                         !move along the line ...
 
287
           ENDDO        
 
288
C       
 
289
C  here with an angle
 
290
C
 
291
        ELSE
 
292
           ANGLE = ORIENT
 
293
           CA = COSD(ANGLE)
 
294
           SA = SIND(ANGLE)
 
295
C       
 
296
C  compare each character with our alphabet
 
297
           DO N=1,LSTR
 
298
              DO NN=1,LALP
 
299
                 IF (STRING(N:N).EQ.ALPHA(NN:NN)) THEN
 
300
                    IF (NN.GT.45) THEN
 
301
                       MM = NN - 45                     !take care of lowercase
 
302
                    ELSE
 
303
                       MM = NN
 
304
                    ENDIF
 
305
                    DO NNN=1,ALPLEN(MM)
 
306
                       IX = ALPFIG(1,NNN,MM) + XXPOS - XPOS
 
307
                       IY = ALPFIG(2,NNN,MM) + YYPOS - YPOS
 
308
                       CALL ROTA(CA,SA,IX,IY,IX,IY)
 
309
                       FCHARX(NNN) = IX + XPOS
 
310
                       FCHARY(NNN) = IY + YPOS
 
311
                    ENDDO
 
312
                    CALL GD8021(DISPLAY,CHAN,FCHARX,FCHARY,
 
313
     +                          ALPLEN(MM),INTENS,1,IDST)
 
314
                 ENDIF
 
315
              ENDDO
 
316
              XXPOS = XXPOS + 9                         !move along the line ...
 
317
           ENDDO        
 
318
        ENDIF
 
319
C       
 
320
C  that's it folks
 
321
        IDST = 0
 
322
        RETURN
 
323
        END
 
324
 
 
325
        SUBROUTINE KKALP(DISPLAY,STRING,LSTR,COL,LINE,MODE,IDST)
 
326
C       
 
327
C++++++++++++++++++++++++++++++++++++++++++++++++++
 
328
C
 
329
C.IDENTIFICATION
 
330
C  subroutine KKALP             version 1.00    880120
 
331
C  K. Banse                     ESO - Garching
 
332
C
 
333
C.KEYWORDS
 
334
C  DeAnza, alphanumerics board
 
335
C
 
336
C.PURPOSE
 
337
C  support IIGTXT for alphanumerics memory
 
338
C
 
339
C.ALGORITHM
 
340
C  use DeAnza level 0 software
 
341
C
 
342
C.INPUT/OUTPUT
 
343
C  call as  KKALP(DISPLAY,STRING,LSTR,COL,LINE,MODE,IDST)
 
344
C
 
345
C  input par:
 
346
C  DISPLAY:     I*4             display id.
 
347
C  STRING:      char.exp.       string to be displayed
 
348
C  LSTR:        I*4             length of STRING
 
349
C  COL:         I*4             column number (0 - 79)
 
350
C  LINE:        I*4             line number (0 - 24)
 
351
C  MODE:        I*4             mode: 0,1,2,3 for white, yellow, etc.
 
352
C
 
353
C  output par:
 
354
C  IDST:        I*4             return status
 
355
C       
 
356
C.VERSIONS
 
357
C--------------------------------------------------
 
358
C
 
359
        IMPLICIT NONE
 
360
C       
 
361
        INTEGER*4       DISPLAY,LSTR,COL,LINE,MODE,IDST
 
362
        INTEGER*4       N,NN,MM
 
363
C       
 
364
        INTEGER*2       UNIT,BYTSTR(80),MODBITS,RES
 
365
        INTEGER*2       LAR,LPA,RR,LR
 
366
C
 
367
        CHARACTER*(*)   STRING
 
368
        CHARACTER       ALPHA*89
 
369
C       
 
370
        INCLUDE 'MID_INCLUDE:DEANZAH.INC'
 
371
        INCLUDE 'MID_INCLUDE:DEANZAS.INC'
 
372
C       
 
373
        EXTERNAL        LAR,LPA,RR,LR
 
374
C       
 
375
        DATA    ALPHA(1:26)     /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
 
376
        DATA    ALPHA(27:57)    
 
377
     +                     /'[\]^_ !"#$%& ()*+,-./0123456789'/
 
378
        DATA    ALPHA(58:63)    /':;<=>?'/
 
379
        DATA    ALPHA(64:89)    /'abcdefghijklmnopqrstuvwxyz'/
 
380
C       
 
381
        UNIT = DISPLAY
 
382
        ALPHA(39:39) = ''''
 
383
        IDST = 0
 
384
C       
 
385
C  make sure we work on low resolution
 
386
        CALL IP8QW(RR,UNIT,DZIOSB,,,SYSREG(12),2,0,11)          !reg. 11
 
387
        RES = IAND(SYSREG(12),"177677)                  !force to low byte xfer
 
388
        RES = IOR(RES,"100)                             !force to low byte xfer
 
389
        CALL IP8QW(LR,UNIT,DZIOSB,,,RES,2,0,11) 
 
390
C       
 
391
C  load address register (reg. 0) of alphanumerics board
 
392
        N = (80 * LINE) + COL                   !a line has 80 chars.
 
393
        CALL IP8QW(LAR,UNIT,DZIOSB,,,N,2,0,0)   !CAP = 0 for A/N board
 
394
C       
 
395
C  shift MODE already into correct bit position
 
396
        MODBITS = ISHFT(MODE,6)
 
397
C       
 
398
C  translate character string to A/N bytes
 
399
        IF (LSTR.LT.1) RETURN
 
400
C
 
401
        DO N=1,LSTR
 
402
           BYTSTR(N) = 0
 
403
C 
 
404
           DO NN=1,89
 
405
              IF (STRING(N:N).EQ.ALPHA(NN:NN)) THEN
 
406
                 IF (NN.GT.63) THEN
 
407
                    MM = NN - 63
 
408
                 ELSE
 
409
                    MM = NN
 
410
                 ENDIF
 
411
                 BYTSTR(N) = IOR(MM,MODBITS)
 
412
              ENDIF
 
413
           ENDDO
 
414
        ENDDO
 
415
C       
 
416
C  send bytes to A/N board
 
417
        CALL IP8QW(LPA,UNIT,DZIOSB,,,BYTSTR,2*LSTR,0,2) !A/N is group 2
 
418
C       
 
419
C  reset resolution in reg. 11
 
420
        CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(12),2,0,11)          !reg. 11
 
421
C       
 
422
        RETURN
 
423
        END
 
424
 
 
425
        SUBROUTINE JOYPSH(UNIT,PUSH,ISS)
 
426
C       
 
427
C++++++++++++++++++++++++++++++++++++++++++++++++++
 
428
C
 
429
C.IDENTIFICATION
 
430
C  subroutine JOYPSH            version 1.00    861121
 
431
C             TRKPSH                    1.00    861121
 
432
C                                       1.10    870513
 
433
C  K. Banse                     ESO - Garching
 
434
C
 
435
C.KEYWORDS
 
436
C  DeAnza, joystick, trackball
 
437
C
 
438
C.PURPOSE
 
439
C  get status of joystick/trackball + cursor status
 
440
C
 
441
C.ALGORITHM
 
442
C  use DeAnza level-0 software
 
443
C
 
444
C.INPUT/OUTPUT
 
445
C  call as  JOYPSH(UNIT,PUSH,ISS)
 
446
C           TRKPSH(UNIT,PUSH,ISS)
 
447
C
 
448
C  input par:
 
449
C  UNIT:        I*2             DeAnza unit
 
450
C
 
451
C  output par:
 
452
C  PUSH:        I*4             = 1 for ENTER button pushed
 
453
C                               = 0 else
 
454
C
 
455
C  in/output par:
 
456
C  ISS:         I*4             cursor bit mask on input
 
457
C                               cursor status: .NOT. 0   or   0
 
458
C       
 
459
C.VERSIONS
 
460
C  1.10         clear ENTER bit after the ENTER button has been pushed
 
461
C               and EVSTAT returned properly
 
462
c               for both JOYPSH + TRKPSH
 
463
C       
 
464
C--------------------------------------------------
 
465
C
 
466
        IMPLICIT NONE
 
467
C       
 
468
        INTEGER*2       UNIT,ENTER,CONTROL
 
469
        INTEGER*2       RPR,LPR
 
470
C       
 
471
        INTEGER*4       PUSH,ISS
 
472
C
 
473
        INCLUDE 'MID_INCLUDE:DEANZAH.INC'
 
474
        INCLUDE 'MID_INCLUDE:DEANZAS.INC'
 
475
C       
 
476
        EXTERNAL        RPR,LPR
 
477
C       
 
478
        DATA    ENTER   /"004000/
 
479
C       
 
480
C  read peripheral register
 
481
        CALL IP8QW(RPR,UNIT,DZIOSB,,,CONTROL,2,0,1)
 
482
C       
 
483
C  'AND' input mask with register
 
484
        ISS = IAND(CONTROL,ISS)         
 
485
C       
 
486
C  test, if something came in
 
487
        IF (IAND(CONTROL,ENTER).NE.0) THEN
 
488
           PUSH = 1
 
489
           CALL IP8QW(LPR,UNIT,DZIOSB,,,1,2,0,1)        !clear control reg.
 
490
        ELSE
 
491
           PUSH = 0
 
492
        ENDIF
 
493
C       
 
494
        RETURN
 
495
        END
 
496
 
 
497
        SUBROUTINE TRKPSH(UNIT,PUSH,ISS)
 
498
C       
 
499
        IMPLICIT NONE
 
500
C       
 
501
        INTEGER*2       UNIT
 
502
        INTEGER*2       IPR,EPUSH,EOFF,ETRACK,TMODE
 
503
        INTEGER*2       RPR,LPR
 
504
C       
 
505
        INTEGER*4       PUSH,ISS,ISC1,ISC2
 
506
C
 
507
        INCLUDE 'MID_INCLUDE:DEANZAH.INC'
 
508
        INCLUDE 'MID_INCLUDE:DEANZAS.INC'
 
509
C
 
510
        EXTERNAL        RPR,LPR
 
511
C
 
512
        DATA    EPUSH   /'0001'O/               !mask for ENTER button
 
513
        DATA    EOFF    /'7776'O/               !mask for complement of ENTER
 
514
        DATA    ETRACK  /'0010'O/               !mask for TRACK/ON switch
 
515
C
 
516
C  look at the TKB status register (reg. 0)
 
517
        CALL IP8QW(RPR,UNIT,DZIOSB,,,IPR,2,0,0) !read peripheral register 0
 
518
C       
 
519
C  always extract cursor states
 
520
        IF (IAND('40'O,IPR).NE.0) THEN
 
521
           ISC1 = 1                                     !bit B6 = cursor 1 on/off
 
522
        ELSE
 
523
           ISC1 = 0
 
524
        ENDIF
 
525
        IF (IAND('20'O,IPR).NE.0) THEN                  !bit B5 = cursor 2 on/off
 
526
           ISC2 = 1
 
527
        ELSE
 
528
           ISC2 = 0
 
529
        ENDIF
 
530
C       
 
531
C  if a cursor has been turned on/off, en/disable cursor tracking
 
532
        TMODE = ISC1 + 2*ISC2   
 
533
        CALL IP8QW(LPR,UNIT,DZIOSB,,,TMODE,2,0,1)       
 
534
        TMODE = TMODE + '40'O                           !add the GO bit
 
535
        CALL IP8QW(LPR,UNIT,DZIOSB,,,TMODE,2,0,1)       
 
536
C       
 
537
C  check for push button or TRACK on
 
538
        IF ( (IAND(ETRACK,IPR).NE.0) .OR.
 
539
     +       (IAND(EPUSH,IPR).NE.0) ) THEN
 
540
           PUSH = 1
 
541
           IPR = IAND(IPR,EOFF)                         !clear the ENTER bit
 
542
           CALL IP8QW(LPR,UNIT,DZIOSB,,,IPR,2,0,0)      !and rewrite the control reg.
 
543
        ELSE
 
544
           PUSH = 0
 
545
        ENDIF
 
546
C       
 
547
C  set up return value for ISS
 
548
        IF (ISS.EQ.0) THEN
 
549
           ISS = ISC1
 
550
        ELSE IF (ISS.EQ.1) THEN
 
551
           ISS = ISC2
 
552
        ELSE
 
553
           ISS = ISC1 + ISC2
 
554
        ENDIF
 
555
C
 
556
        RETURN
 
557
        END
 
558
 
 
559
        SUBROUTINE TRKRD(UNIT,IX,IY)
 
560
C
 
561
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
562
C
 
563
C.IDENTIFICATION
 
564
C  subroutine TRKRD             version 1.00    861121
 
565
C  K. Banse                     ESO - Garching
 
566
C
 
567
C.KEYWORDS
 
568
C  DeAnza, trackball
 
569
C
 
570
C.PURPOSE
 
571
C  to read the trackball displacements
 
572
C
 
573
C.ALGORITHM
 
574
C  use the level-0 DeAnza routines
 
575
C
 
576
C.INPUT/OUTPUT
 
577
C
 
578
C  call as  TRKRD(UNIT,IX,IY)
 
579
C       
 
580
C  input par:
 
581
C  UNIT :       I*2             DeAnza unit no.
 
582
C       
 
583
C  output par:
 
584
C  IX   :       I*4             X trackball displacement in [-128,+127]
 
585
C  IY   :       I*4             Y joystick trackball displacement in [-128,+127]
 
586
C
 
587
C----------------------------------------------------------------------
 
588
C
 
589
        IMPLICIT NONE
 
590
C       
 
591
        INTEGER*2       UNIT,TPOS(2),TMODE
 
592
        INTEGER*2       IJR
 
593
        INTEGER*2       LPR,RPR
 
594
C       
 
595
        INTEGER*4       IX,IY
 
596
        INTEGER*4       IC1,IC2
 
597
C
 
598
        INCLUDE 'MID_INCLUDE:DEANZAH.INC'
 
599
        INCLUDE 'MID_INCLUDE:DEANZAS.INC'
 
600
C       
 
601
        EXTERNAL        LPR,RPR
 
602
C
 
603
C  poll TKB status register (reg. 0)
 
604
        CALL IP8QW(RPR,UNIT,DZIOSB,,,IJR,2,0,0)         !read reg 0
 
605
C       
 
606
C  always extract cursor states
 
607
        IF (IAND('40'O,IJR).NE.0) THEN
 
608
           IC1 = 1                              !bit B6 = cursor 1 on/off
 
609
        ELSE
 
610
           IC1 = 0
 
611
        ENDIF
 
612
        IF (IAND('20'O,IJR).NE.0) THEN                  !bit B5 = cursor 2 on/off
 
613
           IC2 = 1
 
614
        ELSE
 
615
           IC2 = 0
 
616
        ENDIF
 
617
C       
 
618
C  if a cursor has been turned on/off, en/disable cursor tracking
 
619
        TMODE = IC1 + 2*IC2     
 
620
        CALL IP8QW(LPR,UNIT,DZIOSB,,,TMODE,2,0,1)       
 
621
        TMODE = TMODE + '40'O                           !add the GO bit
 
622
        CALL IP8QW(LPR,UNIT,DZIOSB,,,TMODE,2,0,1)       
 
623
C       
 
624
C  get X,Y positions
 
625
        CALL IP8QW(RPR,UNIT,DZIOSB,,,TPOS,4,0,2)
 
626
C       
 
627
C  take care of decrements...
 
628
        IF (IAND('4000'O,TPOS(1)).NE.0)
 
629
     +     TPOS(1) = IOR(TPOS(1),'170000'O)
 
630
        IF (IAND('4000'O,TPOS(2)).NE.0)
 
631
     +     TPOS(2) = IOR(TPOS(2),'170000'O)
 
632
C       
 
633
C  multiply by factor of 3 since trackball is so slow
 
634
        TPOS(1) = 3 * TPOS(1)
 
635
        TPOS(2) = 3 * TPOS(2)
 
636
C       
 
637
        IF (TPOS(1).LT.-128) THEN                       !force into [-128,127]
 
638
           IX = -128
 
639
        ELSE IF (TPOS(1).GT.127) THEN
 
640
           IX = 127
 
641
        ELSE
 
642
           IX = TPOS(1)
 
643
        ENDIF
 
644
        IF (TPOS(2).LT.-128) THEN
 
645
           IY = -128
 
646
        ELSE IF (TPOS(2).GT.127) THEN
 
647
           IY = 127
 
648
        ELSE
 
649
           IY = TPOS(2)
 
650
        ENDIF
 
651
C       
 
652
C  and clear position registers again
 
653
        TPOS(1) = 0
 
654
        TPOS(2) = 0
 
655
        CALL IP8QW(LPR,UNIT,DZIOSB,,,TPOS,4,0,2)
 
656
C       
 
657
        RETURN
 
658
        END
 
659
 
 
660
        SUBROUTINE KKOWLT(UNIT,ISTA,COUNT,ROVT,IDST)
 
661
C
 
662
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
663
C
 
664
C.IDENTIFICATION
 
665
C  subroutine KKOWLT            version 1.00    880120
 
666
C  K. Banse                     ESO - Garching
 
667
C
 
668
C.KEYWORDS
 
669
C  DeAnza display , overlay table
 
670
C
 
671
C.PURPOSE
 
672
C  to load an overlay into the DeAnza,
 
673
C
 
674
C.ALGORITHM
 
675
C  use DeAnza level 0 software
 
676
C
 
677
C.INPUT/OUTPUT
 
678
C  call as  KKOWLT(UNIT,ISTA,COUNT,ROVT,IDST)
 
679
C
 
680
C  input par:
 
681
C  UNIT:        I*2             unit no.
 
682
C  COUNT:       I*4             no. of entries in table to send/read
 
683
C       
 
684
C  input/output par:
 
685
C  ROVT:        R*4 array       OVT table
 
686
C  IDST:        I*4             return status
 
687
C
 
688
C-----------------------------------------------------
 
689
C
 
690
        IMPLICIT NONE
 
691
C       
 
692
        INTEGER*4       ISTA,COUNT,IDST
 
693
        INTEGER*4       N
 
694
C       
 
695
        REAL*4          ROVT(1)
 
696
C       
 
697
        INTEGER*2       UNIT,RESREG,OVT(1024)
 
698
        INTEGER*2       RR,LR,LWA,LVR
 
699
C
 
700
        INCLUDE 'MID_INCLUDE:DEANZAH.INC'
 
701
        INCLUDE 'MID_INCLUDE:DEANZAS.INC'
 
702
C       
 
703
        EXTERNAL        RR,LR,LWA,LVR
 
704
C       
 
705
C  set resolution register for low byte transfer
 
706
        CALL IP8QW(RR,UNIT,DZIOSB,,,SYSREG(12),2,0,11)
 
707
        RESREG = IOR(SYSREG(12),"100)
 
708
        CALL IP8QW(LR,UNIT,DZIOSB,,,RESREG,2,0,11)
 
709
C       
 
710
C  set OVT LUT section (always = 0...) in LUT address register
 
711
        VOCREG(4) = 0                   !shift 9 bits left..
 
712
        CALL IP8QW(LVR,UNIT,DZIOSB,,,VOCREG(4),2,0,3)   
 
713
C
 
714
C  convert real OVT table to I*2 and send it to the DeAnza
 
715
C       
 
716
        DO N=1,COUNT
 
717
           OVT(N) = NINT(ROVT(N)*255.)
 
718
        ENDDO
 
719
C       
 
720
        CALL IP8QW(LWA,UNIT,DZIOSB,,,OVT,COUNT*2,0,1)
 
721
C
 
722
C  reset the resolution register
 
723
        CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(12),2,0,11)
 
724
C
 
725
        RETURN
 
726
        END     
 
727