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

Initial commit

Browse Source
This commit is contained in:
zolliker
2022-08-19 15:22:33 +02:00
commit d682fae506
545 changed files with 48172 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

382
unix/sys.f Executable file
View File

@ -0,0 +1,382 @@
!!------------------------------------------------------------------------------
!! 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