c.. c..some system and glue utility routines c.. c..routine bbb opens and closed files c..routine today gets the date and clock time c..routine zsecond get the elasped cpu time c..routine lenstr finds the non-blank length of a string c..routine sqeeze compresses a string c..routine timlap converts total seconds into hours, minutes, seconds c..routine casedn converts a string to lower case c..routine uttoday gets the ut time out of a machine subroutine bbb(id,lunit,luname,ierr) implicit none save c.. c..this routine opens and closes files in various modes. c.. id function c.. 3 close file c.. 7 close with delete c.. 9 open old file c.. 10 open read/write unformatted new file c.. 11 open old unformatted file c.. 12 append old file c.. 13 open read/write new file c.. c..declare logical opened character*(*) luname integer id,lunit,ierr,i c..initialize ierr = 0 c..close a file if (id.eq.3) then if (lunit.ne.0) then inquire (lunit, opened=opened) if (opened) close (lunit) end if return c..close and delete the file else if (id.eq.7) then inquire (lunit, opened=opened) if (opened) close (lunit,status='delete') return c..open an old named file for reading else if (id.eq.9) then i=index(luname,' ') -1 open(unit=lunit,file=luname(1:i),err=100,status='old') rewind(lunit) return c..open a binary file for reading and writing else if (id.eq.10) then i=index(luname,' ') -1 open(unit=lunit,file=luname(1:i),form='unformatted', 1 err=100,status='unknown') rewind(lunit) return c..open an old binary file for reading else if (id.eq.11) then i=index(luname,' ') -1 open(unit=lunit,file=luname(1:i),form='unformatted', 1 err=100,status='old') rewind(lunit) return c..open old files for writing (append) f77 way c else if (id.eq.12) then c i=index(luname,' ') -1 c open(unit=lunit,file=luname(1:i), c 1 err=100, status='old', access='append') c return c..f90 way c..open old files for writing (append) c else if (id.eq.12) then c i=index(luname,' ') -1 c open(unit=lunit,file=luname(1:i), c 1 err=100, status='old', position='append') c return c..open a new file for reading and writing else if (id.eq.13) then i=index(luname,' ') - 1 open(unit=lunit,file=luname(1:i),err=100,status='unknown') rewind(lunit) return end if c..error with the file 100 write(6,101) luname(1:20) 101 format(1x,'* error with file >',a,'<') ierr = 1 return end subroutine today(adat,atim) implicit none c..forms date and time strings c..declare the pass character*8 atim character*9 adat c..local variables character*3 amon(12) character*8 date character*10 time character*5 zone integer idat(3),itim(3),values(8) data amon/ 'jan' , 'feb' , 'mar' , 'apr' , 'may' , 'jun' , 1 'jul' , 'aug' , 'sep' , 'oct' , 'nov' , 'dec' / c..format statements for the time and date 113 format(i2.2,':',i2.2,':',i2.2) 114 format(i2.2,a3,i4.4) c..initialize adat=' ' atim=' ' c..f77 way, keep capitals for maximum portability c call ITIME(itim) c call IDATE(idat) c write(atim,113) itim c write(adat,114) idat(1),amon(idat(2)),idat(3) c..f90 way call date_and_time(date,time,zone,values) write(atim,113) values(5),values(6),values(7) write(adat,114) values(3),amon(values(2)),values(1) return end subroutine zsecond(time) c.. c..this routine gets the elapsed time of a job from the machine c.. c..declare external ETIME double precision time real ETIME,tarray(2),ttt c..initialize time = 0.0d0 c..f77 way, keep capitals for maximum portability c time = ETIME(tarray) c..f90 doesn't have a way to get the cputime, only wall clock time. grrr. c..f95 intrinsic c call cpu_time(ttt) c time = ttt return end integer function lenstr(string,istrln) implicit none save c..lenstr returns the non blank length length of the string. c.. c..declare integer istrln,i character*(*) string lenstr=0 do i=istrln,1,-1 if (string(i:i).ne. ' ') then if (ichar(string(i:i)).ne. 0 )then lenstr=i goto 20 end if end if enddo 20 return end subroutine sqeeze(line) implicit none save c..this routine takes line and removes all blanks, such as c..those from writing to string with fortran format statements c.. c..declare character*(*) line character*1 achar integer l,n,k,lend,lsiz,lenstr c..find the end of the line lsiz = len(line) lend = lenstr(line,lsiz) n = 0 l = 0 c..do the compression in place 10 continue l = l + 1 achar = line(l:l) if (achar .eq. ' ') goto 10 n = n + 1 line(n:n) = achar if (l .lt. lend) goto 10 c..blank the rest of the line do k=n+1,lsiz line(k:k) = ' ' enddo return end subroutine timlap(tlap,hours,minut,sec,msec) implicit none save c..this routines converts seconds to hours, minutes, seconds and microseconds c.. c..declare integer hours,minut,sec,msec double precision tlap,x msec = 0 sec = 0 minut = 0 hours = 0 sec = int(tlap) msec = 1.0d6 * (tlap-sec) if (sec .ge. 60) then x = dble(sec)/60.0d0 minut = int(x) end if sec = sec - minut*60 if (minut .ge. 60) then x = dble(minut)/60.0d0 hours = int(x) end if minut = minut - hours*60 return end subroutine casedn(string) implicit none save c..this routine converts an ascii string to all lower case. c..declare character*(*) string integer i,x,biga,bigz,change parameter (biga = 65, bigz = 90, change = 32) do i=1,len(string) x = ichar(string(i:i)) if (x .ge. biga .and. x .le. bigz ) then x = x + change string(i:i) = char(x) end if enddo return end subroutine uttoday(iyear,imonth,iday,ihour,iminute,isecond) implicit none save c..this routine gets the UT date and time out of a machine. c..output: c..iyear = integer year c..imonth = integar month, between 1-12 c..iday = integer day of month, between 1-31 c..ihour = hours past midnight, between 0-23 c..iminute = minutes past the hour, 0-59 c..isecond = seconds past the minute, 0-59 c..declare integer iyear,imonth,iday,ihour,iminute,isecond c..local variables external TIME integer TIME integer*4 stime,tarray(9) c..keep capitalized for maximum portability c..of these two f77 intrinsics stime = TIME() call GMTIME(stime,tarray) isecond = tarray(1) iminute = tarray(2) ihour = tarray(3) iday = tarray(4) imonth = tarray(5) + 1 iyear = tarray(6) + 1900 return end