064ec37e9a
- Refactored site specific stuff into a site module - PSI specific stuff is now in the PSI directory. - The old version has been tagged with pre-ansto
232 lines
7.3 KiB
Fortran
232 lines
7.3 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 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
|