linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Works now under OSF1 and Linux

Browse Source
This commit is contained in:
cvs
2002-01-24 15:01:19 +00:00
parent 213a6f2f00
commit 2378909981
11 changed files with 607 additions and 228 deletions
Download Patch File Download Diff File Expand all files Collapse all files

364
tecs/sys_linux.f Normal file
View File

@@ -0,0 +1,364 @@
!!------------------------------------------------------------------------------
!! 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, nam*64
integer i, l
integer getppid
nam='/tmp/.'
nam(7:)=name
call sys_getenv('USER', line)
if (line .eq. ' ') then
call str_trim(line, nam, l)
else
call str_trim(nam, nam, l)
call str_trim(line, nam(1:l)//'_'//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',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',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 print *,'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, iargc
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)
character esc*1, csi*1, ss3*1
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