# # # # RATLIB utility routines - I/O routines # ====================================== # # # Author: William P. Wood, Jr. # Computer Center # Institute For Cancer Research # 7701 Burholme Ave. # Philadelphia, Pa. 19111 # (215) 728 2760 # # Version: 2.0 # # Date: December 18, 1981 # # # # ******************************************************* # * * # * THIS SOFTWARE WAS DEVELOPED WITH SUPPORT * # * FROM THE NATIONAL INSTITUTES OF HEALTH: * # * NIH CA06927 * # * NIH CA22780 * # * * # * DIRECT INQUIRIES TO: * # * COMPUTER CENTER * # * THE INSTITUTE FOR CANCER RESEARCH * # * 7701 BURHOLME AVENUE * # * PHILADELPHIA, PENNSYLVANIA 19111 * # * * # * NO WARRANTY OR REPRESENTATION, EXPRESS OR * # * IMPLIED, IS MADE WITH RESPECT TO THE * # * CORRECTNESS, COMPLETENESS, OR USEFULNESS * # * OF THIS SOFTWARE, NOR THAT USE OF THIS * # * SOFTWARE MIGHT NOT INFRINGE PRIVATELY * # * OWNED RIGHTS. * # * * # * NO LIABILITY IS ASSUMED WITH RESPECT TO * # * THE USE OF, OR FOR DAMAGES RESULTING FROM * # * THE USE OF THIS SOFTWARE * # * * # ******************************************************* # # acopy - copy size lines from fdi to fdo subroutine acopy(fdi, fdo, size) integer fdi, fdo, size integer*4 ni4, ncop ni4 = size call copy(fdi, fdo, ni4, ncop) #$ integer getlin #$ character buf(MAXLINE) #$ integer fdi, fdo, i, size #$ for (i = 1; i <= size; i = i + 1) { #$ if (getlin(buf, fdi) == EOF) #$ break #$ call putlin(buf, fdo) #$ } return end # amove - move name1 to name2 subroutine amove(name1, name2) character name1(ARB), name2(ARB) integer create, open integer fd1, fd2 fd1 = open(name1, READ) if (fd1 == ERR) call cant(name1) fd2 = create(name2, WRITE) if (fd2 == ERR) call cant(name2) call fcopy(fd1, fd2) return end # fcopy - copy file in to file out subroutine fcopy(in, out) integer in, out integer*4 ni4, ncop data ni4/2 147 483 647/ call copy(in, out, ni4, ncop) #$ character buf(MAXLINE) #$ integer getlin #$ integer in, out #$ while (getlin(buf, in) != EOF) #$ call putlin(buf, out) return end # initr4 - initialize standard files subroutine initr4 include iocom.rat include argcom.rat integer ier, i lastc = 0 iolen = 0 do i = 1, MAXOPEN actun(i) = EOS mxfile = MAXOPEN upflag = .true. # fold commands to upper case noread = .true. # haven't read command line yet call opn(ERROUT, ERR$OUT, 'W', ier) if (ier != 0) stop "can't open ERROUT" call opn(STDIN, STD$IN, 'F', ier) # open with carriagecontrol=fortran if (ier != 0) call error("can't open STDIN.") tiin = .true. call opn(STDOUT, STD$OUT, 'W', ier) if (ier != 0) call error("can't open STDOUT.") _ifndef(VAX) call errset(28,.true.,.false.,.true.,.false.,15) # close error call errset(29,.true.,.false.,.true.,.false.,15) # no such file call errset(30,.true.,.false.,.true.,.false.,15) # open failure call errset(43,.true.,.false.,.false.,.false.,15) # file name specification _enddef return end # endr4 - close up shop subroutine endr4 _ifdef(VAX) common /status/ istat _enddef call closec(STDOUT, SAVEF) call closec(STDIN, SAVEF) call closec(ERROUT, SAVEF) _ifdef(VAX) call exit(istat | 16%10000000) _elsedef call exit _enddef end # defnam - provide defaults for file name, reset new defaults - # compatible with old version, doesn't return version number and # doesn't have special processing for asterisks subroutine defnam(file, node, dev, uic, name, ext, reset) character file(FILENAMESIZE) character node(NODESIZE), dev(DEVSIZE), uic(UICSIZE), name(NAMESIZE), ext(EXTSIZE), ver(VERSIZE) logical reset ver(1) = EOS call fparse(file, node, dev, uic, name, ext, ver, reset, .false.) return end # fparse - provide defaults for file name, reset new defaults. # if astrsk is true, asterisks will use the defaults. subroutine fparse(file, node, dev, uic, name, ext, ver, reset, astrsk) character file(FILENAMESIZE), temp(FILENAMESIZE) character node(NODESIZE), dev(DEVSIZE), uic(UICSIZE), name(NAMESIZE), ext(EXTSIZE), ver(VERSIZE) logical reset, astrsk integer l, j, icp, len integer indexq, bkscnq, concat, scan temp(1) = EOS len = concat(temp, file(scan(file, ' ', 1)), FILENAMESIZE) file(1) = EOS j = 1 l = 0 icp = indexq(temp(j), ':') if (icp != 0) { if (temp(icp+1) == ':') icp = icp + 1 else icp = 0 } call adstr(icp, j, l, file, temp, node, NODESIZE-1, reset, .false.) call adstr(indexq(temp(j), ':'), j, l, file, temp, dev, DEVSIZE-1, reset, .false.) call adstr(indexq(temp(j), ']'), j, l, file, temp, uic, UICSIZE-1, reset, .false.) call adstr(bkscnq(temp, ' .;', j) - j, j, l, file, temp, name, NAMESIZE-1, reset, astrsk) call adstr(bkscnq(temp, ' ;', j) - j, j, l, file, temp, ext, EXTSIZE-1, reset, astrsk) call adstr(len+1-j, j, l, file, temp, ver, VERSIZE-1, reset, .false.) return end # adstr - copy piece of file name for fparse subroutine adstr(i, j, l, file, tfile, str, mxstr, reset, astrsk) integer i, j, l, mxstr, k, iast, concat, scan, indexq character file(1), tfile(1), str(1) logical reset, astrsk if (i == 0) l = concat(file, str, FILENAMESIZE) else { if (astrsk) iast = indexq(tfile(j),'*') else iast = 0 if (iast != 0 & iast <= i) { l = concat(file, str, FILENAMESIZE) j = scan(tfile, ' ', j+i) } else { k = min0(mxstr, i) l = concat(file, tfile(j), l+1+k) j = scan(tfile, ' ', j+i) if (reset) call scopy(file, l+1-k, str, 1) } } return end # create - open a new file integer function create(name, stat) character name(ARB) integer open character stat create = open(name,stat) if (create == ERR) { call putlin(name, ERROUT) call remark(": can't create.") } return end # remove - delete a file integer function remove(file) character file(ARB) integer open, closel remove = open(file,READDELETE) if (remove != ERR) remove = closel(remove, DELETEF) return end # openc - open a file, print can't message if error integer function openc(name, stat) character name(ARB), stat integer open openc = open(name, stat) if (openc == ERR) { call putlin(name, ERROUT) call remark(": can't open.") } return end # open - open a file integer function open(name, stat) character name(ARB), stat, buf(FILENAMESIZE) integer ier include iocom.rat call scopy(name, 1, buf, 1) if (stat != PRINTF) call defnam(buf,EOS,DEFAULT$DISK,EOS,EOS,'.',.false.) do i = 1, mxfile { if (actun(i) != EOS) next call opn(i+PRINTER,buf,stat,ier) if (ier .ne. 0) open = ERR else { open = i+PRINTER actun(i) = stat } return } call remark('too many files opened.') open = ERR return end # closec - close a file, print message if error integer function closec(f, stat) character stat integer f, closel closec = closel(f, stat) if (closec == ERR) call remark('error closing file.') return end # close - close a file subroutine close(f) integer f call closel(f, SAVEF) return end # closel - close a file integer function closel(iunit,stat) include iocom.rat integer iunit character stat closel = ERR if (iunit > PRINTER) if (actun(iunit-PRINTER) == EOS) { closel = YES return } if (stat == SAVEF) close(unit=iunit,dispose='KEEP',err=99) else if (stat == DELETEF) close(unit=iunit,dispose='DELETE',err=999) else if (stat == PRINTF) _ifdef(VAX) close(unit=iunit,dispose='PRINT/DELETE',err=999) _elsedef close(unit=iunit,dispose='PRINT',err=999) _enddef else { call remark('illegal command in closel.') return } if (iunit > PRINTER) actun(iunit-PRINTER) = EOS closel = YES 99 continue return 999 continue close(unit=iunit, dispose='KEEP', err=99) if (iunit > PRINTER) actun(iunit-PRINTER) = EOS return end # cant - print can't open file message and stop subroutine cant(buf) # character buf(ARB) call putlin(buf, ERROUT) call error(": can't open.") end # error - print fatal error message, then die subroutine error(buf) character buf(ARB) call xitsta(EXIT_SEVERE_ERROR) if (buf(1) != EOS) call remark(buf) call endr4 return end # outlin - output a line subroutine outlin(buf, f) character buf(ARB) integer f call putlin(buf, f) call putch(NEWLINE, f) return end # remark - print message; assure NEWLINE subroutine remark (line) character line(ARB) integer i for (i=1; line(i) != EOS; i=i+1) { if (line(i) == '.' & line(i+1) == EOS) break call putch (line(i), ERROUT) } if (i == 1) call putch (NEWLINE, ERROUT) else if (line(i-1) != NEWLINE) call putch (NEWLINE, ERROUT) return end # getrec - read a record and insert NEWLIN and EOS integer function getrec(buf, f) character buf(ARB), nbuf(MAXCHARS) integer f, nc, ier, closel include iocom.rat 10 continue call get(f, buf, MAXCARD, nc) if (nc < 0) if (nc == EOF) { getrec = EOF buf(1) = EOF buf(2) = EOS if (f == STDIN) { # close, then reopen STDIN if (closel(STDIN, SAVEF) == ERR) call error("can't close STDIN in getrec.") call opn(STDIN, STD$IN, FORTRAN, ier) if (ier != 0) call error("can't open STDIN in getrec.") tiin = .true. } } else { call putlin('error code ', ERROUT) call itoc(nc, nbuf, MAXCHARS) call putlin(nbuf, ERROUT) call remark(' returned in getrec.') if (.true.) goto 10 } else { getrec = nc+1 buf(getrec) = NEWLINE buf(getrec+1) = EOS } return end # getlin - get a line from a file integer function getlin(inbuf, in) include iocom.rat character inbuf(ARB) integer in, getrec if (lastc < iolen) { # still some chars in ioin getlin = 0 repeat { lastc = lastc+1 getlin = getlin+1 inbuf(getlin) = ioin(lastc) } until (lastc == iolen) inbuf(getlin+1) = EOS } else getlin = getrec(inbuf, in) return #$# getlin - get a line from a file #$ integer function getlin(buf,in) #$ character buf(MAXLINE) #$ character c, getch #$ integer in,i #$ i = 0 #$ repeat { #$ i = i+1 #$ buf(i) = getch(c,in) #$ } #$ until (buf(i) == NEWLINE | buf(i) == EOF) #$ if (buf(i) == EOF) getlin = EOF #$ else getlin = i #$ if (i >= MAXLINE) call error('buffer overflow in getlin.') #$ else buf(i+1) = EOS #$ return #$ end end # getch - get characters from file character function getch(c, f) include iocom.rat character c integer f, getrec if (lastc >= iolen) { iolen = getrec(ioin, f) lastc = 0 if (iolen < 1) { c = EOF getch = EOF return } } lastc = lastc + 1 c = ioin(lastc) getch = c return #$# getch - get characters from file #$ character function getch(c, f) # integer->character #$ character buf(MAXLINE), c, buf2(MAXCARD) #$ integer f, i, lastc, nc #$ equivalence (buf, buf2) #$ data lastc /MAXLINE/, buf(MAXLINE) /NEWLINE/ #$ # note: MAXLINE = MAXCARD + 1 #$ if (buf(lastc) == NEWLINE | lastc >= MAXLINE) { #$ read(f, 1, end=10) nc, buf2 #$ 1 format(q,MAXCARD a1) #$ buf(nc+1) = NEWLINE #$ lastc = 0 #$ } #$ lastc = lastc + 1 #$ c = buf(lastc) #$ getch = c #$ return #$ 10 c = EOF #$ getch = EOF #$ return #$ end end # putch - put characters subroutine putch(c, f) character buf(MAXLINE), c, nbuf(MAXCHARS) integer f, istat, lastc, concat data lastc /0/ if (lastc >= MAXCARD | c == NEWLINE) { call put(f, buf, lastc, istat) if (istat != 0) { lastc = itoc(istat, nbuf, MAXCHARS) call scopy('error code ', 1, buf, 1) lastc = concat(buf, nbuf, MAXLINE) lastc = concat(buf, ' returned in putch', MAXLINE) call put(ERROUT, buf, lastc, istat) stop 'putch' } lastc = 0 if (c == NEWLINE) return } lastc = lastc + 1 buf(lastc) = c return end # putlin - put out line by repeated calls to putch subroutine putlin(b, f) character b(ARB) integer f, i for (i = 1; b(i) != EOS; i = i + 1) call putch(b(i), f) return end # fskip - skip n lines on file fd subroutine fskip(fd, n) integer fd, n integer*4 i4, ir4 i4 = n call skip(fd, i4, ir4) return #$# fskip - skip n lines on file fd #$ subroutine fskip(fd, n) #$ character skplin #$ integer fd, i, n #$ for (i = 1; i <= n; i = i + 1) #$ if (skplin(fd) == EOF) #$ break #$ return #$ end end # fsize - size of file in lines integer function fsize(fd) integer fd integer*4 i4, ir4 data i4/2 147 483 647/ call skip(fd, i4, ir4) if (ir4 > MAXINT) call error('file too big.') fsize = ir4 rewind fd return #$# fsize - size of file in lines #$ integer function fsize(fd) #$ character skplin #$ integer fd #$ for (fsize = 0; skplin(fd) != EOF; fsize = fsize + 1) #$ ; #$ rewind fd #$ return end #$# skplin - skip a line in a file #$ character function skplin(f) #$ integer f #$ read(f,1,end=99,err=99) #$ 1 format() #$ skplin = EOS #$ return #$99 skplin = EOF #$ return #$ end # prompt - prompt for input from STDIN subroutine prompt(buf) include iocom.rat character buf(ARB) if (!tiin) return # return if STDIN is not pointing at the terminal call putch(DOLLAR, STDIN) call putlin(buf, STDIN) call putch(NEWLINE, STDIN) return #$# prompt - output a prompt to ERROUT #$ subroutine prompt(str) #$ character str(ARB) #$ integer i, length #$ write(ERROUT,1) (str(i),i=1,length(str)) #$ 1 format('$', MAXCARD a1) #$ return #$ end end #$# inmap - convert left-adjusted ascii to right-adjusted ascii # #$ character function inmap(char) #$ integer char,ichin #$ character lch(2) #$ equivalence (ichin,lch(1)) #$ ichin = char #$ lch(2) = 0 #$ inmap = ichin #$ return #$ end #$# outmap - convert right-adjusted ascii to left-adjusted ascii # #$ integer function outmap(char) #$ character char #$ outmap = char #$ return #$ end # usrbin - get name of /usr/bin (major tools utility directory) # CHANGE FOR EACH SYSTEM subroutine usrbin(name) character name(ARB) # Insert the name of the directory where all the tools are kept call scopy(USER$BIN, 1, name, 1) return end