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 gcmd - get command line from MCR or terminal
C$define(MESSAGE,-1)
      SUBROUTINE GCMD(LUN, PROMPT, BUF, LEN, MAXLEN, SOURCE)
      BYTE PROMPT(1), BUF(1)
      INTEGER LUN, LEN, MAXLEN, SOURCE
      INTEGER I, J, JUNK
      LOGICAL FIRST
      DATA FIRST/.TRUE./
      LEN = 0
      IF (.NOT.(FIRST)) GOTO 2000
        FIRST = .FALSE.
        CALL GETMCR(BUF, LEN)
        IF (.NOT.(LEN .GT. 0)) GOTO 2020
          SOURCE =  - 2
          I = 1
2040      IF (.NOT.(I .LT. LEN)) GOTO 2060
            IF (.NOT.(BUF(I) .EQ. ' ')) GOTO 2070
              GOTO 2060
2070        CONTINUE
2050        I = I + 1
            GOTO 2040
2060      CONTINUE
          J = I
          I = I + 1
2090      IF (.NOT.(I .LE. LEN)) GOTO 2110
            BUF(I - J) = BUF(I)
2100        I = I + 1
            GOTO 2090
2110      CONTINUE
          LEN = LEN - J
C$  else {
C$    call reccml(buf, len)
C$    source = MESSAGE
C$    }
2020    CONTINUE
2000  CONTINUE
      IF (.NOT.(LEN .LE. 0)) GOTO 2120
        SOURCE = 0
2140    CONTINUE
          CALL READPR(LUN, PROMPT, BUF, LEN, MAXLEN - 1, JUNK)
2150      IF (.NOT.(LEN .GE. 0 .OR. LEN .EQ. -10)) GOTO 2140
2160    CONTINUE
2120  CONTINUE
      BUF(MAX0(1, MIN0(MAXLEN, LEN + 1))) = 0
      RETURN
      END
C rcmd - get the next list command
      INTEGER FUNCTION RCMD(BUF, DOT, PRMFLG)
      INTEGER NC, J
      INTEGER*4DOT
      INTEGER SCAN
      BYTE BUF(1), PROMP(13), TERMC
      LOGICAL PRMFLG
      DATA PROMP(12)/'>'/, PROMP(13)/0/
      IF (.NOT.(PRMFLG)) GOTO 2170
        ENCODE(11, 10, PROMP) DOT
10      FORMAT(1X, I10)
        J = SCAN(PROMP, ' ', 1)
        GOTO 2180
2170   CONTINUE
        J = 1
        PROMP(J) = 0
2180  CONTINUE
2190  CONTINUE
        CALL READPR(2, PROMP(J), BUF, NC, 134 - 2, TERMC)
2200    IF (.NOT.(NC .GE. 0 .OR. NC .EQ. -10)) GOTO 2190
2210  CONTINUE
      RCMD = NC
      IF (.NOT.(RCMD .GE. 0 .AND. TERMC .EQ. 27)) GOTO 2220
C ESC as terminator?
        RCMD = RCMD + 1
        BUF(RCMD) = 27
2220  CONTINUE
      BUF(MAX0(1, RCMD + 1)) = 0
      RETURN
      END
C initio - initialize the io variables
      SUBROUTINE INITIO(F, FOUT)
      INTEGER F, FOUT
      COMMON/CLIST/DOT, ODOT, TOPSCR, FOFF, FMAX, NXTREC, LSTRED, SAVDOT
     *, LOWC, HIGHC, CC, OUTCC, MARKP, MARKB
C current logical record; init: 1
      INTEGER*4DOT
C old value of dot
      INTEGER*4ODOT
C top of last screen; init: 1
      INTEGER*4TOPSCR
C offset in file of logical line 1; init: 0
      INTEGER*4FOFF
C highest line number of logical file; init: MAXINT-1
      INTEGER*4FMAX
C next record on file; init: 1
      INTEGER*4NXTREC
C last record read; init: 0
      INTEGER*4LSTRED
C value of dot saved by the = command; init: 1
      INTEGER*4SAVDOT
C low value of record column range
      INTEGER LOWC
C high value of record column range
      INTEGER HIGHC
C carriagecontrol type of input file
      INTEGER CC
C carriagecontrol type of output file
      INTEGER OUTCC
C index of highest line number in markb; init:0
      INTEGER MARKP
C points to every 100th line on file
      INTEGER MARKB(4, 0:1000)
      DOT = 1
      NXTREC = 1
      TOPSCR = 1
      MARKP =  - 1
      LSTRED = 0
      SAVDOT = 1
      FOFF = 0
      FMAX = 2147483647 - 1
      LOWC = 1
      HIGHC = 512
      CALL GFTYP(F, CC)
      CALL GFTYP(FOUT, OUTCC)
      IF (.NOT.(CC .EQ. 2)) GOTO 2240
C initialize virtual io
        CALL VINIT(F)
2240  CONTINUE
      RETURN
      END
C getinp - get next record, increment nxtrec, mark every 100 lines
      INTEGER FUNCTION GETINP(F, INBUF, BLEN)
      INTEGER F, BLEN, IER, I
      INTEGER*4RDOT
      BYTE INBUF(512), ERRBUF(80)
      COMMON/CLIST/DOT, ODOT, TOPSCR, FOFF, FMAX, NXTREC, LSTRED, SAVDOT
     *, LOWC, HIGHC, CC, OUTCC, MARKP, MARKB
C current logical record; init: 1
      INTEGER*4DOT
C old value of dot
      INTEGER*4ODOT
C top of last screen; init: 1
      INTEGER*4TOPSCR
C offset in file of logical line 1; init: 0
      INTEGER*4FOFF
C highest line number of logical file; init: MAXINT-1
      INTEGER*4FMAX
C next record on file; init: 1
      INTEGER*4NXTREC
C last record read; init: 0
      INTEGER*4LSTRED
C value of dot saved by the = command; init: 1
      INTEGER*4SAVDOT
C low value of record column range
      INTEGER LOWC
C high value of record column range
      INTEGER HIGHC
C carriagecontrol type of input file
      INTEGER CC
C carriagecontrol type of output file
      INTEGER OUTCC
C index of highest line number in markb; init:0
      INTEGER MARKP
C points to every 100th line on file
      INTEGER MARKB(4, 0:1000)
      RDOT = DOT + FOFF
      IF (.NOT.(DOT .GT. FMAX)) GOTO 2260
        GETINP =  - 10
        GOTO 2270
2260   CONTINUE
        IF (.NOT.(RDOT .EQ. LSTRED)) GOTO 2280
          GETINP = BLEN
          GOTO 2290
2280     CONTINUE
          IF (.NOT.(MOD(NXTREC-1, 100) .EQ. 0)) GOTO 2300
            IF (.NOT.((NXTREC-1)/100 .GT. MARKP .AND. MARKP .LT. 1000)) 
     *GOTO 2320
              MARKP = MARKP + 1
              IF (.NOT.(CC .EQ. 2)) GOTO 2340
                CALL VMARK(F, MARKB(1, MARKP))
                GOTO 2350
2340           CONTINUE
                CALL MARKR(F, MARKB(1, MARKP))
2350          CONTINUE
2320        CONTINUE
2300      CONTINUE
          IF (.NOT.(CC .EQ. 2)) GOTO 2360
            CALL VGET(F, INBUF, 512, GETINP)
            GOTO 2370
2360       CONTINUE
            CALL GET(F, INBUF, 512, GETINP)
C BLOCK IO      call bget(f, inbuf, BUFSIZ, getinp)
2370      CONTINUE
          IF (.NOT.(GETINP .GE. 0)) GOTO 2380
            GETINP = MAX0(0, MIN0(HIGHC, GETINP) - LOWC + 1)
            BLEN = GETINP
            IF (.NOT.(LOWC .NE. 1 .AND. BLEN .GT. 0)) GOTO 2400
              DO 2420 I = 1, BLEN
C shift proper byte range to inbuf(1)
                INBUF(I) = INBUF(I - 1 + LOWC)
2420          CONTINUE
2430          CONTINUE
2400        CONTINUE
            LSTRED = NXTREC
            NXTREC = NXTREC + 1
            GOTO 2390
2380       CONTINUE
            IF (.NOT.(GETINP .NE. -10)) GOTO 2440
              ENCODE(69, 10, ERRBUF) GETINP, NXTREC
10            FORMAT('LIST -- ERROR NUMBER 'I3, ' OCCURRED WHILE READING
     * RECORD NUMBER ', I7)
              CALL PUT(2, ERRBUF, 69, IER)
              IF (.NOT.(GETINP .EQ. -40)) GOTO 2460
                GETINP = 0
                BLEN = GETINP
                LSTRED = 0
                NXTREC = NXTREC + 1
                GOTO 2470
2460           CONTINUE
                GETINP =  - 10
2470          CONTINUE
2440        CONTINUE
2390      CONTINUE
2290    CONTINUE
2270  CONTINUE
      RETURN
      END
C typlin - type line if room is left on screen or ntoprt > 0
      INTEGER FUNCTION TYPLIN(F, BUF, BLEN, NPRINT, NTOPRT, IGNRFF)
      BYTE BUF(1), CCBUF(512 + 2), COPYB(512)
      INTEGER F, BLEN, NLINES, IER
      INTEGER*4NPRINT, NTOPRT
      LOGICAL FFFLAG, IGNRFF
      COMMON/CLIST/DOT, ODOT, TOPSCR, FOFF, FMAX, NXTREC, LSTRED, SAVDOT
     *, LOWC, HIGHC, CC, OUTCC, MARKP, MARKB
C current logical record; init: 1
      INTEGER*4DOT
C old value of dot
      INTEGER*4ODOT
C top of last screen; init: 1
      INTEGER*4TOPSCR
C offset in file of logical line 1; init: 0
      INTEGER*4FOFF
C highest line number of logical file; init: MAXINT-1
      INTEGER*4FMAX
C next record on file; init: 1
      INTEGER*4NXTREC
C last record read; init: 0
      INTEGER*4LSTRED
C value of dot saved by the = command; init: 1
      INTEGER*4SAVDOT
C low value of record column range
      INTEGER LOWC
C high value of record column range
      INTEGER HIGHC
C carriagecontrol type of input file
      INTEGER CC
C carriagecontrol type of output file
      INTEGER OUTCC
C index of highest line number in markb; init:0
      INTEGER MARKP
C points to every 100th line on file
      INTEGER MARKB(4, 0:1000)
      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 <lf><cr> after col 80 (see gttyp)
      LOGICAL HLF
C true if term set for auto carriagreturn (see gttyp)
      LOGICAL AUTOCR
      EQUIVALENCE(COPYB(1), CCBUF(3))
C Carriagereturn
C Line Feed
      DATA CCBUF(1), CCBUF(2)/13, 10/
      TYPLIN = 0
      IF (.NOT.(NTOPRT .LE. 0)) GOTO 2480
C normal print mode
        CALL NUMLIN(BUF, COPYB, BLEN, FFFLAG, NLINES)
        IF (.NOT.(NPRINT .GT. 0 .AND. (NPRINT+NLINES .GT. SCRSIZ .OR. (F
     *FFLAG .AND. .NOT.IGNRFF)))) GOTO 2500
          RETURN
2500    CONTINUE
        GOTO 2490
2480   CONTINUE
C n1,n2 Print mode; leave funny chars in buf
        NLINES = 1
        DO 2520 I = 1, BLEN
          COPYB(I) = BUF(I)
2520    CONTINUE
2530    CONTINUE
2490  CONTINUE
      IF (.NOT.(OUTCC .EQ. 2)) GOTO 2540
C output to terminal or NONE file
        CALL PUT(F, CCBUF, BLEN + 2, IER)
        GOTO 2550
2540   CONTINUE
C output to LIST or FORTRAN file
        CALL PUT(F, COPYB, BLEN, IER)
2550  CONTINUE
      NPRINT = NPRINT + NLINES
      DOT = DOT + 1
      NTOPRT = NTOPRT - 1
      IF (.NOT.(NTOPRT .NE. 0)) GOTO 2560
        TYPLIN = 1
2560  CONTINUE
      RETURN
      END
C posit - position file to read record number "newdot"
      SUBROUTINE POSIT(F, NEWDOT)
      INTEGER F
      INTEGER*4NEWDOT, RDOT, MARKL, MARKP4
      INTEGER*4N4, NR4
      COMMON/CLIST/DOT, ODOT, TOPSCR, FOFF, FMAX, NXTREC, LSTRED, SAVDOT
     *, LOWC, HIGHC, CC, OUTCC, MARKP, MARKB
C current logical record; init: 1
      INTEGER*4DOT
C old value of dot
      INTEGER*4ODOT
C top of last screen; init: 1
      INTEGER*4TOPSCR
C offset in file of logical line 1; init: 0
      INTEGER*4FOFF
C highest line number of logical file; init: MAXINT-1
      INTEGER*4FMAX
C next record on file; init: 1
      INTEGER*4NXTREC
C last record read; init: 0
      INTEGER*4LSTRED
C value of dot saved by the = command; init: 1
      INTEGER*4SAVDOT
C low value of record column range
      INTEGER LOWC
C high value of record column range
      INTEGER HIGHC
C carriagecontrol type of input file
      INTEGER CC
C carriagecontrol type of output file
      INTEGER OUTCC
C index of highest line number in markb; init:0
      INTEGER MARKP
C points to every 100th line on file
      INTEGER MARKB(4, 0:1000)
      RDOT = FOFF + NEWDOT
      IF (.NOT.(RDOT .EQ. NXTREC)) GOTO 2580
        RETURN
2580  CONTINUE
      IF (.NOT.(RDOT .EQ. LSTRED)) GOTO 2600
        IF (.NOT.(NXTREC .EQ. RDOT+1)) GOTO 2620
          RETURN
2620     CONTINUE
          LSTRED = 0
2630    CONTINUE
2600  CONTINUE
      MARKP4 = MARKP
      MARKL = MIN0((RDOT - 1)/100, MARKP4)
      IF (.NOT.(MARKL .GT. (NXTREC-1)/100 .OR. NXTREC .GT. RDOT)) GOTO 2
     *640
        IF (.NOT.(CC .EQ. 2)) GOTO 2660
          CALL VPOINT(F, MARKB(1, MARKL))
          GOTO 2670
2660     CONTINUE
          CALL POINTR(F, MARKB(1, MARKL))
2670    CONTINUE
        NXTREC = MARKL*100 + 1
2640  CONTINUE
2680  CONTINUE
        IF (.NOT.((NXTREC-1)/100 .NE. (RDOT-1)/100)) GOTO 2710
          N4 = ((NXTREC - 1)/100*100 + 101) - NXTREC
          GOTO 2720
2710     CONTINUE
          N4 = RDOT - NXTREC
2720    CONTINUE
        IF (.NOT.(MOD(NXTREC-1, 100) .EQ. 0)) GOTO 2730
          IF (.NOT.((NXTREC-1)/100 .GT. MARKP .AND. MARKP .LT. 1000)) GO
     *TO 2750
            MARKP = MARKP + 1
            IF (.NOT.(CC .EQ. 2)) GOTO 2770
              CALL VMARK(F, MARKB(1, MARKP))
              GOTO 2780
2770         CONTINUE
              CALL MARKR(F, MARKB(1, MARKP))
2780        CONTINUE
2750      CONTINUE
2730    CONTINUE
        IF (.NOT.(CC .EQ. 2)) GOTO 2790
          CALL VSKIP(F, N4, NR4)
          GOTO 2800
2790     CONTINUE
          CALL SKIP(F, N4, NR4)
2800    CONTINUE
        NXTREC = NR4 + NXTREC
2690    IF (.NOT.(NXTREC .EQ. RDOT .OR. NR4 .NE. N4)) GOTO 2680
2700  CONTINUE
      NEWDOT = MAX0(1, NXTREC - FOFF)
      RETURN
      END