C	STRING EVALUATOR FOR RPTTAB.
C	PLACES RESULT OF STRING OPERATION IN VARIABLE.
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	03-NOV-81 ADD 'AT' AND 'NAme' OPCODES
C	04-DEC-81 ADD 'SHorten' OPCODE
C	27-JAN-82 REMOVE "TERM" ARGUMENT, INCLUDE COMMON.FLX
C	          USE REVISED GETNAM
C
	SUBROUTINE EVALST(LFMT,FMTBUF,NOPNT,LTRACE,FILERR,EVALER)
	LOGICAL*1  NOPNT,LTRACE, FILERR, EVALER
	BYTE FMTBUF(LFMT)
C
C	DECLARE COMMON BLOCKS
C
	COMMON      /TABDAT/  NREC,NCOLS,LENREC,IOFSET,IPTRD,TABREC,
	1                     DATA
	INTEGER     NREC,NCOLS,LENREC,IOFSET,IPTRD(41),TABREC
	BYTE        DATA(1000)

	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
C	COMMON      /SCRATCH/  SCRATCH
C	BYTE        SCRATCH (576)
	COMMON      /SCRATCH/  STR1,STR2,STR3
C
C	LOCAL DECLARATIONS
C

	LOGICAL*1 QUOTED,NOINT,NOSTR3,EQUAL,LOGIC1
	INTEGER GETVAR,ADDVAR,SEARCH,VERIFY
	REAL JDATE
	BYTE NULL
	DATA NULL /0/
	REAL*8 TARGET,VARNAM
	BYTE VBYTE(8)
	EQUIVALENCE (VBYTE,VARNAM)
	INTEGER OPCODE,LENOP,SUBOP,CONCOP,INDOP,SEAROP,SKIPOP,VALOP,
	1 TRANOP,REPLOP,EQUOP,JDATOP,CHAROP,DATOP,TIMOP,ATOP,NAMEOP,
	1 SHRTOP
	BYTE OPBYTE(2)
	EQUIVALENCE (OPBYTE,OPCODE)
	DATA LENOP,SUBOP,CONCOP,INDOP,SEAROP,SKIPOP,VALOP,TRANOP,REPLOP,
	1 EQUOP,JDATOP,CHAROP,DATOP,TIMOP,ATOP,NAMEOP,SHRTOP /'LE',
	1 'SU','CO','IN','SE','SK','VA','TR','RE',
	1 'EQ','JD','CH','DA','TI','AT','NA','SH'/
C
	BYTE STR1(256),STR2(256),STR3(64)
C
	REAL*8 VARN1,VARN2,VARN3
	EQUIVALENCE (VARN1,STR1),(VARN2,STR2),(VARN3,STR3)
	DATA MAXST1/256/, MAXST2/256/, MAXST3/64/
	INTEGER LEN1,LEN2,LEN3
C
C	CODE
C
	EVALER = .FALSE.
	GET-VARIABLE-NAME
	TARGET = VARNAM
	GET-OPCODE
	PERFORM-OPERATION
	IF (LTRACE) WRITE (TILUN,501) TARGET,(STR1(I),I=1,LEN1)
501	FORMAT (' %STRING: ',A8,' BECOMES '(1X,40A1))
	STORE-VARIABLE
	RETURN
C
	TO GET-VARIABLE-NAME
	IF (INPTR.EQ.0) REPORT-STRING-ERROR
	CALL GETNAM(0,VARNAM,8,LVNAM,FILERR,QUOTED,EVALER)
	IF (FILERR) RETURN
	IF (EVALER) RETURN
	IF (LVNAM.LT.8)
	DO (I=LVNAM+1,8) VBYTE(I) = ' '
	FIN
	FIN

	TO GET-OPCODE
	IF (INPTR.EQ.0) REPORT-STRING-ERROR
	CALL GETNAM(0,STR3,MAXST3,LOPC,FILERR,QUOTED,EVALER)
	IF (FILERR) RETURN
	IF (EVALER) RETURN
	IF (LOPC.LT.2) REPORT-STRING-ERROR
	DO (I=1,2) OPBYTE(I) = STR3(I).AND."137
	FIN

	TO PERFORM-OPERATION
	SELECT (OPCODE)
	(ATOP)   DO-AT-OPERATION
	(CHAROP) DO-CHARACTER-OPERATION
	(CONCOP) DO-CONCATENATION-OPERATION
	(DATOP)  DO-DATE-OPERATION
	(EQUOP)  DO-EQUAL-OPERATION
	(INDOP)  DO-INDEX-OPERATION
	(JDATOP) DO-JDATE-OPERATION
	(LENOP)  DO-LENGTH-OPERATION
	(NAMEOP) DO-NAME-OPERATION
	(REPLOP) DO-REPLACE-OPERATION
	(SEAROP) DO-SEARCH-OPERATION
	(SHRTOP) DO-SHORTEN-OPERATION
	(SKIPOP) DO-SKIP-OPERATION
	(SUBOP)  DO-SUBSTRING-OPERATION
	(TIMOP)  DO-TIME-OPERATION
	(TRANOP) DO-TRANSLATE-OPERATION
	(VALOP)  DO-VALUE-OPERATION
	(OTHERWISE) REPORT-STRING-ERROR
	FIN
	FIN

	TO DO-AT-OPERATION
C	AT <s1> (returns the contents of the variable named in <s1>; or error)
	GET-STRING-1
	IF (LEN1.GT.8) REPORT-STRING-ERROR
	VARNAM = VARN1
	IF (LEN1.LT.8)
	DO (I=LEN1+1,8) VBYTE(I) = ' '
	FIN
	LEN1 = GETVAR(VARNAM,STR1,MAXST1)
D	WRITE (5,9907) VARNAM,LEN1,(STR1(I),I=1,LEN1)
D9907	FORMAT (' AT- : VARNAM: ',A8,' LEN1 ',I8/(1X,60A1))
	IF (LEN1.LE.0) REPORT-VARIABLE-ERROR
	FIN

	TO DO-CHARACTER-OPERATION
C	CHARACTER <n>  (returns the 1-character string whose value is <n>)
	GET-INTEGER
	IF (NOINT) REPORT-STRING-ERROR
	IF (NN.LT.0.OR.NN.GT.255) REPORT-STRING-ERROR
	STR1(1) = NN
	LEN1 = 1
	FIN

	TO DO-CONCATENATION-OPERATION
C	CONCATENATE <string1> <string2>  (place <string1>!!<string2> in target)
	GET-STRING-1
	GET-STRING-2
	IF (LEN1+LEN2 .GT. MAXST1) REPORT-LENGTH-ERROR
	DO (I=1,LEN2) STR1(LEN1+I) = STR2(I)
	LEN1 = LEN1+LEN2
	FIN

	TO DO-DATE-OPERATION
C	SYSTEM-DEPENDENT CALL
	CALL DATE (STR1)
	LEN1 = 9
	FIN

	TO DO-EQUAL-OPERATION
C	EQUAL <string1> <string2>  
	GET-STRING-1
	GET-STRING-2
	LOGIC1 = LEN1.EQ.LEN2.AND.EQUAL(STR1,STR2,LEN1)
	WHEN (LOGIC1) VAREAL = -1.0
	ELSE VAREAL = 0.0
	CONVERT-REAL-TO-VARIABLE
	FIN

	TO DO-INDEX-OPERATION
C	INDEX <string1> <string2>  (place (index of <string2> in <string1>)
C	in target.
	GET-STRING-1
	GET-STRING-2
	IND = INDEX(STR1,STR2,LEN1,LEN2)
	VAREAL = IND
	CONVERT-REAL-TO-VARIABLE
	FIN

	TO DO-JDATE-OPERATION
C	JDATE <string1>  (returns Julian date (from 12-31-1899))
	GET-STRING-2
	VAREAL = JDATE (STR2,LEN2)
	IF (VAREAL.LE.0) REPORT-BAD-DATE
	CONVERT-REAL-TO-VARIABLE
	FIN

	TO DO-LENGTH-OPERATION
C	LENGTH <string>  (place length of <string> in target)
	GET-STRING-1
	VAREAL = LEN1
	CONVERT-REAL-TO-VARIABLE
	FIN

	TO DO-NAME-OPERATION
C	NAME <string1>  (returns TRUE iff string1 is the name of a variable)
	GET-STRING-1
	WHEN (LEN1.GT.8) VAREAL = 0.0
	ELSE
	VARNAM = VARN1
	IF (LEN1.LT.8)
	DO (I=LEN1+1,8) VBYTE(I) = ' '
	FIN
	LOGIC1 = (GETVAR(VARNAM,STR1,MAXST1) .GT. 0)
	WHEN (LOGIC1) VAREAL = -1.0
	ELSE VAREAL = 0.0
	CONVERT-REAL-TO-VARIABLE
	FIN
	FIN

	TO DO-REPLACE-OPERATION
C	REPLACE <string1> <n1> <string2> [<n2>]  (replace string1 starting
C	at the <n1>st character by <string2> [for <n2> characters]
	GET-STRING-1
	GET-INTEGER
	IF (NOINT) REPORT-STRING-ERROR
	N1 = NN
	GET-STRING-2
	GET-INTEGER
	IF (NOINT) NN = LEN2
	IF (N1+NN.GT.MAXST1) REPORT-LENGTH-ERROR
	DO (I=1,NN) STR1(N1-1+I) = STR2(I)
	LEN1 = MAX0(LEN1,N1+NN-1)
	FIN

	TO DO-SEARCH-OPERATION
C	SEARCH <string1> <string2>  (returns index of first character of
C	<string1> which is a member of <string2>)
	GET-STRING-1
	GET-STRING-2
	I1 = SEARCH(STR1,STR2,LEN1,LEN2)
	VAREAL = I1
	CONVERT-REAL-TO-VARIABLE
	FIN

	TO DO-SHORTEN-OPERATION
C	SHORTEN <string1>  (returns all of <string1> up through the last
C	non-blank character.
	GET-STRING-1
	WHILE (STR1(LEN1).EQ.' ') LEN1 = LEN1 -1
	FIN

	TO DO-SKIP-OPERATION
C	SKIP <string1> <string2>  (returns index of first character in
C	<string1> which is NOT a member of <string2>)
	GET-STRING-1
	GET-STRING-2
	I1 = VERIFY(STR1,STR2,LEN1,LEN2)
	VAREAL = I1
	CONVERT-REAL-TO-VARIABLE
	FIN
	TO DO-SUBSTRING-OPERATION
C	SUBSTRING <string1> [<n1>] [<n2>]  (replace <target> by [that part
C	of] <string1> [beginning at the <n1>st character] [and continuing
C	for a total of <n2> characters].
C	%ST <target> SUBST 'abcde'   initializes the target.
	GET-STRING-2
	GET-INTEGER
	IF (NOINT) N1 = 1
	UNLESS (NOINT)
	N1 = NN
	GET-INTEGER
	LEN1 = NN
	FIN
	IF (NOINT) LEN1 = LEN2-N1+1
	IF (N1.LE.0.OR.LEN1.LE.0) REPORT-STRING-ERROR
	IF (LEN1.GT.MAXST1) REPORT-LENGTH-ERROR
	DO (I=1,LEN1) STR1(I) = STR2(I-1+N1)
	FIN
	TO DO-TIME-OPERATION
C	SYSTEM-DEPENDENT CALL
	CALL TIME (STR1)
	LEN1 = 8
	FIN
	TO DO-TRANSLATE-OPERATION
C	TRANSLATE <string1> <string2> <string3>  (for each character of
C	<string1>: if the character appears in <string2>, replace it by
C	the corresponding character of <string3>; if <string3>
C	is shorter than <string2>, results are unpredictable.
	GET-STRING-1
	GET-STRING-2
	GET-STRING-3
	DO (I1 = 1,LEN1)
	I2 = 1
	WHILE (I2.LE.LEN2.AND.STR1(I1).NE.STR2(I2)) I2 = I2+1
	IF (I2.LE.LEN2) STR1(I1) = STR3(I2)
	FIN
	FIN
	TO DO-VALUE-OPERATION
C	VALUE <string1> <n1>  (place value of the <n1>st character of <string1>
C	in <target>.
	GET-STRING-1
	GET-INTEGER
	IF (NOINT) REPORT-STRING-ERROR
	VAREAL = STR1(NN)
	CONVERT-REAL-TO-VARIABLE
	FIN

	TO CONVERT-REAL-TO-VARIABLE
	ENCODE (MAXST1,FMTBUF,STR1,ERR=26) VAREAL,NULL
	IF (.FALSE.)
26	CONTINUE
	REPORT-INVALID-FORMAT
	FIN
	LEN1 = LENGTH(STR1)-1
	IF (NOPNT) LEN1 = LEN1-1
	FIN

	TO GET-INTEGER
C	NN IS INTEGER.  NOINT IS .TRUE. IF NO INTEGER.
	NOINT = INPTR.EQ.0 .OR. INPTR.GE.LLINE
	UNLESS (NOINT)
C	ALLOW INFINITE INDIRECTION FOR NUMERIC OPERANDS
	CALL GETNAM(-1,STR3,MAXST3,LEN3,FILERR,QUOTED,EVALER)
	IF (FILERR) RETURN
	IF (EVALER) RETURN
	NN = EVATOM(LEN3,STR3,EVALER)
	IF (EVALER) REPORT-EVALUATION-ERROR
	FIN
D	WRITE (5,9901) NOINT,NN,LEN3,(STR3(I),I=1,LEN3)
D9901	FORMAT (' GET-INTEGER: NOINT,NN,LEN3,STR3:',L4,2I5/(1X,80A1))
	FIN

	TO GET-STRING-1
	IF (INPTR.EQ.0) REPORT-STRING-ERROR
C	ALLOW ONE LEVEL OF INDIRECTION FOR STRING OPERANDS
	CALL GETNAM(1,STR1,MAXST1,LEN1,FILERR,QUOTED,EVALER)
	IF (FILERR) RETURN
	IF (EVALER) RETURN
D	WRITE (5,9911) QUOTED,LEN1,(STR1(I),I=1,LEN1)
D9911	FORMAT (' GET-STRING-1: QUOTED,LEN1, STR1:',L4,I5/(1X,80A1))
	FIN

	TO GET-STRING-2
	IF (INPTR.EQ.0) REPORT-STRING-ERROR
	CALL GETNAM(1,STR2,MAXST2,LEN2,FILERR,QUOTED,EVALER)
	IF (FILERR) RETURN
	IF (EVALER) RETURN
D	WRITE (5,9912) QUOTED,LEN2,(STR2(I),I=1,LEN2)
D9912	FORMAT (' GET-STRING-2: QUOTED,LEN2, STR2:',L4,I5/(1X,80A1))
	FIN

	TO GET-STRING-3
	IF (INPTR.EQ.0) REPORT-STRING-ERROR
	CALL GETNAM(1,STR3,MAXST3,LEN3,FILERR,QUOTED,EVALER)
	IF (FILERR) RETURN
	IF (EVALER) RETURN
D	WRITE (5,9913) QUOTED,LEN3,(STR3(I),I=1,LEN3)
D9913	FORMAT (' GET-STRING-3: QUOTED,LEN3, STR3:',L4,I5/(1X,80A1))
	FIN

	TO REPORT-BAD-DATE
	WRITE (TILUN,45)
45	FORMAT (' Bad date string.')
	EVALER = .TRUE.
	RETURN
	FIN

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

	TO REPORT-INVALID-FORMAT
	WRITE (TILUN,46) (FMTBUF(I),I=1,LFMT)
46	FORMAT (' Invalid format: ',40A1)
	EVALER = .TRUE.
	RETURN
	FIN

	TO REPORT-LENGTH-ERROR
	WRITE (TILUN,40) MAXST1
40	FORMAT (' String error: length exceeds',I4)
	EVALER = .TRUE.
	RETURN
	FIN

	TO REPORT-STRING-ERROR
	WRITE (TILUN,42)
42	FORMAT (' Invalid string operation.')
	EVALER = .TRUE.
	RETURN
	FIN

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

	TO STORE-VARIABLE
	IF (LEN1.EQ.0)
	LEN1 = 1
	STR1(1) = ' '
	FIN
	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.')
	EVALER = .TRUE.
	RETURN
	FIN
	FIN
	END
	FUNCTION SEARCH(STR1,STR2,LEN1,LEN2)
	INTEGER SEARCH
	BYTE STR1(LEN1),STR2(LEN2)
	LOGICAL*1 NFOUND
	NFOUND = .TRUE.
	I1 = 1
	WHILE (I1.LE.LEN1.AND.NFOUND)
	I2 = 1
	WHILE (I2.LE.LEN2.AND.NFOUND)
	NFOUND = STR1(I1).NE.STR2(I2)
	I2 = I2+1
	FIN
	IF (NFOUND) I1 = I1+1
	FIN
	IF (NFOUND) I1 = 0
	SEARCH = I1
	RETURN
	END