SUBROUTINE DW4UNIX(IDAT,ifirst) DIMENSION IDAT(8) C if(ifirst.eq.0) then OPEN(UNIT=2,STATUS='SCRATCH',FORM='UNFORMATTED') OPEN(UNIT=4,STATUS='SCRATCH',FORM='UNFORMATTED') C CALL unixfile(5,6,'DWUCK4 AT YOUR SERVICE') endif C CALL unixDAT(IDAT) C RETURN END C C SUBROUTINE UNIXFILE (INPUT, IOUTPUT, TITLE) C C @(#)sunfile.f 1.2 90/05/30 10:38:37 J.J.A. Zalmstra C C This subroutine will determine the files associated with STDIN(= unit 5) C and STDOUT (= unit 6) and print a two line title block to STDOUT C C SUBROUTINE UNIXFILE (INPUT, IOUTPUT, TITLE) CHARACTER*(*) TITLE C integer getcwd character*40 instdat, fdate character*40 infile, outfile character*40 user character*40 cwd character*256 arg parameter (instdat = 'Mon May 21 11:05:50 1990 ') infile = 'Standard Input' outfile= 'Standard Output' user = 'unknown' cwd = 'unknown' c c Determine the user c call getenv('USER',arg) if(lnblnk(arg) .ne. 0) user = arg c c We have read all flags and must now check for input and/or c outputfilename. 'arg' contains the argument to check, unless c there are no arguments at all. c nargs = iargc() if(nargs .gt. 0) then call getarg(1,arg) if(arg(1:1) .ne. '-') then open(input,file=arg,err=99) call ltrunc(arg, infile, 40) rewind input endif endif if(nargs .gt. 1) then call getarg(2, arg) open(ioutput,file=arg,err=99) rewind ioutput call ltrunc(arg, outfile, 40) endif c c Print title page c write(6,1020) title,instdat,fdate() if(getcwd(arg) .eq. 0) then call ltrunc(arg, cwd, 40) else write(0,*)'Cannot get current directory name' endif write(ioutput,1030)user,cwd,infile,outfile return 99 write(0,1010)arg stop 1010 format('Cannot open file ',a) 1020 format(1h1,20(1h*),A,20(1h*)// + ' installed',t20,a,/,' today is ',t20,a, + 20(/)) 1030 format(20x,55(1h*)/20x,1h*,t75,1h*/ + 20x,1h*,' User : ',a40,t75,1h*/ + 20x,1h*,' Directory: ',a40,t75,1h*/ + 20x,1h*,' Input : ',a40,t75,1h*/ + 20x,1h*,' Output : ',a40,t75,1h*/ + 20x,1h*,t75,1h*,/20x,55(1h*)/1h1) end subroutine ltrunc(src, dest, maxlen) c c copy src to dest but truncate from the left if c the length of src exceeds maxlen c character*(*) src, dest istart = 1 iend = lnblnk(src) if(iend .gt. maxlen) then istart = iend - maxlen - 3 dest(1:2) = '<-' dest(3:maxlen) = src(istart:iend) else dest = src(istart:iend) endif return end SUBROUTINE unixDAT(IDAT) DIMENSION IDAT(8) C CALL date_and_time(VALUES = IDAT) c RETURN END SUBROUTINE SECOND(TIME) C THIS SUBROUTINE INTERFACES THE SUN SECONDS ROUTINE C TO THE SECONDS CALL IN THE PROGRAMS c implicit real*8 time real tarray(2), time time = etime(tarray) RETURN END