C	SUBTAB -- PROGRAM TO CREATE A SUBTABLE
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
	INTEGER OFFSET,OFFSE2
	BYTE PREF(6)		!TABLE PREFIX CONTAINING '-' AND NULLS
	BYTE ZERO1(10),ZERO2(10)!ZERO-TH COLUMN HEADERS
	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)
C
	COMMON/IVAR/ IVAR
C
	LOGICAL*1 IERR,DELETR
	BYTE FILNAM(20)
	BYTE DATA(1000)
	INTEGER NCOLS
	DATA MAXREC/32767/
C
	GET-TABLE-NAMES
	GET-RECORD-NUMBERS
	MAKE-NEW-TAI-FILE
	IF (N2.EQ.0) N2 = OFFSET+NREC
	IF (N2.LT.N1) REPORT-RECORD-NUMBERS-ERROR
	IF (N1.LT.OFFSET+1.OR.N2.GT.OFFSET+NREC) REPORT-RECORD-NUMBERS-ERROR
	MAKE-NEW-TAB-FILE
	COPY-RECORDS-TO-NEW-TABLE
	IF (DELETR) DELETE-RECORDS-FROM-OLD-TABLE
	CALL-EXIT
	STOP	!!
C
	TO GET-TABLE-NAMES
	WRITE (5,1)
1	FORMAT (' Creating a subtable.'//'$Old table: ')
	READ (5,2) LTNAM,FILNAM
2	FORMAT (Q,20A1)
	LTNAM = LTNAM+1
	FILNAM(LTNAM) = 0
	OPEN-OLD-TABLE
	IF (IERR) STOP
	WRITE (5,3)
3	FORMAT ('$Subtable: ')
	READ (5,2) LTNAM,FILNAM
	LTNAM = LTNAM+1
	FILNAM(LTNAM) = 0
	FIN
	TO GET-RECORD-NUMBERS
	WRITE (5,4)
4	FORMAT ('$Move records starting with # (<cr> for beginning of',
	1 ' table): ')
	READ (5,5) LTNUM,N1
5	FORMAT (Q,I8)
	WRITE (5,6)
6	FORMAT ('$Ending with # (<cr> for end of table): ')
	READ (5,5) LTNUM,N2
	IF (LTNUM.EQ.0) N2 = OFFSET+NREC
	WRITE (5,7)
7	FORMAT ('$Delete records from old table? ')
	READ (5,8) DELETR
8	FORMAT (A1)
	DELETR = DELETR.EQ.'Y'.OR.DELETR.EQ.'y'
	FIN
	TO OPEN-OLD-TABLE
C	SET UP FILENAME OF DESCRIPTOR FILE
	IF (LTNAM.GT.10.OR.LTNAM.LE.1)
	WRITE (5,105)
105	FORMAT (' INVALID TABLE NAME')
	IERR = .TRUE.
	CALL EXIT
	FIN
	CALL MVSTR(FILNAM(LTNAM),'.TAI;1')
	CALL ASSIGN(1,FILNAM)
	READ (1) LENREC,NCOLS
	LENWDS = (LENREC+1)/2
	CALL MVSTR(FILNAM(LTNAM),'.TAB;1')
	CALL ASSIGN(2,FILNAM)
	DEFINE FILE 2 (MAXREC,LENWDS,U,IVAR)
	FIN
	TO MAKE-NEW-TAI-FILE
	CALL MVSTR(FILNAM(LTNAM),'.TAI;1')
	CALL ASSIGN(3,FILNAM)
	CALL FDBSET(3,'NEW')
	WRITE (3) LENREC,NCOLS
	READ (1) IPTRH1,IPTRH2
	WRITE (3) IPTRH1,IPTRH2
	READ (1) L,(DATA(I),I=1,L)	!HEAD1
	WRITE (3) L,(DATA(I),I=1,L)
	READ (1) L,(DATA(I),I=1,L)	!HEAD2
	WRITE (3) L,(DATA(I),I=1,L)
	READ (1) L,(DATA(I),I=1,L)	!TITLE
	WRITE (3) L,(DATA(I),I=1,L)
	READ (1) L,(DATA(I),I=1,L)	!SUBTL
	WRITE (3) L,(DATA(I),I=1,L)
	READ (1) LEN,IPTRD
	WRITE (3) LEN,IPTRD
	READ (1) OFFSET,PREF
	IF (N1.EQ.0) N1 = OFFSET+1
	OFFSE2 = N1-1
	WRITE (3) OFFSE2,PREF
	READ (1) ZERO1,ZERO2
	WRITE (3) ZERO1,ZERO2
	READ (1) NREC
	BACKSPACE 1
	FIN
	TO MAKE-NEW-TAB-FILE
	CALL MVSTR(FILNAM(LTNAM),'.TAB;1')
	LENWDS = (LENREC+1)/2
	CALL ASSIGN(4,FILNAM)
	CALL FDBSET(4,'NEW')
	DEFINE FILE 4 (MAXREC,LENWDS,U,IVAR2)
	FIN
	TO COPY-RECORDS-TO-NEW-TABLE
	DO (IREC = N1,N2)
	READ (2'IREC-OFFSET) (DATA(I),I=1,LENREC)
	WRITE (4'IREC-OFFSE2) (DATA(I),I=1,LENREC)
	FIN
C	UPDATE NREC2 IN NEW .TAI FILE
	NREC2 = N2-N1+1
D	WRITE (5,9904) NREC2
D9904	FORMAT (' SUBTABLE NREC IS',I5)
	WRITE (3) NREC2
	FIN
	TO DELETE-RECORDS-FROM-OLD-TABLE
	NDEL = N2-N1+1
	IF (N2+1-OFFSET.LT.NREC)
D	WRITE (5,9901) N2+1-OFFSET,NREC,N1-OFFSET
D9901	FORMAT (' MOVING RECORDS',I5,' THROUGH',I5,' TO',I5)
	DO (IREC=N2+1-OFFSET,NREC)
	READ (2'IREC) (DATA(I),I=1,LENREC)
	WRITE (2'IREC-NDEL) (DATA(I),I=1,LENREC)
	FIN
	FIN
	IF (N1.EQ.OFFSET+1)
C	CORRECT OFFSET IN OLD .TAI FILE
	OFFSET = OFFSET+NDEL
D	WRITE (5,9902) OFFSET
D9902	FORMAT (' OLD OFFSET BECOMES',I5)
	BACKSPACE 1
	BACKSPACE 1
	WRITE (1) OFFSET,PREF
	WRITE (1) ZERO1,ZERO2
	FIN
C	CORRECT NREC
	NREC = NREC-NDEL
D	WRITE (5,9903) NREC
D9903	FORMAT (' NEW NREC',I5)
	WRITE (1) NREC
	FIN
	TO REPORT-RECORD-NUMBERS-ERROR
	WRITE (5,101) N1,N2,OFFSET+1,OFFSET+NREC
101	FORMAT (' Illegal record range: ',I6,' to',I6/
	1 ' Table has records,',I6,' to',I6,' only.')
	CALL EXIT
	FIN
	TO CALL-EXIT
	WRITE (5,102)
102	FORMAT (' Subtable has been created.')
	CALL EXIT
	FIN
	END