SUBROUTINE TECS_FOR		! File TAS_SRC:[TECS]TECS_FOR.FOR
c	===================
c
cdec$	  ident	'V01D'
c------------------------------------------------------------------------------
c	    Fortran-Interface to the TECS Client
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       01-May-2000 M.Z.  renamed source, TECS_OPEN is now in a separate, system dependent file
c  V01C 11-May-2000 DM.	  Split into modules.
c  V01D 12-May-2000 M.Z.  Changed error handling, no longer automatic call to TECS_OPEN
c------------------------------------------------------------------------------
c
c  For a description of the public interface:
c    on VMS:  search tecs_for.for "!'''!"     (''' may be omitted)
c    on Unix: grep !"!" tecs_for.for
c
c  Public routines in this Module:
c
c    subroutine TECS_OPEN (LUN, INIT, IRET)        - open connection to tecs, if not yet open
c    subroutine TECS_GET_T (IOLUN, TEMP, IRET)     - read the temperature, wait if tecs is configuring
c    subroutine TECS_WRITE_ERROR (IOLUN)           - write out last occured error in TECS_x routines
c
c  For internal use only:
c
c    subroutine TECS_FOR                           - dummy entry point to get module name
c                                                    in library to match the file name.
c    subroutine TECS_ERR_ROUTINE (LUN, TEXT)       - (for internal use only)
c
!!------------------------------------------------------------------------------
!! C Routines with Fortran interface (see TECS_CLI.C):
!!
!!   integer function TECS_SET (TEMP)             - set temperature target
!!   integer function TECS_GET (TEMP)             - get sample temperature
!!   integer function TECS_QUIT_SERVER ()         - force server to quit
!!   integer function TECS_GET_PAR (NAME, PAR)    - get parameter
!!   integer function TECS_SET_PAR (NAME, PAR)    - set parameter
!!   integer function TECS_SEND (CMND, REPLY)     - send command to LakeShore
!!   subroutine TECS_CLOSE                        - close connection to tecs
!!   
!!     real TEMP
!!     character*(*) NAME, PAR, CMND, REPLY
!!
!!     integer return values are error codes (negative means error, like in most C system routines)
!!
!
!  C routines only for internal use in TECS_FOR.FOR:
!
!    integer function TECS_INIT(STARTCMD, PORT)      - open server connection
!    logical function TECS_IS_OPEN ()                - check if tecs is open
!    integer function TECS_GET3(SET_T, REG_T, SAM_T) - read 3 temperatures
!    integer function TECS_WAIT()                    - wait for end of configuration
!
!      character*(*) STARTCMD
!      integer PORT
!      real SET_T,REG_T,SAM_T
c------------------------------------------------------------------------------
	implicit    none
	stop 'TECS_FOR: do not call module header'
	end
!!------------------------------------------------------------------------------
!! Fortran routines in this file:
!!
	SUBROUTINE TECS_OPEN(LUN, INIT, IRET) !!
!!	=====================================
!!
!! Open connection to the Tecs Server, if not yet done.
!! (a) LUN==0: INIT is the start command which should contain "-p <portnumber>"
!! (b) LUN/=0: INIT is the file specification where to read port number and start command
!!
c------------------------------------------------------------------------------
	implicit    none

c--------------------------------------------------------------
c			    Define the dummy arguments
	integer       LUN        !! logical number for reading init file
	character*(*) INIT       !! file specification or start command
	integer	      IRET       !! iret<0 means error
c--------------------------------------------------------------
	integer	      ios, port, i
	character*128 startcmd

! functions:
	integer       tecs_init
	logical       tecs_is_open
c--------------------------------------------------------------

	if (tecs_is_open()) then
	  iret=1 ! already open
	  return
	endif

	port=0

	if (lun .eq. 0) then

c	  extract the port number from the start command

	  i=index(init, '-p ')
	  if (i .eq. 0) i=index(init, '-P ')
	  if (i .ne. 0) then
	    read(init(min(len(init),i+3):),*,iostat=ios) port
	  endif

	  if (port .eq. 0) port=9753

	  if (init(1:1) .eq. '#') then
	    i=index(init, '-')-1
	    if (i .le. 0) i=len(init)
	  else
	    i=len(init)
	  endif
	  iret=tecs_init(init(1:i), port)

	else

c	  if INIT exists, read it to get the port number and the start command

	  startcmd=' '

	  call sys_open(lun, init, 'R', ios)
	  if (ios .eq. 0) read (lun, *, iostat=ios) port
	  if (ios .eq. 0) read (lun, *, iostat=ios) ! skip options line
	  if (ios .eq. 0) read (lun, '(a)', iostat=ios) startcmd
	  close(lun)
	  if (ios .ne. 0) then
	    iret=-2
	    call err_msg('TECS_OPEN: init file not found')
	    return
	  endif
	  if (port .eq. 0) port=9753
	  iret=tecs_init(startcmd, port)

	endif
	end

	SUBROUTINE TECS_GET_T (IOLUN, TEMP, IRET) !!
!!	=========================================
!!
!! Get temperatures and wait if TECS is configuring
!!
	implicit    none

c			Define the dummy arguments

	integer     IOLUN        !! unit to write informational messages
	real*4	    TEMP(4)      !! TASMAD temperature array: set-temp, regulation, sample, aux-temp
	integer     IRET         !! IRET=0: o.k., IRET<0: error
c------------------------------------------------------------------------------
	integer  tecs_get3, tecs_wait
	external tecs_get3, tecs_wait
c------------------------------------------------------------------------------
	iret=tecs_get3(temp(1), temp(3), temp(2)) ! temp(2) and temp(3) are exchanged in MSHOWT
	if (iret .lt. 0) then
	  call err_txt('tecs_get_3'//char(10)//'tecs_get_t')
	  return
	endif
	if (iret .gt. 0) then
!	  write(iolun, *) 'configuring temperature controller ...'
!	  iret=tecs_wait()
!	  if (iret .lt. 0) then
!	    call err_txt('tecs_wait'//char(10)//'tecs_get_t')
!	    return
!	  endif
!	  write(iolun, *) '... done'
!	  iret=tecs_get3(temp(1), temp(3), temp(2)) ! temp(2) and temp(3) are exchanged in MSHOWT
!	  if (iret .lt. 0) then
!	    call err_txt('tecs_get3(2)'//char(10)//'tecs_get_t')
!	    return
!	  endif
	endif
	temp(4)=0.0 ! no auxilliary sensor
	end

	subroutine TECS_WRITE_ERROR(IOLUN)  !!
!!	==================================
!!
!! write out error message of last error and stack info
!!
	implicit    none

	integer IOLUN  !! logical unit for output

	external    tecs_err_routine

	call err_set_outrtn(tecs_err_routine, iolun)
	call err_show('Error in TECS')
	end


	subroutine TECS_WRITE_MSG(IOLUN)  !!
!!	================================
!!
!! write out error message of last error without stack info
!!
	implicit    none

	integer IOLUN  !! logical unit for output

	external    tecs_err_routine

	call err_set_outrtn(tecs_err_routine, iolun)
	call err_short
	end


	SUBROUTINE TECS_ERR_ROUTINE (LUN, TEXT)
!	=======================================
!
! routine called from 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