C @(#)gd8d1.for	17.1.1.1 (ES0-DMD) 01/25/02 17:34:38
C===========================================================================
C Copyright (C) 1995 European Southern Observatory (ESO)
C
C This program is free software; you can redistribute it and/or 
C modify it under the terms of the GNU General Public License as 
C published by the Free Software Foundation; either version 2 of 
C the License, or (at your option) any later version.
C
C This program is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public 
C License along with this program; if not, write to the Free 
C Software Foundation, Inc., 675 Massachusetss Ave, Cambridge, 
C MA 02139, USA.
C
C Corresponding concerning ESO-MIDAS should be addressed as follows:
C	Internet e-mail: midas@eso.org
C	Postal address: European Southern Observatory
C			Data Management Division 
C			Karl-Schwarzschild-Strasse 2
C			D 85748 Garching bei Muenchen 
C			GERMANY
C===========================================================================
C
	SUBROUTINE GD8001(DEVICE,DISPLAY,IDST)
C
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine IIDOPN	version 1.00	880517
C  K. Banse		ESO - Garching
C
C.KEYWORDS
C  DeAnza unit, logical assignment
C
C.PURPOSE
C  fulfill the stuff as prescribed in the IDI document...
C
C.ALGORITHM
C  straight forward
C
C.INPUT/OUTPUT
C  call as  IIDOPN(DEVICE,DISPLAY,IDST)
C
C  input par:
C  DEVICE:	char.exp.	device type: we expect "DEANZ" ...
C	
C  output par:
C  DISPLAY:	I*4		display identifier, used for the DeAnza unit no.
C  IDST:	I*4		return status, 0 = success
C
C.VERSIONS
C  1.00		creation (from IDI_OPEN as of 880118)
C
C--------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*4 	CHANL,DISPLAY,IDST
	INTEGER*4	IAV,N
	INTEGER*4	KUNIT(1),NULLO
C	
	INTEGER*2	UNIT
C	
	CHARACTER*(*)	DEVICE
C	
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
	INCLUDE	'MID_INCLUDE:IDIDEV.INC'
C
C	
	UNIT = QDSPNO
	CALL IP8DAT(UNIT)			!attach unit
C
C  see, if joystick or trackball
	IF (QJOYFL.EQ.1) CALL TRKBAL(UNIT)
C	
C  all o.k. - get the memory stuff in
	N = (QLSTCH + 1) * 2			!QLSTCH = last channel no.
	CALL STKRDI('DAZDEVR',1,N,IAV,MEMREG,KUNIT,NULLO,IDST)
C	
	CALL GD8039(DISPLAY,IDST)		!use IIISTI to clear interactive flags
C	
	IDST = 0
	RETURN
C	
	END

	SUBROUTINE GD8002(DISPLAY,IDST)
C
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine IIDCLO	version 1.00	880118
C  K. Banse		ESO - Garching
C
C.KEYWORDS
C  DeAnza unit, logical assignment
C
C.PURPOSE
C  fulfill the stuff as prescribed in the IDI document...
C
C.ALGORITHM
C  straight forward
C
C.INPUT/OUTPUT
C  call as  IIDCLO(DISPLAY,IDST)
C
C  input par:
C  DISPLAY:	I*4		display identifier
C	
C  output par:
C  IDST:	I*4		return status, 0 = success
C
C.VERSIONS
C  1.00		creation (from IDI_CLOSE as of 880118)
C
C--------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*4 	DISPLAY,IDST
	INTEGER*4	N,KUNIT(1)
C	
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
	INCLUDE	'MID_INCLUDE:IDIDEV.INC/NOLIST'
C	
C  save memory control register stuff
	N = (QLSTCH + 1) * 2
	CALL STKWRI('DAZDEVR',MEMREG,1,N,KUNIT,IDST)
	IDST = 0
C	
	RETURN
	END

	SUBROUTINE GD8003(DISPLAY,IDST)
C 
	INTEGER*4  DISPLAY,IDST
C 
	IDST = 0
	RETURN
C 
	END

	SUBROUTINE GD8004(DISPLAY,IDST)
C 
	INTEGER*4  DISPLAY,IDST
C 
	IDST = 0
	RETURN
C 
	END

	SUBROUTINE GD8010(DISPLAY,CONFNO,IDST)
C	
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine IIDSEL		version 1.00	880202
C  K. Banse                  	ESO - Garching
C
C.KEYWORDS
C  DeAnza, initialisation
C
C.PURPOSE
C  fulfill the requirements as described in the IDI document
C
C.ALGORITHM
C  use DeAnza level 0 software
C
C.INPUT/OUTPUT
C  call as  IIDSEL(DISPLAY,CONFNO,IDST)
C
C  input par:
C  DISPLAY:	I*4		display id.
C  CONFNO:	I*4		configuration number, currently only
C				CONFNO = 2 for RGB mode
C				       = 1 for pseudo-colour mode
C  output par:
C  IDST:	I*4		return status
C	
C.VERSIONS
C
C--------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*4	DISPLAY,CONFNO,IDST
	INTEGER*4	MEMSIZ,STAT
	INTEGER*4	M,N,NN
C		
	INTEGER*2	UNIT
	INTEGER*2	NULL(2)
	INTEGER*2	FCREG,PSR,ITT(256)
	INTEGER*2	LMC,LMR,LR,LVR,WR,LCR,LPR,BPA
C
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
	INCLUDE	'MID_INCLUDE:IDIDEV.INC/NOLIST'
C	
	EXTERNAL	LMC,LMR,LR,LVR,WR,LCR,LPR,BPA
C
	DATA	PSR	/"162344/
	DATA	NULL	/0,0/
	DATA	NN	/0/
C	
C  get unit + last channel
	UNIT = DISPLAY
C	
C
C--------------------------------------------------
C  initialize master sync register + zero the DVP control register (misc. reg. 2
C--------------------------------------------------
C	
	CALL IP8QW(LMR,UNIT,DZIOSB,,,NULL,4,2,2)	!fill 4 bytes => reg. 2 + 3
CCC	CALL IP8QW(LMR,UNIT,DZIOSB,,,NULL,2,1,2)
C	
C--------------------------------------------------
C  handle the system registers (0 - 31)
C--------------------------------------------------
C	
C
C  set RESOLUTION register (reg 11) to: low byte xfer,
C				     yes/no extended memory,
C				     low res VOC,
C				     xres = 1024/512, yres = 1024/512
	IF (QMSZX.LT.1024) THEN		!just test the x-dim of memory
	   SYSREG(12) = "100
	ELSE
	   SYSREG(12) = "140		!extended memory ...
	ENDIF
C
C  set FOREGROUND register (reg 12) to: value = 0
	SYSREG(13) = 0
C
C  set BACKGROUND register (reg 13) to: value = 0
	SYSREG(14) = 0
C	
C  and write it out
	CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(12),6,1,11)
C
C  set the X registers
	SYSREG(17) = 0			!X = 0		(16)
	SYSREG(18) = 0			!XT = 0		(17)
	SYSREG(19) = SYSREG(17)		!XMIN = X	(18)
	SYSREG(20) = QMSZX - 1		!XMAX = 511,1023,... (19)
	SYSREG(21) = 0			!XAMIN = 0	(20)
	SYSREG(22) = SYSREG(20)		!XAMAX = XMAX	(21)
	SYSREG(23) = SYSREG(20)		!DX = XMAX	(22)
	SYSREG(24) = 0			!XTEMP = 0	(23)
C	
C  and write it out
	CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(17),16,1,16)
C
C  set the X registers
	SYSREG(25) = 0			!Y = 0		(24)
	SYSREG(26) = 0			!YT = 0		(25)
	SYSREG(27) = SYSREG(25)		!YMIN = 0	(26)
	SYSREG(28) = QMSZY - 1		!YMAX = 511, 1023, ... (27)
	SYSREG(29) = 0			!YAMIN = 0	(28)
	SYSREG(30) = SYSREG(28)		!YAMAX = YMAX	(29)
	SYSREG(31) = SYSREG(28)		!DY = YMAX	(30)
	SYSREG(32) = 0			!YTEMP = 0	(31)
C	
C  and write it out
	CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(25),16,1,24)
C	
C--------------------------------------------------
C  clear all CMRs
C--------------------------------------------------
C	
C  clear all following SYREGS = CMR0 - CMR15
	DO N=33,64
	   SYSREG(N) = 0
	ENDDO
	CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(33),64,1,32)
C	
C--------------------------------------------------
C  initialize Peripheral Select reg.
C--------------------------------------------------
C	
C                 cursor board i -> VOC i
C                 A/N generator i -> VOC i
C	
	CALL IP8QW(LMR,UNIT,DZIOSB,,,PSR,2,0,0)
C	
C--------------------------------------------------
C  init + clear all DeAnza memories
C--------------------------------------------------
C	
C  set CONTROL register (reg 10) to: matrix mode,
C				     x-dir primary, y-dir seconday,
C				     increment secondary axis by +1
C				     increment primary axis by +1
	SYSREG(11) = "10
	CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(11),2,0,10)
C	
	DO M=0,QLSTCH
	   N = M + 1
	   MEMREG(1,N) = 0			!default for register 0
	   MEMREG(2,N) = QDSZY - 1		!default for reg. 1 is top line of screen
	   MEMREG(3,N) = -1			!default for register 2
	   IF (M.EQ.QLSTCH) THEN
	      MEMREG(4,N) = "12000		!declare channel as graphics
	   ELSE
	      MEMREG(4,N) = "10000		!default for register 3
	   ENDIF
	   MEM7RG(N) = 0			!default for register 7
C	
	   CALL IP8QW(LMC,UNIT,DZIOSB,,,MEMREG(1,N),8,M,0)
C	
	   SYSREG(33) = 2**M			!fill also low part of CMR0
	   CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(33),2,1,32)
	   CALL IP8QW(WR,UNIT,DZIOSB,,,NN,2,0,1)	!NN is dummy
	ENDDO
C
C  set CONTROL register (reg 10) to: non-matrix mode,
C				     x-dir primary, y-dir seconday,
C				     increment secondary axis by +1
C				     increment primary axis by +1
	SYSREG(11) = 0
C	
C  broadcast ramp ITT to all memory channels
	M = QLSTCH + 1		!total no. of memories
	SYSREG(33) = (2**M) - 1
	CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(33),2,0,32)
	DO N=1,256
	   ITT(N) = N - 1
	ENDDO
	CALL IP8QW(BPA,UNIT,DZIOSB,,,ITT,512,0,0)
C	
C  reset also DX, DY registers and CMR0
	SYSREG(23) = 0
	SYSREG(31) = 0
	SYSREG(33) = 0
	CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(11),46,1,10)
C
C--------------------------------------------------
C  clear A/N memory
C--------------------------------------------------
C	
	IF (QALPNO.NE.0) CALL GD8018(DISPLAY,QALPNO,1,0,IDST)
C
C--------------------------------------------------
C  initialize cursor registers
C--------------------------------------------------
C	
	CURREG(1) = 224		!set cursor coord. to center of screen
	CURREG(2) = 224
	CURREG(3) = 274
	CURREG(4) = 274
C	
C  set up Cursor Control register (reg. 4):
C	disable display of programmable cursors
C	both cursors use VOC LUT section 0 (black area -> LUT section 2)
C	disable priority blinking
C	disable intensity inversion, disable X-, Y- components for cursor 1 + 2
C	use fixed cursor form 0
	CURREG(5) = 0
	CURREG(6) = 0
	CURREG(7) = 0
	CALL IP8QW(LCR,UNIT,DZIOSB,,,CURREG(1),14,0,0)
C
C--------------------------------------------------
C  initialize VOC registers:
C--------------------------------------------------
C	
C	enable split screen, disable cursors
C	enable alpha numerics
C	all FCRs use channel 0 + bypass LUT
C	
	VOCREG(1) = 0			!X split	(0)
	VOCREG(2) = QDSZY - 1		!Y split	(1)
C	
C  set VOC control reg.:
C	cursor enable, alphanumeric enable,
C	graphics enable, hardsplit enable
C	
	VOCREG(3) = "042403		!CONTROL	(2)
C	
C  use LUT section 0
	VOCREG(4) = 0			!LUT address	(3)
C	
C  send the stuff out
	CALL IP8QW(LVR,UNIT,DZIOSB,,,VOCREG,8,0,0)
C
C  set up FCR's for colour + graphics
C--------------------------------------------------
C	
C	
	IF (CONFNO.EQ.1) THEN
C	
C  in pseudo colour mode:
C  channel 0  ->  all screen segments + R, G, B channel
C  bypass LUT
C  QLSTCH ->  all screen segments + overlay channel
C	
	   FCREG = ISHFT(QLSTCH,8)
	   DO N=1,4
	      FCR(N) = 0
	      FCR(N+4) = FCREG
	   ENDDO
C	
	ELSE
C	
C  in RGB mode:
C  channel 0  ->  all screen segments + R channel
C  channel 1  ->  all screen segments + G channel
C  channel 2  ->  all screen segments + B channel
C  bypass LUT
C  QLSTCH     ->  all screen segments + overlay channel
C	
	   IF (QLSTCH.LT.3) THEN
	      DO N=1,8				!send chan 0 to everything
		 FCR(N) = "010020
	      ENDDO
	      IF (QLSTCH.GE.1) THEN
	         DO N=1,4			!send chan 0,1 comme il faut
		    FCR(N) = "010420
	         ENDDO
	      ENDIF
	      IF (QLSTCH.GE.2) THEN
	         DO N=5,8			!send chan 0,1,2 comme il faut
		    FCR(N) = "22
	         ENDDO
	      ENDIF
	   ELSE
	      DO N=1,4				!send chan 0,1,2,3 comme il faut
		 FCR(N) = "010420
		 FCR(N+4) = "001422
	      ENDDO
	   ENDIF
	ENDIF
C	
C  send the stuff out
	CALL IP8QW(LVR,UNIT,DZIOSB,,,FCR,16,0,8)
C	
C  alright then...
	RETURN
	END

	SUBROUTINE GD8016(DISPLAY,CHANS,NOCHAN,LUTF,ITTF,IDST)
C	
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine IIDSDP		version 1.00	880201
C  K. Banse                  	ESO - Garching
C
C.KEYWORDS
C  DeAnza, memory channel, ITT, LUT
C
C.PURPOSE
C  fulfill the requirements as described in the IDI document 
C
C.ALGORITHM
C  use DeAnza level 0 software
C
C.INPUT/OUTPUT
C  call as  IIDSDP(DISPLAY,CHANS,NOCHAN,LUTF,ITTF,IDST)
C
C  input par:
C  DISPLAY:	I*4		display id.
C  CHANS:	I*4 array	memory id's
C  NOCHAN:	I*4		no. of memories
C  LUTF:	I*4 array	LUT flags : -1 = leave it as it is
C				             7 = R + G + B
C					     1 = R
C					     2 = G
C					     4 = B
C  ITTF:	I*4 array	ITT flags : -1 = leave it as it is
C					     0 = bypass ITT
C					     1 = use ITT
C	
C  output par:
C  IDST:	I*4		return status
C
C--------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*4	DISPLAY,CHANS(1),NOCHAN,LUTF(1),ITTF(1)
	INTEGER*4	IDST,N,LOOP,SPLITMODE
C	
	INTEGER*2	UNIT,FCLEFT,FCRIGHT,BY
	INTEGER*2	WORK,CLEAR
	INTEGER*2	LMC,RVR,LVR
C
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
	INCLUDE	'MID_INCLUDE:IDIDEV.INC'
C	
	EXTERNAL	LMC,LVR,RVR
C	
	UNIT = DISPLAY
	CALL STKRDI('DAZHOLD',3,1,N,SPLITMODE,N,N,N)
C 
C  loop over channels
	DO 1000 LOOP=1,NOCHAN
C	
C  test, if we have to modify ITT visibility
	   IF (ITTF(LOOP).GE.0) THEN
C	
C  clear + set ITT bit (12) of memory register 3 of channel CHAN
	      N = CHANS(LOOP) + 1
	      MEMREG(4,N) = IAND(MEMREG(4,N),"167777)	
	      IF (ITTF(LOOP).NE.0)
     +	         MEMREG(4,N) = IOR(MEMREG(4,N),"10000)	
C	
C  and send it out
	      CALL IP8QW(LMC,UNIT,DZIOSB,,,MEMREG(4,N),2,CHANS(LOOP),3)
	   ENDIF
C	
	   IF (CHANS(LOOP).EQ.QOVCH) GOTO 1000
C	
C  now handle the LUT part
C	
	   IF (LUTF(LOOP).LT.0) THEN			!leave bypass flag as it is
	      WORK = CHANS(LOOP)
	      CLEAR = "160				!clear only channel
	   ELSE
	      CLEAR = "140				!clear bypass bit + channel
	      IF (LUTF(LOOP).NE.0) THEN
	         BY = 0
	      ELSE
	         BY = "20
	      ENDIF
	      WORK = IOR(BY,CHANS(LOOP))		!update bypass flag
	   ENDIF
C	
C  for image channels we only have to work in non-split, non-RGB mode ...
	   CALL IP8QW(RVR,UNIT,DZIOSB,,,FCR,16,0,8)	!get current FCRs
C	
	   IF (QRGBFL.EQ.1) GOTO 1000
	   IF (SPLITMODE.EQ.0) THEN
C	
C  update FCR for screen segment 3 only (that's the one we see)
	      FCRIGHT = IAND(FCR(4),CLEAR)	!get right byte + keep only LUT section
	      FCRIGHT = IOR(FCRIGHT,WORK)	!include new bypass bit + channel
	      FCLEFT = ISHFT(FCR(4),-8)		!get left byte of FCR3
	      FCLEFT = IAND(FCLEFT,CLEAR)	!only keep LUT section
	      FCLEFT = IOR(FCLEFT,WORK)		!include new bypass bit + channel
C	
	      FCR(4) = ISHFT(FCLEFT,8)		!put the pieces back together
	      FCR(4) = IOR(FCR(4),FCRIGHT)
C	
	      FCRIGHT = IAND(FCR(8),CLEAR)	!get right byte + keep only LUT section
	      FCRIGHT = IOR(FCRIGHT,WORK)	!include new bypass bit + channel
	      FCR(8) = IAND(FCR(8),"177400)	!clear right byte completely
	      FCR(8) = IOR(FCR(8),FCRIGHT)	!and add in new right side
	   ELSE
C	
C  in split mode we only update the bypass flag
	      DO N=1,8
		 FCLEFT = ISHFT(FCR(N),-8)		!get left byte
		 FCRIGHT = IAND(FCR(N),"377)		!get right byte
		 IF (IAND(FCLEFT,"17).EQ.CHANS(LOOP)) THEN
		    FCLEFT = IAND(FCLEFT,"357)	!get rid of old BY bit
		    FCLEFT = IOR(FCLEFT,BY)		!insert new one
		 ENDIF
		 IF (IAND(FCRIGHT,"17).EQ.CHANS(LOOP)) THEN
		    FCRIGHT = IAND(FCRIGHT,"357)	!get rid of old BY bit
		    FCRIGHT = IOR(FCRIGHT,BY)	!insert new one
		 ENDIF
C	
		 FCR(N) = ISHFT(FCLEFT,8)		!put the bytes together
		 FCR(N) = IOR(FCR(N),FCRIGHT)
	      ENDDO
	   ENDIF
C	
C  send the FCRs back to the DeAnza
	   CALL IP8QW(LVR,UNIT,DZIOSB,,,FCR,16,0,8)
C	
1000	CONTINUE
C 
	IDST = 0
	RETURN
	END

	SUBROUTINE GD8050(DISPLAY,LUNO,IDST)
C
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine IIDIAG		version 1.00	880202
C  K. Banse                  	ESO - Garching
C
C.KEYWORDS
C  DeAnza, system status
C
C.PURPOSE
C  display the different DeAnza registers
C
C.ALGORITHM
C  use IP8LIB routines to read the registers
C
C.INPUT/OUTPUT
C	
C--------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*4 	DISPLAY,LUNO,IDST
	INTEGER*4	CURSOR,HI,LO
	INTEGER*4	I,IAV,M,N,N1
C
	INTEGER*2	REG(14),XREG(8),YREG(8)
	INTEGER*2	PSR
	INTEGER*2	JOYREG(3)
	INTEGER*2	BITTS(16)
	INTEGER*2	XREAL,YREAL
	INTEGER*2	UNIT
	INTEGER*2	RR,RMR,RVR,RCR,RPR
C	
	CHARACTER	DAZREG(14)*5
	CHARACTER*2	SS(8)
C
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
C	
	EXTERNAL	RR,RMR,RVR,RCR,RPR
C
	DATA	DAZREG	/'CMD','ISR',' ','PSR','RSR','DW',' ',
     +                   'DATA','IR','COUNT','CNTRL','RES','FG','BG'/
	DATA	SS	/'00','01','10','11','00','01','10','11'/
C	
	UNIT = DISPLAY
C
C  read interesting system registers
	CALL IP8QW(RR,UNIT,DZIOSB,,,REG,2,0,0)		!crashes the VAX...
 	CALL IP8QW(RR,UNIT,DZIOSB,,,REG(2),2,0,1)		!crashes the VAX...
 	CALL IP8QW(RR,UNIT,DZIOSB,,,REG(4),2,0,3)		!PSR
 	CALL IP8QW(RR,UNIT,DZIOSB,,,REG(5),2,0,4)		!RSR
 	CALL IP8QW(RR,UNIT,DZIOSB,,,REG(6),2,0,5)		!DW
CC 	CALL IP8QW(RR,UNIT,DZIOSB,,,REG(8),2,0,7)		!gives driver fault
CC 	CALL IP8QW(RR,UNIT,DZIOSB,,,REG(9),2,0,8)		!gives driver fault
 	CALL IP8QW(RR,UNIT,DZIOSB,,,REG(10),2,0,9)	!COUNT
	CALL IP8QW(RR,UNIT,DZIOSB,,,REG(11),8,1,10)	!CONTRL - BG
C
C  read X, Y registers
	CALL IP8QW(RR,UNIT,DZIOSB,,,XREG,16,1,16)
	CALL IP8QW(RR,UNIT,DZIOSB,,,YREG,16,1,24)
	XREG(5) = IAND("3777,XREG(5))
	XREG(6) = IAND("3777,XREG(6))
	YREG(5) = IAND("3777,YREG(5))
	YREG(6) = IAND("3777,YREG(6))
C
C  read Peripheral Select reg.
	CALL IP8QW(RMR,UNIT,DZIOSB,,,PSR,2,0,0)
	CURSOR = IAND("3,ISHFT(PSR,-8))
C
C  read VOC registers
	CALL IP8QW(RVR,UNIT,DZIOSB,,,VOCREG,8,0,0)
	CALL IP8QW(RVR,UNIT,DZIOSB,,,FCR,16,0,8)
C
C  read cursor registers
	CALL IP8QW(RCR,UNIT,DZIOSB,,,CURREG,14,CURSOR,0)
C
C  read joystick registers
	CALL IP8QW(RPR,UNIT,DZIOSB,,,JOYREG,6,CURSOR,1)
C
C  now let's massage the info we got...
C
C  display system interface registers 9 - 13
	WRITE(LUNO,10001)
C
C  display all interesting system registers
	N = 0				!CMD
	N1 = 1
	CALL BITS(REG(N1),BITTS)
	WRITE(LUNO,10100) N,DAZREG(N1),REG(N1)
	WRITE(LUNO,10020) (BITTS(I),I=16,1,-1)
C
	N = 1				!ISR
	N1 = 2
	CALL BITS(REG(N1),BITTS)
	WRITE(LUNO,10101) N,DAZREG(N1),REG(N1)
	WRITE(LUNO,10020) (BITTS(I),I=16,1,-1)
C
	N = 3				!PSR
	N1 = 4
	CALL BITS(REG(N1),BITTS)
	WRITE(LUNO,10103) N,DAZREG(N1),REG(N1)
	WRITE(LUNO,10020) (BITTS(I),I=16,1,-1)
C
	N = 4				!RSR
	N1 = 5
	CALL BITS(REG(N1),BITTS)
	WRITE(LUNO,10104) N,DAZREG(N1),REG(N1)
	WRITE(LUNO,10020) (BITTS(I),I=16,1,-1)
C
	N = 5				!DW
	N1 = 6
	WRITE(LUNO,10105) N,DAZREG(N1),REG(N1)
	LO = IAND(REG(N1),"377)
	HI = ISHFT(IAND(REG(N1),"177400),-8)
	WRITE(LUNO,10200) HI,LO
C
	N = 9				!COUNT
	N1 = 10
	WRITE(LUNO,10109) N,DAZREG(N1),REG(N1)
	WRITE(LUNO,10201) REG(N1)
C
	N = 10				!CONTRL
	N1 = 11
	CALL BITS(REG(N1),BITTS)
	WRITE(LUNO,10110) N,DAZREG(N1),REG(N1)
	WRITE(LUNO,10020) (BITTS(I),I=16,1,-1)
C
	N = 11				!RES
	N1 = 12
	CALL BITS(REG(N1),BITTS)
	WRITE(LUNO,10111) N,DAZREG(N1),REG(N1)
	WRITE(LUNO,10020) (BITTS(I),I=16,1,-1)
C
	N = 12				!FG
	N1 = 13
	WRITE(LUNO,10112) N,DAZREG(N1),REG(N1)
	WRITE(LUNO,10201) REG(N1)
C
	N = 13				!BG
	N1 = 14
	WRITE(LUNO,10113) N,DAZREG(N1),REG(N1)
	WRITE(LUNO,10201) REG(N1)
C
C  display X, Y reg.
	XREAL = XREG(1) + XREG(2)
	YREAL = YREG(1) + YREG(2)
	WRITE(LUNO,10002) XREG(1),YREG(1),XREG(2),YREG(2),
     +                  XREAL,YREAL,(XREG(I),YREG(I),I=3,8)
C
C  display PSR
	CALL BITS(PSR,BITTS)
	WRITE(LUNO,10003) PSR,(BITTS(I),I=16,1,-1)
C
C  display cursor reg.
	CALL BITS(CURREG(5),BITTS)
	WRITE(LUNO,10004) (CURREG(I),I=1,5),(BITTS(N),N=16,1,-1),
     +                  (CURREG(I),I=6,7)
C
C  display joystick reg.
	CALL BITS(JOYREG(1),BITTS)
	XREAL = IAND("377,ISHFT(JOYREG(3),-8))
	YREAL = IAND(JOYREG(3),"377)
	WRITE(LUNO,10005) JOYREG(1),(BITTS(N),N=16,1,-1),
     +                  JOYREG(2),JOYREG(3),XREAL,YREAL
C
C  display VOC registers
	VOCREG(1) = IAND("777,VOCREG(1))
	VOCREG(2) = IAND("777,VOCREG(2))
	CALL BITS(VOCREG(3),BITTS)
	WRITE(LUNO,10006) (VOCREG(I),I=1,3),(BITTS(I),I=16,1,-1),
     +                  VOCREG(4)
	WRITE(LUNO,10007)
	DO N=8,1,-1
	   CALL BITS(FCR(N),BITTS)
	   M = N - 1
	   WRITE(LUNO,10008) M,(BITTS(I),I=16,1,-1),SS(N)
	ENDDO
C
C  job done
	IDST = 0
	RETURN
C
C  FORMATS
10001	FORMAT('0system interface registers:')
10002	FORMAT('0X, Y registers  (dec.):'/
     +         ' X     = ',I6,T40,'Y     = ',I6/
     +         ' XT    = ',I6,T40,'YT    = ',I6/
     +         ' XREAL = ',I6,'*'T40,'YREAL = ',I6,'*'/
     +         ' XMIN  = ',I6,T40,'YMIN  = ',I6/
     +         ' XMAX  = ',I6,T40,'YMAX  = ',I6/
     +         ' XAMIN = ',I6,T40,'YAMIN = ',I6/
     +         ' XAMAX = ',I6,T40,'YAMAX = ',I6/
     +         ' DX    = ',I6,T40,'DY    = ',I6/
     +         ' XTEMP = ',I6,T40,'YTEMP = ',I6)
10003	FORMAT('0Peripheral Select : ',O6,' (oct) or',T40,'C3 C2 C1 ',
     +         'C0  A3 A2 A1 A0'/
     +         T40,2I1,1X,2I1,1X,2I1,1X,2I1,2X,2I1,1X,2I1,1X,2I1,1X,2I1)
10004	FORMAT('0Cursor registers :'/
     +         ' X, Y - coord. of cursor 1 = ',2I4,'  (dec)'/
     +         ' X, Y - coord. of cursor 2 = ',2I4,'  (dec)'/
     +         ' cursor control reg. = ',O6,' or',
     +         T40,'P2 P1 PE PB I2 B2 Y2 X2 I1 B1 Y1 X1 F3-F0'/
     +         T40,I2,11I3,2X,4I1/
     +         ' LUT address reg. = ',O6,' (oct)'/
     +         ' cursor rate reg. = ',O6,' (oct)')
10005	FORMAT('0joystick registers 1 - 3:'/
     +         ' control reg. = ',O6,' (oct) or',
     +         T40,'RES. T E M C2 C1 J7 - J2 IE CL'/
     +         T40,3I1,1X,3I2,2I3,2X,6I1,2I3/
     +         ' A/B optional input  = ',O6,' (oct)'/
     +         ' X/Y displacement = ',O6,' (oct) or',
     +         T40,'    Y       X'/
     +         T40,I6,2X,I6)
10006	FORMAT(' VOC registers:'/
     +         ' X split reg. = ',O6,' (oct)'/
     +         ' Y split reg. = ',O6,' (oct)'/
     +         ' control reg. = ',O6,' (oct) or',
     +         T40,'* CE AR M1 M0 AE GB GE *** P1 P0 SS SY SX'/
     +         T40,I1,7I3,1X,3I1,5I3/
     +         ' LUT address reg. = ',O6,' (oct)')
10007	FORMAT('0FCR registers:'//
     +         '        * S6+5 BY B3-B0  * S6+5 BY B3-B0  segment')
10008	FORMAT(' FCR',I2,2X,I1,3X,2I1,I3,2X,4I1,I3,3X,2I1,
     +         I3,2X,4I1,'  -> ',A)
10020	FORMAT(T32,I2,15I3)
10100	FORMAT(' reg.',I2,1X,A,' = ',O6,' (oct)'
     +  ,T32,'SR CR DW CW SC IE S2 MF CD VB AD P1 P0  D  I MS')
10101	FORMAT('0reg.',I2,1X,A,' = ',O6,' (oct)'
     +  ,t32,'I1 IQ IC IA IS S2 S2 MF CD VB AD P1 P0  D  I MS')
10103   FORMAT('0reg.',I2,1X,A,' = ',O6,' (oct)'
     +	,T32,'A2 A1 A0  *  *  *  *  * U7 U6 U5 U4 U3 U2 U1 U0')
10104   FORMAT('0reg.',I2,1X,A,' = ',O6,' (oct)'
     +	,T32,' *  *  *  *  *  *  * HS CD VB AP RR WR ID EF MS')
10105   FORMAT('0reg.',I2,1X,A,' = ',O6,' (oct)'
     +	,T32,'UPPER BOUND   LOWER BOUND')
10109   FORMAT('0reg.',I2,1X,A,' = ',O6,' (oct)'
     +	,T32,'UNSIGNED 16 BIT INTEGER')
10110   FORMAT('0reg.',I2,1X,A,' = ',O6,' (oct)'
     +	,T32,' *  *  *  *      CSC    PB AG MG SW ME PS SI PI')
10111   FORMAT('0reg.',I2,1X,A,' = ',O6,' (oct)'
     +	,T32,' *  *  *  *  *  *  *  * MR SG 1K MS Y1 Y0 X1 X0')
10112   FORMAT('0reg.',I2,1X,A,' = ',O6,' (oct)'
     +	,T32,' *  *  *  *  *  *  *  * FOREGROUND DATA VALUE')
10113   FORMAT('0reg.',I2,1X,A,' = ',O6,' (oct)'
     +	,T32,' *  *  *  *  *  *  *  * BACKGROUND DATA VALUE')
10200	FORMAT(T32,I5,I6)
10201	FORMAT(T32,I8)
	END