C C C C LIST File Listing Utility C ========================= C C Author: William Wood C C Address: 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 1, 1980 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 C C note the order of the next several defines is significant! C comment this out for export version C ICR ONLY define(NOTICR,# NOT ICR) C Local ICR functions supported by LIST: C Invoke LIST on SRD-selected files C Route output to printer port of DT80 C Invoke HELP facility for LIST C Allow screen widths other than SCRWIDTH C Record or Block i/o. C set to define(RECORDIO,) for record io C size of buffer for mark/point C BLOCK IO define(MARKSIZE,3) C gttyp - get terminal type SUBROUTINE GTTYP(F) INTEGER F, F2, TYPE, ACR, IERR parameter IOWAL = "410 parameter TCTTP="10, TCWID="1, SFGMC="2560, TUSR0="20, TCHHT="21, * SFSMC="2440, TCHFF = "17, TCACR = "24 COMMON/TERM/SCRSIZ, SCRWID, SYSWID, SAVTAB, HLF, AUTOCR C current screen size; init: SCRLENGTH INTEGER SCRSIZ C (SCRLENGTH = real screen length-1 = 23) C current screen width; init: syswid INTEGER SCRWID C screen width from terminal driver (see gttyp) INTEGER SYSWID C saves value of system's hardware tabs flag INTEGER SAVTAB C true if hardware after col 80 (see gttyp) LOGICAL HLF C true if term set for auto carriagreturn (see gttyp) LOGICAL AUTOCR SCRSIZ = 23 C C the return of screen width is inconsistent across operating systems; C thus it is an installation dependent function, but could be included C if you figure out how the screen width is returned at your installation. C C ICR ONLY call qiofn(f, SFGMC, TCWID, syswid, ierr) # get screen width C ICR ONLY if (ierr == 0) C ICR ONLY if (syswid > 0) C ICR ONLY syswid = syswid-1 C ICR ONLY else C ICR ONLY syswid = 256+syswid-1 C ICR ONLY else SYSWID = 80 SCRWID = SYSWID C C if your terminals do a hardware line feed and carriagereturn after the C 80th character but before the 81st character (ADM3A's do this if set for C auto newline in their switch bank) then set hlf (hardware line-feed) to C true, otherwise set hlf to false. C On our system, ADM3A's have terminal type USR0. C C ICR ONLY call qiofn(f, SFGMC, TCTTP, type, ierr) # get terminal type C ICR ONLY if (type == TUSR0 | ierr ~= 0) HLF = .TRUE. C ICR ONLY else C ICR ONLY hlf = .false. C C if your terminal is set for auto carriagereturn then software tabs work C properly all the time; otherwise they only work properly for the first C line of output from a record. Therefore autocr should be set true if the C terminal is set for auto carriagereturn, so that NUMLIN knows what's what. C The following code probably won't have to be modified. C note: auto carriagereturn is known as "wrap" on M systems. C C get auto carriagereturn flag - CALL QIOFN(F, SFGMC, TCACR, ACR, IERR) C used in NUMLIN IF (.NOT.(ACR .EQ. 1 .AND. IERR .EQ. 0)) GOTO 2000 AUTOCR = .TRUE. GOTO 2010 2000 CONTINUE AUTOCR = .FALSE. C C now set terminal for no hardware tabs so NUMLIN knows where it is on the screen C 2010 CONTINUE CALL QIOFN(F, SFGMC, TCHHT, SAVTAB, IERR) CALL QIOFN(F, SFSMC, TCHHT, 0, IERR) RETURN C tabbak - reset hardware tab status on exit from list. C also reset screen width. ENTRY TABBAK(F2) CALL QIOFN(F2, SFSMC, TCHHT, SAVTAB, IERR) C ICR ONLY call setwid(f2, syswid) RETURN END C qiofn - do a qio function SUBROUTINE QIOFN(F, FUNC, CHAR, VAL, IERR) INTEGER F, FUNC, CHAR, VAL, IERR, DPB(6), DSW, IOSB(2) BYTE BUF(2), BIOSB parameter IOWAL = "410 parameter TCTTP="10, TCWID="1, SFGMC="2560, TUSR0="20, TCHHT="21, * SFSMC="2440, TCHFF = "17, TCACR = "24 EQUIVALENCE(BIOSB, IOSB) BUF(1) = CHAR BUF(2) = VAL CALL GETADR(DPB, BUF) DPB(2) = 2 CALL WTQIO(FUNC, F, F, , IOSB, DPB, DSW) IF (.NOT.(BIOSB .GE. 0 .AND. DSW .GE. 0)) GOTO 2020 IERR = 0 IF (.NOT.(FUNC .EQ. SFGMC)) GOTO 2040 VAL = BUF(2) 2040 CONTINUE GOTO 2030 2020 CONTINUE IERR = - 1 2030 CONTINUE RETURN END C C numlin - castrate control chars, count number of lines to print this record C C This routine figures out how many lines would be printed if a record C were printed at the terminal, sets non-printing (NONP) characters C to 0, and detects form feeds. C C non-printing character C printing character C ^G (bell) C tab C line feed C form feed C back space C carriage return SUBROUTINE NUMLIN(BUF, OUTB, BLEN, FFFLAG, NLINES) INTEGER BLEN, NLINES, PRLEN, I, NL LOGICAL FFFLAG BYTE BUF(1), OUTB(1) BYTE CHARS( - 128:127) COMMON/TERM/SCRSIZ, SCRWID, SYSWID, SAVTAB, HLF, AUTOCR C current screen size; init: SCRLENGTH INTEGER SCRSIZ C (SCRLENGTH = real screen length-1 = 23) C current screen width; init: syswid INTEGER SCRWID C screen width from terminal driver (see gttyp) INTEGER SYSWID C saves value of system's hardware tabs flag INTEGER SAVTAB C true if hardware after col 80 (see gttyp) LOGICAL HLF C true if term set for auto carriagreturn (see gttyp) LOGICAL AUTOCR DATA CHARS/128*1, 7*1, 3, 7, 4, 5, 1, 6, 8, 18*1, 95*2, 1/ FFFLAG = .FALSE. PRLEN = 0 NLINES = 1 IF (.NOT.(BLEN .LE. 0)) GOTO 2060 RETURN 2060 CONTINUE DO 2080 I = 1, BLEN OUTB(I) = BUF(I) GOTO(1, 2, 3, 4, 5, 6, 7, 8), CHARS(OUTB(I)) 1 CONTINUE OUTB(I) = 0 GOTO 2080 4 CONTINUE IF (.NOT.((PRLEN .LT. SCRWID .AND. NLINES .EQ. 1) .OR. AUTOCR)) *GOTO 2100 PRLEN = 8*(PRLEN/8 + 1) GOTO 2110 2100 CONTINUE PRLEN = PRLEN + 8 2110 CONTINUE GOTO 2080 5 CONTINUE IF (.NOT.(.NOT.HLF)) GOTO 2120 NL = MAX0(0, PRLEN - 1)/SCRWID GOTO 2130 2120 CONTINUE NL = PRLEN/SCRWID 2130 CONTINUE NLINES = NLINES + NL + 1 PRLEN = PRLEN - NL*SCRWID GOTO 2080 6 CONTINUE OUTB(I) = 0 C signal new page FFFLAG = .TRUE. GOTO 2080 7 CONTINUE NL = PRLEN/SCRWID NLINES = NLINES + NL PRLEN = MAX0(0, PRLEN - NL*SCRWID - 1) GOTO 2080 8 CONTINUE NL = PRLEN/SCRWID NLINES = NLINES + NL PRLEN = 0 GOTO 2080 3 CONTINUE GOTO 2080 2 CONTINUE PRLEN = PRLEN + 1 2080 CONTINUE 2090 CONTINUE IF (.NOT.(.NOT.HLF)) GOTO 2140 NL = MAX0(0, PRLEN - 1)/SCRWID GOTO 2150 2140 CONTINUE NL = PRLEN/SCRWID 2150 CONTINUE NLINES = NLINES + NL RETURN END C ICR ONLY # escseq - send out a terminal control sequence beginning with ESC C ICR ONLY subroutine escseq(f, seq) C ICR ONLY integer f, dsw, dpb(6) C ICR ONLY integer length C ICR ONLY byte seq(1), tseq(10) C ICR ONLY include qiofn.cmn C ICR ONLY data tseq(1)/ESC/ C ICR ONLY C ICR ONLY call scopy(seq, 1, tseq, 2) C ICR ONLY call getadr(dpb(1), tseq) C ICR ONLY dpb(2) = length(tseq) C ICR ONLY call wtqio(IOWAL, f, f, , , dpb, dsw) C ICR ONLY return C ICR ONLY end C ICR ONLY # setwid - set terminal screen width characteristic C ICR ONLY subroutine setwid(f, wid) C ICR ONLY integer wid, ierr C ICR ONLY include qiofn.cmn C ICR ONLY C ICR ONLY call qiofn(f, SFSMC, TCWID, wid+1, ierr) C ICR ONLY return C ICR ONLY end