C define(VAX) C location of system-wide "SYMBOLS." file C maximum field for integer strings C must be highest lu for standard files C C C C RATLIB utility routines - I/O routines C ====================================== C C C Author: William P. Wood, Jr. C Computer Center C Institute For Cancer Research C 7701 Burholme Ave. C Philadelphia, Pa. 19111 C (215) 728 2760 C C Version: 2.0 C C Date: December 18, 1981 C C C C ******************************************************* C * * C * THIS SOFTWARE WAS DEVELOPED WITH SUPPORT * C * FROM THE NATIONAL INSTITUTES OF HEALTH: * C * NIH CA06927 * C * NIH CA22780 * C * * C * DIRECT INQUIRIES TO: * C * COMPUTER CENTER * C * THE INSTITUTE FOR CANCER RESEARCH * C * 7701 BURHOLME AVENUE * C * PHILADELPHIA, PENNSYLVANIA 19111 * C * * C * NO WARRANTY OR REPRESENTATION, EXPRESS OR * C * IMPLIED, IS MADE WITH RESPECT TO THE * C * CORRECTNESS, COMPLETENESS, OR USEFULNESS * C * OF THIS SOFTWARE, NOR THAT USE OF THIS * C * SOFTWARE MIGHT NOT INFRINGE PRIVATELY * C * OWNED RIGHTS. * C * * C * NO LIABILITY IS ASSUMED WITH RESPECT TO * C * THE USE OF, OR FOR DAMAGES RESULTING FROM * C * THE USE OF THIS SOFTWARE * C * * C ******************************************************* C C acopy - copy size lines from fdi to fdo SUBROUTINE ACOPY(FDI, FDO, SIZE) INTEGER FDI, FDO, SIZE INTEGER*4NI4, NCOP NI4 = SIZE CALL COPY(FDI, FDO, NI4, NCOP) C$ integer getlin C$ character buf(MAXLINE) C$ integer fdi, fdo, i, size C$ for (i = 1; i <= size; i = i + 1) { C$ if (getlin(buf, fdi) == EOF) C$ break C$ call putlin(buf, fdo) C$ } RETURN END C amove - move name1 to name2 SUBROUTINE AMOVE(NAME1, NAME2) BYTE NAME1(1), NAME2(1) INTEGER CREATE, OPEN INTEGER FD1, FD2 FD1 = OPEN(NAME1, 'R') IF (.NOT.(FD1 .EQ. -1)) GOTO 2000 CALL CANT(NAME1) 2000 CONTINUE FD2 = CREATE(NAME2, 'W') IF (.NOT.(FD2 .EQ. -1)) GOTO 2020 CALL CANT(NAME2) 2020 CONTINUE CALL FCOPY(FD1, FD2) RETURN END C fcopy - copy file in to file out SUBROUTINE FCOPY(IN, OUT) INTEGER IN, OUT INTEGER*4NI4, NCOP DATA NI4/2147483647/ CALL COPY(IN, OUT, NI4, NCOP) C$ character buf(MAXLINE) C$ integer getlin C$ integer in, out C$ while (getlin(buf, in) != EOF) C$ call putlin(buf, out) RETURN END C initr4 - initialize standard files SUBROUTINE INITR4 COMMON/FCOMR/MXFILE, IOLEN, LASTC, TIIN, ACTUN(6), IOIN(134) INTEGER MXFILE INTEGER IOLEN INTEGER LASTC LOGICAL TIIN BYTE ACTUN BYTE IOIN COMMON/CARG/ARGSTR(134), UPFLAG, NOREAD BYTE ARGSTR LOGICAL UPFLAG, NOREAD INTEGER IER, I LASTC = 0 IOLEN = 0 DO 2040 I = 1, 6 ACTUN(I) = 0 2040 CONTINUE MXFILE = 6 C fold commands to upper case UPFLAG = .TRUE. C haven't read command line yet NOREAD = .TRUE. CALL OPN(3, 'TI:', 'W', IER) IF (.NOT.(IER .NE. 0)) GOTO 2060 STOP'can''t open ERROUT' 2060 CONTINUE C open with carriagecontrol=fortran CALL OPN(5, 'TI:', 'F', IER) IF (.NOT.(IER .NE. 0)) GOTO 2080 CALL ERROR('can''t open STDIN.') 2080 CONTINUE TIIN = .TRUE. CALL OPN(2, 'TI:', 'W', IER) IF (.NOT.(IER .NE. 0)) GOTO 2100 CALL ERROR('can''t open STDOUT.') 2100 CONTINUE C close error CALL ERRSET(28, .TRUE., .FALSE., .TRUE., .FALSE., 15) C no such file CALL ERRSET(29, .TRUE., .FALSE., .TRUE., .FALSE., 15) C open failure CALL ERRSET(30, .TRUE., .FALSE., .TRUE., .FALSE., 15) C file name specification CALL ERRSET(43, .TRUE., .FALSE., .FALSE., .FALSE., 15) RETURN END C endr4 - close up shop SUBROUTINE ENDR4 CALL CLOSEC(2, 'S') CALL CLOSEC(5, 'S') CALL CLOSEC(3, 'S') CALL EXIT END C defnam - provide defaults for file name, reset new defaults - C compatible with old version, doesn't return version number and C doesn't have special processing for asterisks SUBROUTINE DEFNAM(FILE, NODE, DEV, UIC, NAME, EXT, RESET) BYTE FILE(34) BYTE NODE(1), DEV(6), UIC(10), NAME(10), EXT(5), VER(7) LOGICAL RESET VER(1) = 0 CALL FPARSE(FILE, NODE, DEV, UIC, NAME, EXT, VER, RESET, .FALSE.) RETURN END C fparse - provide defaults for file name, reset new defaults. C if astrsk is true, asterisks will use the defaults. SUBROUTINE FPARSE(FILE, NODE, DEV, UIC, NAME, EXT, VER, RESET, AST *RSK) BYTE FILE(34), TEMP(34) BYTE NODE(1), DEV(6), UIC(10), NAME(10), EXT(5), VER(7) LOGICAL RESET, ASTRSK INTEGER L, J, ICP, LEN INTEGER INDEXQ, BKSCNQ, CONCAT, SCAN TEMP(1) = 0 LEN = CONCAT(TEMP, FILE(SCAN(FILE, ' ', 1)), 34) FILE(1) = 0 J = 1 L = 0 ICP = INDEXQ(TEMP(J), ':') IF (.NOT.(ICP .NE. 0)) GOTO 2120 IF (.NOT.(TEMP(ICP+1) .EQ. ':')) GOTO 2140 ICP = ICP + 1 GOTO 2150 2140 CONTINUE ICP = 0 2150 CONTINUE 2120 CONTINUE CALL ADSTR(ICP, J, L, FILE, TEMP, NODE, 1 - 1, RESET, .FALSE.) CALL ADSTR(INDEXQ(TEMP(J), ':'), J, L, FILE, TEMP, DEV, 6 - 1, RES *ET, .FALSE.) CALL ADSTR(INDEXQ(TEMP(J), ']'), J, L, FILE, TEMP, UIC, 10 - 1, RE *SET, .FALSE.) CALL ADSTR(BKSCNQ(TEMP, ' .;', J) - J, J, L, FILE, TEMP, NAME, 10 *- 1, RESET, ASTRSK) CALL ADSTR(BKSCNQ(TEMP, ' ;', J) - J, J, L, FILE, TEMP, EXT, 5 - 1 *, RESET, ASTRSK) CALL ADSTR(LEN + 1 - J, J, L, FILE, TEMP, VER, 7 - 1, RESET, .FALS *E.) RETURN END C 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 BYTE FILE(1), TFILE(1), STR(1) LOGICAL RESET, ASTRSK IF (.NOT.(I .EQ. 0)) GOTO 2160 L = CONCAT(FILE, STR, 34) GOTO 2170 2160 CONTINUE IF (.NOT.(ASTRSK)) GOTO 2180 IAST = INDEXQ(TFILE(J), '*') GOTO 2190 2180 CONTINUE IAST = 0 2190 CONTINUE IF (.NOT.(IAST .NE. 0 .AND. IAST .LE. I)) GOTO 2200 L = CONCAT(FILE, STR, 34) J = SCAN(TFILE, ' ', J + I) GOTO 2210 2200 CONTINUE K = MIN0(MXSTR, I) L = CONCAT(FILE, TFILE(J), L + 1 + K) J = SCAN(TFILE, ' ', J + I) IF (.NOT.(RESET)) GOTO 2220 CALL SCOPY(FILE, L + 1 - K, STR, 1) 2220 CONTINUE 2210 CONTINUE 2170 CONTINUE RETURN END C create - open a new file INTEGER FUNCTION CREATE(NAME, STAT) BYTE NAME(1) INTEGER OPEN BYTE STAT CREATE = OPEN(NAME, STAT) IF (.NOT.(CREATE .EQ. -1)) GOTO 2240 CALL PUTLIN(NAME, 3) CALL REMARK(': can''t create.') 2240 CONTINUE RETURN END C remove - delete a file INTEGER FUNCTION REMOVE(FILE) BYTE FILE(1) INTEGER OPEN, CLOSEL REMOVE = OPEN(FILE, 'X') IF (.NOT.(REMOVE .NE. -1)) GOTO 2260 REMOVE = CLOSEL(REMOVE, 'D') 2260 CONTINUE RETURN END C openc - open a file, print can't message if error INTEGER FUNCTION OPENC(NAME, STAT) BYTE NAME(1), STAT INTEGER OPEN OPENC = OPEN(NAME, STAT) IF (.NOT.(OPENC .EQ. -1)) GOTO 2280 CALL PUTLIN(NAME, 3) CALL REMARK(': can''t open.') 2280 CONTINUE RETURN END C open - open a file INTEGER FUNCTION OPEN(NAME, STAT) BYTE NAME(1), STAT, BUF(34) INTEGER IER COMMON/FCOMR/MXFILE, IOLEN, LASTC, TIIN, ACTUN(6), IOIN(134) INTEGER MXFILE INTEGER IOLEN INTEGER LASTC LOGICAL TIIN BYTE ACTUN BYTE IOIN CALL SCOPY(NAME, 1, BUF, 1) IF (.NOT.(STAT .NE. 'P')) GOTO 2300 CALL DEFNAM(BUF, 0, 'SY:', 0, 0, '.', .FALSE.) 2300 CONTINUE DO 2320 I = 1, MXFILE IF (.NOT.(ACTUN(I) .NE. 0)) GOTO 2340 GOTO 2320 2340 CONTINUE CALL OPN(I + 6, BUF, STAT, IER) IF (.NOT.(IER.NE.0)) GOTO 2360 OPEN = - 1 GOTO 2370 2360 CONTINUE OPEN = I + 6 ACTUN(I) = STAT 2370 CONTINUE RETURN 2320 CONTINUE CALL REMARK('too many files opened.') OPEN = - 1 RETURN END C closec - close a file, print message if error INTEGER FUNCTION CLOSEC(F, STAT) BYTE STAT INTEGER F, CLOSEL CLOSEC = CLOSEL(F, STAT) IF (.NOT.(CLOSEC .EQ. -1)) GOTO 2380 CALL REMARK('error closing file.') 2380 CONTINUE RETURN END C close - close a file SUBROUTINE CLOSE(F) INTEGER F CALL CLOSEL(F, 'S') RETURN END C closel - close a file INTEGER FUNCTION CLOSEL(IUNIT, STAT) COMMON/FCOMR/MXFILE, IOLEN, LASTC, TIIN, ACTUN(6), IOIN(134) INTEGER MXFILE INTEGER IOLEN INTEGER LASTC LOGICAL TIIN BYTE ACTUN BYTE IOIN INTEGER IUNIT BYTE STAT CLOSEL = - 1 IF (.NOT.(IUNIT .GT. 6)) GOTO 2400 IF (.NOT.(ACTUN(IUNIT-6) .EQ. 0)) GOTO 2420 CLOSEL = 1 RETURN 2420 CONTINUE 2400 CONTINUE IF (.NOT.(STAT .EQ. 'S')) GOTO 2440 CLOSE(UNIT = IUNIT, DISPOSE = 'KEEP', ERR = 99) GOTO 2450 2440 CONTINUE IF (.NOT.(STAT .EQ. 'D')) GOTO 2460 CLOSE(UNIT = IUNIT, DISPOSE = 'DELETE', ERR = 999) GOTO 2450 2460 CONTINUE IF (.NOT.(STAT .EQ. 'P')) GOTO 2480 CLOSE(UNIT = IUNIT, DISPOSE = 'PRINT', ERR = 999) GOTO 2450 2480 CONTINUE CALL REMARK('illegal command in closel.') RETURN 2450 CONTINUE IF (.NOT.(IUNIT .GT. 6)) GOTO 2500 ACTUN(IUNIT - 6) = 0 2500 CONTINUE CLOSEL = 1 99 CONTINUE RETURN 999 CONTINUE CLOSE(UNIT = IUNIT, DISPOSE = 'KEEP', ERR = 99) IF (.NOT.(IUNIT .GT. 6)) GOTO 2520 ACTUN(IUNIT - 6) = 0 2520 CONTINUE RETURN END C cant - print can't open file message and stop C SUBROUTINE CANT(BUF) BYTE BUF(1) CALL PUTLIN(BUF, 3) CALL ERROR(': can''t open.') END C error - print fatal error message, then die SUBROUTINE ERROR(BUF) BYTE BUF(1) CALL XITSTA(4) IF (.NOT.(BUF(1) .NE. 0)) GOTO 2540 CALL REMARK(BUF) 2540 CONTINUE CALL ENDR4 RETURN END C outlin - output a line SUBROUTINE OUTLIN(BUF, F) BYTE BUF(1) INTEGER F CALL PUTLIN(BUF, F) CALL PUTCH(10, F) RETURN END C remark - print message; assure NEWLINE SUBROUTINE REMARK(LINE) BYTE LINE(1) INTEGER I I = 1 2560 IF (.NOT.(LINE(I) .NE. 0)) GOTO 2580 IF (.NOT.(LINE(I) .EQ. '.' .AND. LINE(I+1) .EQ. 0)) GOTO 2590 GOTO 2580 2590 CONTINUE CALL PUTCH(LINE(I), 3) 2570 I = I + 1 GOTO 2560 2580 CONTINUE IF (.NOT.(I .EQ. 1)) GOTO 2610 CALL PUTCH(10, 3) GOTO 2620 2610 CONTINUE IF (.NOT.(LINE(I-1) .NE. 10)) GOTO 2630 CALL PUTCH(10, 3) 2630 CONTINUE 2620 CONTINUE RETURN END C getrec - read a record and insert NEWLIN and EOS INTEGER FUNCTION GETREC(BUF, F) BYTE BUF(1), NBUF(7) INTEGER F, NC, IER, CLOSEL COMMON/FCOMR/MXFILE, IOLEN, LASTC, TIIN, ACTUN(6), IOIN(134) INTEGER MXFILE INTEGER IOLEN INTEGER LASTC LOGICAL TIIN BYTE ACTUN BYTE IOIN 10 CONTINUE CALL GET(F, BUF, 132, NC) IF (.NOT.(NC .LT. 0)) GOTO 2650 IF (.NOT.(NC .EQ. -10)) GOTO 2670 GETREC = - 10 BUF(1) = - 10 BUF(2) = 0 IF (.NOT.(F .EQ. 5)) GOTO 2690 C close, then reopen STDIN IF (.NOT.(CLOSEL(5, 'S') .EQ. -1)) GOTO 2710 CALL ERROR('can''t close STDIN in getrec.') 2710 CONTINUE CALL OPN(5, 'TI:', 'F', IER) IF (.NOT.(IER .NE. 0)) GOTO 2730 CALL ERROR('can''t open STDIN in getrec.') 2730 CONTINUE TIIN = .TRUE. 2690 CONTINUE GOTO 2680 2670 CONTINUE CALL PUTLIN('error code ', 3) CALL ITOC(NC, NBUF, 7) CALL PUTLIN(NBUF, 3) CALL REMARK(' returned in getrec.') IF (.NOT.(.TRUE.)) GOTO 2750 GOTO 10 2750 CONTINUE 2680 CONTINUE GOTO 2660 2650 CONTINUE GETREC = NC + 1 BUF(GETREC) = 10 BUF(GETREC + 1) = 0 2660 CONTINUE RETURN END C getlin - get a line from a file INTEGER FUNCTION GETLIN(INBUF, IN) COMMON/FCOMR/MXFILE, IOLEN, LASTC, TIIN, ACTUN(6), IOIN(134) INTEGER MXFILE INTEGER IOLEN INTEGER LASTC LOGICAL TIIN BYTE ACTUN BYTE IOIN BYTE INBUF(1) INTEGER IN, GETREC IF (.NOT.(LASTC .LT. IOLEN)) GOTO 2770 C still some chars in ioin GETLIN = 0 2790 CONTINUE LASTC = LASTC + 1 GETLIN = GETLIN + 1 INBUF(GETLIN) = IOIN(LASTC) 2800 IF (.NOT.(LASTC .EQ. IOLEN)) GOTO 2790 INBUF(GETLIN + 1) = 0 GOTO 2780 2770 CONTINUE GETLIN = GETREC(INBUF, IN) 2780 CONTINUE RETURN C$# getlin - get a line from a file C$ integer function getlin(buf,in) C$ character buf(MAXLINE) C$ character c, getch C$ integer in,i C$ i = 0 C$ repeat { C$ i = i+1 C$ buf(i) = getch(c,in) C$ } C$ until (buf(i) == NEWLINE | buf(i) == EOF) C$ if (buf(i) == EOF) getlin = EOF C$ else getlin = i C$ if (i >= MAXLINE) call error('buffer overflow in getlin.') C$ else buf(i+1) = EOS C$ return C$ end END C getch - get characters from file BYTE FUNCTION GETCH(C, F) COMMON/FCOMR/MXFILE, IOLEN, LASTC, TIIN, ACTUN(6), IOIN(134) INTEGER MXFILE INTEGER IOLEN INTEGER LASTC LOGICAL TIIN BYTE ACTUN BYTE IOIN BYTE C INTEGER F, GETREC IF (.NOT.(LASTC .GE. IOLEN)) GOTO 2820 IOLEN = GETREC(IOIN, F) LASTC = 0 IF (.NOT.(IOLEN .LT. 1)) GOTO 2840 C = - 10 GETCH = - 10 RETURN 2840 CONTINUE 2820 CONTINUE LASTC = LASTC + 1 C = IOIN(LASTC) GETCH = C RETURN C$# getch - get characters from file C$ character function getch(c, f) # integer->character C$ character buf(MAXLINE), c, buf2(MAXCARD) C$ integer f, i, lastc, nc C$ equivalence (buf, buf2) C$ data lastc /MAXLINE/, buf(MAXLINE) /NEWLINE/ C$ # note: MAXLINE = MAXCARD + 1 C$ if (buf(lastc) == NEWLINE | lastc >= MAXLINE) { C$ read(f, 1, end=10) nc, buf2 C$ 1 format(q,MAXCARD a1) C$ buf(nc+1) = NEWLINE C$ lastc = 0 C$ } C$ lastc = lastc + 1 C$ c = buf(lastc) C$ getch = c C$ return C$ 10 c = EOF C$ getch = EOF C$ return C$ end END C putch - put characters SUBROUTINE PUTCH(C, F) BYTE BUF(134), C, NBUF(7) INTEGER F, ISTAT, LASTC, CONCAT DATA LASTC/0/ IF (.NOT.(LASTC .GE. 132 .OR. C .EQ. 10)) GOTO 2860 CALL PUT(F, BUF, LASTC, ISTAT) IF (.NOT.(ISTAT .NE. 0)) GOTO 2880 LASTC = ITOC(ISTAT, NBUF, 7) CALL SCOPY('error code ', 1, BUF, 1) LASTC = CONCAT(BUF, NBUF, 134) LASTC = CONCAT(BUF, ' returned in putch', 134) CALL PUT(3, BUF, LASTC, ISTAT) STOP'putch' 2880 CONTINUE LASTC = 0 IF (.NOT.(C .EQ. 10)) GOTO 2900 RETURN 2900 CONTINUE 2860 CONTINUE LASTC = LASTC + 1 BUF(LASTC) = C RETURN END C putlin - put out line by repeated calls to putch SUBROUTINE PUTLIN(B, F) BYTE B(1) INTEGER F, I I = 1 2920 IF (.NOT.(B(I) .NE. 0)) GOTO 2940 CALL PUTCH(B(I), F) 2930 I = I + 1 GOTO 2920 2940 CONTINUE RETURN END C fskip - skip n lines on file fd SUBROUTINE FSKIP(FD, N) INTEGER FD, N INTEGER*4I4, IR4 I4 = N CALL SKIP(FD, I4, IR4) RETURN C$# fskip - skip n lines on file fd C$ subroutine fskip(fd, n) C$ character skplin C$ integer fd, i, n C$ for (i = 1; i <= n; i = i + 1) C$ if (skplin(fd) == EOF) C$ break C$ return C$ end END C fsize - size of file in lines INTEGER FUNCTION FSIZE(FD) INTEGER FD INTEGER*4I4, IR4 DATA I4/2147483647/ CALL SKIP(FD, I4, IR4) IF (.NOT.(IR4 .GT. 32767)) GOTO 2950 CALL ERROR('file too big.') 2950 CONTINUE FSIZE = IR4 REWIND FD RETURN C$# fsize - size of file in lines C$ integer function fsize(fd) C$ character skplin C$ integer fd C$ for (fsize = 0; skplin(fd) != EOF; fsize = fsize + 1) C$ ; C$ rewind fd C$ return END C$# skplin - skip a line in a file C$ character function skplin(f) C$ integer f C$ read(f,1,end=99,err=99) C$ 1 format() C$ skplin = EOS C$ return C$99 skplin = EOF C$ return C$ end C prompt - prompt for input from STDIN SUBROUTINE PROMPT(BUF) COMMON/FCOMR/MXFILE, IOLEN, LASTC, TIIN, ACTUN(6), IOIN(134) INTEGER MXFILE INTEGER IOLEN INTEGER LASTC LOGICAL TIIN BYTE ACTUN BYTE IOIN BYTE BUF(1) IF (.NOT.(.NOT.TIIN)) GOTO 2970 C return if STDIN is not pointing at the terminal RETURN 2970 CONTINUE CALL PUTCH(36, 5) CALL PUTLIN(BUF, 5) CALL PUTCH(10, 5) RETURN C$# prompt - output a prompt to ERROUT C$ subroutine prompt(str) C$ character str(ARB) C$ integer i, length C$ write(ERROUT,1) (str(i),i=1,length(str)) C$ 1 format('$', MAXCARD a1) C$ return C$ end END C$# inmap - convert left-adjusted ascii to right-adjusted ascii # C$ character function inmap(char) C$ integer char,ichin C$ character lch(2) C$ equivalence (ichin,lch(1)) C$ ichin = char C$ lch(2) = 0 C$ inmap = ichin C$ return C$ end C$# outmap - convert right-adjusted ascii to left-adjusted ascii # C$ integer function outmap(char) C$ character char C$ outmap = char C$ return C$ end C usrbin - get name of /usr/bin (major tools utility directory) C CHANGE FOR EACH SYSTEM SUBROUTINE USRBIN(NAME) BYTE NAME(1) C Insert the name of the directory where all the tools are kept CALL SCOPY('DP1:[6,110]', 1, NAME, 1) RETURN END