375 lines
7.9 KiB
Fortran
375 lines
7.9 KiB
Fortran
!!------------------------------------------------------------------------------
|
|
!! MODULE SYS
|
|
!!------------------------------------------------------------------------------
|
|
!! 10.9.97 M. Zolliker
|
|
!!
|
|
!! System dependent subroutines for LINUX
|
|
!!------------------------------------------------------------------------------
|
|
!!
|
|
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
|
|
!-----------------------------------------------------------------------------
|
|
!
|
|
subroutine sys_open_read(lun, name, ios)
|
|
!
|
|
! open a file as read only (needed to open files with read-only access)
|
|
integer lun, ios
|
|
character name*(*)
|
|
|
|
open (lun, file=name, status='old', iostat=ios)
|
|
end
|