!!------------------------------------------------------------------------------
!! 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_TEMP_NAME(NAME, PATH) !!
!!	====================================
!! get a temporary file name
!!
	character*(*) NAME !! (in) name
	character*(*) PATH !! (out) path

	character line*64, pid*5
	integer i, l

	integer getppid

	call sys_getenv('USER', line)
	if (line .eq. ' ') then
	  call str_trim(line, '/tmp/.'//name, l)
	else
	  call str_trim(line, '/tmp/.'//name//'_'//line, l)
	endif

	write(pid,'(i5)') getppid()
	i=1
1	if (pid(i:i) .eq. ' ') then
	  i=i+1
	  goto 1
	endif
	path=line(1:l)//'.'//pid(i:5)
	end

!!-----------------------------------------------------------------------------
!!
	subroutine SYS_LOAD_ENV(FILE) !!
!!	=============================
!! load environment from temporary file
!!
	character*(*) FILE !! filename

	character path*128, line*128
	integer lun, i, l

	integer getppid

	call sys_temp_name(file, path)
	call sys_get_lun(lun)
	open(lun,file=path,status='old',readonly,err=9)
5	read(lun,'(q,a)',end=8) l, line
	l=min(l,len(line))
	i=index(line,'=')
	if (i .eq. 0) then
	  if (l .gt. 0) call sys_setenv(line(1:l), ' ')
	elseif (i .gt. 1 .and. i .lt. l) then
	  call sys_setenv(line(1:i-1),line(i+1:l))
	endif	  
	goto 5
8	close(lun)
9	call sys_free_lun(lun)
	end

!!-----------------------------------------------------------------------------
!!
	subroutine SYS_SAVE_ENV(FILE, NAMES, N_NAMES) !!
!!	=============================================
!! save environment on temporary file
!!
	character*(*) FILE      !! filename
	integer N_NAMES         !! number of names
	character*(*) NAMES(N_NAMES)    !! names of variables to save

	character path*128, line*128
	integer lun, i, j, l

	call sys_temp_name(file, path)
	call sys_get_lun(lun)

	open(lun,file=path,status='unknown',carriagecontrol='list'
	1,err=19)

	do i=1,n_names
	  call sys_getenv(names(i), line)
	  call str_trim(names(i),names(i), j)
	  call str_trim(line,line, l)
	  write(lun,'(3a)') names(i)(1:j),'=',line(1:l)
	enddo

	close(lun)
9	call sys_free_lun(lun)
	return

19	type *,'SYS_SAVE_ENV: can not open tmp. file'
	goto 9
	end

!!-----------------------------------------------------------------------------
!!
	subroutine SYS_WAIT(SECONDS)	!!
!!      ============================
!! wait for SECONDS
	real SECONDS !! resolution should be better than 0.1 sec.

	real tim, del

	tim=secnds(0.0)
1	del=seconds-secnds(tim)
	if (del .ge. 0.999) then
	  call sleep(int(del))
	  goto 1
	endif
	if (del .gt. 0) then	
	  call usleep(int(del*1E6))
	  goto 1
	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
