C max card size C maximum field for integer strings C must be 2 more than MAXCARD C must be highest lu for standard files C C C C RATFIV structured Fortran compiler C ================================== C C Authors: Original by B. Kernighan and P. J. Plauger, C with rewrites and enhancements by David Hanson and C friends (U. of Arizona), Joe Sventek and Debbie C Scherrer (Lawrence Berkely Laboratory), and C William Wood (Institute For Cancer Research). C C Address: William Wood C Computer Center C Institute For Cancer Research C 7701 Burholme Ave. C Philadelphia, Pa. 19111 C (215) 728 2760 C C Version: 1.0 C C Date: May 14, 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 * THIS SOFTWARE WAS DESIGNED FOR USE ON A * C * PDP-11/70 OPERATING UNDER IAS V3.0 USING * C * THE FORTRAN-IV PLUS COMPILER. * 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, OPENL INTEGER FD1, FD2 FD1 = OPENL(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/2000000/ 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, ACTUN(6) BYTE ACTUN INTEGER MXFILE COMMON/FCOMR2/TIIN LOGICAL TIIN COMMON/CARG/ARGSTR(134), UPFLAG, NOREAD BYTE ARGSTR LOGICAL UPFLAG, NOREAD COMMON/RAT401/LASTC, BUF BYTE BUF(134) INTEGER LASTC INTEGER IER, I LASTC = 1 BUF(LASTC) = 13 DO 2040 I = 1, 6 ACTUN(I) = 0 2040 CONTINUE 2050 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 create - open a new file INTEGER FUNCTION CREATE(NAME, STAT) BYTE NAME(1) INTEGER OPENL BYTE STAT CREATE = OPENL(NAME, STAT) IF (.NOT.(CREATE .EQ. -1)) GOTO 2120 CALL PUTLIN(NAME, 3) CALL REMARK(': can''t create.') 2120 CONTINUE RETURN END C remove - delete a file INTEGER FUNCTION REMOVE(FILE) BYTE FILE(1) INTEGER OPENL, CLOSEL REMOVE = OPENL(FILE, 'X') IF (.NOT.(REMOVE .NE. -1)) GOTO 2140 REMOVE = CLOSEL(REMOVE, 'D') 2140 CONTINUE RETURN END C openc - open a file, print can't message if error INTEGER FUNCTION OPENC(NAME, STAT) BYTE NAME(1), STAT INTEGER OPENL OPENC = OPENL(NAME, STAT) IF (.NOT.(OPENC .EQ. -1)) GOTO 2160 CALL PUTLIN(NAME, 3) CALL REMARK(': can''t open.') 2160 CONTINUE RETURN END C open - open a file C openl - open a file INTEGER FUNCTION OPEN(NAME, STAT) ENTRY OPENL(NAME, STAT) BYTE NAME(1), STAT, BUF(34) INTEGER IER COMMON/FCOMR/MXFILE, ACTUN(6) BYTE ACTUN INTEGER MXFILE COMMON/FCOMR2/TIIN LOGICAL TIIN CALL SCOPY(NAME, 1, BUF, 1) IF (.NOT.(STAT .NE. 'P')) GOTO 2180 CALL DEFNAM(BUF, 0, 'SY:', 0, 0, '.', .FALSE.) 2180 CONTINUE DO 2200 I = 1, MXFILE IF (.NOT.(ACTUN(I) .NE. 0)) GOTO 2220 GOTO 2200 2220 CONTINUE CALL OPN(I + 6, BUF, STAT, IER) IF (.NOT.(IER.NE.0)) GOTO 2240 OPEN = - 1 GOTO 2250 2240 CONTINUE OPEN = I + 6 ACTUN(I) = STAT 2250 CONTINUE RETURN 2200 CONTINUE 2210 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 2260 CALL REMARK('error closing file.') 2260 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, ACTUN(6) BYTE ACTUN INTEGER MXFILE COMMON/FCOMR2/TIIN LOGICAL TIIN INTEGER IUNIT BYTE STAT CLOSEL = - 1 IF (.NOT.(IUNIT .GT. 6)) GOTO 2280 IF (.NOT.(ACTUN(IUNIT-6) .EQ. 0)) GOTO 2300 CLOSEL = 1 RETURN 2300 CONTINUE 2280 CONTINUE IF (.NOT.(STAT .EQ. 'S')) GOTO 2320 close(unit=iunit,dispose='KEEP',err=99) GOTO 2330 2320 CONTINUE IF (.NOT.(STAT .EQ. 'D')) GOTO 2340 close(unit=iunit,dispose='DELETE',err=999) GOTO 2350 2340 CONTINUE IF (.NOT.(STAT .EQ. 'P')) GOTO 2360 close(unit=iunit,dispose='PRINT',err=999) GOTO 2370 2360 CONTINUE CALL REMARK('illegal command in closel.') RETURN 2370 CONTINUE 2350 CONTINUE 2330 CONTINUE IF (.NOT.(IUNIT .GT. 6)) GOTO 2380 ACTUN(IUNIT - 6) = 0 2380 CONTINUE CLOSEL = 1 99 CONTINUE RETURN 999 CONTINUE close(unit=iunit, dispose='KEEP', err=99) IF (.NOT.(IUNIT .GT. 6)) GOTO 2400 ACTUN(IUNIT - 6) = 0 2400 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 defnam - provide defaults for file name, reset new defaults SUBROUTINE DEFNAM(FILE, NODE, DEV, UIC, NAME, EXT, RESET) BYTE FILE(34) BYTE NODE(1), DEV(6), UIC(10), NAME(10), EXT(5) BYTE TEMP(34) LOGICAL RESET INTEGER L, J INTEGER INDEX, BKSCAN, CONCAT, SCAN TEMP(1) = 0 J = CONCAT(TEMP, FILE(SCAN(FILE, ' ', 1)), 34) FILE(1) = 0 J = 1 L = 0 CALL ADSTR(INDEX(TEMP(J), ':'), J, L, FILE, TEMP, DEV, 6 - 1, RESE *T) CALL ADSTR(INDEX(TEMP(J), ']'), J, L, FILE, TEMP, UIC, 10 - 1, RES *ET) CALL ADSTR(BKSCAN(TEMP, ' .;', J) - J, J, L, FILE, TEMP, NAME, 10 *- 1, RESET) CALL ADSTR(BKSCAN(TEMP, ' ;', J) - J, J, L, FILE, TEMP, EXT, 5 - 1 *, RESET) C append possible version L = CONCAT(FILE, TEMP(J), 34) RETURN END C adstr - support routine for defnam SUBROUTINE ADSTR(I, J, L, FILE, TFILE, STR, MXSTR, RESET) INTEGER I, J, L, MXSTR, K INTEGER CONCAT, SCAN BYTE FILE(1), TFILE(1), STR(1) LOGICAL RESET IF (.NOT.(I .EQ. 0)) GOTO 2420 L = CONCAT(FILE, STR, 34) GOTO 2430 2420 CONTINUE K = MIN0(MXSTR, I) L = CONCAT(FILE, TFILE(J), L + 1 + K) J = SCAN(TFILE, ' ', J + I) IF (.NOT.(RESET)) GOTO 2440 CALL SCOPY(FILE, L + 1 - K, STR, 1) 2440 CONTINUE 2430 CONTINUE RETURN 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 2460 CALL REMARK(BUF) 2460 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(13, F) RETURN END C remark - print message; assure NEWLINE SUBROUTINE REMARK(LINE) BYTE LINE(1) INTEGER I I = 1 2480 IF (.NOT.(LINE(I) .NE. 0)) GOTO 2500 IF (.NOT.(LINE(I) .EQ. '.' .AND. LINE(I+1) .EQ. 0)) GOTO 2510 GOTO 2500 2510 CONTINUE CALL PUTCH(LINE(I), 3) 2490 I = I + 1 GOTO 2480 2500 CONTINUE IF (.NOT.(I .EQ. 1)) GOTO 2530 CALL PUTCH(13, 3) GOTO 2540 2530 CONTINUE IF (.NOT.(LINE(I-1) .NE. 13)) GOTO 2550 CALL PUTCH(13, 3) 2550 CONTINUE 2540 CONTINUE RETURN END C getrec - read a record and insert NEWLIN and EOS INTEGER FUNCTION GETREC(BUF, F) BYTE BUF(1), NBUF(10) INTEGER F, NC, IER, CLOSEL COMMON/FCOMR/MXFILE, ACTUN(6) BYTE ACTUN INTEGER MXFILE COMMON/FCOMR2/TIIN LOGICAL TIIN 10 CONTINUE CALL GET(F, BUF, 132, NC) IF (.NOT.(NC .LT. 0)) GOTO 2570 IF (.NOT.(NC .EQ. -10)) GOTO 2590 GETREC = - 10 BUF(1) = - 10 BUF(2) = 0 IF (.NOT.(F .EQ. 5)) GOTO 2610 C close, then reopen STDIN IF (.NOT.(CLOSEL(5, 'S') .EQ. -1)) GOTO 2630 CALL ERROR('can''t close STDIN in getrec.') 2630 CONTINUE CALL OPN(5, 'TI:', 'F', IER) IF (.NOT.(IER .NE. 0)) GOTO 2650 CALL ERROR('can''t open STDIN in getrec.') 2650 CONTINUE TIIN = .TRUE. 2610 CONTINUE GOTO 2600 2590 CONTINUE CALL PUTLIN('fcs error code ', 3) CALL ITOC(NC, NBUF, 10) CALL PUTLIN(NBUF, 3) CALL REMARK(' returned in getrec.') IF (.NOT.(.TRUE.)) GOTO 2670 GOTO 10 2670 CONTINUE 2600 CONTINUE GOTO 2580 2570 CONTINUE GETREC = NC + 1 BUF(GETREC) = 13 BUF(GETREC + 1) = 0 2580 CONTINUE RETURN END C getlin - get a line from a file INTEGER FUNCTION GETLIN(INBUF, IN) COMMON/RAT401/LASTC, BUF BYTE BUF(134) INTEGER LASTC BYTE INBUF(1) INTEGER IN, GETREC IF (.NOT.(BUF(LASTC) .NE. 13)) GOTO 2690 C still some chars in buf GETLIN = 0 2710 CONTINUE LASTC = LASTC + 1 GETLIN = GETLIN + 1 INBUF(GETLIN) = BUF(LASTC) 2720 IF (.NOT.(BUF(LASTC) .EQ. 13)) GOTO 2710 2730 CONTINUE INBUF(GETLIN + 1) = 0 GOTO 2700 2690 CONTINUE GETLIN = GETREC(INBUF, IN) 2700 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/RAT401/LASTC, BUF BYTE BUF(134) INTEGER LASTC BYTE C INTEGER F, NC, GETREC IF (.NOT.(BUF(LASTC) .EQ. 13)) GOTO 2740 NC = GETREC(BUF, F) IF (.NOT.(NC .GE. 0)) GOTO 2760 LASTC = 0 GOTO 2770 2760 CONTINUE C = - 10 GETCH = - 10 BUF(3) = 13 LASTC = 3 RETURN 2770 CONTINUE 2740 CONTINUE LASTC = LASTC + 1 C = BUF(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(10) INTEGER F, ISTAT, LASTC, CONCAT DATA LASTC/0/ IF (.NOT.(LASTC .GE. 132 .OR. C .EQ. 13)) GOTO 2780 CALL PUT(F, BUF, LASTC, ISTAT) IF (.NOT.(ISTAT .NE. 0)) GOTO 2800 LASTC = ITOC(ISTAT, NBUF, 10) CALL SCOPY('fcs 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' 2800 CONTINUE LASTC = 0 IF (.NOT.(C .EQ. 13)) GOTO 2820 RETURN 2820 CONTINUE 2780 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 2840 IF (.NOT.(B(I) .NE. 0)) GOTO 2860 CALL PUTCH(B(I), F) 2850 I = I + 1 GOTO 2840 2860 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/2000000/ CALL SKIP(FD, I4, IR4) IF (.NOT.(IR4 .GT. 32767)) GOTO 2870 CALL ERROR('file too big.') 2870 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, ACTUN(6) BYTE ACTUN INTEGER MXFILE COMMON/FCOMR2/TIIN LOGICAL TIIN BYTE BUF(1), TCHAR, TBUF(134) INTEGER I DATA TCHAR/1H./, TBUF(1)/'$'/ IF (.NOT.(.NOT.TIIN)) GOTO 2890 C return if STDIN is not pointing at the terminal RETURN 2890 CONTINUE I = 1 2910 IF (.NOT.(BUF(I) .NE. TCHAR .AND. I .LT. 134-1)) GOTO 2930 TBUF(I + 1) = BUF(I) 2920 I = I + 1 GOTO 2910 2930 CONTINUE TBUF(I + 1) = 0 CALL PUTLIN(TBUF, 5) CALL PUTCH(13, 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$ byte 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