C @(#)gd8d2.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
     +	GD8006(DISPLAY,TOTCONF,SZX,SZY,DEPTH,NLUT,NITT,NCURS,IDST)
C	
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine IIDQDV		version 1.00	880118
C  K. Banse                  	ESO - Garching
C
C.KEYWORDS
C  DeAnza, configuration
C
C.PURPOSE
C  fulfill the requirements as described in the IDI document
C
C.ALGORITHM
C  use DeAnza level 0 + 1 software
C
C.INPUT/OUTPUT
C  call as  IIDQDV(DISPLAY,TOTCONF,SZX,SZY,DEPTH,NLUT,NITT,NCURS,IDST)
C
C  input par:
C  DISPLAY:	I*4		display id.
C
C  output par:
C  TOTCONF:	I*4		number of available configurations
C  SZX:		I*4		display size in x
C  SZY:		I*4		display size in y
C  DEPTH:	I*4		display depth
C  NLUT:	I*4		number of LUTs
C  NITT:	I*4		number of ITTs
C  NCURS:	I*4		number of cursors
C  IDST:	I*4		return status
C	
C--------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*4	DISPLAY,TOTCONF,SZX,SZY,DEPTH,
     +                  NLUT,NITT,NCURS,IDST
C
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
	INCLUDE	'MID_INCLUDE:IDIDEV.INC'
	INCLUDE	'MID_INCLUDE:IDIMEM.INC'
C	
C  use DZDEV to return some of the required info
	TOTCONF = 2
	SZX = QDSZX
	SZY = QDSZY
	DEPTH = QDDEP
	NLUT = 4
	NITT = 4
	NCURS = 2
C
C  that's it folks...
	IDST = 0
	RETURN
	END

	SUBROUTINE GD8009(DISPLAY,CONFNO,MEMTYP,TOTMEM,
     +                    CONFMODE,MEMID,MEMSZX,MEMSZY,MEMDEP,
     +	                  ITTDEP,NOMEM,IDST)
C	
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine IIDQDC		version 1.00	880118
C  K. Banse                  	ESO - Garching
C
C.KEYWORDS
C  DeAnza, configuration
C
C.PURPOSE
C  fulfill the requirements as described in the IDI document
C
C.ALGORITHM
C  use DeAnza level 0 + 1 software
C
C.INPUT/OUTPUT
C  call as IIDQDC(DISPLAY,CONFNO,MEMTYP,TOTMEM,CONFMODE,MEMID,MEMSZX,MEMSZY,
C                 MEMDEP,ITTDEP,NOMEM,IDST)
C
C  input par:
C  DISPLAY:	I*4		display id.
C  CONFNO:	I*4		configuration number, starting with 1
C  MEMTYP:	I*4		type of memory:
C				= 1 for image, = 2 for alphanumeric,
C				= 4 for graphics (and bit combinations...)
C  TOTMEM:	I*4		max. no. of memories
C
C  output par:
C  CONFMODE:	I*4		configuration mode
C  MEMID:	I*4 		memory id's
C  MEMSZX:	I*4		memory size in x
C  MEMSZY:	I*4		memory size in y
C  MEMDEP:	I*4		memory depth
C  ITTDEP:	I*4		depth of connected ITT's
C  NOMEM:	I*4		number of memories
C  IDST:	I*4		return status
C	
C--------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*4	DISPLAY,CONFNO,MEMTYP,TOTMEM
	INTEGER*4	CONFMODE,MEMID(1),MEMSZX(1),MEMSZY(1),MEMDEP(1)
	INTEGER*4	ITTDEP(1),NOMEM,IDST
	INTEGER*4	IAV,N,ICOUNT
C
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
	INCLUDE	'MID_INCLUDE:IDIDEV.INC'
	INCLUDE	'MID_INCLUDE:IDIMEM.INC'
C	
C	
	NOMEM = 0
	IDST = 0
	ICOUNT = QLSTCH + 1
	IF (ICOUNT.GT.TOTMEM) ICOUNT = TOTMEM
C	
C  check input memory
	IF (TOTMEM.LT.1) THEN
	   IDST = 91
	   RETURN
	ENDIF
C	
C  test memory type
	IF ( (MEMTYP.GT.2) .AND. (MEMTYP.NE.4) ) RETURN
C	
C  for alpahnumerics and overlay memory, CONFNO is irrelevant
	IF (MEMTYP.EQ.2) THEN
	   NOMEM = 1
	   MEMID(1) = 99
	   MEMSZX(1) = QMSZX
	   MEMSZY(1) = QMSZY
	   MEMDEP(1) = QMDEP
	   ITTDEP(1) = 8
	   RETURN
C
	ELSE IF (MEMTYP.EQ.4) THEN
	   IF (QOVCH.LT.0) RETURN		!no graphics channel...
	   NOMEM = 1
	   MEMID(1) = QOVCH
	   MEMSZX(1) = QMSZX
	   MEMSZY(1) = QMSZY
	   MEMDEP(1) = QMDEP
	   ITTDEP(1) = 8
	   RETURN
	ENDIF
C	
C  test input configuration no.
	IF (CONFNO.EQ.0) GOTO 1000		!treat monochrome like pseudo-colour
	IF (CONFNO.EQ.1) GOTO 1000
	IF (CONFNO.EQ.2) GOTO 2000
	IF (CONFNO.EQ.-1) THEN
	   IF (QRGBFL.EQ.0) THEN
	      GOTO 1000
	   ELSE
	      GOTO 2000
	   ENDIF
	ENDIF
C	
	IDST = 90
	RETURN
C	
C  here for pseudo-colour mode
1000	DO N=0,ICOUNT-1
	   IF (N.NE.QOVCH) THEN
	      NOMEM = NOMEM + 1
	      MEMID(NOMEM) = N
	      IF (NOMEM.EQ.TOTMEM) GOTO 1100
	   ENDIF
	ENDDO
C	
1100	DO N=1,NOMEM
	   MEMSZX(N) = QMSZX
	   MEMSZY(N) = QMSZY
	   MEMDEP(N) = QMDEP
	   ITTDEP(N) = 8
	ENDDO
        RETURN
C	
C  here for RGB mode
2000	IF (QLSTCH.LE.1) RETURN		!not enough memories for RGB mode
C	
	NOMEM = 3
	DO N=1,NOMEM
	   MEMID(N) = N - 1
	   MEMSZX(N) = QMSZX
	   MEMSZY(N) = QMSZY
	   MEMDEP(N) = QMDEP
	   ITTDEP(N) = 8
	ENDDO
	RETURN
C	
	END

	SUBROUTINE GD8007(DISPLAY,CAPA,OUTSIZ,OUTDAT,TOTAL,IDST)
C	
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine IIDQCI		version 1.00	880609
C  K. Banse                  	ESO - Garching
C
C.KEYWORDS
C  DeAnza, configuration
C
C.PURPOSE
C  fulfill the requirements as described in the IDI document
C
C.ALGORITHM
C  use DeAnza level 0 + 1 software
C
C.INPUT/OUTPUT
C  call as  IIDQCI(DISPLAY,CAPA,OUTSIZ,OUTDAT,TOTAL,IDST)
C
C  input par:
C  DISPLAY:	I*4		display id.
C  CAPA:	I*4		capability no.
C  OUTSIZ:	I*4		size of output array
C
C  output par:
C  OUTDAT:	I*4 array	output data
C  TOTAL:	I*4		number of data values returned
C  IDST:	I*4		return status
C	
C--------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*4	DISPLAY,CAPA,OUTSIZ,OUTDAT(1),TOTAL,IDST
	INTEGER*4	KK
C
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
	INCLUDE	'MID_INCLUDE:IDIDEV.INC/NOLIST'
	INCLUDE	'MID_INCLUDE:IDIMEM.INC/NOLIST'
C	
C  init
	TOTAL = 1
	IDST = 0
	KK = CAPA/10
	GOTO (1000,2000,3000,4000,5000,6000,7000,8000,9000,10000),KK
C	
	IF (CAPA.EQ.1) THEN
	   OUTDAT(1) = 1
	   RETURN
	ELSE
	   GOTO 11011
	ENDIF
C	
C  capability in [10,19]
1000	IF (CAPA.EQ.10) THEN
	   OUTDAT(1) = 2
C
	ELSE IF (CAPA.EQ.11) THEN
	   IF (QRGBFL.EQ.0) THEN
	      OUTDAT(1) = 1
	   ELSE
	      OUTDAT(1) = 2
	   ENDIF
C
	ELSE IF (CAPA.EQ.12) THEN
	   OUTDAT(1) = QDSZX
	   OUTDAT(2) = QDSZY
	   TOTAL = 2
C
	ELSE IF (CAPA.EQ.13) THEN
	   OUTDAT(1) = QDDEP
C
	ELSE IF (CAPA.EQ.14) THEN
	   OUTDAT(1) = 8
C
	ELSE IF (CAPA.EQ.15) THEN
	   OUTDAT(1) = 4
C
	ELSE IF (CAPA.EQ.16) THEN
	   OUTDAT(1) = 4
C
	ELSE IF (CAPA.EQ.17) THEN
	   OUTDAT(1) = 1
	   OUTDAT(2) = 8
	   TOTAL = 2
C	
	ELSE
	   GOTO 11011
	ENDIF
C	
	RETURN
C	
C  capability in [20,29]
2000	RETURN
C	
C  capability in [30,39]
3000	RETURN
C	
C  capability in [40,49]
4000	IF (CAPA.EQ.40) THEN
	   OUTDAT(1) = 2
	ENDIF
C	
	RETURN
C	
C  capability in [50,59]
5000	RETURN
C	
C  capability in [60,69]
6000	RETURN
C	
C  capability in [70,79]
7000	RETURN
C	
C  capability in [80,89]
8000	RETURN
C	
C  capability in [90,99]
9000	RETURN
C	
C  capability in [100,109]
10000	RETURN
C 	
C
11011	IDST = 90
	RETURN
	END

	SUBROUTINE GD8048(DISPLAY,MEMIDS,XOFFS,YOFFS,SPLIT_FLAG,
     +                    SPLX,SPLY,IDST)
C	
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine IIDSSS		version 1.00	880628
C  K. Banse                  	ESO - Garching
C
C.KEYWORDS
C  ImageDisplay, split screen
C
C.PURPOSE
C  fulfill the requirements as described in the IDI document
C
C.ALGORITHM
C  use DeAnza level 0 + 1 software
C
C.INPUT/OUTPUT
C  call as  IIDSSS(DISPLAY,MEMIDS,XOFFS,YOFFS,SPLIT_FLAG,SPLX,SPLY,IDST)
C
C  input par:
C  DISPLAY:	I*4		display id.
C  MEMIDS:	I*4 array	memory ids, 4 channels if split_flag = 0
C				            2 channels if = 1 or 2 
C					    1 channel if = -1
C  SPLIT_FLAG:	I*4		split flag:-1 = clear split screen mode
C					    0 = full split, 0,1,2,3
C					    1 = 1,0 or 2,3
C					    2 = 1,2 or 0,3
C  XOFFS:	I*4 array	x-offsets of memory
C  YOFFS:	I*4 array	y-offsets of memory
C  SPLX:	I*4 		x split address
C  SPLY:	I*4 		y split address
C	
C  output par:
C  IDST:	I*4		return status
C	
C.VERSIONS
C--------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*4	DISPLAY,MEMIDS(1),SPLIT_FLAG,XOFFS(1),YOFFS(1)
	INTEGER*4	SPLX,SPLY,IDST
	INTEGER*4	MMIDS(4),CHAN,N,M,IOFF,LIMIT
C	
	INTEGER*2	UNIT,FCREG,FCLEFT,FCRIGHT
	INTEGER*2	XSPLIT,YSPLIT,SCR
	INTEGER*2	RVR,LVR,LMC
C 
	CHARACTER*20	FRAME
C 
	REAL*4		RINF(6)
C
	INCLUDE	'MID_INCLUDE:IDIDEV.INC'
	INCLUDE	'MID_INCLUDE:IDIMEM.INC'
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
C	
	EXTERNAL	RVR,LVR,LMC
C	
C  check, if we want to clear split screen mode
	CALL IP8QW(RVR,UNIT,DZIOSB,,,FCR,16,0,8)
	XSPLIT = SPLX
	YSPLIT = SPLY
	IF (SPLIT_FLAG.LT.0) GOTO 5000			!do that elsewhere...
C 
C *****
C	
C  here for "real" split screen" business
C	
C *****
C	
	MMIDS(1) = MEMIDS(2)
	MMIDS(2) = MEMIDS(1)
C	
C  set scroll values for all memory channels involved
	IF (SPLIT_FLAG.EQ.0) THEN
	   LIMIT = 4
	   MMIDS(3) = MEMIDS(3)
	   MMIDS(4) = MEMIDS(4)
	ELSE
	   LIMIT = 2
	ENDIF
C 
	DO M=1,LIMIT
	   CHAN = MMIDS(M)
	   CALL GETICH(QDSPNO,CHAN,FRAME,RINF,IDST)
	   N = CHAN + 1
	   MEMREG(1,N) = IAND(MEMREG(1,N),"176000)		!clear SCROLX
	   SCR = IAND(SCROLX,"001777)
	   MEMREG(1,N) = IOR(MEMREG(1,N),SCR)
	   MEMREG(2,N) = IAND(MEMREG(2,N),"176000)		!clear SCROLY
	   SCR = IAND(SCROLY,"001777)
	   MEMREG(2,N) = IOR(MEMREG(2,N),SCR)
	   CALL IP8QW(LMC,UNIT,DZIOSB,,,MEMREG(1,N),4,CHAN,0)
	ENDDO
C	
C  now set up split screen (depends on mode)
	IF (QRGBFL.EQ.1) THEN				!LUT = NULL.LUT !!
	   FCR(1) = "000020			!0 R, 1 R	0 = use LUT
	   FCR(2) = "010401			!1 G, 0 G	1 = bypass LUT
	   FCR(3) = "001002			!0 B, 0 B
	   FCR(4) = "000000			!0 x, 0 x
	   FCR(5) = IAND(FCR(5),"177400)	!xxx, 0 R
	   FCREG = IAND(FCR(6),"177400)			!clear right byte
	   FCR(6) = IOR(FCREG,"1)		!xxx, 0 G
	   FCREG = IAND(FCR(7),"177400)			!clear right byte
	   FCR(7) = IOR(FCREG,"23)		!xxx, 1 B
	   FCREG = IAND(FCR(8),"177400)			!clear right byte
	   FCR(8) = IOR(FCREG,"20)		!xxx, 0 x
	ELSE
	   FCR(1) = IAND(FCR(1),"170160)	!
	   FCREG = IAND(FCR(2),"170160)		!clear out channels
	   FCR(2) = IOR(FCREG,"401)		!channel 1 -> segment 1, G + R
	   FCREG = IAND(FCR(3),"170160)		!clear out channels
	   FCR(3) = IOR(FCREG,"1002)		!channel 2 -> segment 2, G + R
	   FCREG = IAND(FCR(4),"170160)		!clear out channels
	   FCR(4) = IOR(FCREG,"1403)		!channel 3 -> segment 3, G + R
	   FCR(5) = IAND(FCR(5),"177600)	!channel 0 -> segment 0, B
	   FCREG = IAND(FCR(6),"177600)		!clear out right channel
	   FCR(6) = IOR(FCREG,"1)		!channel 1 -> segment 1, B
	   FCREG = IAND(FCR(7),"177600)		!clear out right channel
	   FCR(7) = IOR(FCREG,"2)		!channel 2 -> segment 2, B
	   FCREG = IAND(FCR(8),"177600)		!clear out right channel
	   FCR(8) = IOR(FCREG,"3)		!channel 3 -> segment 3, B
	ENDIF
C	
C  jump to common end
	GOTO 8000
C *****
C	
C  here for clear split screen business
C	
C *****
5000	MMIDS(1) = MEMIDS(1)
C	
C  loop through FCRs + reset scroll values for all memory channels involved
	DO M=1,8
	   FCLEFT = ISHFT(FCR(M),-8)		!get left byte
C	
	   CHAN = IAND(FCR(M),"17)		!pull out channel from right byte
	   CALL GETICH(QDSPNO,CHAN,FRAME,RINF,IDST)
	   N = CHAN + 1
	   MEMREG(1,N) = IAND(MEMREG(1,N),"176000)		!clear SCROLX
	   SCR = IAND(SCROLX,"001777)
	   MEMREG(1,N) = IOR(MEMREG(1,N),SCR)
	   MEMREG(2,N) = IAND(MEMREG(2,N),"176000)		!clear SCROLX
	   SCR = IAND(SCROLY,"001777)
	   MEMREG(2,N) = IOR(MEMREG(2,N),SCR)
	   CALL IP8QW(LMC,UNIT,DZIOSB,,,MEMREG(1,N),4,CHAN,0)
C	
	   IF (IAND(FCLEFT,"17).NE.CHAN) THEN
	      CHAN = IAND(FCLEFT,"17)		!pull out channel
   	      CALL GETICH(QDSPNO,CHAN,FRAME,RINF,IDST)
	      N = CHAN + 1
	      MEMREG(1,N) = IAND(MEMREG(1,N),"176000)		!clear SCROLX
	      SCR = IAND(SCROLX,"001777)
	      MEMREG(1,N) = IOR(MEMREG(1,N),SCR)
	      MEMREG(2,N) = IAND(MEMREG(2,N),"176000)		!clear SCROLY
	      SCR = IAND(SCROLY,"001777)
	      MEMREG(2,N) = IOR(MEMREG(2,N),SCR)
	      CALL IP8QW(LMC,UNIT,DZIOSB,,,MEMREG(1,N),4,CHAN,0)
	   ENDIF
	ENDDO
C	
C  now set up single display (depends on mode)
	IF (QRGBFL.EQ.1) THEN
	   DO M=1,4
	      FCR(M) = "010420				!channel 1, 0 (green, red)
	      FCREG = IAND(FCR(M+4),"177740)		!clear out BY bit + channel
	      FCR(M+4) = IOR(FCREG,"22)			!channel 2 (blue)
	   ENDDO
	ELSE
	   DO M=1,4
	      FCR(M) = MMIDS(1)			!channel MMIDS(1) everywhere...
	      FCR(M+4) = IAND(FCR(M+4),"177740)
	      FCR(M+4) = IOR(FCR(M+4),MMIDS(1))
	   ENDDO
	ENDIF
C *****
C	
C  common terminating section
C	
C *****
C	
C  rewrite FCRs
8000	CALL IP8QW(LVR,UNIT,DZIOSB,,,FCR,16,0,8)
C	
C  update split addresses
	VOCREG(1) = XSPLIT
	VOCREG(2) = YSPLIT
	CALL IP8QW(LVR,UNIT,DZIOSB,,,VOCREG(1),4,0,0)
C	
	IDST = 0
	RETURN
	END

	SUBROUTINE GD8005(ERNO,ERSTR,LSTR)
C	
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine IIDERR		version 1.00	880502
C  K. Banse                  	ESO - Garching
C
C.KEYWORDS
C  Error message
C
C.PURPOSE
C  fulfill the requirements as described in the IDI document
C
C.ALGORITHM
C
C.INPUT/OUTPUT
C  call as  IIDERR(ERNO,ERSTR,LSTR)
C
C  input par:
C  ERNO:	I*4		error no.
C
C  output par:
C  ERSTR:	char. string    error message
C  LSTR:	I*4		lenght of error message
C	
C--------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*4	ERNO,LSTR
	INTEGER*4	KSTR
C 
	CHARACTER*(*)	ERSTR
C 
	ERSTR = ' '
	LSTR = LEN(ERSTR)
	KSTR = LSTR
C 
C  error numbers are sorted according to originating routines
	IF (ERNO.GT.199) GOTO 200
C 
C  here for errors from the IIC... routines
	RETURN
C 
200	IF (ERNO.GT.299) GOTO 300
C 
C  here for errors from the IID... routines
	RETURN
C 
300	IF (ERNO.GT.399) GOTO 400
C 
C  here for errors from the IID... routines
	RETURN
C 
400	IF (ERNO.GT.499) GOTO 500
C 
C  here for errors from the III... routines
	IF (ERNO.EQ.401) THEN
	   ERSTR(1:) = 'Unsupported interactor type '
	   KSTR = 31
	ELSE IF (ERNO.EQ.402) THEN
	   ERSTR(1:) = 'Trigger no. out of range, should be in [0,9] '
	   KSTR = 45
	ELSE IF (ERNO.EQ.403) THEN
	   ERSTR(1:) = 'Unsupported object type '
	   KSTR = 28
	ELSE IF (ERNO.EQ.404) THEN
	   ERSTR(1:) = 'No description for given interactor '
	   KSTR = 40
	ELSE IF (ERNO.EQ.409) THEN
	   ERSTR(1:) = 'No interaction enabled '
	   KSTR = 27
	ENDIF
	GOTO 9000
C 
500	IF (ERNO.GT.599) GOTO 600
C 
C  here for errors from the IIG... routines
	RETURN
C 
600	IF (ERNO.GT.699) GOTO 700
C 
C  here for errors from the IIL... routines
	RETURN
C 
700	IF (ERNO.GT.799) GOTO 800
C 
C  here for errors from the IIM... routines
	RETURN
C 
800	IF (ERNO.GT.899) GOTO 900
C 
C  here for errors from the IIR... routines
	RETURN
C 
C  here for errors from the IIZ... routines
900	RETURN
C 
9000	IF (KSTR.LT.LSTR) LSTR = KSTR
	RETURN
C 
	END