C	FILE TABSUB.FLX
C	SUBROUTINES TO EXTRACT AND REPLACE STRINGS IN TABLES.
C	PRECEDE BY CALLING OPNTAB.
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	MOD. 21-JAN-82 TO USE IALT
C
C	28-JAN-82  INCLUDE STANDARD COMMON
C
C	SUBROUTINE PUTTAB(LTRACE,TABERR)
C
C	SUBROUTINE GETTAB(LTRACE,TABERR)
C
C	MODIFIED 10-81 TO WRITE RECORD ONLY WHEN NECESSARY
C
	SUBROUTINE GETTAB(LTRACE,TABERR)
	LOGICAL*1 LTRACE,TABERR
	CALL GETPUT(0,LTRACE,TABERR)
	RETURN
	END
	SUBROUTINE PUTTAB(LTRACE,TABERR)
	LOGICAL*1 LTRACE,TABERR
	CALL GETPUT(1,LTRACE,TABERR)
	RETURN
	END
C	SUBROUTINE GETPUT actually does the work.
C
	SUBROUTINE GETPUT(GPSW,LTRACE,TABERR)
C
C	INCLUDE 'COMMON.FLX'
C
C	Declare common blocks.
C
	COMMON      /TABDAT/  NREC,NCOLS,LENREC,OFFSET,IPTRD,TABREC,
	1                     DATA,IALT,IDUM
	INTEGER     NREC,NCOLS,LENREC,OFFSET,IPTRD(41),TABREC
	BYTE        DATA(1000)
	LOGICAL*1   IALT,IDUM    !1-82

	COMMON      /LUN/     INLUN,OUTLUN,TILUN,TABLUN,TAILUN,RDFLUN
	INTEGER     INLUN,OUTLUN,TILUN,TABLUN,TAILUN,RDFLUN

	COMMON      /INPUT/   IREC,INPTR,LLINE,INLINE
	BYTE        INLINE(132)
	DATA        MAXIN/132/

	COMMON      /OUTPUT/  OUTLIN,OUTPTR,OUTEND
	BYTE        OUTLIN (132)
	INTEGER     OUTPTR,OUTEND
	DATA        MAXOUT /132/

	COMMON      /FILES/   FILNAM,MAXFNM,MODNAM,LFNAM,FLREC,
	1                     MAXLVL,INLVL,OLDLVL,ULBUF,CARCTL,TERM
	1                     ,OUTOPN,TBOPEN
C
C	File stack.
C
	BYTE        FILNAM(26,5)
	DATA        MAXFNM/26/
	REAL*4      MODNAM(5)                 !9-OCT-81 RAD50 MODULE NAMES
	INTEGER     LFNAM(5)                  !LENGTHS OF NAMES
C	                                      !POINTERS TO  START OF CURRENT
C	                                        !OR NEXT RECORD
  	REAL*4      FLREC(5)                  !9-OCT-81 CHANGED FROM
C	                                      !RECORD PTR TO BYTE PTR
C
D	INTEGER     IFLREC(2,5)
D	EQUIVALENCE (IFLREC,FLREC)
	DATA        MAXLVL/5/
	INTEGER     INLVL                     !CURRENT LEVEL POINTER
	INTEGER     OLDLVL                    !PREVIOUS LEVEL POINTER
	INTEGER     ULBUF (7)
	BYTE        CARCTL
	LOGICAL*1   TERM,OUTOPN,TBOPEN
C
C	Scratch memory.  Definitions may differ from subroutine to subroutine,
C	or may use equivalence statements.
C
	COMMON      /SCRATC/  SCRATC
	BYTE        SCRATC (576)
C
C	Local declarations.
C
	INTEGER GPSW,GET,PUT
C	ROW NUMBER CHECK DEPENDS ON THESE VALUES
	DATA GET,PUT/0,1/
	LOGICAL*1 LTRACE,TABERR
	LOGICAL*1 QUOTED,FILERR
C
	REAL*8 VARNAM,TARGET
	BYTE VBYTE(8)
	EQUIVALENCE (VARNAM,VBYTE)
	BYTE STR1(256)
	REAL*8 VARN1
	EQUIVALENCE (STR1,VARN1)
	EQUIVALENCE (STR1,SCRATC)
	DATA MAXSTR/256/
	INTEGER COLNO,ROWNO
	INTEGER GETVAR,ADDVAR,GETDTA,PUTDTA,VERIFY
C
D	WRITE (5,9902) GPSW,NREC,NCOLS,LENREC,TABREC
D9902	FORMAT (' ENTER GETPUT; GPSW,NREC,NCOLS,LENREC,TABREC='/5I6)
C
	TABERR = .FALSE.
	UNLESS (TBOPEN) REPORT-TABLE-NOT-OPEN
	GET-TARGET
	GET-ROW-NUMBER
	GET-COLUMN-NUMBER
	SELECT (GPSW)
	(GET)
	GET-DATA-FROM-TABLE
	STORE-DATA-IN-TARGET
	IF (LTRACE) WRITE (TILUN,501) TARGET,ROWNO+OFFSET,COLNO
	1 ,(STR1(I),I=1,LEN1)
501	FORMAT (' %GET ',A8,' FROM ROW',I5,' COLUMN',I5,': VALUE ',
	1 (1X,50A1))
	FIN
	(PUT)
	GET-DATA-FROM-TARGET
	STORE-DATA-IN-TABLE
	IF (LTRACE) WRITE (TILUN,502) TARGET,ROWNO+OFFSET,COLNO,
	1 (STR1(I),I=1,LEN1)
502	FORMAT (' %PUT ',A8,' IN ROW',I5,', COLUMN',I5,': VALUE',
	1 (1X,40A1))
	FIN
	(OTHERWISE)
	WRITE (TILUN,40) GPSW
40	FORMAT (' INVALID GET/PUT SWITCH:',I8)
	TABERR = .TRUE.
	RETURN
	FIN
	FIN
	RETURN

	TO GET-COLUMN-NUMBER
	ISTAR = NCOLS
	GET-INTEGER
	COLNO = NN
	IF (COLNO.LT.1.OR.COLNO.GT.NCOLS) REPORT-COLUMN-ERROR
	FIN

	TO GET-DATA-FROM-TABLE
	LEN1 = GETDTA(ROWNO,COLNO,STR1,MAXSTR)
D	WRITE (5,9912) ROWNO,COLNO,LEN1,(STR1(I),I=1,LEN1)
D9912	FORMAT (' GETPUT: GET-DATA-FROM-TABLE: ROW',I4,' COL',I4,
D	1 ' LEN1',I5,' DATA:'/(1X,60A1))
	IF (LEN1.LE.0) REPORT-LENGTH-ERROR
	FIN

	TO GET-DATA-FROM-TARGET
	LEN1 = GETVAR(TARGET,STR1,MAXSTR)
D	WRITE (5,9903) TARGET,LEN1,(STR1(I),I=1,LEN1)
D9903	FORMAT (' GETPUT: GET-DATA-FROM-TARGET: ',A8,
D	1 ' LEN1',I5,' DATA:'/(1X,60A1))
	IF (LEN1.LE.0) REPORT-VARIABLE-ERROR
	FIN

	TO GET-INTEGER
	IF (INPTR.EQ.0) REPORT-TABLE-ERROR
	CALL GETNAM (-1,STR1,MAXSTR,LEN1,FILERR,QUOTED,TABERR)
	IF (FILERR.OR.TABERR) RETURN
	WHEN (STR1(1).EQ.'*') NN = ISTAR
	ELSE NN = EVATOM(LEN1,STR1,TABERR)
	IF (TABERR) REPORT-EVALUATION-ERROR
D	WRITE (5,9901) NN,LEN1,(STR1(I),I=1,LEN1)
D9901	FORMAT (' GETPUT: GET-INTEGER: NN,LEN1,STR1:',2I5/(1X,80A1))
	FIN

	TO GET-ROW-NUMBER
	ISTAR = NREC
	GET-INTEGER
	ROWNO = NN-OFFSET
	IF (ROWNO.LE.0.OR.ROWNO.GT.NREC+GPSW) REPORT-ROW-ERROR
	FIN

	TO GET-TARGET
	IF (INPTR.EQ.0) REPORT-TABLE-ERROR
	CALL GETNAM(0,VARNAM,8,LVNAM,FILERR,QUOTED,TABERR)
D	WRITE (5,9914) VARNAM
D9914	FORMAT (' GETPUT: VARNAM = ',A8)
	IF (FILERR) RETURN
	IF (TABERR) RETURN
	IF (LVNAM.LT.8)
	DO (I=LVNAM+1,8) VBYTE(I) = ' '
	FIN
	TARGET=VARNAM
	FIN

	TO REPORT-COLUMN-ERROR
	WRITE (TILUN,42) COLNO
42	FORMAT (' Invalid column number:',I8)
	TABERR = .TRUE.
	RETURN
	FIN

	TO REPORT-EVALUATION-ERROR
	WRITE (TILUN,47)
47	FORMAT (' Evaluation error')
	RETURN
	FIN

	TO REPORT-LENGTH-ERROR
C	MESSAGE HAS ALREADY BEEN PRINTED.
	TABERR = .TRUE.
	RETURN
	FIN

	TO REPORT-ROW-ERROR
	WRITE (TILUN,43) ROWNO+OFFSET
43	FORMAT (' Invalid row number:',I8)
	TABERR = .TRUE.
	RETURN
	FIN

	TO REPORT-TABLE-ERROR
	WRITE (TILUN,41)
41	FORMAT (' Invalid table operation.')
	TABERR = .TRUE.
	RETURN
	FIN

	TO REPORT-TABLE-NOT-OPEN
	WRITE (TILUN,45)
45	FORMAT (' No table is open')
	TABERR = .TRUE.
	RETURN
	FIN

	TO REPORT-VARIABLE-ERROR
	WRITE (TILUN,44) VARNAM
44	FORMAT (' Table error: no such variable as: ',A8)
D	WRITE (5,9904) VBYTE
D9904	FORMAT (8O8)
	TABERR = .TRUE.
	RETURN
	FIN

	TO STORE-DATA-IN-TABLE
	IRET = PUTDTA(ROWNO,COLNO,STR1,LEN1)
	IF (IRET.LT.0) REPORT-LENGTH-ERROR
	FIN

	TO STORE-DATA-IN-TARGET
	IRET = ADDVAR(TARGET,STR1,LEN1)
	IF (IRET.LT.0)
	SELECT (IRET)
	(-3) WRITE (TILUN,61)
	(-2) WRITE (TILUN,62)
	(-1) WRITE (TILUN,63)
	FIN
61	FORMAT (' NO ROOM IN VARIABLE INDEX.')
62	FORMAT (' NO ROOM IN VARIABLE STORAGE AREA.')
63	FORMAT (' VARIABLE HAS LENGTH <0.')
	TABERR = .TRUE.
	RETURN
	FIN
	FIN
	END
C
C	Function GETDTA returns data from table.
C	Returns (+)=length of data, -1=failure.
C
	FUNCTION GETDTA(IROW,ICOL,STRING,MAXSTR)
	INTEGER GETDTA,IROW,ICOL,MAXSTR
	BYTE STRING(MAXSTR)
C
C	INCLUDE 'COMMON.FLX'
C
C	Declare common blocks.
C
	COMMON      /TABDAT/  NREC,NCOLS,LENREC,OFFSET,IPTRD,TABREC,
	1                     DATA,IALT,IDUM
	INTEGER     NREC,NCOLS,LENREC,OFFSET,IPTRD(41),TABREC
	BYTE        DATA(1000)
	LOGICAL*1   IALT,IDUM    !1-82

	COMMON      /LUN/     INLUN,OUTLUN,TILUN,TABLUN,TAILUN,RDFLUN
	INTEGER     INLUN,OUTLUN,TILUN,TABLUN,TAILUN,RDFLUN

	COMMON      /INPUT/   IREC,INPTR,LLINE,INLINE
	BYTE        INLINE(132)
	DATA        MAXIN/132/

	COMMON      /OUTPUT/  OUTLIN,OUTPTR,OUTEND
	BYTE        OUTLIN (132)
	INTEGER     OUTPTR,OUTEND
	DATA        MAXOUT /132/

	COMMON      /FILES/   FILNAM,MAXFNM,MODNAM,LFNAM,FLREC,
	1                     MAXLVL,INLVL,OLDLVL,ULBUF,CARCTL,TERM
	1                     ,OUTOPN,TBOPEN
C
C	File stack.
C
	BYTE        FILNAM(26,5)
	DATA        MAXFNM/26/
	REAL*4      MODNAM(5)                 !9-OCT-81 RAD50 MODULE NAMES
	INTEGER     LFNAM(5)                  !LENGTHS OF NAMES
C	                                      !POINTERS TO  START OF CURRENT
C	                                        !OR NEXT RECORD
  	REAL*4      FLREC(5)                  !9-OCT-81 CHANGED FROM
C	                                      !RECORD PTR TO BYTE PTR
C
D	INTEGER     IFLREC(2,5)
D	EQUIVALENCE (IFLREC,FLREC)
	DATA        MAXLVL/5/
	INTEGER     INLVL                     !CURRENT LEVEL POINTER
	INTEGER     OLDLVL                    !PREVIOUS LEVEL POINTER
	INTEGER     ULBUF (7)
	BYTE        CARCTL
	LOGICAL*1   TERM,OUTOPN,TBOPEN
C
C	Scratch memory.  Definitions may differ from subroutine to subroutine,
C	or may use equivalence statements.
C
	COMMON      /SCRATC/  SCRATC
	BYTE        SCRATC (576)
C
C	Local declarations.
C
	IF (IROW.NE.TABREC) READ-RECORD
	GET-ENTRY
	RETURN

	TO READ-RECORD
	IF (IALT) WRITE (TABLUN'TABREC) (DATA(I),I=1,LENREC) !10-81, 1-82
	READ(TABLUN'IROW) (DATA(I),I=1,LENREC)
D	WRITE (5,9901) IROW,(DATA(I),I=1,LENREC)
D9901	FORMAT (' GETDTA: READ RECORD',I6,' DATA ='/(1X,40A1))
	TABREC = IROW
	IALT = .FALSE.
	FIN

	TO GET-ENTRY
	GETDTA = IPTRD(ICOL+1)-IPTRD(ICOL)
	IF (GETDTA.GT.MAXSTR) REPORT-LENGTH-ERROR
	K = IPTRD(ICOL)-1
	DO (I=1,GETDTA) STRING(I) = DATA(I+K)
D	WRITE (5,9902) IPTRD(ICOL),IPTRD(ICOL+1),(STRING(I),I=1,GETDTA)
D9902	FORMAT (' GETDTA: ENTRY POINTERS:',2I5,' ENTRY: '/(1X,60A1))
	FIN

	TO REPORT-LENGTH-ERROR
	WRITE (TILUN,40) GETDTA,MAXSTR
40	FORMAT (' Column width,',I6,', exceeds variable width,',I6)
	GETDTA = -1
	RETURN
	FIN
	END
C
C	Function PUTDTA puts data into table.
C	Returns +1=success; -1=length error.
C
	FUNCTION PUTDTA(IROW,ICOL,STRING,LENSTR)
	INTEGER PUTDTA,IROW,ICOL,LENSTR
	BYTE STRING(LENSTR)
C
C	INCLUDE 'COMMON.FLX'
C
C	Declare common blocks.
C
	COMMON      /TABDAT/  NREC,NCOLS,LENREC,OFFSET,IPTRD,TABREC,
	1                     DATA,IALT,IDUM
	INTEGER     NREC,NCOLS,LENREC,OFFSET,IPTRD(41),TABREC
	BYTE        DATA(1000)
	LOGICAL*1   IALT,IDUM    !1-82

	COMMON      /LUN/     INLUN,OUTLUN,TILUN,TABLUN,TAILUN,RDFLUN
	INTEGER     INLUN,OUTLUN,TILUN,TABLUN,TAILUN,RDFLUN

	COMMON      /INPUT/   IREC,INPTR,LLINE,INLINE
	BYTE        INLINE(132)
	DATA        MAXIN/132/

	COMMON      /OUTPUT/  OUTLIN,OUTPTR,OUTEND
	BYTE        OUTLIN (132)
	INTEGER     OUTPTR,OUTEND
	DATA        MAXOUT /132/

	COMMON      /FILES/   FILNAM,MAXFNM,MODNAM,LFNAM,FLREC,
	1                     MAXLVL,INLVL,OLDLVL,ULBUF,CARCTL,TERM
	1                     ,OUTOPN,TBOPEN
C
C	File stack.
C
	BYTE        FILNAM(26,5)
	DATA        MAXFNM/26/
	REAL*4      MODNAM(5)                 !9-OCT-81 RAD50 MODULE NAMES
	INTEGER     LFNAM(5)                  !LENGTHS OF NAMES
C	                                      !POINTERS TO  START OF CURRENT
C	                                        !OR NEXT RECORD
  	REAL*4      FLREC(5)                  !9-OCT-81 CHANGED FROM
C	                                      !RECORD PTR TO BYTE PTR
C
D	INTEGER     IFLREC(2,5)
D	EQUIVALENCE (IFLREC,FLREC)
	DATA        MAXLVL/5/
	INTEGER     INLVL                     !CURRENT LEVEL POINTER
	INTEGER     OLDLVL                    !PREVIOUS LEVEL POINTER
	INTEGER     ULBUF (7)
	BYTE        CARCTL
	LOGICAL*1   TERM,OUTOPN,TBOPEN
C
C	Scratch memory.  Definitions may differ from subroutine to subroutine,
C	or may use equivalence statements.
C
	COMMON      /SCRATC/  SCRATC
	BYTE        SCRATC (576)
C
C	Local declarations.
C
	BYTE BUFFER(8)
	INTEGER ADDVAR
C
D	WRITE (5,9904) IROW,ICOL,TABREC
D9904	FORMAT (' ENTER PUTDTA WITH IROW, ICOL, TABREC',3I6)
	IF (IROW.NE.TABREC)
	IF (IALT) WRITE (TABLUN'TABREC) (DATA(I),I=1,LENREC) !10-81, 1-82
	WHEN (IROW.LE.NREC) READ-RECORD
	ELSE
C	Fortran OTS problem!  Don't write without doing a read first to
C	fill block buffer.
	IROW = IROW-1
	READ-RECORD
	IROW = IROW+1
	DO (I=1,LENREC) DATA(I) = ' '
	TABREC = IROW
	FIN
	FIN
	PUT-DATA-IN-COLUMN
C10-81	WRITE-RECORD
	IF (IROW.GT.NREC) UPDATE-INDEX-FILE
	PUTDTA = 1
	IALT = .TRUE.     !1-82
	RETURN

	TO READ-RECORD
	READ(TABLUN'IROW) (DATA(I),I=1,LENREC)
D	WRITE (5,9901) IROW,(DATA(I),I=1,LENREC)
D9901	FORMAT (' PUTDTA: READ RECORD',I6,' DATA ='/(1X,40A1))
	TABREC = IROW
	FIN

	TO PUT-DATA-IN-COLUMN
	LCOL = IPTRD(ICOL+1)-IPTRD(ICOL)
	IF (LCOL.LT.LENSTR) REPORT-LENGTH-ERROR
	K = IPTRD(ICOL)-1
	DO (I=1,LENSTR) DATA(I+K) = STRING(I)
	IF (LENSTR.LT.LCOL)
	DO (I=LENSTR+1,LCOL) DATA(I+K) = ' '
	FIN
	FIN

	TO REPORT-LENGTH-ERROR
	WRITE (TILUN,40) LENSTR,LCOL
40	FORMAT (' Variable length,',I6,', exceeds column width,',I6)
	PUTDTA = -1
	RETURN
	FIN

	TO UPDATE-INDEX-FILE
	NREC = NREC+1
	WRITE (TAILUN) NREC
D	WRITE (5,9902) NREC
D9902	FORMAT (' UPDATE INDEX FILE: NREC = ',I5)
	BACKSPACE TAILUN
C	Update "LASTROW"
	LASTR = EVATOM(7,'LASTROW',ERR)
C	if (err) report-last-row-error
	LASTR = LASTR+1
	ENCODE (8,20,BUFFER) LASTR
20	FORMAT (I8)
	IRET = ADDVAR('LASTROW',BUFFER,8)
	FIN
	END