C @(#)gd8m2.for	17.1.1.1 (ES0-DMD) 01/25/02 17:34:39
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 GD8011(DISPLAY,CHAN,NOCHAN,VIS,IDST)
C	
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine IIMSMV		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  IIMSMV(DISPLAY,CHAN,NOCHAN,VIS,IDST)
C
C  input par:
C  DISPLAY:	I*4		display id.
C  CHAN:	I*4 array	memory ids
C  NOCHAN:	I*4 		no. of memories
C  VIS:		I*4 		visibility: 0 = not visible
C					    1 = visible
C  output par:
C  IDST:	I*4		return status
C
C--------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*4	DISPLAY,CHAN(1),NOCHAN,VIS,IDST
	INTEGER*4	KCHAN,KK,N,SPLITMODE
C	
	INTEGER*2	UNIT,FCLEFT,FCRIGHT,BY
	INTEGER*2	CLEAR,CLAN,SETAN
	INTEGER*2	LMC,RVR,LVR
C
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
	INCLUDE	'MID_INCLUDE:IDIDEV.INC'
C 
	DATA	CLAN /"175777/, SETAN /"002000/
C	
	EXTERNAL	LMC,LVR,RVR
C	
	UNIT = DISPLAY
	CALL IP8QW(RVR,UNIT,DZIOSB,,,VOCREG(3),2,0,2)
	CLEAR = "160
C	
C  get more info from keyword DAZHOLD
	CALL STKRDI('DAZHOLD',3,1,N,SPLITMODE,N,N,N)
C	
C  if CHAN  = overlay channel, we only handle the GE bit in VOC control register
C	
	DO KK=1,NOCHAN
	   KCHAN = CHAN(KK)
C 
C  if overlay channel, clear + set GE bit (8) of register 2, depending upon VIS
	   IF (KCHAN.EQ.QOVCH) THEN	
	      VOCREG(3) = IAND(VOCREG(3),"177377)
	      IF (VIS.GT.0) VOCREG(3) = IOR(VOCREG(3),"400)
	      CALL IP8QW(LVR,UNIT,DZIOSB,,,VOCREG(3),2,0,2)
	      GOTO 1000
C	
C  if alpha channel, clear + set AE bit (10) of register 2, depending upon VIS
	   ELSE IF (KCHAN.GE.QALPNO) THEN
	      VOCREG(3) = IAND(VOCREG(3),CLAN)
	      IF (VIS.GT.0)
     +	         VOCREG(3) = IOR(VOCREG(3),SETAN)	
	      CALL IP8QW(LVR,UNIT,DZIOSB,,,VOCREG(3),2,0,2)
	      GOTO 1000
	   ENDIF
C	
C  for image channels we only have to work in non-split, non-RGB mode ...
C	
	   IF ( (QRGBFL.NE.1) .AND. (SPLITMODE.EQ.0) ) THEN
	      CALL IP8QW(RVR,UNIT,DZIOSB,,,FCR,16,0,8)	!get current FCRs
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,KCHAN)	!include channel
	      FCLEFT = ISHFT(FCR(4),-8)	!get left byte of FCR3
	      FCLEFT = IAND(FCLEFT,CLEAR)	!only keep LUT section
	      FCLEFT = IOR(FCLEFT,KCHAN)	!include 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,KCHAN)	!include channel
	      FCR(8) = IAND(FCR(8),"177400)	!clear right byte completely
	      FCR(8) = IOR(FCR(8),FCRIGHT)	!and add in new right side
C	
C  send the FCRs back to the DeAnza
	      CALL IP8QW(LVR,UNIT,DZIOSB,,,FCR,16,0,8)
	   ENDIF
1000	ENDDO
C	
	IDST = 0
	RETURN
	END

	SUBROUTINE GD8015(DISPLAY,CHAN,LUT,ITT,IDST)
C	
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine IIMSLT	version 1.00	880202
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  IIMSLT(DISPLAY,CHAN,LUT,ITT,IDST)
C
C  input par:
C  DISPLAY:	I*4		display id.
C  CHAN:	I*4		memory id
C  LUT:		I*4		LUT id - (0,1,2,3)
C  ITT:		I*4 		ITT id - (0,1,2,3)
C	
C  output par:
C  IDST:	I*4		return status
C
C--------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*4	DISPLAY,CHAN,ITT,LUT,IDST
	INTEGER*4	N,FOUND,ONCE
C	
	INTEGER*2	UNIT,ITTSECT(4),FCLEFT,FCRIGHT,LUTSECT
	INTEGER*2	RVR,LVR
C
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
C	
	EXTERNAL	RVR,LVR
C	
	DATA	ITTSECT	/0,"400,"1000,"1400/
C
C  clear + set ITT section bits (9,8) of memory register 3 of channel CHAN
	IF (ITT.GE.0) THEN
	   N = CHAN + 1
	   MEMREG(4,N) = IAND(MEMREG(4,N),"176377)		
	   MEMREG(4,N) = IOR(MEMREG(4,N),ITTSECT(ITT+1))	
	ENDIF
C	
C  now handle the LUT part
	IF (LUT.LT.0) GOTO 8000
C 
	LUTSECT = ISHFT(LUT,5)
	ONCE = 0
	CALL IP8QW(RVR,UNIT,DZIOSB,,,FCR,16,0,8)		!get FCRs
C	
	DO N=1,8
	   FOUND = 0
	   FCLEFT = ISHFT(FCR(N),-8)		!get left byte
	   FCRIGHT = IAND(FCR(N),"377)		!get right byte
	   IF (IAND(FCLEFT,"17).EQ.CHAN) THEN
	      FOUND = 1
	      FCLEFT = IAND(FCLEFT,"37)		!get rid of old LUT section
	      FCLEFT = IOR(FCLEFT,LUTSECT)	!insert new one
	   ENDIF
	   IF (IAND(FCRIGHT,"17).EQ.CHAN) THEN
	      FOUND = 1
	      FCRIGHT = IAND(FCRIGHT,"37)		!get rid of old LUT section
	      FCRIGHT = IOR(FCRIGHT,LUTSECT)	!insert new one
	   ENDIF
C	
	   IF (FOUND.EQ.1) THEN
	      ONCE = 1				!indicate that we changed at least once
	      FCR(N) = ISHFT(FCLEFT,8)
	      FCR(N) = IOR(FCR(N),FCRIGHT)	!put the pieces back together
	   ENDIF
	ENDDO
C	
C  if something modified, send the FCRs back to the DeAnza
	IF (ONCE.EQ.1) THEN
	   UNIT = DISPLAY
	   CALL IP8QW(LVR,UNIT,DZIOSB,,,FCR,16,0,8)
	ENDIF
C	
8000	IDST = 0
	RETURN
	END

	SUBROUTINE GD8047(DISPLAY,MEMIDS,MEMLIM,DELAY,IDST)
C	
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine IIMBL			version 1.00	880502
C  K. Banse             	     	ESO - Garching
C  1.10     890609	1.20	900327
C
C.KEYWORDS
C  DeAnza, memory channels
C
C.PURPOSE
C  fulfill the requirements as described in the IDI document (Feb. 86)
C
C.ALGORITHM
C  use DeAnza level 0 software
C
C.INPUT/OUTPUT
C  call as IIMBLM(DISPLAY,MEMIDS,MEMLIM,DELAY,IDST)
C 
C  input par:
C  DISPLAY:	I*4		display id.
C  MEMIDS:	I*4 array	memory ids
C  MEMLIM:	I*4		dimension of MEMIDS
C  DELAY:	R*4 array	delay in seconds
C  IDST:	I*4		return status
C	
C.VERSIONS
C  1.00		from old IDI_BLME
C  1.10		DELAY is also an array (see doc ...)
C  1.20		use routine DAZWAI for waiting
C--------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*4	DISPLAY,MEMIDS(1),MEMLIM,IDST
	INTEGER*4	N,CHAN,KDELAY,LENC,OFF,IAV,STAT
C
	REAL*4		DELAY(1)
C	
	CHARACTER	INFO*80
C	
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
C	
C  now loop over memory ids
100	DO N=1,MEMLIM				!MEMLIM should be > 0 ...!
	   CHAN = MEMIDS(N)
	   KDELAY = NINT(DELAY(N) * 1000.)      !convert seconds to milliseconds
	   CALL GD8011(DISPLAY,CHAN,1,1,IDST)	!leave ITT + LUT visibility as it is
	   CALL WALPHB(CHAN,0)				!show alpha info...
C	
C  now wait
	   CALL DAZWAI(KDELAY)
	ENDDO
C	
C  now we do it over and over again...
	GOTO 100
C	
C  we don't get out here, but a CTRL/C is used to turn IIMBLM off ...
1000	RETURN
	END