C @(#)gd8m1.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 GD8018(DISPLAY,CHAN,NOCHAN,VALUE,IDST)
C	
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine IIMCMY		version 1.00	880122
C  K. Banse                  	ESO - Garching
C
C.KEYWORDS
C  DeAnza, memory
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  IIMCMY(DISPLAY,CHAN,NOCHAN,VALUE,IDST)
C
C  input par:
C  DISPLAY:	I*4		display id.
C  CHAN:	I*4 array	memory ids
C  NOCHAN:	I*4		no. of memory ids
C  VALUE:	I*4		constant
C
C  output par:
C  IDST:	I*4		return status
C	
C.VERSIONS
C
C--------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*4	DISPLAY,CHAN(1),NOCHAN,VALUE,IDST
	INTEGER*4	N,NN
C	
	INTEGER*2	UNIT,BYTSTR(40),RES
	INTEGER*2	LAR,LPA,RR,LR,WR,LMC
C
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
	INCLUDE	'MID_INCLUDE:IDIDEV.INC'
	INCLUDE	'MID_INCLUDE:IDIMEM.INC'
C	
	DATA	BYTSTR	/40*0/
C	
	EXTERNAL	LAR,LPA,RR,LR,WR,LMC
C
	UNIT = DISPLAY
C
C  loop through memories
	DO NN=1,NOCHAN
	   N = CHAN(NN) + 1
C
C  if alpha memory treat it differently
	   IF (N.GT.90) THEN
C	
C  make sure we work on high resolution
	      CALL IP8QW(RR,UNIT,DZIOSB,,,SYSREG(12),2,0,11)		!reg. 11
	      RES = IAND(SYSREG(12),"177677)		!force to full byte xfer
	      CALL IP8QW(LR,UNIT,DZIOSB,,,RES,2,0,11)	
C	
C  load address register (reg. 0) of alphanumerics board with addr. 0
	      CALL IP8QW(LAR,UNIT,DZIOSB,,,0,2,0,0)	!CAP = 0 for A/N board
C	
C  send 25 times 80 bytes to A/N board
	      DO N=1,25
	         CALL IP8QW(LPA,UNIT,DZIOSB,,,BYTSTR,80,0,2)	!A/N is group 2
	      ENDDO
C	
C  reset resolution in reg. 11
	      CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(12),2,0,11)		!reg. 11
	   ELSE	
C	
C  set up memory registers
	      MEMREG(1,N) = 0
	      MEMREG(2,N) = QDSZY - 1
	      MEMREG(3,N) = -1				!default for register 2
	      MEMREG(4,N) = IAND(MEMREG(4,N),"175777)	!clear G bit (10)
	      IF (CHAN(NN).EQ.QOVCH)			!if graphics channel...
     +		 MEMREG(4,N) = IOR(MEMREG(4,N),"2000)	!set G bit again
	      MEM7RG(N) = 0				!default for register 7
C	
	      CALL IP8QW(LMC,UNIT,DZIOSB,,,MEMREG(1,N),8,CHAN,0)
C 	
C  get system registers 10 - 31, and 32,33 = CMR0
	      CALL IP8QW(RR,UNIT,DZIOSB,,,SYSREG(11),48,1,10)
C	
C  set up CMR0 for memory channel CHAN(NN)
	      SYSREG(33) = 2**CHAN(NN)
	      SYSREG(34) = 0			!34+33 = CMR0 (CHAN always < 15)
C	
C  set the X registers
	      SYSREG(17) = 0				!X = start value	(16)
	      SYSREG(18) = 0				!XT = 0		(17)
	      SYSREG(19) = SYSREG(17)			!XMIN = X	(18)
	      SYSREG(20) = QMSZX - 1			!XMAX = last value (19)
	      SYSREG(21) = 0				!XAMIN = 0	(20)
	      SYSREG(22) = SYSREG(20)			!XAMAX = XMAX
	      SYSREG(23) = SYSREG(20)			!DX = XAMAX	(22)
	      SYSREG(24) = 0				!XTEMP = 0	(23)
C
C  set the Y registers
	      SYSREG(25) = 0				!Y = start value	(24)
	      SYSREG(26) = 0				!YT = 0		(25)
	      SYSREG(27) = SYSREG(25)			!YMIN = Y	(26)
	      SYSREG(28) = QMSZY - 1			!YMAX = last value (27)
	      SYSREG(29) = 0				!YAMIN = 0	(28)
	      SYSREG(30) = SYSREG(28)			!YAMAX = YMAX
	      SYSREG(31) = SYSREG(28)			!DY = YAMAX	(30)
	      SYSREG(32) = 0				!YTEMP = 0	(31)
C	
C  set up matrix mode, x-primary, y-secondary, positive increments
	      SYSREG(11) = "10			!CONTROL	(10)
C	
C  set resolution to single byte transfer
	      SYSREG(12) = IAND(SYSREG(12),"177477)	!RESOLUTION	(11)
	      SYSREG(12) = IOR(SYSREG(12),"100)
C	
C  fill foreground register with value
	      SYSREG(13) = VALUE			!FG		(12)
C	
C  write system registers back
	      CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(11),48,1,10)
C	
C  finally issue the "write rectangle command"
	      CALL IP8QW(WR,UNIT,DZIOSB,,,N,2,0,1)		!N is dummy value...
C	
C  reset to non matrix mode
	      SYSREG(11) = 0			!CONTROL	(10)
	      CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(11),2,0,10)
	   ENDIF
C
	ENDDO
C	
	IDST = 0
	RETURN
	END

	SUBROUTINE GD8020(DISPLAY,CHAN,LOADFL,SZX,SZY,DEPTH,
     +		          XBEG,YBEG,IDST)
C	
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine IIMSTW		version 1.00	880616
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  IIMSTW(DISPLAY,CHAN,LOADFL,SZX,SZY,DEPTH,XBEG,YBEG,IDST)
C
C  input par:
C  DISPLAY:	I*4		display id.
C  CHAN:	I*4		memory id
C  LOADFL:	I*4		load direction: 0 = bottom-up, 1 = top-down
C  SZX:		I*4		size in x
C  SZY:		I*4		size in y
C  DEPTH:	I*4		depth in bits per pixel
C  XBEG:	I*4		x offset
C  YBEG:	I*4		y offset
C
C  output par:
C  IDST:	I*4		return status
C	
C.VERSIONS
C
C--------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*4	DISPLAY,CHAN,SZX,SZY,LOADFL,DEPTH,IDST,XBEG,YBEG
	INTEGER*4	N,NN
C	
	INTEGER*2	UNIT,FCREG,POWCHAN(10)
	INTEGER*2	LMC,LR,LVR,RR,RVR
C
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
	INCLUDE	'MID_INCLUDE:IDIDEV.INC/NOLIST'
	INCLUDE	'MID_INCLUDE:IDIMEM.INC/NOLIST'
C	
	EXTERNAL	LMC,LR,LVR,RR,RVR
C	
	DATA	POWCHAN	/1,2,4,8,16,32,64,128,256,512/
C
C	
	UNIT = DISPLAY
	N = CHAN + 1
C	
C  read + modify relevant system registers
	CALL IP8QW(RR,UNIT,DZIOSB,,,SYSREG(12),42,1,11)
C	
C  set to non-matrix mode and take care of load direction (in register 10)
	IF (LOADFL.EQ.0) THEN
	   SYSREG(11) = 0			!bottom-up
	ELSE
	   SYSREG(11) = 2			!top-down
	ENDIF
C
C  set RESOLUTION register (reg 11):
C  always 2 bytes xfer
C	
	SYSREG(12) = IAND(SYSREG(12),"177677)
C
C  set the X registers
	SYSREG(17) = XBEG			!X = start value	(16)
	SYSREG(18) = 0				!XT = 0		(17)
	SYSREG(19) = SYSREG(17)			!XMIN = X	(18)
	SYSREG(20) = SYSREG(17) + SZX -1	!XMAX = last value (19)
	SYSREG(21) = 0				!XAMIN = 0	(20)
	SYSREG(22) = QMSZX - 1			!XAMAX = 511,1023, ... (21)
	SYSREG(23) = 0				!DX = 0		(22)
	SYSREG(24) = 0				!XTEMP = 0	(23)
C
C  set the Y registers
	SYSREG(25) = YBEG			!Y = start value	(24)
	SYSREG(26) = 0				!YT = 0		(25)
	SYSREG(27) = SYSREG(25)			!YMIN = Y	(26)
	SYSREG(28) = SYSREG(25) + SZY -1	!YMAX = last value (27)
	SYSREG(29) = 0				!YAMIN = 0	(28)
	SYSREG(30) = QMSZY - 1			!YAMAX = 511,1023,... (29)
	SYSREG(31) = 0				!DY = 0		(30)
	SYSREG(32) = 0				!YTEMP = 0	(31)
C	
C  and write it all out
	CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(11),44,1,10)
C	
C  set up CMR 0 + 1
C	
	SYSREG(33) = POWCHAN(N)
	SYSREG(34) = 0			!34+33 = CMR0 (CHAN always < 15)
	IF (DEPTH.EQ.16) THEN
	   SYSREG(35) = POWCHAN(N+1)
	ELSE
	   SYSREG(35) = 0
	ENDIF
	SYSREG(36) = 0			!36+35 = CMR1 (CHAN always < 15)
	CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(33),8,1,32)
C
C  for graphics channel we also have to update the FCRs
	IF (CHAN.EQ.QOVCH) THEN
	   CALL IP8QW(RVR,UNIT,DZIOSB,,,FCR(5),8,0,12)
	   FCREG = ISHFT(CHAN,8)		!put channel into left byte of FCREG
	   DO N=5,8
	      FCR(N) = IAND(FCR(N),"377)	!clear left byte of FCRs
	      FCR(N) = IOR(FCR(N),FCREG)	!and replace by FCREG
	   ENDDO
C	
	   CALL IP8QW(LVR,UNIT,DZIOSB,,,FCR(5),8,0,12)
	ENDIF
C	
C  alright then...
	IDST = 0
	RETURN
	END

	SUBROUTINE GD8017(DISPLAY,CHAN,PIX,SIZE,DEPTH,PACK,XBEG,YBEG,IDST)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION:
C  subroutine IIMWMY		version 1.00	880118
C  K. Banse			ESO - Garching
C
C.KEYWORDS:
C  memory, DeAnza
C
C.PURPOSE:
C  write a 2-dimensional image into given memory board of DeAnza
C  handle the functions as described in the IDI document
C
C.ALGORITHM:
C  wait for unit to be ready
C  send the data (either low byte or both are transferred)
C	
C.INPUT/OUTPUT:
C  call as IIMWMY(DISPLAY,CHAN,PIX,SIZE,DEPTH,PACK,XBEG,YBEG,IDST)
C
C  input par:
C  DISPLAY:	I*4		unit no.
C  CHAN:	I*4 array	memory board(s) to store image in
C  PIX:		I*4 array	array containing the pixels
C  SIZE:	I*4		no. of pixels
C  DEPTH:	I*4		depth of pixel
C  PACK:	I*4		packing factor:
C				1, 2 or 4 pixels per integer (32 bits)
C  XBEG:	I*4		data position in x
C  YBEG:	I*4		data position in y
C	
C  Note:	the XBEG, YBEG values are ignored, for the data positions
C		in x and y are initialized once and automatically upgraded
C		by subsequent writes ...
C
C  output par:
C  IDST:	I*4		return status
C
C------------------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*4 	DISPLAY,CHAN,SIZE,DEPTH,PACK
	INTEGER*4	XBEG,YBEG,PIX(1),IDST
	INTEGER*4	NN
C
	INTEGER*2	UNIT,NO_BYTES
	INTEGER*2	WI
C
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
	INCLUDE	'MID_INCLUDE:IDIDEV.INC/NOLIST'
	INCLUDE	'MID_INCLUDE:IDIMEM.INC/NOLIST'
C	
	EXTERNAL 	WI
C
C  set total transfer rate
	UNIT = DISPLAY
	IF (DEPTH.EQ.8) THEN
	   NN = SIZE
	   NO_BYTES = 1
	ELSE
	   NN = SIZE * 2
	   NO_BYTES = 2
	ENDIF
C
C  send everything to the DeAnza in one go
	CALL IP8W(UNIT)
	CALL IP8Q(WI,UNIT,DZIOSB,,,PIX,NN,NO_BYTES,1)		!don't wait for completion
C
C  we've done it again
	IDST = 0
	RETURN
	END

	SUBROUTINE GD8019(DISPLAY,CHAN,SIZE,XBEG,YBEG,DEPTH,
     +                    PACK,ITTFLG,PIX,IDST)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION:
C  subroutine IIMRMY		version 1.00	880118
C  K. Banse			ESO - Garching
C
C.KEYWORDS:
C  memory, DeAnza
C
C.PURPOSE:
C  read a 2-dimensional image from given memory board of DeAnza
C  handle the functions as described in the IDI document
C
C.ALGORITHM:
C  wait for unit to be ready
C  read the data (either low byte or both are transferred)
C	
C.INPUT/OUTPUT:
C  call as IIMRMY(DISPLAY,CHAN,SIZE,XBEG,YBEG,DEPTH,PACK,ITTFLG,PIX,IDST)
C
C  input par:
C  DISPLAY:	I*4		unit no.
C  CHAN:	I*4 array	memory board(s) to store image in
C  SIZE:	I*4		no. of pixels
C  DEPTH:	I*4		depth of pixel
C  XBEG:	I*4		data position in x
C  YBEG:	I*4		data position in y
C	
C  output par:
C  PIX:		I*4 array	array containing the pixels
C  IDST:	I*4		return status
C
C.VERSIONS
C
C------------------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*4 	DISPLAY,CHAN,SIZE,DEPTH,PACK,ITTFLG
	INTEGER*4	XBEG,YBEG,IDST
	INTEGER*4	NOCHUNKS,REMAINDER,NOFF,NITT,ILADR,N
C
	INTEGER*2	UNIT,NO_BYTES,SAVREG(8),ITT(256)
	INTEGER*2	RESREG,TEMP
	INTEGER*2	RI,LR,RR,LMC,RPA
C 
	BYTE		PIX(1),TPIX(2)
C 
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
	INCLUDE	'MID_INCLUDE:IDIDEV.INC'
	INCLUDE	'MID_INCLUDE:IDIMEM.INC'
C 
	EQUIVALENCE	(TEMP,TPIX(1))
C	
	EXTERNAL 	RI,LR,RR,LMC,RPA
C
	UNIT = DISPLAY
C	
C  check depth
	IF (DEPTH.NE.8) THEN
	   NO_BYTES = 2
	   IDST = 1			!currently only 8-bit pixels supported
	   RETURN
	ELSE
	   NO_BYTES = 1
	ENDIF
C 
C  if we only want to get 1 pixel we set up the transfer window here
C  otherwise a call to IIMSTW should have been done before... !!!
C 
	IF (SIZE.EQ.1) THEN
C 
C  set RESOLUTION register (reg 11) to 2 bytes transfer
	   CALL IP8QW(RR,UNIT,DZIOSB,,,SYSREG(12),42,1,11)
	   SYSREG(12) = IAND(SYSREG(12),"177677)	
	   CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(12),2,0,11)
C 
	   DO NOFF=1,4
	      SAVREG(NOFF) = SYSREG(16+NOFF)
	      SAVREG(4+NOFF) = SYSREG(24+NOFF)
	   ENDDO
C	
C  set up x-, y-registers
	   SYSREG(17) = XBEG
	   SYSREG(18) = 0
	   SYSREG(19) = XBEG
	   SYSREG(20) = XBEG
	   CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(17),8,1,16)
	   SYSREG(25) = YBEG
	   SYSREG(26) = 0
	   SYSREG(27) = YBEG
	   SYSREG(28) = YBEG 
	   CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(25),8,1,24)
C	
C  load CMR 0 + read the one value
	   SYSREG(33) = 2**CHAN
	   CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(33),2,1,32)
	   CALL IP8QW(RI,UNIT,DZIOSB,,,PIX(1),1,NO_BYTES,1)
C 
C  reset the system registers as they were
	   DO NOFF=1,4
	      SYSREG(16+NOFF) = SAVREG(NOFF) 
	      SYSREG(24+NOFF) = SAVREG(4+NOFF) 
	   ENDDO
	   CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(17),8,1,16)
	   CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(25),8,1,24)
	ELSE
C	
C  get no. of chunks of 32000 pixels
	   NOCHUNKS = SIZE / 32000
	   REMAINDER = SIZE - (NOCHUNKS*32000)
C
C  read everything from the DeAnza
	   NOFF = 1
	   DO WHILE (NOCHUNKS.GT.0)
	      CALL IP8QW(RI,UNIT,DZIOSB,,,PIX(NOFF),32000,NO_BYTES,1)
	      NOFF = NOFF + 32000			!PIX is declared as I*4 ...!
	      NOCHUNKS = NOCHUNKS - 1
	   ENDDO
C	
	   IF (REMAINDER.GT.0)
     +	      CALL IP8QW(RI,UNIT,DZIOSB,,,PIX(NOFF),REMAINDER,NO_BYTES,1)
	ENDIF
C 
C  now see, if we also have to do the ITT mapping
	IF (ITTFLG.EQ.0) GOTO 9000
C 
	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  build ITT address
	IF (ITTNUM.LE.3) THEN
	   NITT = ITTNUM
	ELSE
	   NITT = ITTNUM - 100
	ENDIF
	N = "10000				!set ITT enable bit
	ILADR = IOR(N,ISHFT(NITT,8))		!integrate also ITT section
	N = CHAN + 1
	MEMREG(4,N) = IAND(MEMREG(4,N),"176377)		!clear L9,L8 bit (9,8)
	MEMREG(4,N) = IOR(MEMREG(4,N),ILADR)
C
C  read the table from the DeAnza
	CALL IP8QW(LMC,UNIT,DZIOSB,,,MEMREG(4,N),2,CHAN,3)	!set LUT address reg.
	N = 256							!no. of elements
	CALL IP8QW(RPA,UNIT,DZIOSB,,,ITT,N*2,CHAN,0)
	DO N=1,256
	   ITT(N) = IAND(ITT(N),"377)
	ENDDO
C 
C  and reset the Resolution register
	CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(12),2,0,11)
C 
C  now map through the ITT
	DO N=1,SIZE
	   TEMP = 0
	   TPIX(1) = PIX(N)
	   TEMP = ITT(TEMP+1)
	   PIX(N) = TPIX(1)
	ENDDO
C	
C  we've done it again
9000	IDST = 0
	RETURN
	END