C	PROGRAM TO LIST A TABLE
C
C  Submitted by:
C  
C  	R. N. Stillwell
C  	Institute for Lipid Research
C  	Baylor College of Medicine
C  	Houston, Texas 77030
C  	
C  (who would be glad to receive comments, suggestions, bug fixes, etc., but
C  who promises no support whatever).
C  
C  Literature reference:
C  
C  	R. N. Stillwell.  A low-overhead laboratory data management system
C  	for the PDP11.  Comput. Biomed. Res., 15, 29-38(1982).
C  
C  Acknowledgement:
C
C  	This software was developed under National Institutes of Health grants
C  	GM-13901 and GM-26611.
C 
C  General permission is hereby granted to copy, modify, or distribute this
C  program, but not for profit.  Copyright to this software is and shall
C  remain in the public domain.
C
C	MODIFIED 12-NOV-81 TO ADD SEARCH FACILITY
C
	COMMON/TABX/HEAD1,HEAD2,IPTRH1,IPTRH2,IPTRD,
	1 LEN,OFFSET,PREF,ZERO1,ZERO2
C
	BYTE HEAD1(1000),HEAD2(1000)
	BYTE ZERO1(10),ZERO2(10)!ZERO-TH COLUMN HEADERS
	INTEGER OFFSET
	BYTE PREF(6)		!TABLE PREFIX CONTAINING '-' AND NULLS
	INTEGER LEN(40)		!LENGTH OF COLUMN I
	INTEGER IPTRH1(41)	!POINTER TO START OF HEAD1(I)
	INTEGER IPTRH2(41)	!POINTER TO START OF HEAD2(I)
	INTEGER IPTRD(41)	!POINTER TO START OF DATA FOR COL. I
	DATA MAXCOL/40/		!MAX. NUMBER OF COLUMNS
	DATA MAXLEN/1000/	!MAX. LENGTH OF DATA FOR EACH RECORD
	DATA MAXHD/1000/	!MAX. LENGTH OF HEAD1,HEAD2
C
C
	COMMON/TITL/ LENTL,TITLE,LENSTL,SUBTL
C
	BYTE TITLE(80),SUBTL(80)
	BYTE TABNAM(10),DATA(1000)
	INTEGER TERWID
	BYTE DEST(20),MCRBUF(80),TERM(4)
	LOGICAL*1 SEARCH,EQUAL,LP0,OK
	DATA TERM/'T','I',':',0/
	BYTE NAME(10),ALPNUM(37)
	INTEGER CR,SPACE
	DATA SPACE,CR/"40,"15/
	DATA ALPNUM/ 'A','B','C','D','E','F','G','H','I','J','K','L',
	1 'M','N','O','P','Q','R','S','T','U','V','W','X',
	1 'Y','Z','0','1','2','3','4','5','6','7','8','9',
	1 0/
	BYTE LINE(132)
	BYTE BLANK,COLSEP
	DATA BLANK,COLSEP/' ','!'/
	BYTE EQU
	DATA EQU/'='/
	BYTE SLASH
C	ISLASH IS '/<null>'
	INTEGER ISLASH
	EQUIVALENCE (SLASH,ISLASH)
	DATA SLASH /'/'/
	BYTE PAGSEP,REPLY
	INTEGER SRCOL,SRPOS,SRLEN
	BYTE SRTYP,SRSTRG(81)
	LOGICAL*1 HIT
	REAL LOWLIM,UPLIM
	REAL JDATE
	INTEGER VERIFY
C
	GET-TABLE-NAME-AND-DESTINATION
	OPEN-TABLE
	ASK-ROWS
	PAGE = 1
	ISTCOL = 1
	ASK-GROUP-SEPARATOR
	IF (SEARCH) ASK-SEARCH-PARAMETERS
	WRITE-TITLE
	REPEAT UNTIL (ISTCOL.GT.NCOLS)
	SEE-HOW-MANY-COLUMNS-FIT-ON-SCREEN
	LIST-SO-MANY-COLUMNS
	IF (ISTCOL.LE.NCOLS) LIST-GROUP-SEPARATOR
	FIN
	IF (LP0)
	WRITE (5,5) DEST,DEST,DEST 
5	FORMAT (' YOUR TABLE IS WRITTEN IN A FILE CALLED ',20A1/
	1 ' YOU MAY EITHER: 1) HAVE IT PRINTED ON THE LINE PRINTER',/
	1 ' OR 2) TYPE IT ON YOUR TERMINAL.',//
	1 ' 1)      PDS> PRINT[/DEL] ',20A1,' <CR>'/
	1 '              OR'/
	1 ' 2)      PDS> TYPE ',20A1,' <CR>')
	FIN
	IF (PAGSEP) WRITE (6,14) 
	STOP
C
	TO ASK-ROWS
	WRITE (5,31)
31	FORMAT ('$FIRST ROW TO LIST: ')
	READ (5,32) IROW1
32	FORMAT (I6)
	CONDITIONAL
	(IROW1.EQ.0) IROW1 = 1
	(IROW1.LE.OFFSET) IROW1 = 1
	(IROW1.GT.OFFSET) IROW1 = IROW1-OFFSET
	FIN
	WRITE (5,33)
33	FORMAT ('$LAST ROW (<CR> FOR ALL): ')
	READ (5,32) IROWL
	CONDITIONAL
	(IROWL.EQ.0) IROWL = NREC
	(IROWL.GT.OFFSET+NREC) IROWL = NREC
	(IROWL.GE.OFFSET) IROWL = IROWL-OFFSET
	(IROWL.GT.NREC) IROWL = NREC
	FIN
	FIN
C
	TO GET-TERMINAL-WIDTH
C
C	CALL MACRO FUNCTION WHICH RETURNS WIDTH
C
	MAXWID = TERWID(5)
	FIN

	TO GET-TABLE-NAME-AND-DESTINATION
	CALL GETMCR(MCRBUF)
	LBUF = INDEX(MCRBUF,CR)
D	WRITE (5,9910) LBUF
D9910	FORMAT (' LBUF: ',I4)
	WHEN (LBUF.GT.5)
	MCRBUF(LBUF) = 0
C
C	RSX NOTE:
C	PDS INSERTS A SPACE BEFORE A / IN THE COMMAND LINE;
C	MCR DOES NOT.  REMOVING "CRSX" BELOW MAY MAKE THIS WORK INDER RSX.
C
C	SQUEEZE OUT 'LST'
	LSP = INDEX(MCRBUF,SPACE)
CRSX	LSL = INDEX(MCRBUF,ISLASH)
CRSX	IF (LSL.GT.0) LSP = LSL-1
	CALL MVSTR (MCRBUF,MCRBUF(LSP+1))
C	CHECK FOR /SEarch SWITCH
	SEARCH = EQUAL(MCRBUF,'/SE',3)
	IF (SEARCH)
	LSP = INDEX(MCRBUF,SPACE)
	CALL MVSTR(MCRBUF,MCRBUF(LSP+1))
	FIN
C	GET TABLE NAME AND DESTINATION
	LSP = INDEX(MCRBUF,SPACE)
D	WRITE (5,9913) LSP
D9913	FORMAT (' LSP: ',I4)
	WHEN (LSP.EQ.0) CALL MVSTR(NAME,MCRBUF)
	ELSE
	CALL MVSTR(NAME,MCRBUF,LSP)
	CALL MVSTR(DEST,MCRBUF(LSP+1))
	FIN
D	WRITE (5,9912) NAME,NAME
D9912	FORMAT (' NAME: ',10A1/10O5)
D	WRITE (5,9914) DEST,DEST
D9914	FORMAT (' DEST: ',20A1/20O5)
	CHECK-NAME
	IF (.NOT.OK) STOP
C	SEE IF DEST IS LP:
	WHEN (LENGTH(DEST).GT. 1)
	LP0 = (EQUAL(DEST,'LP:').OR.EQUAL(DEST,'LP0:'))
	WHEN (LP0) 
	CALL MVSTR(DEST,NAME)
	CALL MVSTR(DEST(LENGTH(DEST)),'.LST')
	FIN
	ELSE
	IF (INDEX(DEST,'.').EQ.0) CALL MVSTR(DEST(LENGTH(DEST)),'.LST')
	FIN
	MAXWID = 132
	FIN
	ELSE
	DO (I=1,4) DEST(I) = TERM(I)
	GET-TERMINAL-WIDTH
	FIN
	FIN
	ELSE
	REPEAT UNTIL (OK)
	WRITE (5,3)
3	FORMAT ('$ENTER THE NAME: ')
	READ (5,23) LFNAM,NAME
23	FORMAT (Q,80A1)
	LFNAM = LFNAM+1
	NAME(MIN0(10,LFNAM)) = 0
	CHECK-NAME
	FIN
	DO (I=1,4) DEST(I) = TERM(I)
	GET-TERMINAL-WIDTH
	FIN
	CALL ASSIGN (6,'SY0:')
	CALL ASSIGN (6,DEST)
D	WRITE (5,9904) DEST
D9904	FORMAT (' DEST: ',10A1)
	FIN
C
	TO CHECK-NAME
	OK = .FALSE.
	CONDITIONAL
	(LFNAM.GT.10) WRITE (5,34) 
	(VERIFY(NAME,ALPNUM).NE.0) WRITE (5,35)
	(OTHERWISE) OK = .TRUE.
	FIN
34	FORMAT (' NO MORE THAN 10 CHARACTERS, PLEASE.')
35	FORMAT (' LETTERS AND NUMBERS ONLY, PLEASE.')
	FIN
C
C
	TO OPEN-TABLE
	LOGICAL*1 IERR
	CALL FDBSET(1,'R')
	CALL FDBSET(2,'R')
	CALL OPNTAB(NAME,NREC,LENREC,NCOLS,IERR)
	LP = LENGTH(PREF) 
D	WRITE (5,9901) NREC,NCOLS,LP
D9901	FORMAT (' NREC,NCOLS,LP:',3I8)
	FIN
	TO SEE-HOW-MANY-COLUMNS-FIT-ON-SCREEN
	LSTCOL = ISTCOL-1
	IWID = LP+9
	WHILE (LSTCOL.LT.NCOLS.AND.IWID.LT.MAXWID+1)
	LSTCOL = LSTCOL+1
	IWID = IWID + LEN(LSTCOL) +3
	FIN
	IF (IWID.GT.MAXWID)
C  IF ONLY ONE COLUMN, AND IT IS TOO LONG, TRUNCATE IT.  ELSE DROP ONE COL.
	WHEN (LSTCOL.EQ.ISTCOL) IWID = MAXWID+1

	ELSE
	IWID = IWID - LEN(LSTCOL) - 3
	LSTCOL = LSTCOL-1
	FIN
	FIN
D	WRITE (5,9905) ISTCOL,LSTCOL,IWID
D9905	FORMAT (' ISTCOL, LSTCOL, IWID:',3I5)
	FIN
C
	TO ASK-GROUP-SEPARATOR
	WRITE (5,21)
21	FORMAT (' USE SEPARATE-PAGE FORMAT? ')
	READ (5,22) REPLY
22	FORMAT (A1)
	PAGSEP = REPLY.EQ.'Y'
	IF (PAGSEP) 
	WRITE (6,14)
	FIN
	FIN
C
	TO ASK-SEARCH-PARAMETERS
	WRITE (5,41)
41	FORMAT ('$SEARCH COLUMN: ')
	READ (5,42) SRCOL
42	FORMAT (I5)
	SRPOS = IPTRD(SRCOL)
	SRLEN = IPTRD(SRCOL+1)-IPTRD(SRCOL)
	REPEAT UNTIL (OK)
	WRITE (5,43)
43	FORMAT ('$SEARCH TYPE: String, Numeric, or Date: ')
	READ (5,44) SRTYP
44	FORMAT (A1)
	ISRTYP = SRTYP
	IF (ISRTYP.GE."141) SRTYP = SRTYP.AND."137
	OK = (SRTYP.EQ.'S'.OR.SRTYP.EQ.'D'.OR.SRTYP.EQ.'N')
	UNLESS (OK) WRITE (5,45)
45	FORMAT (' REPLY WITH THE LETTER S, N, OR D.')
	FIN
	SELECT (SRTYP)
	('S') GET-STRING-TARGET
	('N') GET-NUMERIC-LIMITS
	('D') GET-DATE-LIMITS
	FIN
	FIN

	TO GET-STRING-TARGET
	WRITE (5,46)
46	FORMAT ('$STRING TO SEARCH FOR: ')
	READ (5,47) LQ,SRSTRG
47	FORMAT (Q,81A1)
	SRSTRG(MIN0(LQ+1,81)) = 0
	FIN

	TO GET-NUMERIC-LIMITS
	WRITE (5,48)
48	FORMAT ('$LOWER LIMIT FOR MATCHING (<CR> = -INFINITY): ')
	READ (5,49) LQ,LOWLIM
49	FORMAT (Q,F20.0)
	IF (LQ.EQ.0) LOWLIM = -1.E38
	WRITE (5,50)
50	FORMAT ('$UPPER LIMIT FOR MATCHING (<CR> = +INFINITY): ')
	READ (5,49) LQ,UPLIM
	IF (LQ.EQ.0) UPLIM = 1.E38
	FIN

	TO GET-DATE-LIMITS
	REPEAT UNTIL (OK)
	WRITE (5,52)
52	FORMAT ('$EARLIEST DATE TO MATCH: ')
	READ (5,47) LQ,SRSTRG
	LOWLIM = JDATE(SRSTRG,LQ)
	OK = LOWLIM.GT.0.0
	UNLESS (OK) WRITE (5,53)
53	FORMAT (' Not a valid date.')
	FIN
	REPEAT UNTIL (OK)
	WRITE (5,54)
54	FORMAT ('$LATEST DATE TO MATCH: ')
	READ (5,47) LQ,SRSTRG
	UPLIM = JDATE(SRSTRG,LQ)
	OK = UPLIM.GT.0.0
	UNLESS (OK) WRITE (5,53)
	FIN
	FIN

	TO LIST-SO-MANY-COLUMNS
	LIST-ROW-SEPARATOR
	LIST-COLUMN-HEADERS
	LIST-ROW-SEPARATOR
	IROW = IROW1
	WHILE (IROW.LE.IROWL)
	SET-UP-PREFIX
	DO (JJ=1,8)
	IF (IROW.LE.IROWL)
	LIST-5-ROWS
	LIST-ROW-SEPARATOR
	FIN
	FIN
	IF (IROW.LE.IROWL)
	IF (PAGSEP) 
	WRITE (6,14)
	PAGE = PAGE + .01
	WRITE-TITLE
	LIST-ROW-SEPARATOR
	LIST-COLUMN-HEADERS
	LIST-ROW-SEPARATOR
	FIN
	FIN
	FIN
	ISTCOL = LSTCOL+1
	PAGE = INT(PAGE) + 1.0
	FIN
C
	TO LIST-GROUP-SEPARATOR
	WHEN (PAGSEP) 
	WRITE (6,14)
	WRITE-TITLE
	FIN
	ELSE
	WRITE (6,15) (SLASH,I=1,IWID-2)
	WRITE (6,15) BLANK
	FIN
14	FORMAT ('1')
	FIN
C
	TO LIST-ROW-SEPARATOR
	WRITE (6,15) (EQU,I=1,IWID-2)
15	FORMAT (1X,132A1)
	FIN
	TO LIST-COLUMN-HEADERS
	LINE(1) = COLSEP
	DO (I=2,132) LINE(I) = BLANK
	LINE(LP+7) = COLSEP
	LINPOS = LP + 9
	DO (ICOL = ISTCOL,LSTCOL)
	ENCODE (2,16,LINE(LINPOS)) ICOL
16	FORMAT (I2)
	LINPOS = MIN0(MAXWID+1,LINPOS + LEN(ICOL)+3)
	LINE(LINPOS-2) = COLSEP
	FIN
	WRITE (6,15) (LINE(I),I=1,LINPOS-2)
C
	DO (I=7,132) LINE(I) = BLANK
	DO (I=3,12) LINE(I) = ZERO1(I-2)
	LINE(LP+7) = COLSEP
	LINPOS = LP + 9
	ITOT = LINPOS
	DO (ICOL = ISTCOL,LSTCOL)
	ITOT = MIN0(MAXWID+1, ITOT + LEN(ICOL) + 3)
	DO (I=IPTRH1(ICOL),IPTRH1(ICOL+1)-1)
	LINE(LINPOS) = HEAD1(I)
	LINPOS = MIN0(132, LINPOS+1)
	FIN
	LINPOS = ITOT 
	LINE(LINPOS-2) = COLSEP
D	WRITE (5,15) LINE
	FIN
	WRITE (6,15) (LINE(I),I=1,LINPOS-2)
C
	DO (I=7,132) LINE(I) = BLANK
	DO (I=3,12) LINE(I) = ZERO2(I-2)
	LINE(LP+7) = COLSEP
	LINPOS = LP + 9
	ITOT = LINPOS
	DO (ICOL = ISTCOL,LSTCOL)
	ITOT = MIN0(MAXWID+1, ITOT + LEN(ICOL) + 3)
	DO (I=IPTRH2(ICOL),IPTRH2(ICOL+1)-1)
	LINE(LINPOS) = HEAD2(I)
	LINPOS = MIN0(132, LINPOS+1)
	FIN
	LINPOS = ITOT 
	LINE(LINPOS-2) = COLSEP
	FIN
	WRITE (6,15) (LINE(I),I=1,LINPOS-2)
	FIN

	TO LIST-5-ROWS
	II = 1
	WHILE (II.LE.5.AND.IROW.LE.IROWL)
	IREC = IROW
	READ (2'IREC) (DATA(J),J=1,LENREC)
	WHEN (SEARCH) CHECK-FOR-HIT
	ELSE HIT = .TRUE.
	IF (HIT)
	DO (I=LP+2,132) LINE(I) = BLANK
	ENCODE (4,11,LINE(LP+2)) IROW+OFFSET
11	FORMAT (I4)
	LINE(LP+7) = COLSEP
	LINPOS = LP + 9
	ITOT = LINPOS
	DO (ICOL = ISTCOL,LSTCOL)
	ITOT = MIN0(MAXWID+1, ITOT + LEN(ICOL) + 3)
	DO (I=IPTRD(ICOL),IPTRD(ICOL+1)-1)
	LINE(LINPOS) = DATA(I)
	LINPOS = MIN0(132, LINPOS+1)
	FIN
	LINPOS = ITOT
	LINE(LINPOS-2) = COLSEP
	FIN
	WRITE (6,15) (LINE(I),I=1,LINPOS-2)
	II = II+1
	FIN
	IROW = IROW+1
	FIN
	FIN

	TO CHECK-FOR-HIT
	SELECT (SRTYP)
	('S') HIT = INDEX(DATA(SRPOS),SRSTRG,SRLEN) .GT. 0
	('N') CHECK-NUMERIC-HIT
	('D') CHECK-DATE-HIT
	FIN
	FIN

	TO CHECK-NUMERIC-HIT
	DO (I=1,SRLEN) SRSTRG(I) = DATA(I+SRPOS-1)
	ISR = SRLEN
	WHILE (SRSTRG(ISR).EQ.' '.AND.ISR.GE.1) ISR = ISR-1
	HIT = .FALSE.
	IF (ISR.GE.1)
	NDIG = VERIFY(SRSTRG,'0123456789. ',ISR)
	IF (NDIG.EQ.0)
	DECODE (ISR,55,SRSTRG) SRNUM
55	FORMAT (F80.0)
	HIT = (LOWLIM.LE.SRNUM) .AND. (SRNUM.LE.UPLIM)
	FIN
	FIN
D	WRITE (5,9921) (SRSTRG(I),I=1,SRLEN)
D9921	FORMAT (' CHECK STRING ',80A1)
D	WRITE (5,9922) SRNUM,HIT
D9922	FORMAT (' SRNUM =',F14.5,' HIT =',L3)
	FIN

	TO CHECK-DATE-HIT
	DO (I=1,SRLEN) SRSTRG(I) = DATA(I+SRPOS-1)
	SRNUM = JDATE(SRSTRG,SRLEN)
	HIT = (SRNUM.GE.0) .AND. (LOWLIM.LE.SRNUM) .AND. (SRNUM.LE.UPLIM)
D	WRITE (5,9921) (SRSTRG(I),I=1,SRLEN)
D	WRITE (5,9922) SRNUM,HIT
	FIN
C
	TO SET-UP-PREFIX
	DO (I=1,LP-1) LINE(I+2) = PREF(I)
	LINE(1) = COLSEP
	FIN
C
C
	TO WRITE-TITLE
	DO (I=1,132) LINE(I) = BLANK
	N = LENTL/2
	ICENT = MAXWID/2
	LINPOS = ICENT - N
D	WRITE (5,9902) N,ICENT,LINPOS
D9902	FORMAT (' N,ICENT,LINPOS: ',3I5)
	DO (I=1,LENTL)
	LINE(LINPOS) = TITLE(I)
	LINPOS = MIN0(132, LINPOS+1)
	FIN
	LINPOS = MAXWID - 7
	ENCODE (5,12,LINE(LINPOS)) PAGE
12	FORMAT (F5.2)
	WRITE (6,15)(LINE(I),I=1,MAXWID-1)
	FIN
C
	END