insert tecs_client into archive + little update

tecs/sys_aunix.f

@@ -0,0 +1,245 @@
+!!------------------------------------------------------------------------------
+!! MODULE SYS
+!!------------------------------------------------------------------------------
+!! 10.9.97 M. Zolliker
+!!
+!! System dependent subroutines for ALPHA UNIX
+!!------------------------------------------------------------------------------
+!!
+	subroutine SYS_GETENV(NAME, VALUE)	!!
+!!	==================================
+!!
+!! Get logical name NAME
+!! If the logical name is not in any table, VALUE will be blank
+
+	implicit none
+!! Arguments:
+	character*(*) NAME		!! logical name
+	character*(*) VALUE		!! result
+
+	integer l
+	integer lnblnk
+
+	l=lnblnk(name)
+	call getenv(name(1:l), value)
+	end
+
+!!-----------------------------------------------------------------------------
+!!
+	subroutine SYS_DATE(YEAR, MONTH, DAY) !!
+!!      -------------------------------------
+!!
+!! get actual date
+!!
+	integer YEAR, MONTH, DAY !! 4-Digits year, month and day
+
+	integer tarray(9)
+	external time
+	integer time
+
+	call ltime(time(), tarray)
+	day=tarray(4)
+	month=tarray(5)+1   ! tarray(5): months since january (0-11)!
+	year=tarray(6)+1900 ! tarray(6): years since 1900, no y2k problem
+	end
+
+!!-----------------------------------------------------------------------------
+!!
+	subroutine SYS_REMOTE_HOST(STR, TYPE) !!
+!!
+!! get remote host name/number
+!!
+!! type: TN telnet, RT: decnet, XW: X-window
+!!
+	character STR*(*), TYPE*(*) !!
+
+	character host*128
+	integer i,j
+	integer lnblnk
+
+	call sys_getenv('HOST', host)
+	call sys_getenv('DISPLAY', str)
+	i=index(str,':')
+	if (i .gt. 1) then
+	  str=str(1:i-1)
+	  type='XW'
+	else
+	  call sys_getenv('REMOTEHOST', str)
+	  if (str .ne. ' ') then
+	    type='TN'
+	  else
+	    str=host
+	    type='LO'
+	  endif
+	endif
+
+!   add domain to short host names
+	i=index(str, '.') 
+	j=index(host, '.')
+	if (j .gt. 0 .and. i .eq. 0) then
+	  i=lnblnk(str)
+	  str(i+1:)=host(j:)
+	endif
+	end
+
+!!-----------------------------------------------------------------------------
+!!
+	subroutine SYS_GET_LUN(LUN)    !!
+!!
+!! allocate logical unit number
+
+	integer LUN     !! out
+
+	logical*1 act(50:100)/51*.false./
+	save act
+
+	integer l
+
+	l=50
+	do while (l .lt. 99 .and. act(l))
+	  l=l+1
+	enddo
+	if (l .eq. 100) stop 'SYS_GET_LUN: no more luns available'
+	lun=l
+	act(l)=.true.
+	return
+!!
+	entry SYS_FREE_LUN(LUN)        !!
+!!
+!! deallocate logical unit number
+
+	if (act(lun)) then
+	  act(lun)=.false.
+	else
+	  stop 'SYS_FREE_LUN: lun already free'
+	endif
+	end
+
+!!-----------------------------------------------------------------------------
+!!
+	subroutine SYS_RENAME_FILE(OLD, NEW)      !!
+!!      ====================================
+!!
+	character OLD*(*), NEW*(*)      !! (in) old, new filename
+
+	call rename(OLD, NEW)
+	end
+
+!!-----------------------------------------------------------------------------
+!!
+	subroutine SYS_DELETE_FILE(NAME)      !!
+!!      ================================
+!!
+	character NAME*(*)      !! (in) filename
+
+	call unlink(NAME)
+	end
+
+!!-----------------------------------------------------------------------------
+!!
+	subroutine SYS_HOME(HOME)   !!
+!!      =========================
+!!
+!! get home directory (+ dot)
+
+	character HOME*(*)      !! (out) filename
+
+	integer l
+	integer lnblnk
+
+	call sys_getenv('HOME',home)
+	l=lnblnk(home)
+	if (l .lt. len(home)-1) then
+	  if (home(l:l) .ne. '/') then
+	    home(l+1:l+1)='/'
+	    l=l+1
+	  endif
+	  home(l+1:l+1)='.'
+	  l=l+1
+	endif
+	end
+
+!!------------------------------------------------------------------------------
+!!
+	subroutine SYS_CHECK_SYSTEM(CODE)  !!
+!!      =================================
+!!
+	character CODE*(*) !!
+
+	code='ALPHA_UNIX'         !!
+	end
+
+!!-----------------------------------------------------------------------------
+!!
+	subroutine SYS_GET_CMDPAR(STR, L)	!!
+!!	---------------------------------
+!!
+	character*(*) STR !!
+	integer L	!!
+
+	integer i
+	integer lnblnk
+
+	l=0
+	str=' '
+	do i=1,iargc()
+	  if (l .lt. len(str)) then
+	    call getarg(i, str(l+1:))
+	    l=lnblnk(str)
+	    l=l+1
+	  endif
+	enddo
+	if (l .gt. 0) then
+	  if (str(1:l) .eq. ' ') l=0
+	endif
+	end
+
+!!-----------------------------------------------------------------------------
+!!
+	subroutine SYS_GET_KEY(KEY, TMO) !!
+!!
+!! read for keyboard with timeout, without echo
+!!
+	character KEY*1 !!
+	integer TMO !! timeout in seconds (<100)
+
+        parameter esc=char(27), csi=char(155), ss3=char(143)
+
+	call sys_get_raw_key(key, tmo)
+1	if (key .eq. esc) then
+	  call sys_get_raw_key(key, tmo)
+	  if (key .eq. 'O') then
+	    key=ss3
+	    goto 1
+	  elseif (key .eq. '[') then
+	    key=csi
+	    goto 1
+	  endif
+	elseif (key .eq. csi) then
+	  call sys_get_raw_key(key, tmo)
+	  do while (key .ge. '0' .and. key .le. '9') 
+	    call sys_get_raw_key(key, tmo)
+	  enddo
+	  key=' '
+	elseif (key .eq. ss3) then
+	  call sys_get_raw_key(key, tmo)
+	  if (key .eq. 'm') then
+	    key='-'
+	  elseif (key .eq. 'l') then
+	    key='+'
+	  elseif (key .eq. 'n') then
+	    key='.'
+	  elseif (key .eq. 'M') then
+	    key=char(13)
+	  elseif (key .eq. 'S') then
+	    key='*'
+	  elseif (key .eq. 'R') then
+	    key='/'
+	  elseif (key .eq. 'Q') then
+	    key='='
+	  else
+	    key=' '
+	  endif
+	endif
+	end
+