C C C C LIST File Listing Utility C ========================= C C Author: William P. Wood, Jr. 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: 3.0 C C Date: December 29, 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 C define(VAX) C note the order of the next several defines is significant! C ICR ONLY define(NOTICR,# NOT ICR) C Local ICR functions supported by LIST: C Invoke LIST on wild card file names 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$call qiofn(f, SFGMC, TCACR, acr, ierr) # get auto carriagereturn flag- C$ # used in NUMLIN C$if (acr == 1 & ierr == 0) C$ autocr = .true. C$else AUTOCR = .FALSE. C C now set term for no hardware tabs so NUMLIN knows where it is on the screen C C$call qiofn(f, SFGMC, TCHHT, savtab, ierr) C$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) C$call qiofn(f2, SFSMC, TCHHT, savtab, ierr) C ICR ONLY call setwid(f2, syswid) RETURN END C$# qiofn - do a qio function C$subroutine qiofn(f, func, char, val, ierr) C$integer f, func, char, val, ierr, dpb(6), dsw, iosb(2) C$byte buf(2), biosb C$include qiofn.cmn C$equivalence (biosb, iosb) C$ C$buf(1) = char C$buf(2) = val C$call getadr(dpb, buf) C$dpb(2) = 2 C$call wtqio(func, f, f, , iosb, dpb, dsw) C$if (biosb >= 0 & dsw >= 0) { C$ ierr = 0 C$ if (func == SFGMC) C$ val = buf(2) C$ } C$else C$ ierr = -1 C$return C$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 characters C to 0, and detects form feeds. C SUBROUTINE NUMLIN(BUF, OUTB, BLEN, FFFLAG, NLINES) INTEGER BLEN, NLINES, PRLEN, I, NL LOGICAL FFFLAG BYTE BUF(1), OUTB(1) 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 FFFLAG = .FALSE. PRLEN = 0 NLINES = 1 IF (.NOT.(BLEN .LE. 0)) GOTO 2000 RETURN 2000 CONTINUE DO 2020 I = 1, BLEN OUTB(I) = BUF(I) I2040 = (OUTB(I)) GOTO 2040 2060 CONTINUE CONTINUE GOTO 2050 2070 CONTINUE NL = PRLEN/SCRWID NLINES = NLINES + NL PRLEN = MAX0(0, PRLEN - NL*SCRWID - 1) GOTO 2050 2080 CONTINUE IF (.NOT.((PRLEN .LT. SCRWID .AND. NLINES .EQ. 1) .OR. AUTOCR) *) GOTO 2090 PRLEN = 8*(PRLEN/8 + 1) GOTO 2100 2090 CONTINUE PRLEN = PRLEN + 8 2100 CONTINUE GOTO 2050 2110 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 2050 2140 CONTINUE OUTB(I) = 0 C signal new page FFFLAG = .TRUE. GOTO 2050 2150 CONTINUE NL = PRLEN/SCRWID NLINES = NLINES + NL PRLEN = 0 GOTO 2050 2160 CONTINUE OUTB(I) = '$' PRLEN = PRLEN + 1 GOTO 2050 2170 CONTINUE C regular printing chars PRLEN = PRLEN + 1 GOTO 2050 2180 CONTINUE C anything else OUTB(I) = 0 GOTO 2050 2040 CONTINUE IF (I2040 .EQ. 7) GOTO 2060 IF (I2040 .EQ. 8) GOTO 2070 IF (I2040 .EQ. 9) GOTO 2080 IF (I2040 .EQ. 10) GOTO 2110 IF (I2040 .EQ. 12) GOTO 2140 IF (I2040 .EQ. 13) GOTO 2150 IF (I2040 .EQ. 27) GOTO 2160 IF (I2040 .GE. 32 .AND. I2040 .LE. 126) GOTO 2170 GOTO 2180 2050 CONTINUE 2020 CONTINUE IF (.NOT.(.NOT.HLF)) GOTO 2190 NL = MAX0(0, PRLEN - 1)/SCRWID GOTO 2200 2190 CONTINUE NL = PRLEN/SCRWID 2200 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