insert tecs_client into archive + little update
This commit is contained in:
cvs
208
tecs/tecs_for.f
Normal file
208
tecs/tecs_for.f
Normal file
@@ -0,0 +1,208 @@
|
||||
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 ErrSetOutRtn(tecs_err_routine, iolun)
|
||||
call err_show('Error in TECS')
|
||||
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
|
||||
Reference in New Issue
Block a user