383 lines
8.5 KiB
Fortran
Executable File
383 lines
8.5 KiB
Fortran
Executable File
!!------------------------------------------------------------------------------
|
|
!! MODULE SYS
|
|
!!------------------------------------------------------------------------------
|
|
!! 26.11.02 M. Zolliker
|
|
!!
|
|
!! System dependent subroutines for unix
|
|
!!------------------------------------------------------------------------------
|
|
!!
|
|
subroutine SYS_GETENV(NAME, VALUE) !!
|
|
!! ==================================
|
|
!!
|
|
!! Get environment variable NAME
|
|
!! try all uppercase also
|
|
|
|
implicit none
|
|
!! Arguments:
|
|
character*(*) NAME !! logical name
|
|
character*(*) VALUE !! result
|
|
|
|
integer l
|
|
character nam*128
|
|
|
|
call sys_loadenv
|
|
call str_trim(nam, name, l)
|
|
call getenv(nam(1:l), value)
|
|
if (value .ne. ' ') RETURN
|
|
if (nam(1:1) .ge. 'a') then
|
|
call str_upcase(nam(1:l), nam(1:l))
|
|
else
|
|
call str_lowcase(nam(1:l), nam(1:l))
|
|
endif
|
|
call getenv(nam(1:l), value)
|
|
end
|
|
|
|
!!------------------------------------------------------------------------------
|
|
!!
|
|
subroutine SYS_GETENV_IDX(NAME, VALUE, IDX) !!
|
|
!! ===========================================
|
|
!!
|
|
!! Get environment variable NAME, only list element IDX (start with 0)
|
|
!! (separated by comma)
|
|
|
|
implicit none
|
|
!! Arguments:
|
|
character*(*) NAME !! logical name
|
|
character*(*) VALUE !! result
|
|
integer IDX !! index
|
|
|
|
integer l,pos,j,i
|
|
character nam*128, list*1024
|
|
|
|
call str_trim(nam, name, l)
|
|
call getenv(nam(1:l), list)
|
|
if (list .eq. ' ') then
|
|
if (nam(1:1) .ge. 'a') then
|
|
call str_upcase(nam(1:l), nam(1:l))
|
|
else
|
|
call str_lowcase(nam(1:l), nam(1:l))
|
|
endif
|
|
call getenv(nam(1:l), list)
|
|
endif
|
|
pos=0
|
|
do i=1,idx
|
|
j=index(list(pos+1:), ',')
|
|
if (j .eq. 0) then
|
|
value=' '
|
|
RETURN
|
|
endif
|
|
pos=pos+j
|
|
enddo
|
|
j=index(list(pos+1:), ',')
|
|
if (j .eq. 1) then
|
|
value=' '
|
|
RETURN
|
|
endif
|
|
if (j .le. 0) then
|
|
value=list(pos+1:)
|
|
else
|
|
value=list(pos+1:pos+j-1)
|
|
endif
|
|
end
|
|
|
|
!!-----------------------------------------------------------------------------
|
|
!!
|
|
subroutine SYS_DATE(YEAR, MONTH, DAY) !!
|
|
!! -------------------------------------
|
|
!!
|
|
!! get actual date
|
|
!!
|
|
integer YEAR, MONTH, DAY !! 4-Digits year, month and day
|
|
|
|
integer darray(3)
|
|
external idate
|
|
|
|
call idate(darray)
|
|
day=darray(1)
|
|
month=darray(2)
|
|
year=darray(3)
|
|
end
|
|
|
|
!!-----------------------------------------------------------------------------
|
|
!!
|
|
subroutine SYS_GET_CMDPAR(STR, L) !!
|
|
!! ---------------------------------
|
|
!!
|
|
character*(*) STR !!
|
|
integer L !!
|
|
|
|
integer i,iargc
|
|
|
|
l=0
|
|
str=' '
|
|
do i=1,iargc()
|
|
if (l .lt. len(str)) then
|
|
call getarg(i, str(l+1:))
|
|
call str_trim(str, str, l)
|
|
l=l+1
|
|
endif
|
|
enddo
|
|
if (l .gt. 0) then
|
|
if (str(1:l) .eq. ' ') l=0
|
|
endif
|
|
end
|
|
|
|
!!-----------------------------------------------------------------------------
|
|
!!
|
|
subroutine SYS_REMOTE_HOST(STR, TYPE) !!
|
|
!!
|
|
!! get remote host name/number
|
|
!!
|
|
!! type: TN telnet, RT: decnet, LO: local, XW: X-window (ssh or telnet)
|
|
!!
|
|
character STR*(*), TYPE*(*) !!
|
|
|
|
character host*128, line*128, path*256, os*7
|
|
integer i,j,lun,iostat
|
|
|
|
integer system
|
|
external system
|
|
|
|
call sys_getenv('OS', os)
|
|
if (os .eq. 'Windows') then
|
|
str='local'
|
|
type='LO'
|
|
return
|
|
endif
|
|
call sys_getenv('HOST', host)
|
|
call sys_getenv('DISPLAY', str)
|
|
i=index(str,':')
|
|
type=' '
|
|
if (i .gt. 1) then
|
|
str=str(1:i-1)
|
|
type='XW'
|
|
if (str .ne. 'localhost') goto 80
|
|
endif
|
|
call sys_getenv('REMOTEHOST', str)
|
|
if (str .eq. ' ') then
|
|
call sys_temp_name('.whoami', path)
|
|
call sys_delete_file(path)
|
|
i=system('who -m > '//path)
|
|
call sys_get_lun(lun)
|
|
call sys_open(lun, path, 'r', iostat)
|
|
if (iostat .ne. 0) goto 9
|
|
read(lun,'(a)',end=9,err=9) line
|
|
9 close(lun)
|
|
call sys_delete_file(path)
|
|
i=index(line,'(')
|
|
if (i .ne. 0 .and. i .lt. len(line)) then
|
|
str=line(i+1:)
|
|
i=index(str, ')')
|
|
if (i .ne. 0) str(i:)=' '
|
|
endif
|
|
endif
|
|
i=index(str,':')
|
|
if (i .ne. 0) str(i:)=' '
|
|
if (str .ne. ' ') then
|
|
if (type .eq. ' ') type='TN'
|
|
else
|
|
str=host
|
|
type='LO'
|
|
endif
|
|
|
|
c add domain to short host names
|
|
80 i=index(str, '.')
|
|
j=index(host, '.')
|
|
if (j .gt. 0 .and. i .eq. 0) then
|
|
call str_trim(str, str, i)
|
|
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_TEMP_NAME0(NAME, PATH) !!
|
|
!! ====================================
|
|
!! get a temporary file name (disabled)
|
|
!!
|
|
character*(*) NAME !! (in) name
|
|
character*(*) PATH !! (out) path
|
|
|
|
character line*64, pid*12, user*64
|
|
integer i, l
|
|
|
|
integer getppid
|
|
|
|
call sys_getenv('USER', user)
|
|
line(1:6)='/tmp/.'
|
|
line(7:)=name
|
|
call str_trim(line, line, l)
|
|
if (user .ne. ' ') then
|
|
line(l+1:)='_'//user
|
|
call str_trim(line, line, l)
|
|
endif
|
|
write(pid,'(i12)') getppid()
|
|
i=1
|
|
1 if (pid(i:i) .eq. ' ') then
|
|
i=i+1
|
|
goto 1
|
|
endif
|
|
path=line(1:l)//'.'//pid(i:12)
|
|
end
|
|
|
|
!!-----------------------------------------------------------------------------
|
|
!!
|
|
! subroutine SYS_LOAD_ENV(FILE) !!
|
|
!! =============================
|
|
!! load environment from temporary file
|
|
!!
|
|
! character*(*) FILE !! filename
|
|
!
|
|
! character path*128, line*128
|
|
! integer lun, i, l, iostat
|
|
!
|
|
! integer getppid
|
|
!
|
|
! call sys_temp_name(file, path)
|
|
! call sys_get_lun(lun)
|
|
! call sys_open(lun, path, 'r', iostat)
|
|
! if (iostat .ne. 0) goto 9
|
|
!5 read(lun,'(a)',end=8) line
|
|
! call str_trim(line, line, l)
|
|
! 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, iostat
|
|
|
|
call sys_temp_name(file, path)
|
|
call sys_get_lun(lun)
|
|
|
|
call sys_open(lun, path, 'wo', iostat)
|
|
if (iostat .ne. 0) goto 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_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
|
|
|
|
call sys_getenv('HOME',home)
|
|
call str_trim(home, home, l)
|
|
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
|