225 lines
7.2 KiB
Fortran
225 lines
7.2 KiB
Fortran
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 dependend 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,*,iostat=ios) port
|
||
endif
|
||
|
||
if (port .eq. 0) port=9753
|
||
iret=tecs_init(init, port)
|
||
|
||
else
|
||
|
||
c if INIT exists, read it to get the port number and the start command
|
||
|
||
startcmd=' '
|
||
|
||
open (lun, file=init, status='old', readonly, iostat=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 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_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
|