C @(#)gd8aux.for	17.1.1.1 (ES0-DMD) 01/25/02 17:34:47
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 KKCTAB(SHAPE,COLOUR,CURSAR,IDST)
C	
C	      =  2   - use table CROSSA.CUR (or CROSSC.CUR)
C	      =  3   - use table CROSSB.CUR (or CROSSD.CUR)
C	      =  4   - use table SQUARE.CUR  [not implemented yet...]
C	      =  5   - use table DIAMOND.CUR [not implemented yet...]
C	      =  6   - use table CIRCLE.CUR
C	      =  7   - use table ARROW.CUR
C	      =  8   - use table SMALL.CUR  (small xhair)
C	      =  0   - use table stored in keyword IN_A
C
	IMPLICIT NONE
C	
	INTEGER*4	SHAPE,COLOUR,IDST
	INTEGER*4	OLDSHAPE
	INTEGER*4	NCOLS,NROWS,N
	INTEGER*4	TABCOLNUM,TID
	INTEGER*4	E_C,E_D,E_L,LTAB
	INTEGER*4	KUNIT(1),NULLO
C	
	INTEGER*2	CURSAR(1)
C	
	CHARACTER	TABLEFILE*60,FILE*80
	CHARACTER	TABUNIT*16,MYLABEL*16
C	
	INTEGER*4	TABNULL
C 
	INCLUDE 'MID_INCLUDE:ST_DEF.INC'
C 
	DATA	MYLABEL	  /'CURSOR '/
	DATA	OLDSHAPE  /-1/
C 
	INCLUDE 'MID_INCLUDE:ST_DAT.INC'
C
C
	IDST = 0
C 
C  check, if we already loaded that last time ...
	IF ( (OLDSHAPE.EQ.SHAPE) .AND. (COLOUR.NE.99) ) RETURN
	OLDSHAPE = SHAPE
C
	IF (SHAPE.EQ.3) THEN
	   TABLEFILE(1:) = 'crossb.cur '
	   IF (COLOUR.EQ.1) TABLEFILE(6:6) = 'd'
C
	ELSE IF (SHAPE.EQ.4) THEN
	   TABLEFILE(1:) = 'square.cur '
C
	ELSE IF (SHAPE.EQ.5) THEN
	   TABLEFILE(1:) = 'diamond.cur '
C
	ELSE IF (SHAPE.EQ.6) THEN
	   TABLEFILE(1:) = 'circle.cur '
C
	ELSE IF (SHAPE.EQ.7) THEN
	   TABLEFILE(1:) = 'arrow.cur '
C
	ELSE IF (SHAPE.EQ.8) THEN
	   TABLEFILE(1:) = 'small.cur '
C
	ELSE IF (SHAPE.EQ.0) THEN
	   CALL STKRDC('IN_A',1,1,60,N,TABLEFILE,KUNIT,NULLO,IDST)
	   N = INDEX(TABLEFILE,' ')
	   TABLEFILE(N:) = '.cur '
C
	ELSE 						!default is cross
	   TABLEFILE(1:) = 'crossa.cur '
	   IF (COLOUR.EQ.1) TABLEFILE(6:6) = 'c'
	ENDIF
C	
C  first look for system table, then for own table
	FILE(1:) = 'MID_SYSTAB:'//TABLEFILE
	CALL STECNT('GET',E_C,E_L,E_D)
	CALL STECNT('PUT',1,0,0)
	CALL TBTOPN(FILE,F_I_MODE,TID,IDST)
	CALL STECNT('PUT',E_C,E_L,E_D)
	IF (IDST.NE.0) THEN
	   IDST = 0
	   FILE = TABLEFILE
	   CALL TBTOPN(FILE,F_I_MODE,TID,IDST)
	ENDIF
	IF (IDST.NE.0) THEN
	   IDST = 2
	   RETURN
	ENDIF
C	
C  get info about table
	CALL TBIGET(TID,NCOLS,NROWS,N,N,N,IDST)
	CALL TBLSER(TID,MYLABEL,TABCOLNUM,IDST)
	IF (TABCOLNUM.LE.0) THEN		!incorrect columns...
	   IDST = 1
	   RETURN
	ENDIF
C	
C  now read cursor table
	DO N=1,1024
	   CALL TBRRDI(TID,N,1,TABCOLNUM,CURSAR(N),TABNULL,IDST)
	ENDDO
C
C  release table file properly
	CALL TBTCLO(TID,IDST)
C
	RETURN
	END

	SUBROUTINE TRKBAL(UNIT)
C
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine TRKBAL	version 1.00	861120
C  K. Banse		ESO - Garching
C
C.KEYWORDS
C  DeAnza unit, logical assignment
C
C.PURPOSE
C  init registers for use woth trackball
C
C.ALGORITHM
C  according to DeAnza manual
C
C.INPUT/OUTPUT
C  call as  TRKBAL(UNIT)
C
C  input par:
C  UNIT:	I*2		DeAnza unit no.
C				currently always 0
C
C--------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*2	UNIT,TBGO,TMASK,NUL(4)
	INTEGER*2	LPR
C
	EXTERNAL 	LPR
C
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
C
	DATA	TBGO	/'143'O/
	DATA	TMASK	/'103'O/
	DATA	NUL	/0,0,0,0/
C	
C  clear status reg. + X,Y position registers
	CALL IP8QW(LPR,UNIT,DZIOSB,,,NUL,8,0,0)	
C	
C  set tracking mode + GO flag (bit 5) in TKB control register (reg. 1)
	CALL IP8QW(LPR,UNIT,DZIOSB,,,TMASK,2,0,1)	!enable both cursors
	CALL IP8QW(LPR,UNIT,DZIOSB,,,TBGO,2,0,1)	!as above, but also set but 5 to 1
C	
	RETURN
	END

	SUBROUTINE BITS(IN,BIT)
C
C  the word array BIT(16) is set to 0 or 1
C  if the corresponding bit in word IN is set
C
	INTEGER*2	IN,BIT(16)
	INTEGER*2	MASK(16)
C
	DATA	MASK	/"1,"2,"4,"10,"20,"40,
     +                   "100,"200,"400,"1000,"2000,"4000,
     +                   "10000,"20000,"40000,"100000/
C
	DO N=1,16
	   IF (IAND(MASK(N),IN).NE.0) THEN
	      BIT(N) = 1
	   ELSE
	      BIT(N) = 0
	   ENDIF
	ENDDO
C
	RETURN
	END

	SUBROUTINE KKGRA(DISPLAY,CHAN,STRING,LSTR,XPOS,YPOS,PATH,
     +	                  ORIENT,INTENS,HT,IDST)
C
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine KKGRA		version 1.00	880513
C  K. Banse                  	ESO - Garching
C
C.KEYWORDS
C  DeAnza, overlay channel, alphabet
C
C.PURPOSE
C  support text plotting in the graphics memory
C
C.ALGORITHM
C  characters are built in a 7*8 matrix (x:0-6, y:0-7)
C  use IIGPLY to plot the stuff in the overlay plane
C
C.INPUT/OUTPUT
C call as  KKGRA(DISPLAY,CHAN,STRING,LSTR,XPOS,YPOS,PATH,ORIENT,INTENS,HT,IDST)
C
C  input par:
C  DISPLAY:	I*4		unit no.
C  CHAN:	I*4		memory id
C  STRING:	char. expr.	character string to be displayed
C  LSTR:	I*4		length of above
C  XPOS:	I*4 		x-position
C  YPOS:	I*4 		y-position
C  PATH:	I*4		text path:
C  INTENS:	I*4		intensity
C  HT:		I*4		text height, currently not supported
C				characters are built in a 7*8 matrix
C                               or fixed in the alphanumerics memory
C	
C  output par:
C  IDST:	I*4		return status
C
C--------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*4	DISPLAY,CHAN,LSTR,ORIENT
	INTEGER*4	INTENS,XPOS,YPOS,PATH,HT,IDST
	INTEGER*4 	N,NN,NNN,MM
	INTEGER*4	FCHARX(14),FCHARY(14)
	INTEGER*4	XXPOS,YYPOS,IX,IY
C	
	CHARACTER*(*)	STRING
C	
	REAL*4		ANGLE,CA,SA
C	
	INCLUDE 'MID_INCLUDE:DAZFONT.INC'
C
C	
	XXPOS = XPOS				!save start coords.
	YYPOS = YPOS
C	
C  currently text path is always taken as = 0, (runs from left to right)
C	
C  compare each character with our alphabet
	IF (ORIENT.EQ.0) THEN
	   DO N=1,LSTR
	      DO NN=1,LALP
	         IF (STRING(N:N).EQ.ALPHA(NN:NN)) THEN
	            IF (NN.GT.45) THEN
		       MM = NN - 45		!take care of lowercase chars.
	            ELSE
		       MM = NN
		    ENDIF
C
	            DO NNN=1,ALPLEN(MM)
		       FCHARX(NNN) = ALPFIG(1,NNN,MM) + XXPOS
		       FCHARY(NNN) = ALPFIG(2,NNN,MM) + YYPOS
		    ENDDO
		    CALL GD8021(DISPLAY,CHAN,FCHARX,FCHARY,
     +                          ALPLEN(MM),INTENS,1,IDST)
	         ENDIF
	      ENDDO
	      XXPOS = XXPOS + 9 			!move along the line ...
	   ENDDO	
C	
C  here with an angle
C
	ELSE
	   ANGLE = ORIENT
	   CA = COSD(ANGLE)
	   SA = SIND(ANGLE)
C	
C  compare each character with our alphabet
	   DO N=1,LSTR
	      DO NN=1,LALP
	         IF (STRING(N:N).EQ.ALPHA(NN:NN)) THEN
		    IF (NN.GT.45) THEN
		       MM = NN - 45			!take care of lowercase
		    ELSE
		       MM = NN
		    ENDIF
	            DO NNN=1,ALPLEN(MM)
		       IX = ALPFIG(1,NNN,MM) + XXPOS - XPOS
		       IY = ALPFIG(2,NNN,MM) + YYPOS - YPOS
		       CALL ROTA(CA,SA,IX,IY,IX,IY)
		       FCHARX(NNN) = IX + XPOS
		       FCHARY(NNN) = IY + YPOS
		    ENDDO
		    CALL GD8021(DISPLAY,CHAN,FCHARX,FCHARY,
     +                          ALPLEN(MM),INTENS,1,IDST)
	         ENDIF
	      ENDDO
	      XXPOS = XXPOS + 9 			!move along the line ...
 	   ENDDO	
	ENDIF
C	
C  that's it folks
	IDST = 0
	RETURN
	END

	SUBROUTINE KKALP(DISPLAY,STRING,LSTR,COL,LINE,MODE,IDST)
C	
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine KKALP		version 1.00	880120
C  K. Banse                  	ESO - Garching
C
C.KEYWORDS
C  DeAnza, alphanumerics board
C
C.PURPOSE
C  support IIGTXT for alphanumerics memory
C
C.ALGORITHM
C  use DeAnza level 0 software
C
C.INPUT/OUTPUT
C  call as  KKALP(DISPLAY,STRING,LSTR,COL,LINE,MODE,IDST)
C
C  input par:
C  DISPLAY:	I*4		display id.
C  STRING:	char.exp.	string to be displayed
C  LSTR:	I*4		length of STRING
C  COL:		I*4		column number (0 - 79)
C  LINE:	I*4		line number (0 - 24)
C  MODE:	I*4		mode: 0,1,2,3 for white, yellow, etc.
C
C  output par:
C  IDST:	I*4		return status
C	
C.VERSIONS
C--------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*4	DISPLAY,LSTR,COL,LINE,MODE,IDST
	INTEGER*4	N,NN,MM
C	
	INTEGER*2	UNIT,BYTSTR(80),MODBITS,RES
	INTEGER*2	LAR,LPA,RR,LR
C
	CHARACTER*(*)	STRING
	CHARACTER	ALPHA*89
C	
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
C	
	EXTERNAL	LAR,LPA,RR,LR
C	
	DATA	ALPHA(1:26)	/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
	DATA	ALPHA(27:57)	
     +		           /'[\]^_ !"#$%& ()*+,-./0123456789'/
	DATA	ALPHA(58:63)	/':;<=>?'/
	DATA	ALPHA(64:89)	/'abcdefghijklmnopqrstuvwxyz'/
C	
	UNIT = DISPLAY
	ALPHA(39:39) = ''''
	IDST = 0
C	
C  make sure we work on low resolution
	CALL IP8QW(RR,UNIT,DZIOSB,,,SYSREG(12),2,0,11)		!reg. 11
	RES = IAND(SYSREG(12),"177677)			!force to low byte xfer
	RES = IOR(RES,"100)				!force to low byte xfer
	CALL IP8QW(LR,UNIT,DZIOSB,,,RES,2,0,11)	
C	
C  load address register (reg. 0) of alphanumerics board
	N = (80 * LINE) + COL			!a line has 80 chars.
	CALL IP8QW(LAR,UNIT,DZIOSB,,,N,2,0,0)	!CAP = 0 for A/N board
C	
C  shift MODE already into correct bit position
	MODBITS = ISHFT(MODE,6)
C	
C  translate character string to A/N bytes
	IF (LSTR.LT.1) RETURN
C
	DO N=1,LSTR
	   BYTSTR(N) = 0
C 
	   DO NN=1,89
	      IF (STRING(N:N).EQ.ALPHA(NN:NN)) THEN
		 IF (NN.GT.63) THEN
		    MM = NN - 63
		 ELSE
		    MM = NN
		 ENDIF
     		 BYTSTR(N) = IOR(MM,MODBITS)
	      ENDIF
	   ENDDO
	ENDDO
C	
C  send bytes to A/N board
	CALL IP8QW(LPA,UNIT,DZIOSB,,,BYTSTR,2*LSTR,0,2)	!A/N is group 2
C	
C  reset resolution in reg. 11
	CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(12),2,0,11)		!reg. 11
C	
	RETURN
	END

	SUBROUTINE JOYPSH(UNIT,PUSH,ISS)
C	
C++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine JOYPSH		version 1.00	861121
C  	      TRKPSH			1.00	861121
C  					1.10	870513
C  K. Banse                  	ESO - Garching
C
C.KEYWORDS
C  DeAnza, joystick, trackball
C
C.PURPOSE
C  get status of joystick/trackball + cursor status
C
C.ALGORITHM
C  use DeAnza level-0 software
C
C.INPUT/OUTPUT
C  call as  JOYPSH(UNIT,PUSH,ISS)
C	    TRKPSH(UNIT,PUSH,ISS)
C
C  input par:
C  UNIT:	I*2		DeAnza unit
C
C  output par:
C  PUSH:	I*4		= 1 for ENTER button pushed
C				= 0 else
C
C  in/output par:
C  ISS:		I*4		cursor bit mask on input
C				cursor status: .NOT. 0   or   0
C	
C.VERSIONS
C  1.10		clear ENTER bit after the ENTER button has been pushed
C		and EVSTAT returned properly
c		for both JOYPSH + TRKPSH
C	
C--------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*2	UNIT,ENTER,CONTROL
	INTEGER*2	RPR,LPR
C	
	INTEGER*4	PUSH,ISS
C
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
C	
	EXTERNAL	RPR,LPR
C	
	DATA	ENTER	/"004000/
C	
C  read peripheral register
	CALL IP8QW(RPR,UNIT,DZIOSB,,,CONTROL,2,0,1)
C	
C  'AND' input mask with register
	ISS = IAND(CONTROL,ISS)		
C	
C  test, if something came in
     	IF (IAND(CONTROL,ENTER).NE.0) THEN
	   PUSH = 1
	   CALL IP8QW(LPR,UNIT,DZIOSB,,,1,2,0,1)	!clear control reg.
	ELSE
	   PUSH = 0
	ENDIF
C	
	RETURN
	END

	SUBROUTINE TRKPSH(UNIT,PUSH,ISS)
C	
	IMPLICIT NONE
C	
	INTEGER*2 	UNIT
	INTEGER*2	IPR,EPUSH,EOFF,ETRACK,TMODE
	INTEGER*2	RPR,LPR
C	
	INTEGER*4	PUSH,ISS,ISC1,ISC2
C
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
C
	EXTERNAL 	RPR,LPR
C
	DATA	EPUSH	/'0001'O/		!mask for ENTER button
	DATA	EOFF	/'7776'O/		!mask for complement of ENTER
	DATA	ETRACK	/'0010'O/		!mask for TRACK/ON switch
C
C  look at the TKB status register (reg. 0)
	CALL IP8QW(RPR,UNIT,DZIOSB,,,IPR,2,0,0)	!read peripheral register 0
C	
C  always extract cursor states
	IF (IAND('40'O,IPR).NE.0) THEN
	   ISC1 = 1					!bit B6 = cursor 1 on/off
	ELSE
	   ISC1 = 0
	ENDIF
	IF (IAND('20'O,IPR).NE.0) THEN			!bit B5 = cursor 2 on/off
	   ISC2 = 1
	ELSE
	   ISC2 = 0
	ENDIF
C	
C  if a cursor has been turned on/off, en/disable cursor tracking
	TMODE = ISC1 + 2*ISC2	
	CALL IP8QW(LPR,UNIT,DZIOSB,,,TMODE,2,0,1)	
	TMODE = TMODE + '40'O				!add the GO bit
	CALL IP8QW(LPR,UNIT,DZIOSB,,,TMODE,2,0,1)	
C	
C  check for push button or TRACK on
	IF ( (IAND(ETRACK,IPR).NE.0) .OR.
     +	     (IAND(EPUSH,IPR).NE.0) ) THEN
	   PUSH = 1
	   IPR = IAND(IPR,EOFF)				!clear the ENTER bit
	   CALL IP8QW(LPR,UNIT,DZIOSB,,,IPR,2,0,0)	!and rewrite the control reg.
	ELSE
	   PUSH = 0
	ENDIF
C	
C  set up return value for ISS
	IF (ISS.EQ.0) THEN
	   ISS = ISC1
	ELSE IF (ISS.EQ.1) THEN
	   ISS = ISC2
	ELSE
	   ISS = ISC1 + ISC2
	ENDIF
C
	RETURN
	END

	SUBROUTINE TRKRD(UNIT,IX,IY)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine TRKRD		version 1.00	861121
C  K. Banse			ESO - Garching
C
C.KEYWORDS
C  DeAnza, trackball
C
C.PURPOSE
C  to read the trackball displacements
C
C.ALGORITHM
C  use the level-0 DeAnza routines
C
C.INPUT/OUTPUT
C
C  call as  TRKRD(UNIT,IX,IY)
C	
C  input par:
C  UNIT	:	I*2		DeAnza unit no.
C	
C  output par:
C  IX	:	I*4		X trackball displacement in [-128,+127]
C  IY	:	I*4		Y joystick trackball displacement in [-128,+127]
C
C----------------------------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*2	UNIT,TPOS(2),TMODE
	INTEGER*2 	IJR
	INTEGER*2	LPR,RPR
C	
	INTEGER*4	IX,IY
	INTEGER*4	IC1,IC2
C
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
C	
	EXTERNAL 	LPR,RPR
C
C  poll TKB status register (reg. 0)
	CALL IP8QW(RPR,UNIT,DZIOSB,,,IJR,2,0,0)		!read reg 0
C	
C  always extract cursor states
	IF (IAND('40'O,IJR).NE.0) THEN
	   IC1 = 1				!bit B6 = cursor 1 on/off
	ELSE
	   IC1 = 0
	ENDIF
	IF (IAND('20'O,IJR).NE.0) THEN			!bit B5 = cursor 2 on/off
	   IC2 = 1
	ELSE
	   IC2 = 0
	ENDIF
C	
C  if a cursor has been turned on/off, en/disable cursor tracking
	TMODE = IC1 + 2*IC2	
	CALL IP8QW(LPR,UNIT,DZIOSB,,,TMODE,2,0,1)	
	TMODE = TMODE + '40'O				!add the GO bit
	CALL IP8QW(LPR,UNIT,DZIOSB,,,TMODE,2,0,1)	
C	
C  get X,Y positions
	CALL IP8QW(RPR,UNIT,DZIOSB,,,TPOS,4,0,2)
C	
C  take care of decrements...
	IF (IAND('4000'O,TPOS(1)).NE.0)
     +	   TPOS(1) = IOR(TPOS(1),'170000'O)
	IF (IAND('4000'O,TPOS(2)).NE.0)
     +	   TPOS(2) = IOR(TPOS(2),'170000'O)
C	
C  multiply by factor of 3 since trackball is so slow
	TPOS(1) = 3 * TPOS(1)
	TPOS(2) = 3 * TPOS(2)
C	
	IF (TPOS(1).LT.-128) THEN			!force into [-128,127]
	   IX = -128
	ELSE IF (TPOS(1).GT.127) THEN
	   IX = 127
	ELSE
	   IX = TPOS(1)
	ENDIF
	IF (TPOS(2).LT.-128) THEN
	   IY = -128
	ELSE IF (TPOS(2).GT.127) THEN
	   IY = 127
	ELSE
	   IY = TPOS(2)
	ENDIF
C	
C  and clear position registers again
	TPOS(1) = 0
	TPOS(2) = 0
	CALL IP8QW(LPR,UNIT,DZIOSB,,,TPOS,4,0,2)
C	
	RETURN
	END

	SUBROUTINE KKOWLT(UNIT,ISTA,COUNT,ROVT,IDST)
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine KKOWLT		version 1.00	880120
C  K. Banse			ESO - Garching
C
C.KEYWORDS
C  DeAnza display , overlay table
C
C.PURPOSE
C  to load an overlay into the DeAnza,
C
C.ALGORITHM
C  use DeAnza level 0 software
C
C.INPUT/OUTPUT
C  call as  KKOWLT(UNIT,ISTA,COUNT,ROVT,IDST)
C
C  input par:
C  UNIT:	I*2		unit no.
C  COUNT:	I*4		no. of entries in table to send/read
C	
C  input/output par:
C  ROVT:	R*4 array	OVT table
C  IDST:	I*4		return status
C
C-----------------------------------------------------
C
	IMPLICIT NONE
C	
	INTEGER*4	ISTA,COUNT,IDST
	INTEGER*4	N
C	
	REAL*4		ROVT(1)
C	
	INTEGER*2 	UNIT,RESREG,OVT(1024)
	INTEGER*2	RR,LR,LWA,LVR
C
	INCLUDE	'MID_INCLUDE:DEANZAH.INC'
	INCLUDE	'MID_INCLUDE:DEANZAS.INC'
C	
	EXTERNAL	RR,LR,LWA,LVR
C	
C  set resolution register for low byte transfer
	CALL IP8QW(RR,UNIT,DZIOSB,,,SYSREG(12),2,0,11)
	RESREG = IOR(SYSREG(12),"100)
	CALL IP8QW(LR,UNIT,DZIOSB,,,RESREG,2,0,11)
C	
C  set OVT LUT section (always = 0...) in LUT address register
	VOCREG(4) = 0			!shift 9 bits left..
	CALL IP8QW(LVR,UNIT,DZIOSB,,,VOCREG(4),2,0,3)	
C
C  convert real OVT table to I*2 and send it to the DeAnza
C	
	DO N=1,COUNT
	   OVT(N) = NINT(ROVT(N)*255.)
	ENDDO
C	
	CALL IP8QW(LWA,UNIT,DZIOSB,,,OVT,COUNT*2,0,1)
C
C  reset the resolution register
	CALL IP8QW(LR,UNIT,DZIOSB,,,SYSREG(12),2,0,11)
C
	RETURN
	END