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