C @(#)gd8c.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 GD8029(DISPLAY,CHAN,CURSNO,SHAPE,COLOUR,XC,YC,IDST)
C	
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  a) subroutine IICINC		version 1.00	880921
C  b) subroutine IICSCV		version 1.00	880915
C  c) subroutine IICWCP		version 1.00	880915
C  d) subroutine IICRCP		version 1.00	880915
C  K. Banse                  	ESO - Garching
C
C.KEYWORDS
C  DeAnza, cursor boards
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
C  a) IICINC(DISPLAY,CHAN,CURSNO,SHAPE,COLOUR,XC,YC,IDST)
C  b) IICSCV(DISPLAY,CURSNO,VIS,IDST)
C  c) IICWCP(DISPLAY,CHAN,CURSNO,XC,YC,IDST)
C  d) IICRCP(DISPLAY,CHAN,CURSNO,XC,YC,MEMO,IDST)
C
C  input par:
C  DISPLAY:	I*4		display id.
C  CHAN:	I*4		memory id (not used, always assumed to be -1 ...)
C  CURSNO:	I*4		cursor number, 0 or 1
C  SHAPE:	I*4		cursor shape
C				= 0 for DeAnza programmable or fixed cursors
C				  1,2,3,7 as in IDI doc. page 44
C  COLOUR:	I*4		cursor colour
C				if shape = 0 
C				= 0 for just set cursor on 
C				  1,...,16 for fixed forms 0,...,15 
C				  99 for loading a programmable cursor,
C				     name stored in keyword IN_A
C				if shape > 0 
C				  0,1,2 as in IDI doc. page 38
C  XC:		I*4		x cursor position
C  YC:		I*4		y cursor position
C
C  VIS:		I*4		1 = visible, 0 = invisible
C
C  output par:
C  MEMO:	I*4		memory cursor is currently pointing to
C
C  IDST:	I*4		return status
C	
C--------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*4	DISPLAY,CHAN,CURSNO,SHAPE,COLOUR,XC,YC,IDST
	INTEGER*4	N,FIX
C		
	INTEGER*2	UNIT,CURSAR(1024)
	INTEGER*2	PMASK,COFF,RESREG,I2WORD(2),XY
	INTEGER*2	RR,LR,LCR,RCR,LPA
C 
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
C	
	EQUIVALENCE	(I2WORD(1),N)
C 
	EXTERNAL	LR,RR,LCR,RCR,LPA
C
C  get unit
	UNIT = DISPLAY
	IDST = 0
C	
C  get cursor control register
	CALL IP8QW(RCR,UNIT,DZIOSB,,,CURREG(5),2,0,4)
C	
C  set up bit masks
	IF (CURSNO.EQ.0) THEN
	   PMASK = "40000
	   COFF = "177717			!leave P2 bit as it is
	   XY = "60
	ELSE
	   PMASK = "100000
	   COFF = "176377			!leave P1 bit as it is
	   XY = "1400
	ENDIF
C
C  clear P2 (15), Y2, X2 (9,8) or P1 (14), Y1, X1 (5,4)
C  clear F3, F2,F1,F0 bits (3, 2,1,0)
C	
	N = IAND(CURREG(5),COFF)
	N = IAND(N,"177760)
	CURREG(5) = I2WORD(1)			!to avoid integer overflow ....
C	
C  branch according to cursor shape
C	
	IF (SHAPE.NE.0) GOTO 1000
C 
C  DeAnza specific stuff, see if fixed (COLOUR in [1,16]) or programmable
        IF ( (COLOUR.GE.1) .AND. (COLOUR.LE.16) ) THEN
	   FIX = COLOUR - 1
	   FIX = IAND(FIX,"17)				!cut out last 4 bits
	   CURREG(5) = IOR(CURREG(5),FIX)		!insert fixed cursor shape
	   CURREG(5) = IOR(CURREG(5),XY)		!insert X, Y components
	ELSE
	   CURREG(5) = IOR(CURREG(5),PMASK)
C	
C  check, if just enable current cursor
	   IF (COLOUR.EQ.0) GOTO 5000
C
C  read specified cursor shape from table file (COLOUR = 99)
	   CALL KKCTAB(SHAPE,COLOUR,CURSAR,IDST)
	   IF (IDST.NE.0) THEN
	      IDST = 71
	      RETURN
	   ENDIF
C	
C  set resolution register for low byte transfer
	   CALL IP8QW(RR,UNIT,DZIOSB,,,SYSREG(12),2,0,11)
	   RESREG = IAND(SYSREG(12),"177677)
	   RESREG = IOR(RESREG,"100)
	   CALL IP8QW(LR,UNIT,DZIOSB,,,RESREG,2,0,11)
C
C  finally load the cursor table into the DeAnza + reset SYSREG(12)
	   CALL IP8QW(LPA,UNIT,DZIOSB,,,CURSAR,2048,CURSNO,3)
	   CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(12),2,0,11)
	ENDIF
        GOTO 5000
C	
C  handle the "official" IDI cursor shapes
C	
1000	IF ( SHAPE.EQ.1) THEN				!Cross hair
	   CURREG(5) = IOR(CURREG(5),XY)		!insert X, Y components
	ELSE
	   CURREG(5) = IOR(CURREG(5),PMASK)		!all others are implemented
C							!via programmable cursors
C  read specified cursor shape from table file 
	   CALL KKCTAB(SHAPE,COLOUR,CURSAR,IDST)
	   IF (IDST.NE.0) THEN
	      IDST = 71
	      RETURN
	   ENDIF
C	
C  set resolution register for low byte transfer
	   CALL IP8QW(RR,UNIT,DZIOSB,,,SYSREG(12),2,0,11)
	   RESREG = IAND(SYSREG(12),"177677)
	   RESREG = IOR(RESREG,"100)
	   CALL IP8QW(LR,UNIT,DZIOSB,,,RESREG,2,0,11)
C
C  finally load the cursor table into the DeAnza + reset SYSREG(12)
	   CALL IP8QW(LPA,UNIT,DZIOSB,,,CURSAR,2048,CURSNO,3)
	   CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(12),2,0,11)
	ENDIF
C	
C  send cursor control register to the Deanza
5000	CALL IP8QW(LCR,UNIT,DZIOSB,,,CURREG(5),2,0,4)
C
C  look, if we also want to position the cursor
	IF (XC.GE.0)
     +	   CALL GD8032(DISPLAY,CHAN,CURSNO,XC,YC,IDST)
C	
C  alright then...
	RETURN
	END

	SUBROUTINE GD8030(DISPLAY,CURSNO,VIS,IDST)
C
	IMPLICIT NONE
C	
	INTEGER*4	DISPLAY,CURSNO,VIS,IDST
	INTEGER*4	IPROG
C		
	INTEGER*2	UNIT
	INTEGER*2	CURSOFF,CURSON,PMASK,CMASK
	INTEGER*2	LCR,RCR
C
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
C	
	EXTERNAL	LCR,RCR
C
C  get unit
	UNIT = DISPLAY
C	
C  get cursor register 4
	CALL IP8QW(RCR,UNIT,DZIOSB,,,CURREG(5),2,0,4)
C	
C  set bit masks
	IF (CURSNO.EQ.0) THEN
	   PMASK = "40000
	   CURSOFF = "137717
	   CMASK = "60
	ELSE
	   PMASK = "100000
	   CURSOFF = "076377
	   CMASK = "1400
	ENDIF
C
C  test, if we are using fixed or programmable cursors
	IPROG = 0			! 4 bytes = 0
	IPROG = IAND(CURREG(5),PMASK)
C	
	IF (IPROG.NE.0) THEN
	   CURSON = PMASK
	ELSE
	   CURSON = CMASK
	ENDIF
C	
C  dis/enable cursor
	IF (VIS.EQ.0) THEN
	   CURREG(5) = IAND(CURREG(5),CURSOFF)
	ELSE
	   CURREG(5) = IOR(CURREG(5),CURSON)
	ENDIF
C	
C  and send it to the Deanza
	CALL IP8QW(LCR,UNIT,DZIOSB,,,CURREG(5),2,0,4)
C	
C  alright then...
	IDST = 0
	RETURN
	END

	SUBROUTINE GD8032(DISPLAY,CHAN,CURSNO,XC,YC,IDST)
C
	IMPLICIT NONE
C	
	INTEGER*4	DISPLAY,CHAN,CURSNO,XC,YC,IDST
	INTEGER*4	N1,N
C		
	INTEGER*2	UNIT
	INTEGER*2	LCR
C
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
C	
	EXTERNAL	LCR
C
C  get unit
	UNIT = DISPLAY
C	
C  set index
	IF (CURSNO.EQ.0) THEN
	   N = 0
	   N1 = 1
	ELSE
	   N = 2
	   N1 = 3
	ENDIF
C	
C  cut off irrelevant parts of XC, YC
	CURREG(N1) = IAND(XC,"777)
	CURREG(N1+1) = IAND(YC,"777)
C	
C  and send it to the Deanza
	CALL IP8QW(LCR,UNIT,DZIOSB,,,CURREG(N1),4,0,N)
C	
C  alright then...
	IDST = 0
	RETURN
	END

	SUBROUTINE GD8031(DISPLAY,CHAN,CURSNO,XC,YC,MEMO,IDST)
C
	IMPLICIT NONE
C	
	INTEGER*4	DISPLAY,CHAN,CURSNO,XC,YC,MEMO,IDST
	INTEGER*4	N1,N,ISS
C		
	INTEGER*2	UNIT,CONTROL,FCREG
	INTEGER*2	RCR,RVR,LPR
C
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
C	
	EXTERNAL	RCR,RVR,LPR
C
C  get unit
	UNIT = DISPLAY
C	
C  set index
	IF (CURSNO.EQ.0) THEN
	   N = 0
	   N1 = 1
	ELSE
	   N = 2
	   N1 = 3
	ENDIF
C	
C  get cursor registers from the Deanza
	CALL IP8QW(RCR,UNIT,DZIOSB,,,CURREG(N1),4,0,N)
C	
C  fill parameters
	XC = CURREG(N1)
	YC = CURREG(N1+1)
C	
C  get X-, Y- split registers + FCRs
	CALL IP8QW(RVR,UNIT,DZIOSB,,,VOCREG(1),4,0,0)
	CALL IP8QW(RVR,UNIT,DZIOSB,,,FCR(1),16,0,8)
C	
C  determine relevant FCR
	IF ( (VOCREG(1).EQ.0) .AND. (VOCREG(2).EQ.511) ) THEN
	   FCREG = FCR(4)			!no split screen
	ELSE
	   IF (XC.LT.VOCREG(1)) THEN
	      ISS = 1
	      IF (YC.LT.VOCREG(2)) ISS = 2
	   ELSE
	      ISS = 0
	      IF (YC.LT.VOCREG(2)) ISS = 3
	   ENDIF
	   FCREG = FCR(ISS+1)
	ENDIF
C	
C  pull out memory channel from FCR
	MEMO = IAND(FCREG,"17)
C	
C  alright then...
	IDST = 0
	RETURN
	END