sics/tecs/tecs_tas.for

	SUBROUTINE TECS_TAS		! File TAS_SRC:[TECS]TECS_TAS.FOR
c	===================
c
cdec$	  ident	'V01B'
c------------------------------------------------------------------------------
c	    Interface to the TECS Client for TASMAD
c
c  M. Zolliker, March 2000
c Updates:
c  V01A 21-Mar-2000 DM.	  Integrate into TASMAD
c       05-Apr-2000 M.Z.  modifed error handling/changed arguments in TeccGet3
c------------------------------------------------------------------------------
c  Entry points in this Module:
c
c    TECS_TAS    - this is a dummy entry point to get module name in library
c 		    to match the file name.
c    TECS_INIT (ERRLUN)		      - initialising call.
c    TECS_GET_TEMP (ERRLUN, TEMP)     - read the temperature
c    TECS_SET_TEMP (ERRLUN, SET_TEMP) - set the temperature
c    TECS_SET_PAR (ERRLUN, NAME, PAR) - set parameter
c    TECS_GET_PAR (ERRLUN, NAME, PAR) - get parameter
c    TECS_SEND_CMD (ERRLUN, CMD, RESPONSE)    - send command to TC
c    TECS_OPEN (CONN, ERRLUN)	      - Open connection to TECS
c    TECS_ERR_ROUTINE (LUN, TEXT)     - report an error (for internal use only)
c------------------------------------------------------------------------------
	implicit    none

c			Define the dummy arguments

	integer	    ERRLUN       !! lun to write error messages
	real*4	    TEMP(4)      !! TASMAD temperature array: set-temp, regulation, sample, aux-temp
	real*4	    SET_TEMP     !! set temperature
	character   NAME*(*)     !! parameter name
	character   PAR*(*)      !! parameter
	character   CMD*(*)      !! command to send to temperature controller
	character   RESPONSE*(*) !! response from temperature controller
c------------------------------------------------------------------------------
	integer	    iret, l
	character startcmd*80
	common /tecs_init_com/startcmd
	integer*8   conn/0/
	save	    conn ! not needed for initialized variables

	integer  tecc_get3, tecc_set, tecc_set_par, tecc_get_par, tecc_send
	external tecc_get3, tecc_set, tecc_set_par, tecc_get_par, tecc_send
	integer	 tecc_quit_server, tecc_wait
	external tecc_quit_server, tecc_wait
c------------------------------------------------------------------------------
	stop 'TECS_TAS: do not call module header'

	entry TECS_INIT (ERRLUN, CMD)
!!	=============================

	if (conn .eq. 0) call tecs_open(conn, errlun)
	return

	entry TECS_GET_TEMP (ERRLUN, TEMP)
!!	==================================

	if (conn .eq. 0) then
	  call tecs_open(conn, errlun)
	  if (conn .eq. 0) return
	endif
1	iret=tecc_get3(conn, temp(1), temp(3), temp(2)) ! temp(2) and temp(3) are exchanged in MSHOWT
	if (iret .lt. 0) goto 9
	if (iret .gt. 0) then
	  write(errlun, *) 'configuring temperature controller ...'
	  iret=tecc_wait(conn)
	  if (iret .lt. 0) goto 9
	  write(errlun, *) '... done'
	  iret=tecc_get3(conn, temp(1), temp(3), temp(2)) ! temp(2) and temp(3) are exchanged in MSHOWT
	  if (iret .lt. 0) goto 9
	endif
2	temp(4)=0.0 ! no auxilliary sensor
	return

	entry TECS_SET_TEMP (ERRLUN, SET_TEMP)
!!	======================================

	if (conn .eq. 0) then
	  call tecs_open(conn, errlun)
	  if (conn .eq. 0) return
	endif
	iret=tecc_set(conn, set_temp)
	if (iret .lt. 0) goto 9
	return

	entry TECS_SET_PAR (ERRLUN, NAME, PAR)
!!	======================================

	if (conn .eq. 0) then
	  call tecs_open(conn, errlun)
	  if (conn .eq. 0) return
	endif
	iret=tecc_set_par(conn, name, par)
	if (iret .lt. 0) goto 9
	return

	entry TECS_GET_PAR (ERRLUN, NAME, PAR)
!!	======================================

	if (conn .eq. 0) then
	  call tecs_open(conn, errlun)
	  if (conn .eq. 0) return
	endif
	iret=tecc_get_par(conn, name, par)
	if (iret .lt. 0) goto 9
	par(iret+1:)=' '
	return

	entry TECS_SEND_CMD (ERRLUN, CMD, RESPONSE)
!!	===========================================

	if (conn .eq. 0) then
	  call tecs_open(conn, errlun)
	  if (conn .eq. 0) return
	endif
	iret=tecc_send(conn, cmd, response)
	if (iret .lt. 0) goto 9
	response(iret+1:)=' '
	return

	entry TECS_QUIT(ERRLUN)
!!	=======================
	if (conn .eq. 0) then
	  call tecs_open(conn, errlun)
	  if (conn .eq. 0) return
	endif
	iret=tecc_quit_server(conn)
	if (iret .lt. 0) goto 9
	return

    9	call err_show('Error in TECS_TAS')
	return

	end
	SUBROUTINE TECS_OPEN (CONN, ERRLUN)
!	===================================

	implicit    none

c--------------------------------------------------------------
c			    Define the dummy arguments
	integer*8   conn
	integer	    errlun
c--------------------------------------------------------------
	integer	    lun, port, ios, i

	character startcmd*80
	common /tecs_init_com/startcmd
	data startcmd/' '/

	integer*8   tecc_init
	external    tecc_init, tecs_err_routine
c--------------------------------------------------------------
c		If MAD_TECS:TECS.INIT exists, read it to get the port number and start command

	call ErrSetOutRtn(tecs_err_routine, errlun)
	port=0
	if (startcmd .eq. ' ') then
	  call lib$get_lun (lun)
	  open (lun, file='mad_tecs:tecs.init', status='old',
     +			      readonly, iostat=ios)
	  if (ios .eq. 0) read (lun, '(a)', iostat=ios) startcmd
	  close(lun)
	  call lib$free_lun(lun)
	endif
	i=index(startcmd, '-p ')
	if (i .ne. 0) then
	  read(startcmd(i+2:),*,iostat=ios) port
	endif
	if (port .eq. 0) port=9753
c--------------------------------------------------------------

	conn = tecc_init(startcmd, port)
	if (conn .eq. 0) then
	  call err_show('Error in TECS_OPEN')
	endif

	end
	SUBROUTINE TECS_ERR_ROUTINE (LUN, TEXT)
!	=======================================
c
c routine called from C
c
	implicit    none
c--------------------------------------------------------------
c			    Define the dummy arguments
	byte	text(128)
	integer lun
c--------------------------------------------------------------
	integer i, j
c--------------------------------------------------------------
	do i=1,128
	  if (text(i) .eq. 0) then
	    write(lun, '(x,128a1)') (text(j), j=1,i-1)
	    return
	  endif
	enddo
! no terminating ASCII NUL found
	write(lun, *) 'error in TECS_ERR_ROUTINE: illegal error text'
	end