!!------------------------------------------------------------------------------ !! 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