      Subroutine RMMAIN
C
C  ****************************************************************
C
C  RELATIONAL INFORMATION MANAGEMENT SYSTEM (RIM) - VERSION 5
C
C  THIS PROGRAM IS AN IMPLEMENTATION OF THE RELATIONAL ALGEBRA
C  MODEL OF DATA BASE MANAGEMENT.
C
C  THE PRINCIPAL AUTHORS ARE
C
C  WAYNE J. ERICKSON
C    DATA MANAGEMENT CONSULTANT
C    2029 5TH STREET S.E.
C    PUYALLUP,WASHINGTON 98371
C  FREDERIC P. GRAY JR.
C    BOEING COMERCIAL AIRPLANE COMPANY (BCAC)
C  GEOFFREY VONLIMBACH
C    BOEING COMPUTER SERVICES COMPANY (BCS)
C
C  CONTRIBUTIONS TO RIM-5 CODE WERE ALSO MADE BY
C
C  LAURA B. HAMED (UNLOAD) AND
C  STIG O. WAHLSTROM (SORT) OF BCS AND BCAC RESPECTIVELY.
C
C
C Ported to Unix (specifically sun4) 8/1991 by
C  Glenn C. Everhart
C  Build is just "f77 rim.for".
C  The port fixes things like case of input, gets file
C operations and so on working, and does NOT use the sun
C compiler's "vax fortran compatible" features.
C Major other hacks by Glenn Everhart. User noticeable will be the
C mixed case messages!
C
C This version of RIM also is modified for use with AnalytiCalc
C by the replacement of console I/O with subroutine calls
C so that I/O can be controlled more sensibly; this was done
C by Glenn Everhart.
C
C  RIM-5 EXTENDS THE CAPABILITIES OF RIM-4
C  PRIMARILY BY ADDING CAPABILITY FOR VARIABLE LENGTH
C  ATTRIBUTES,ADDING SEVERAL ATTRIBUTE TYPES,IMPLEMENTING
C  BOTH DIRECT AND MENU MODE,EXPANDING THE COMMAND LANGUAGE
C  AND ENTENDING THE FORTRAN INTERFACE CAPABILITIES
C
C  RIM-5 IS WRITTEN IN FORTRAN 77 AND IS INTENDED TO
C  BE EASILY IMPLEMENTED ON COMPUTERS SUPPORTING THIS
C  LANGUAGE.
C
C  RIM WAS ORIGINALLY DEVELOPED UNDER THE IPAD PROJECT
C  (NASA CONTRACT NAS-14700) BY WAYNE ERICKSON AND
C  DENNIS COMFORT BOTH AT THAT TIME WITH BCS. EXTENSIONS
C  TO RIM WERE THEN MADE BY WAYNE ERICKSON AND FRED GRAY
C  RESULTING IN VERSION 4 (RIM-4) IN LATE 1980.
C
C  MAJOR MILESTONES IN THE DEVELOPMENT OF RIM:
C
C     1/78 TO 3/78 - WAYNE ERICKSON AND DENNIS COMFORT DEVELOP
C                    VERSION 1 OF RIM AS PART OF THE IPAD PROJECT
C     4/78 TO 9/78 - WAYNE AND DENNIS MAKE FURTHER ENHANCEMENTS TO
C                    MAKE VERSION 2 WHILE AT IPAD
C     6/79 TO 9/79 - WAYNE MAKES VERSION 3 OF RIM AT THE UNIVERSITY
C                    OF WASHINGTON. THIS VERSION USED THE CDC
C                    SEGMENTED LOADER AND THE FASTIO PACKAGE.
C     9/79 TO 5/80 - WAYNE MAKES VERSION 4 OF RIM FOR THE UNIVERSITY
C                    OF WASHINGTON AND BOEING/NASA. THIS VERSION COULD
C                    HANDLE RELATIONS OF ANY LENGTH AND HAD KEY ELEMENTS
C     5/80 TO 1/81 - FRED GRAY EXTENDS VERSION 4 AT BOEING TO INCLUDE
C                    AN ENHANCED COMMAND LANGUAGE AND A MENU MODE OF
C                    EXECUTION.
C     9/80 TO 1/81 - WAYNE DEVELOPES A VAX VERSION OF RIM BASED ON THE
C                    CDC VERSION.
C     2/81 TO 9/81 - WAYNE TOGETHER WITH JEFF VON LIMBACH AND FRED GRAY
C                    OF BOEING DEVELOP THE RIM PORTABLE VERSION (RIM-5).
C
C  ****************************************************************
C
C  RIM IS SUBJECT TO THE RESTRICTIONS AND DISCLAIMERS LISTED BELOW.
C
C  RESTRICTIONS AND DISCLAIMERS
C
C  THIS SOFTWARE IS PROVIDED BY THE BOEING COMPANY UNDER NASA CONTRACT
C  NAS1-14700 (IPAD).  BOEING DEVELOPED AND/OR DISTRIBUTED IPAD SOFTWARE
C  AND DOCUMENTATION MAY BE USED BY AUTHORIZED RECIPIENTS SUBJECT TO THE
C  FOLLOWING LEGENDS.
C
C   BECAUSE OF ITS POSSIBLE COMMERCIAL VALUE, THIS DATA DEVELOPED
C   UNDER U.S. GOVERNMENT CONTRACT NAS1-14700 IS BEING DISSEMINATED
C   WITHIN THE U.S. IN ADVANCE OF GENERAL PUBLICATION.  THIS DATA MAY
C   BE DUPLICATED AND USED BY THE RECIPIENT WITH THE EXPRESSED LIMIT-
C   ATIONS THAT THE DATA WILL NOT BE PUBLISHED NOR WILL IT BE RELEASED
C   TO FOREIGN PARTIES WITHOUT PRIOR PERMISSION OF THE BOEING COMPANY.
C   RELEASE OF THIS DATA TO OTHER DOMESTIC PARTIES BY THE RECIPIENT
C   SHALL ONLY BE MADE SUBJECT TO THESE LIMITATIONS.  THE LIMITATIONS
C   CONTAINED IN THIS LEGEND WILL BE CONSIDERED VOID AFTER OCT. 15,
C   1985.  THIS LEGEND SHALL BE MARKED ON ANY REPRODUCTION OF THIS
C   DATA IN WHOLE OR IN PART.
C
C   BY ACCEPTANCE OF AND IN CONSIDERATION OF THE RECEIPT OF THE DOCU-
C   MENT, DATA, OR SOFTWARE, PRODUCED BY THE BOEING COMPANY (BOEING)
C   UNDER NATIONAL AERONAUTICS AND SPACE ADMINISTRATION (NASA) DEVEL-
C   OPMENT CONTRACT NO. NAS1-14700 (IPAD), THE THIRD PARTY RECIPIENT,
C   ITS SUCCESSORS AND ASSIGNS AGREE AS FOLLOWS:
C
C      DISTRIBUTION OF THIS SOFTWARE (INCLUDING RELATED DATA AND
C      OTHER DOCUMENTATION) IS MADE BY BOEING ONLY AS AN
C      ACCOMODATION TO NASA. THIS SOFTWARE IS PROVIDED TO ALL
C      RECIPIENTS IN AN "AS IS" CONDITION. IN CONSIDERATION OF
C      RECEIPT OF THIS SOFTWARE, THE REQUESTOR AND ANY SUBSEQUENT
C      RECIPIENT ("RECIPIENT" HEREIN), AND THEIR SUCCESSORS AND
C      ASSIGNS, AGREE AS FOLLOWS:  THE BOEING COMPANY MAKES NO
C      WARRANTY WHATSOEVER IN CONNECTION WITH THIS SOFTWARE, AND THE
C      RECIPIENT HEREBY WAIVES, RELEASES AND RENOUNCES ALL
C      WARRANTIES,GUARANTEES, OBLIGATIONS, LIABILITIES, RIGHTS AND
C      REMEDIES, EXPRESS OR IMPLIED, ARISING BY LAW, CONTRACT OR
C      OTHERWISE WITH RESPECT TO SUCH SOFTWARE. THE RECIPIENT SHALL
C      INCLUDE VERBATIM THE ENTIRE CONTENTS OF THIS DISCLAIMER,
C      INCLUDING THIS SENTENCE, WITH ANY AND ALL COPIES OF THIS
C      SOFTWARE WHICH IS PROVIDED TO ANY OTHER RECIPIENT.
C
C  ****************************************************************
C
C  PURPOSE: THIS PROGRAM CONTROLS THE TWO MAIN BRANCHES OF THE
C           RIM SYSTEM -- MENU AND COMMAND. IF THE USER
C           SELECTS THE MENU MODE, CONTROL IS PASSED TO THE
C           SUBROUTINE INTCON, IF THE COMMAND MODE IS SELECTED CONTROL
C           IS PASSED TO THE SUBROUTINE RIM. UPON AN "EXIT" THE
C           RETURNING AND/OR REPLACING OF THE DATABASE FILES IS
C           HANDLED BY MACHINE DEPENDENT ROUTINES, IE CDCPUT.
C
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:CDCDBS.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:SELCOM.BLK
      INCLUDE rin:DCLAR6.BLK
      LOGICAL TTY
      INTEGER VER
      INTEGER UDXX
      INTEGER MACH(2)
C allow to pass into and out of RIM with only ONE initialization
C call.
	save inited
	integer inited
	data inited/0/
      DATA VER /3H5.1/
      DATA UDXX /4HUD23/
      DATA MACH(1),MACH(2) /4H-Ana,4Hly--/
	if(inited.ne.0)goto 3521
C
CBCS **** START
C
C  INITIALIZE - BATCH SHOULD BE FALSE ON OTHER MACHINES
C
      NUMOPN = 0
      BATCH = .FALSE.
      K = 0
      IF(.NOT.TTY(K)) BATCH = .TRUE.
C
CBCS **** END
C
C  OPEN THE INPUT AND OUTPUT FILES AND INITIALIZE
C
      NINT = 5
      NOUT = 6
      NOUTR = 6
      CALL LXCONS
      CALL RMSTRT
      CALL SETIN(K8IN)
      CALL SETOUT(K8OUT)
      ULPP = 0
      UMCPL = 0
      INTOPT = 0
      NEXTOP = K8BEGI
      ECHO = .FALSE.
      CALL LXSET(KWECHO,K4OFF)
      IF(.NOT.BATCH) GO TO 50
      ECHO = .TRUE.
      CALL LXSET(KWECHO,K4ON)
   50 CONTINUE
C
C  GET THE DATE AND TIME
C
      CALL RMDATE(IDAY)
      CALL RMTIME(ITIME)
C
C  SET THE PROMPT CHARACTER - CDC ONLY
C
CBCS **** START
C
      CALL LXSET(K4PROM,K4RP)
C
CBCS **** END
C
C  SET THE VERSION AND UPDATE IDENTIFIER
C
C
C  PRINT THE RIM EXECUTION HEADER
C
	if (nout.eq.6)goto 3140
      WRITE(NOUT,100) MACH(1),MACH(2),VER,UDXX,IDAY,ITIME
  100 FORMAT(1X,11HBegin RIM -,2A4,8H Version,1X,A3,
     X       3X,A4,10X,A8,4X,A8)
	WRITE(NOUT,7200)
7200	FORMAT(' Updated 3/1986. }command spawns command.')
	goto 3141
3140	continue
      WRITE(c128wk,100) MACH(1),MACH(2),VER,UDXX,IDAY,ITIME
      call atxto
3141	continue
	inited=1
	goto 3522
3521	continue
	nextop=K8RIM
3522	continue
C
C  EXECUTION OPTION IS COMMAND BY DEFAULT - PRINT MESSAGE
C
      IF(BATCH) GO TO 500
      IF(.NOT.CONNI) GO TO 500
	if(nout.eq.6)goto 3142
      WRITE(NOUT,200)
  200 FORMAT(1X,16HRIM Command mode,
     X         1X,26HEnter "MENU" for MENU mode)
      GO TO 500
3142	continue
	write(c128wk,200)
	call atxto
	goto 500
C
C  ****************************************************************
C
C             I N T E R A C T I V E      S E C T I O N
C
C  ****************************************************************
C
350   CONTINUE
	if(nout.eq.6)goto 3143
	WRITE(NOUT,360)
	goto 400
3143	continue
	write(c128wk,360)
	call atxto
  360 FORMAT(1X,13HRIM menu mode)
  400 CONTINUE
      INTOPT = 0
  410 CONTINUE
      CALL INTCON(INTOPT)
      IF(INTOPT.EQ.K4EXIT) GO TO 900
      IF(INTOPT.EQ.K4QUIT) GO TO 850
      IF(INTOPT.EQ.K4COM) GO TO 600
      IF(INTOPT.EQ.K4QUE) GO TO 600
      IF(INTOPT.EQ.K4LOD) GO TO 800
      IF((INTOPT.NE.K4CRE).AND.(INTOPT.NE.K4UPD)) GO TO 400
C
C  SET THE INPUT FILE TO SCHEMA AND READ THE FIRST RECORD
C
      CALL SETIN(K8SCH)
      LENREC = 0
      CALL LXLREC(DUM,LENREC,DUM)
C
C  COMPILE THE SCHEMA AND SET INPUT BACK TO "INPUT"
C
      CALL CSC
      CALL SETIN(K8IN)
      GO TO 410
C
C  ****************************************************************
C
C                  D I R E C T      S E C T I O N
C
C  ****************************************************************
C
  500 CONTINUE
      IF(NEXTOP.EQ.K8BEGI) GO TO 600
      IF(NEXTOP.EQ.K8RIM  ) GO TO 600
      IF(NEXTOP.EQ.K8DEFI) GO TO 700
      IF(NEXTOP.EQ.K8LOAD) GO TO 800
      IF(NEXTOP.EQ.K8MENU) GO TO 350
      IF(NEXTOP.EQ.KWRETU) return
C
C  BRANCH TO STATEMENT 400 IF RIM WAS CALLED FROM THE
C  MENU MODE
C
      IF(INTOPT.EQ.K4QUE) GO TO 400
      IF(NEXTOP.EQ.K8EXIT  ) GO TO 900
C
C  CALL RIM FOR QUERY FUNCTIONS
C
  600 CONTINUE
      CALL RIM
      GO TO 500
C
C  CALL CSC TO DEFINE THE SCHEMA
C
  700 CONTINUE
      CALL CSC
      NEXTOP = K8RIM
      GO TO 500
C
C  CALL DBLOAD TO LOAD THE DATABASE
C
  800 CONTINUE
      CALL DBLOAD
      NEXTOP = K8RIM
      IF(INTOPT.EQ.K4LOD) GO TO 410
      GO TO 500
C
C  ****************************************************************
C
C                       E X I T     S E C T I O N
C
C  ****************************************************************
C
C  DROP THE DATABASE FILES - QUIT
C
  850 CONTINUE
      GO TO 9999
  900 CONTINUE
      IF(BATCH) GO TO 999
      IF(.NOT.CONNI) GO TO 999
      IF(.NOT.CONNO) CALL SETOUT(K8OUT)
      CALL RMDBPT(NAMDB,DBSTAT)
C
C  PRINT THE CLOSING MESSAGE AND EXIT
C
  999 CONTINUE
      CALL RMDATE(IDAY)
      CALL RMTIME(ITIME)
c      WRITE(NOUT,7001) IDAY,ITIME
c 7001 FORMAT(1X,17HEnd RIM execution,25X,A8,4X,A8)
C
C  ERROR MESSAGES -------------------------------------------------
C
 8001 FORMAT(1X,41H-ERROR- Either "1" or "2" must be entered)
C
 9999 CONTINUE
	Return
      END
      SUBROUTINE ADDDAT(INDEX,ID,ARRAY,LENGTH)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   ADD A TUPLE TO THE DATA FILE
C
C  PARAMETERS:
C         INDEX---BLOCK REFERENCE NUMBER
C         ID------PACKED ID WORD WITH OFFSET,IOBN
C         ARRAY---ARRAY TO RECEIVE THE TUPLE
C         LENGTH--LENGTH OF THE TUPLE
      INCLUDE rin:F2COM.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:FLAGS.BLK
C
      INTEGER OFFSET
      INTEGER ARRAY(*)
C
C  UNPAC THE ID WORD.
C
      CALL ITOH(OFFSET,IOBN,ID)
C
C  CALCULATE THE NEW ID VALUE.
C
      IF(LF2WRD + LENGTH + 1 .LE. LENBF2) GO TO 100
      LF2REC = LF2REC + 1
      LF2WRD = 1
  100 CONTINUE
      CALL HTOI(LF2WRD,LF2REC,ID)
      IF(IOBN.EQ.0) GO TO 500
C
C  SEE IF THE NEEDED BLOCK IS CURRENTLY IN CORE.
C
      NUMBLK = 0
      DO 200 I=1,3
      IF(IOBN.EQ.CURBLK(I)) NUMBLK = I
  200 CONTINUE
      IF(NUMBLK.NE.0) GO TO 400
      NUMBLK = INDEX
C
C  WE MUST DO PAGING.
C
C  SEE IF THE CURRENT BLOCK NEEDS WRITING.
C
      IF(MODFLG(NUMBLK).EQ.0) GO TO 300
C
C  WRITE OUT THE CURRENT BLOCK.
C
      KQ1 = BLKLOC(NUMBLK)
      CALL RIOOUT(FILE2,CURBLK(NUMBLK),BUFFER(KQ1),LENBF2,IOS)
      IF(IOS.NE.0) RMSTAT = 2200 + IOS
  300 CONTINUE
C
C  READ IN THE NEEDED BLOCK.
C
      CALL BLKCHG(NUMBLK,LENBF2,1)
      KQ1 = BLKLOC(NUMBLK)
      CALL RIOIN(FILE2,IOBN,BUFFER(KQ1),LENBF2,IOS)
      CURBLK(NUMBLK) = IOBN
      IF(IOS.EQ.0) GO TO 400
C
C  WRITE OUT THE RECORD FOR THE FIRST TIME.
C
      CALL RIOOUT(FILE2,IOBN,BUFFER(KQ1),LENBF2,IOS)
      IF(IOS.NE.0) RMSTAT = 2200 + IOS
  400 CONTINUE
      MODFLG(NUMBLK) = 1
      IFMOD = .TRUE.
C
C  FIX UP THE ID POINTER SO IT POINTS TO THE NEXT TUPLE.
C
      KQ0 = BLKLOC(NUMBLK) - 1
      ISIGN = 1
      IF(BUFFER(KQ0 + OFFSET).LT.0) ISIGN = -1
      BUFFER(KQ0 + OFFSET) = ISIGN * ID
      MODFLG(NUMBLK) = 1
      IFMOD = .TRUE.
C
C  NOW MOVE THE NEW TUPLE.
C
  500 CONTINUE
      CALL ITOH(OFFSET,IOBN,ID)
C
C  SEE IF THE NEEDED BLOCK IS CURRENTLY IN CORE.
C
      NUMBLK = 0
      DO 600 I=1,3
      IF(IOBN.EQ.CURBLK(I)) NUMBLK = I
  600 CONTINUE
      IF(NUMBLK.NE.0) GO TO 800
      NUMBLK = INDEX
C
C  WE MUST DO PAGING.
C
C  SEE IF THE CURRENT BLOCK NEEDS WRITING.
C
      IF(MODFLG(NUMBLK).EQ.0) GO TO 700
C
C  WRITE OUT THE CURRENT BLOCK.
C
      KQ1 = BLKLOC(NUMBLK)
      CALL RIOOUT(FILE2,CURBLK(NUMBLK),BUFFER(KQ1),LENBF2,IOS)
      IF(IOS.NE.0) RMSTAT = 2200 + IOS
  700 CONTINUE
C
C  READ IN THE NEEDED BLOCK.
C
      CALL BLKCHG(NUMBLK,LENBF2,1)
      KQ1 = BLKLOC(NUMBLK)
      CURBLK(NUMBLK) = IOBN
      IF(LF2WRD.EQ.1) GO TO 750
      CALL RIOIN(FILE2,IOBN,BUFFER(KQ1),LENBF2,IOS)
      IF(IOS.EQ.0) GO TO 800
C
C  WRITE OUT THE RECORD FOR THE FIRST TIME.
C
  750 CONTINUE
      CALL RIOOUT(FILE2,IOBN,BUFFER(KQ1),LENBF2,IOS)
      IF(IOS.NE.0) RMSTAT = 2200 + IOS
  800 CONTINUE
      MODFLG(NUMBLK) = 1
      IFMOD = .TRUE.
C
C  MOVE THE TUPLE TO THE PAGE.
C
      KQ0 = BLKLOC(NUMBLK) - 1
      BUFFER(KQ0 + OFFSET) = 0
      BUFFER(KQ0 + OFFSET + 1) = LENGTH
      CALL BLKMOV(BUFFER(KQ0 + OFFSET + 2),ARRAY(1),LENGTH)
      LF2WRD = LF2WRD + LENGTH + 2
C
C  ALL DONE.
C
      RETURN
      END
      SUBROUTINE ATTADD
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   ADD A NEW TUPLE TO THE ATTRIBUTE RELATION
C
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:ATTBLE.BLK
      INCLUDE rin:F1COM.BLK
      INCLUDE rin:FLAGS.BLK
C
C  GET THE PAGE FOR ADDING NEW TUPLES.
C
      MRSTRT = NAROW
      CALL ATTPAG(MRSTRT)
      I = MRSTRT
      NAROW = NAROW + 1
      IF(I.EQ.APBUF) NAROW = (APBUF * LF1REC) + 1
C
C  MOVE THE DATA FROM THE TUPLE TO THE BUFFER.
C
      ATTBLE(1,I) = NAROW
      CALL BLKMOV(ATTBLE(2,I),ATTNAM,2)
      CALL BLKMOV(ATTBLE(4,I),RELNAM,2)
      ATTBLE(6,I) = ATTCOL
      ATTBLE(7,I) = ATTLEN
      ATTBLE(8,I) = ATTYPE
      ATTBLE(9,I) = ATTKEY
      ATTMOD = 1
      IFMOD = .TRUE.
      CROW = 0
      LROW = 0
      IF(I.LT.APBUF) RETURN
C
C  WE JUST FILLED A BUFFER. MAKE SURE ATTBLE GETS THE NEXT ONE.
C
      ATTBUF(1) = NAROW
      MRSTRT = NAROW
      CALL ATTPAG(MRSTRT)
      RETURN
      END
      SUBROUTINE ATTDEL(STATUS)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   DELETE THE CURRENT TUPLE FROM THE ATTRIBUTE RELATION
C             BASED ON CONDITIONS SET UP IN LOCATT AND ATTGET
C
C  PARAMETERS:
C         STATUS--STATUS VARIABLE - 0 MEANS OK, 1 MEANS NO WAY
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:ATTBLE.BLK
      INCLUDE rin:START.BLK
      INTEGER STATUS
C
      STATUS = 0
      IF(LROW.EQ.0) GO TO 9000
C
C  CHANGE THE TUPLE STATUS FLAG TO DELETED.
C
      ATTBLE(1,LROW) = -ATTBLE(1,LROW)
      ATTMOD = 1
      GO TO 9999
C
C  UNABLE TO FIND WHAT WE ARE LOOKING FOR.
C
 9000 CONTINUE
      STATUS = 1
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE ATTGET(STATUS)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   RETRIEVE THE NEXT TUPLE FROM THE ATTRIBUTE RELATION
C             BASED ON CONDITIONS SET UP IN LOCATT
C
C  PARAMETERS:
C         STATUS--STATUS VARIABLE - 0 MEANS OK, 1 MEANS NO WAY
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:ATTBLE.BLK
      INCLUDE rin:MISC.BLK
      INTEGER STATUS
      LOGICAL EQ
      LOGICAL NE
C
      STATUS = 0
      IF(CROW.EQ.0) GO TO 9000
C
C  SEE WHAT THE CALLER WANTS.
C
      IF(EQ(CRNAME,BLANK)) GO TO 1000
C
C  CRNAME IS SPECIFIED.
C
      I = CROW
      GO TO 200
  100 CONTINUE
      CALL ATTPAG(MRSTRT)
C
C  LOOK FOR THE ATTRIBUTE IN THIS RELATION.
C
      I = MRSTRT
  200 CONTINUE
      IF(I.GT.APBUF) GO TO 300
      IF(NE(ATTBLE(4,I),CRNAME)) GO TO 9000
      IF(EQ(CANAME,BLANK)) GO TO 2000
      IF(EQ(ATTBLE(2,I),CANAME)) GO TO 2000
      I = I + 1
      GO TO 200
C
C  GET THE NEXT PAGE.
C
  300 CONTINUE
      MRSTRT = ATTBUF(1)
      IF(MRSTRT.EQ.0) GO TO 9000
      GO TO 100
C
C  SCAN FOR ATTRIBUTE WITHOUT RELATION SPECIFIED.
C
 1000 CONTINUE
      I = CROW
      GO TO 1200
 1100 CONTINUE
      CALL ATTPAG(MRSTRT)
      I = MRSTRT
 1200 CONTINUE
      IF(I.GT.APBUF) GO TO 1400
      IF(ATTBLE(1,I).LT.0) GO TO 1300
      IF(EQ(ATTBLE(2,I),CANAME)) GO TO 2000
 1300 CONTINUE
      I = I + 1
      GO TO 1200
C
C  GET THE NEXT PAGE.
C
 1400 CONTINUE
      MRSTRT = ATTBUF(1)
      IF(MRSTRT.EQ.0) GO TO 9000
      GO TO 1100
C
C  MOVE THE STUFF FROM ROW CROW.
C
 2000 CONTINUE
      CROW = I
      CALL BLKMOV(ATTNAM,ATTBLE(2,CROW),2)
      CALL BLKMOV(RELNAM,ATTBLE(4,CROW),2)
      ATTCOL = ATTBLE(6,CROW)
      ATTLEN = ATTBLE(7,CROW)
      ATTYPE = ATTBLE(8,CROW)
      ATTKEY = ATTBLE(9,CROW)
C
C  UNPAC THE LENGTH DATA
C
      CALL ITOH(ATTCHA,ATTWDS,ATTLEN)
      LROW = CROW
      CROW = CROW + 1
      GO TO 9999
C
C  UNABLE TO FIND WHAT WE ARE LOOKING FOR.
C
 9000 CONTINUE
      STATUS = 1
      CROW = 0
      LROW = 0
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE ATTNEW(RNAME,NATT)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   ADD A NEW RELATION TO THE ATTRIBUTE RELATION
C
C  PARAMETERS:
C         RNAME---NAME OF A RELATION
C         NATT----NUMBER OF ATTRIBUTES IN THE RELATION
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:ATTBLE.BLK
      INCLUDE rin:F1COM.BLK
      INCLUDE rin:START.BLK
      INCLUDE rin:DCLAR1.BLK
C
C  ADJUST NAROW IF ALL ATTRIBUTES WILL NOT FIT ON THE PAGE.
C
      MRSTRT = NAROW
      CALL ATTPAG(MRSTRT)
      I = MRSTRT
      IF((I + NATT).LE.APBUF) GO TO 100
      NAROW = (APBUF * LF1REC) + 1
      ATTBUF(1) = NAROW
      ATTMOD = 1
  100 CONTINUE
      IF(START.NE.KSFRIA) KSFRIA = START
      RETURN
      END
      SUBROUTINE ATTPAG(THEROW)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   DO PAGING AS NEEDED FOR THE ATTRIBUTE RELATION
C
C  PARAMETERS:
C         THEROW--INPUT - ROW WANTED
C                 OUTPUT - ACTUAL ROW TO USE IN THE BUFFER
      INCLUDE rin:ATTBLE.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:F1COM.BLK
      INTEGER THEROW
C
C  TURN THE REQUESTED ROW INTO A RECORD AND OFFSET.
C
      NNREC = ((THEROW - 1) / APBUF) + 1
      NNROW = THEROW - ((NNREC - 1) * APBUF)
C
C  SEE IF WE ALREADY HAVE THIS RECORD IN THE BUFFER.
C
      IF(NNREC.EQ.CAREC) GO TO 300
C
C  WE MUST DO PAGING.
C
C  SEE IF THE CURRENT RECORD IN THE BUFFER HAS BEEN MODIFIED.
C
      IF(ATTMOD.EQ.0) GO TO 100
C
C  WRITE OUT THE CURRENT RECORD.
C
      CALL RIOOUT(FILE1,CAREC,ATTBUF,LENBF1,IOS)
      IF(IOS.NE.0) RMSTAT = 2100 + IOS
C
C  READ IN THE NEEDED RECORD.
C
  100 CONTINUE
      ATTMOD = 0
      IF(NNREC.GT.LF1REC) GO TO 150
      CALL RIOIN(FILE1,NNREC,ATTBUF,LENBF1,IOS)
      IF(IOS.EQ.0) GO TO 200
C
C  THERE WAS NO DATA ON THE FILE - WRITE SOME.
C
  150 CONTINUE
      CALL ZEROIT(ATTBUF,LENBF1)
      CALL RIOOUT(FILE1,NNREC,ATTBUF,LENBF1,IOS)
      IF(IOS.NE.0) RMSTAT = 2100 + IOS
      LF1REC = LF1REC + 1
  200 CONTINUE
      CAREC = NNREC
C
C  SET THE POINTER TO THE ACTUAL ROW IN THE BUFFER.
C
  300 CONTINUE
      THEROW = NNROW
      RETURN
      END
      SUBROUTINE ATTPUT(STATUS)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   REPLACE THE CURRENT TUPLE FROM THE ATTRIBUTE RELATION
C             BASED ON CONDITIONS SET UP IN LOCATT AND ATTGET
C
C  PARAMETERS:
C         STATUS--STATUS VARIABLE - 0 MEANS OK, 1 MEANS NO WAY
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:ATTBLE.BLK
      INTEGER STATUS
C
      STATUS = 0
      IF(LROW.EQ.0) GO TO 9000
C
C  MOVE THE STUFF TO ROW LROW.
C
      CALL BLKMOV(ATTBLE(2,LROW),ATTNAM,2)
      CALL BLKMOV(ATTBLE(4,LROW),RELNAM,2)
      ATTBLE(6,LROW) = ATTCOL
      ATTBLE(7,LROW) = ATTLEN
      ATTBLE(8,LROW) = ATTYPE
      ATTBLE(9,LROW) = ATTKEY
      ATTMOD = 1
      IFMOD = .TRUE.
      GO TO 9999
C
C  UNABLE TO FIND WHAT WE ARE LOOKING FOR.
C
 9000 CONTINUE
      STATUS = 1
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE BLKCHG(IND,NROWS,NCOLS)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:    CHANGE THE DIMENSIONS OF AN EXISTING BLOCK
C
C  PARAMETERS
C     INPUT:   IND-----BLOCK INDEX
C              NROWS---NUMBER OF ROWS
C              NCOLS---NUMBER OF COLUMNS
      INCLUDE rin:INCORE.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:BUFFER.BLK
C
C  SEE IF THE BLOCK HAS EXISTING DATA.
C
      IF(BLOCKS(1,IND).NE.0) GO TO 100
C
C  USE BLKDEF SINCE THIS IS A NEW BLOCK.
C
      CALL BLKDEF(IND,NCOLS,NROWS)
      RETURN
C
C  EXTRACT THE EXISTING DIMENSIONS.
C
  100 CONTINUE
      KNR = BLOCKS(2,IND)
      KNC = BLOCKS(3,IND)
      NWOLD = KNR * KNC
      KS = BLOCKS(1,IND)
C
C  SEE IF WE EXPAND OR CONTRACT.
C
      NWNEW = NROWS * NCOLS
      IF(NWNEW.EQ.NWOLD) RETURN
      NWADD = NWNEW - NWOLD
      IF(NEXT + NWADD .GT. LIMIT) GO TO 7500
C
C  MAKE ROOM IN THE BUFFER.
C
      MOVE = NEXT - (KS+NWOLD)
      IF(NWADD.GT.0) MOVE = -MOVE
      IF(KS + NWOLD .LT. NEXT)
     X CALL BLKMOV(BUFFER(KS+NWNEW),BUFFER(KS+NWOLD),MOVE)
      IF(NWADD.GT.0) CALL ZEROIT(BUFFER(KS+NWOLD),NWADD)
C
C  UPDATE THE INCORE INDEX.
C
      BLOCKS(1,IND) = KS
      BLOCKS(2,IND) = NROWS
      BLOCKS(3,IND) = NCOLS
      DO 200 I=1,NUMBL
      IF(BLOCKS(1,I).EQ.0) GO TO 200
      ITEST = BLOCKS(1,I)
      IF(ITEST.LE.KS) GO TO 200
      BLOCKS(1,I) = BLOCKS(1,I) + NWADD
  200 CONTINUE
      NEXT = NEXT + NWADD
      RETURN
C
C  NOT ENOUGH ROOM.
C
 7500 CONTINUE
      RMSTAT = 1001
      RETURN
      END
      SUBROUTINE BLKCLN
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE: CLEAN OUT THE ENTIRE BUFFER AREA
C
C  PARAMETERS -- NONE
C
      INCLUDE rin:INCORE.BLK
      INCLUDE rin:F2COM.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:RIMCOM.BLK
C
C  WRITE OUT ANY PAGES THAT HAVE BEEN MODIFIED
C
      DO 100 I=1,3
      IF(MODFLG(I).EQ.0) GO TO 90
      KQ1 = BLKLOC(I)
      CALL RIOOUT(FILE2,CURBLK(I),BUFFER(KQ1),LENBF2,IOS)
      IF(IOS.NE.0) RMSTAT = 2200 + IOS
      MODFLG(I) = 0
   90 CONTINUE
      CURBLK(I) = 0
  100 CONTINUE
C
C  ZERO OUT BLOCKS AND BUFFER
C
      CALL ZEROIT(BLOCKS(1,1),60)
      NEXT = 1
      NUMBL = 0
      CALL ZEROIT(BUFFER(1),LIMIT)
      RETURN
      END
      SUBROUTINE BLKCLR(IND)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:    CLEAR A BLOCK FROM THE INCORE BUFFER
C
C  PARAMETERS
C     INPUT:   IND-----BLOCK INDEX
      INCLUDE rin:INCORE.BLK
      INCLUDE rin:BUFFER.BLK
C
C  SEE IF ANYTHING IS THERE NOW.
C
      IF(BLOCKS(1,IND).EQ.0) RETURN
      KNR = BLOCKS(2,IND)
      KNC = BLOCKS(3,IND)
      NWOLD = KNR * KNC
      KS = BLOCKS(1,IND)
C
C  ZERO OUT THE SPACE.
C
      CALL ZEROIT(BUFFER(KS),NWOLD)
C
C  COMPRESS THE REMAINING BLOCKS.
C
      MOVE = NEXT - (KS+NWOLD)
      IF(KS+NWOLD.NE.NEXT)
     X CALL BLKMOV(BUFFER(KS),BUFFER(KS + NWOLD),MOVE)
C
C  UPDATE THE INCORE INDEX.
C
      BLOCKS(1,IND) = 0
      DO 100 I=1,NUMBL
      IF(BLOCKS(1,I).EQ.0) GO TO 100
      IF(BLOCKS(1,I).LE.KS) GO TO 100
      BLOCKS(1,I) = BLOCKS(1,I) - NWOLD
  100 CONTINUE
      NEXT = NEXT - NWOLD
      IF(IND.EQ.NUMBL) NUMBL = NUMBL - 1
      RETURN
      END
      SUBROUTINE BLKDEF(IND,NROWS,NCOLS)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:    DEFINE A NEW BLOCK FOR THE INCORE BUFFER
C
C  PARAMETERS
C     INPUT:   IND-----BLOCK INDEX
C              NROWS---NUMBER OF ROWS
C              NCOLS---NUMBER OF COLUMNS
      INCLUDE rin:INCORE.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:BUFFER.BLK
C
C  CLEAR ANY EXISTING BLOCK FOR THIS INDEX.
C
      IF(BLOCKS(1,IND).NE.0) CALL BLKCLR(IND)
C
C  SET UP THE NEW BLOCK.
C
      NWNEW = NROWS * NCOLS
      IF(NEXT + NWNEW .GT.LIMIT) GO TO 7500
      CALL ZEROIT(BUFFER(NEXT),NWNEW)
C
C  UPDATE THE INCORE INDEX.
C
      BLOCKS(1,IND) = NEXT
      BLOCKS(2,IND) = NROWS
      BLOCKS(3,IND) = NCOLS
      NEXT = NEXT + NWNEW
      IF(IND.GT.NUMBL) NUMBL = IND
      RETURN
C
C  NOT ENOUGH ROOM.
C
 7500 CONTINUE
      RMSTAT = 1001
      RETURN
      END
      SUBROUTINE BLKEXT(IND,NROWS,NCOLS)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:    EXTRACT THE NUMBER OF ROWS AND COLUMNS FOR A BLOCK
C
C  PARAMETERS
C     INPUT:   IND-----BLOCK INDEX
C     OUTPUT:  NROWS---NUMBER OF ROWS
C              NCOLS---NUMBER OF COLUMNS
      INCLUDE rin:INCORE.BLK
C
C  EXTRACT THE DATA FROM BLOCKS.
C
      NROWS = BLOCKS(2,IND)
      NCOLS = BLOCKS(3,IND)
      RETURN
      END
      INTEGER FUNCTION BLKLOC(IND)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:    RETURN THE STARTING ADDRESS FOR THE REQUESTED BLOCK
C
C  PARAMETERS
C     INPUT:   IND-----BLOCK INDEX
C     OUTPUT:  BLKLOC--ADDRESS OF 1,1 ENTRY FOR THE BLOCK
      INCLUDE rin:INCORE.BLK
      INCLUDE rin:RIMCOM.BLK
      KS = BLOCKS(1,IND)
      IF(KS.EQ.0) GO TO 7500
      BLKLOC = KS
      RETURN
C
C  UNDEFINED BLOCK.
C
 7500 CONTINUE
      RMSTAT = 1002
      BLKLOC = 0
      RETURN
      END
      SUBROUTINE BLKMOV(TO,FROM,NWORDS)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   MOVE WORDS BETWEEN ARRAYS
C
      INTEGER TO(*),FROM(*)
      IF(NWORDS.LT.0) GO TO 200
C
C  MOVE FROM THE FRONT OF THE ARRAYS.
C
      DO 100 I=1,NWORDS
      TO(I) = FROM(I)
  100 CONTINUE
      RETURN
C
C  MOVE FROM THE REAR OF THE ARRAYS.
C
  200 CONTINUE
      NW = -NWORDS
      DO 300 I=1,NW
      TO(NW+1-I) = FROM(NW+1-I)
  300 CONTINUE
      RETURN
      END
      SUBROUTINE BTADD(VALU,IPTR,TYPE)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   ADD NEW VALUES TO A BTREE
C
C  PARAMETERS
C    INPUT:  VALU----KEY VALUE TO PROCESS
C            IPTR----POINTER TO TUPLE HAVING THIS KEY VALUE
C            TYPE----TYPE OF VARIABLE BEING ADDED
C
C  SUBROUTINES USED
C         BTGET---PAGING ROUTINE
C         BTSERT--USED TO INSERT VALUES IN A BTREE
C         BTPUT---PAGING ROUTINE
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:F3COM.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:BTBUF.BLK
      INCLUDE rin:START.BLK
      INCLUDE rin:STACK.BLK
C
      INTEGER VAL,VALT,VALU(*)
      REAL RVAL
      EQUIVALENCE (RVAL,VAL)
      INTEGER TYPE
C
C  INITIAL START OF THE SCAN.
C
      SP = 0
      KSTART = START
      VAL = VALU(1)
      ITYPE = TYPE
      IF(TYPE.EQ.KZTEXT) ITYPE = KZINT
      IP = IPTR
  100 CONTINUE
      SP = SP + 1
      STACK(SP) = KSTART
C
C  FETCH A NODE.
C
      CALL BTGET(KSTART,IN)
      KEND = IN + (LENBF3/3) - 1
C
C  LOOP THROUGH A NODE.
C
      DO 300 J=IN,KEND
C
C  CHECK FOR END-OF-LIST WORD.
C
      IF(VALUE(1,J).EQ.ENDWRD) GO TO 200
C
C  IF THE VALUE IS LT VAL THEN KEEP LOOKING.
C
      IF((ITYPE.EQ.KZINT).AND.(VALUE(1,J).LT.VAL)) GO TO 300
      IF((ITYPE.NE.KZINT).AND.(RVALUE(1,J).LT.RVAL)) GO TO 300
C
C  FOUND A BIGGER VALUE.
C
  200 CONTINUE
C
C  GO TO THE NEXT BRANCH IF THERE IS ONE.
C
      IF(VALUE(2,J).GE.0) GO TO 400
      KSTART = -VALUE(2,J)
      GO TO 100
  300 CONTINUE
C
C  WE DID NOT FIND THE END-OF-LIST WORD. DISASTER.
C
      GO TO 1000
C
C  ADD IT BETWEEN EXISTING VALUES.
C
  400 CONTINUE
C
C  CHECK FOR A DUPLICATE VALUE.
C
      IF(VALUE(1,J).NE.VAL) GO TO 500
C
C  WE HAVE A MULTIPLE VALUE. SEE IF THIS IS THE FIRST DUPLICATE.
C
      IF(VALUE(3,J).NE.0) GO TO 420
C
C  DO SPECIAL PROCESSING FOR THE FIRST MULTIPLE VALUE.
C
      IPTR1 = VALUE(2,J)
      IF(MOTADD.LT.LENBF3) GO TO 410
      MOTADD = 0
      MOTREC = LF3REC
      CALL BTGET(MOTREC,IN)
      LF3REC = LF3REC + 1
  410 CONTINUE
      CALL HTOI(MOTADD+1,MOTREC,KWORD)
      VALUE(3,J) = KWORD
      VALUE(2,J) = KWORD
      CALL BTPUT(STACK(SP))
C
C  ADD THE FIRST LINK TO THE MOT.
C
      CALL BTGET(MOTREC,IN)
      MOTIND = 3 * IN - 3
      MOTADD = MOTADD + 1
      MOTIND = MOTIND + MOTADD
      CORE(MOTIND+1) = IPTR1
      MOTADD = MOTADD + 1
      CALL BTPUT(MOTREC)
  420 CONTINUE
C
C  FIX UP THE END POINTER.
C
      IF(MOTADD.LT.LENBF3) GO TO 430
      MOTADD = 0
      MOTREC = LF3REC
      CALL BTGET(MOTREC,IN)
      LF3REC = LF3REC + 1
  430 CONTINUE
      CALL ITOH(MOTIND,MOTID,VALUE(2,J))
      CALL HTOI(MOTADD+1,MOTREC,VALUE(2,J))
      CALL BTPUT(STACK(SP))
C
C  GET THE END OF THE MOT TRAIL.
C
      CALL BTGET(MOTID,IN)
      IN = 3 * IN - 3
      MOTIND = MOTIND + IN
C
C  ADD THE NEXT LINK IN THE MOT.
C
      MOTADD = MOTADD + 1
      CALL HTOI(MOTADD,MOTREC,KWORD)
      CORE(MOTIND) = KWORD
      CALL BTPUT(MOTID)
C
C  NOW ADD THE POINTER TO THE MOT.
C
      CALL BTGET(MOTREC,IN)
      IN = 3 * IN - 3
      MOTADD = MOTADD + 1
      MOTIND = IN + MOTADD
      CORE(MOTIND) = IPTR
      CALL BTPUT(MOTREC)
      RETURN
C
C  THIS VALUE IS NOT IN THE BTREE YET.
C
  500 CONTINUE
C
C  CALL BTSERT TO INSERT THE DATA.
C
      VALT = VAL
      IPT = IP
  600 CONTINUE
      CALL BTSERT(VALT,IPT,STACK,SP,J,IN)
      IF(SP.EQ.0) RETURN
C
C  FETCH THE NEXT NODE UP THE STACK.
C
      CALL BTGET(STACK(SP),IN)
C
C  CALCULATE A NEW VALUE FOR J.
C
      KEND = IN + (LENBF3/3) - 1
      DO 700 J=IN,KEND
      IF(VALUE(1,J).EQ.ENDWRD) GO TO 600
      IF((ITYPE.EQ.KZINT).AND.(VALUE(1,J).LT.VAL)) GO TO 700
      IF((ITYPE.NE.KZINT).AND.(RVALUE(1,J).LT.RVAL)) GO TO 700
C
C  WE FOUND A BIGGER VALUE.
C
      GO TO 600
  700 CONTINUE
C
C  SOMETHING IS WRONG. WE CANNOT FIND A LARGER VALUE.
C
      RMSTAT = 1003
      RETURN
C
C  LOOKUP FOR A VALUE NOT IN THE TREE.
C
 1000 CONTINUE
      RETURN
      END
      SUBROUTINE BTGET(ID,NSTRT)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:    RETREIVE OR SET UP A BTREE OR MOT NODE.
C
C  PARAMETERS
C     INPUT:   ID------DESIRED RECORD NUMBER
C     OUTPUT:  NSTRT---BUFFER INDEX FOR REQUESTED NODE
C
      INCLUDE rin:BTBUF.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:F3COM.BLK
C
C  SEE IF THE BLOCK IS IN CORE.
C
      DO 100 NUMB=1,NUMIC
      IF(ID.EQ.ICORE(3,NUMB)) GO TO 1000
  100 CONTINUE
C
C  THE REQUESTED BLOCK IS NOT IN THE BUFFER.
C
C   DETERMINE WHICH SLOT IN THE BUFFER WE SHOULD USE.
C
      IF(NUMIC.GE.MAXIC) GO TO 200
C
C  STILL ROOM IN THE BUFFER.
C
      NUMIC = NUMIC + 1
      NUMB = NUMIC
      GO TO 500
C
C  WE MUST DETERMINE WHO WILL BE MOVED OUT.
C
  200 CONTINUE
      MINUMB = 1
      IF(MINUMB.EQ.LAST) MINUMB = 2
      MINUSE = ICORE(1,MINUMB)
      DO 300 NUMB=1,NUMIC
      IF(NUMB.EQ.LAST) GO TO 300
      NUMUSE = ICORE(1,NUMB)
      IF(NUMUSE.EQ.0) GO TO 400
      IF(NUMUSE.GT.MINUSE) GO TO 300
      MINUSE = NUMUSE
      MINUMB = NUMB
  300 CONTINUE
C
C  USE THE BLOCK THAT WAS USED THE LEAST.
C
      NUMB = MINUMB
  400 CONTINUE
C
C  BLOCK NUMB WILL BE USED.
C
C  SEE IF THE BLOCK CURRENTLY THERE MUST BE WRITTEN OUT.
C
      IF(ICORE(2,NUMB).EQ.0) GO TO 500
C
C  WRITE IT OUT.
C
      ISTRT = (NUMB-1) * LENBF3 + 1
      IEND = ISTRT + LENBF3 - 1
      IOBN = ICORE(3,NUMB)
      CALL RIOOUT(FILE3,IOBN,CORE(ISTRT),LENBF3,IOS)
      IF(IOS.NE.0) RMSTAT = 2300 + IOS
  500 CONTINUE
C
C  CHANGE THE ICORE ENTRY.
C
      ICORE(3,NUMB) = ID
      ICORE(2,NUMB) = 0
C
C  READ IN DESIRED BLOCK.
C
      ISTRT = (NUMB-1) * LENBF3 + 1
      CALL RIOIN(FILE3,ID,CORE(ISTRT),LENBF3,IOS)
      IF(ID.GE.LF3REC) GO TO 600
      IF(IOS.EQ.0) GO TO 1000
  600 CONTINUE
      CALL ZEROIT(CORE(ISTRT),LENBF3)
      CALL RIOOUT(FILE3,ID,CORE(ISTRT),LENBF3,IOS)
      IF(IOS.NE.0) RMSTAT = 2300 + IOS
C
C  UPDATE THE ICORE ARRAY AND SET NSTRT.
C
 1000 CONTINUE
      ICORE(1,NUMB) = ICORE(1,NUMB) + 1
      ISTRT = ((NUMB-1) * LENBF3) / 3 + 1
      NSTRT = ISTRT
      LAST = NUMB
      RETURN
      END
      SUBROUTINE BTINIT(START)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   INITIALIZE FOR A NEW BTREE
C
C  PARAMETERS:
C         START---NEW RECORD USED FOR THIS BTREE
C
      INCLUDE rin:F3COM.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:BTBUF.BLK
C
      INTEGER START
C
C  GET THE NEXT NODE.
C
      CALL BTGET(LF3REC,N1)
C
C  INSERT THE END-OF-LIST WORD.
C
      VALUE(1,N1) = ENDWRD
      VALUE(2,N1) = 1
      VALUE(3,N1) = 0
C
C  WRITE OUT THIS NODE.
C
      CALL BTPUT(LF3REC)
      START = LF3REC
      LF3REC = LF3REC + 1
      RETURN
      END
      SUBROUTINE BTLKI(VAL,IPTR,MOTID)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  LOOKUP PROCESSING ROUTINE FOR BTREES
C
C  PARAMETERS
C    INPUT:  VAL-----KEY VALUE TO PROCESS
C            IPTR----POINTER TO TUPLE HAVING THIS KEY VALUE
C            MOTID---MOT LINK
C
C  SUBROUTINES USED
C         BTGET---PAGING ROUTINE
C
      INCLUDE rin:F3COM.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:BTBUF.BLK
      INCLUDE rin:START.BLK
C
      INTEGER VAL
C
C  SET UP VARIABLES BASED ON THE ENTRY POINT.
C
C
C  INITIAL START OF THE SCAN.
C
      KSTART = START
  100 CONTINUE
C
C  FETCH A NODE.
C
      CALL BTGET(KSTART,IN)
      KEND = IN + (LENBF3/3) - 1
C
C  LOOP THROUGH A NODE.
C
      DO 300 J=IN,KEND
C
C  CHECK FOR END-OF-LIST WORD.
C
      IF(VALUE(1,J).EQ.ENDWRD) GO TO 200
C
C  IF THE VALUE IS LT VAL THEN KEEP LOOKING.
C
      IF(VALUE(1,J).LT.VAL) GO TO 300
C
C  FOUND A BIGGER VALUE.
C
  200 CONTINUE
C
C  GO TO THE NEXT BRANCH IF THERE IS ONE.
C
      IF(VALUE(2,J).GE.0) GO TO 400
      KSTART = -VALUE(2,J)
      GO TO 100
  300 CONTINUE
C
C  WE DID NOT FIND THE END-OF-LIST WORD. DISASTER.
C
      GO TO 500
C
C  DONE SCANNING THE BTREE.
C
  400 CONTINUE
C
C  CHECK FOR AN EQUAL VALUE.
C
      IF(VALUE(1,J).NE.VAL) GO TO 500
C
C  PROCESS WAS A LOOKUP. RETURN THE TUPLE POINTER.
C
      IPTR = VALUE(2,J)
      MOTID = VALUE(3,J)
      IF(MOTID.NE.0) CALL MOTSCN(MOTID,IPTR)
      RETURN
C
C  THIS VALUE IS NOT IN THE BTREE YET.
C
  500 CONTINUE
      IPTR = 0
      MOTID = 0
      RETURN
      END
      SUBROUTINE BTLKR(VAL,IPTR,MOTID)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  LOOKUP PROCESSING ROUTINE FOR BTREES
C
C  PARAMETERS
C    INPUT:  VAL-----KEY VALUE TO PROCESS
C            IPTR----POINTER TO TUPLE HAVING THIS KEY VALUE
C            MOTID---MOT LINK
C
C  SUBROUTINES USED
C         BTGET---PAGING ROUTINE
C
      INCLUDE rin:F3COM.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:BTBUF.BLK
      INCLUDE rin:START.BLK
C
      REAL VAL
C
C  SET UP VARIABLES BASED ON THE ENTRY POINT.
C
C
C  INITIAL START OF THE SCAN.
C
      KSTART = START
  100 CONTINUE
C
C  FETCH A NODE.
C
      CALL BTGET(KSTART,IN)
      KEND = IN + (LENBF3/3) - 1
C
C  LOOP THROUGH A NODE.
C
      DO 300 J=IN,KEND
C
C  CHECK FOR END-OF-LIST WORD.
C
      IF(VALUE(1,J).EQ.ENDWRD) GO TO 200
C
C  IF THE VALUE IS LT VAL THEN KEEP LOOKING.
C
      IF(RVALUE(1,J).LT.VAL) GO TO 300
C
C  FOUND A BIGGER VALUE.
C
  200 CONTINUE
C
C  GO TO THE NEXT BRANCH IF THERE IS ONE.
C
      IF(VALUE(2,J).GE.0) GO TO 400
      KSTART = -VALUE(2,J)
      GO TO 100
  300 CONTINUE
C
C  WE DID NOT FIND THE END-OF-LIST WORD. DISASTER.
C
      GO TO 500
C
C  DONE SCANNING THE BTREE.
C
  400 CONTINUE
C
C  CHECK FOR AN EQUAL VALUE.
C
      IF(RVALUE(1,J).NE.VAL) GO TO 500
C
C  PROCESS WAS A LOOKUP. RETURN THE TUPLE POINTER.
C
      IPTR = VALUE(2,J)
      MOTID = VALUE(3,J)
      IF(MOTID.NE.0) CALL MOTSCN(MOTID,IPTR)
      RETURN
C
C  THIS VALUE IS NOT IN THE BTREE YET.
C
  500 CONTINUE
      IPTR = 0
      MOTID = 0
      RETURN
      END
      SUBROUTINE BTLKT(VAL,IPTR,MOTID)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  LOOKUP PROCESSING ROUTINE FOR BTREES
C
C  PARAMETERS:
C    INPUT:  VAL-----KEY VALUE TO PROCESS
C            IPTR----POINTER TO TUPLE HAVING THIS KEY VALUE
C            MOTID---MOT LINK
C
C  HASH THE TEXT STRING INTO AN INTEGER AND CALL BTLKI.
C
      INTEGER VAL(*)
      IVAL = VAL(1)
      CALL BTLKI(IVAL,IPTR,MOTID)
      RETURN
      END
      SUBROUTINE BTMOVE(NEW,OLD,NV)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   MOVE NV VALUES FROM OLD TO NEW.
C
      INCLUDE rin:BTBUF.BLK
      INTEGER OLD
      IS = 1
      IF(NV.LT.0) IS = -1
      N = IS * NV
      DO 100 I=1,N
      IN = NEW + IS * (I - 1)
      IO = OLD + IS * (I - 1)
      VALUE(1,IN) = VALUE(1,IO)
      VALUE(2,IN) = VALUE(2,IO)
      VALUE(3,IN) = VALUE(3,IO)
  100 CONTINUE
      RETURN
      END
      SUBROUTINE BTPUT(ID)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:    TURN ON THE WRITE FLAG ON THE INDICATED BLOCK
C
C  PARAMETERS
C     INPUT:   ID------RECORD NUMBER
      INCLUDE rin:F3COM.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:FLAGS.BLK
C
C  LOOK FOR THIS BLOCK IN CORE.
C
      DO 100 NUMB=1,NUMIC
      IF(ID.EQ.ICORE(3,NUMB)) GO TO 200
  100 CONTINUE
C
C  DISASTER. WE CANNOT FIND THE BLOCK.
C
      RMSTAT = 1004
      RETURN
C
C  SET THE WRITE FLAG.
C
  200 CONTINUE
      ICORE(2,NUMB) = 1
      IFMOD = .TRUE.
      RETURN
      END
      SUBROUTINE BTREP(VALU,IPTR,IPTRO,TYPE)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   REPLACE VALUES IN A BTREE
C
C  PARAMETERS
C    INPUT:  VALU----KEY VALUE TO PROCESS
C         IPTR----NEW POINTER TO BE USED
C         IPTRO---OLD POINTER TO BE REPLACED
C         TYPE----TYPE OF VARIABLE BEING ADDED
C
C
C  SUBROUTINES USED
C         BTGET---PAGING ROUTINE
C         BTPUT---PAGING ROUTINE
C
C  DECLARATIVES
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:F3COM.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:BTBUF.BLK
      INCLUDE rin:START.BLK
      INCLUDE rin:STACK.BLK
C
      INTEGER VAL,VALU(*)
      REAL RVAL
      EQUIVALENCE (RVAL,VAL)
      INTEGER TYPE
C
C  INITIAL START OF THE SCAN.
C
      SP = 0
      KSTART = START
      VAL = VALU(1)
      ITYPE = TYPE
      IF(TYPE.EQ.KZTEXT) ITYPE = KZINT
      IP = IPTR
  100 CONTINUE
      SP = SP + 1
      STACK(SP) = KSTART
C
C  FETCH A NODE.
C
      CALL BTGET(KSTART,IN)
      KEND = IN + (LENBF3/3) - 1
C
C  LOOP THROUGH A NODE.
C
      DO 300 J=IN,KEND
C
C  CHECK FOR END-OF-LIST WORD.
C
      IF(VALUE(1,J).EQ.ENDWRD) GO TO 200
C
C  IF THE VALUE IS LT VAL THEN KEEP LOOKING.
C
      IF((ITYPE.EQ.KZINT).AND.(VALUE(1,J).LT.VAL)) GO TO 300
      IF((ITYPE.NE.KZINT).AND.(RVALUE(1,J).LT.RVAL)) GO TO 300
C
C  FOUND A BIGGER VALUE.
C
  200 CONTINUE
C
C  GO TO THE NEXT BRANCH IF THERE IS ONE.
C
      IF(VALUE(2,J).GE.0) GO TO 400
      KSTART = -VALUE(2,J)
      GO TO 100
  300 CONTINUE
C
C  WE DID NOT FIND THE END-OF-LIST WORD. DISASTER.
C
      GO TO 1000
C
C  END OF THE BTREE SEARCH.
C
  400 CONTINUE
C
C  CHECK FOR A DUPLICATE VALUE.
C
      IF(VALUE(1,J).NE.VAL) GO TO 1000
      IF(VALUE(3,J).NE.0) GO TO 450
      IF(VALUE(2,J).NE.IPTRO) GO TO 450
      VALUE(2,J) = IPTR
      CALL BTPUT(KSTART)
      GO TO 1000
  450 CONTINUE
C
C  WE HAVE A MULTIPLE VALUE. FOLLOW THE LINKS.
C
C  GET THE MOT NODE.
C
      MOTIND = 3 * J
      MOTIDP = STACK(SP)
      IF(VALUE(3,J).EQ.0) GO TO 1000
      CALL ITOH(MOTIND,MOTID,VALUE(3,J))
C
C  MOT LINK TRAIL.
C
  460 CONTINUE
      CALL BTGET(MOTID,IN)
      IN = 3 * IN - 3
      MOTIDP = MOTID
  470 CONTINUE
      MOTIND = MOTIND + IN
      IF(CORE(MOTIND+1).EQ.IPTRO) GO TO 500
      IF(CORE(MOTIND).EQ.0) GO TO 1000
      CALL ITOH(MOTIND,MOTID,CORE(MOTIND))
C
C  SEE IF WE ARE ON THE SAME MOT PAGE.
C
      IF(MOTID.EQ.MOTIDP) GO TO 470
      GO TO 460
C
C  REPLACE THE POINTER.
C
  500 CONTINUE
      CORE(MOTIND+1) = IPTR
      CALL BTPUT(MOTIDP)
      RETURN
C
C  LOOKUP FOR A VALUE NOT IN THE TREE.
C
 1000 CONTINUE
      RETURN
      END
      SUBROUTINE BTSERT(VAL,IP,STACK,SP,LOC,IN)
      INCLUDE rin:TEXT.BLK
C
C  INSERT VAL INTO LOC REFERENCED BY THE STACK POINTER.
C
C  SUBROUTINES USED
C         BTGET---PAGING ROUTINE
C         BTPUT---PAGING ROUTINE
C         BTMOVE--MOVES DATA BETWEEN AREAS
C
      INCLUDE rin:F3COM.BLK
      INCLUDE rin:BTBUF.BLK
      INCLUDE rin:START.BLK
      INTEGER VALT
      INTEGER VAL,STACK(*),SP
C
      KEND = IN + (LENBF3/3) - 1
      J = LOC
C
C  CHECK TO SEE IF THE NODE IS ALREADY FULL.
C
      IF(VALUE(2,KEND).NE.0) GO TO 100
C
C  STILL ROOM.
C
      NV = KEND - J
      CALL BTMOVE(KEND,KEND-1,-NV)
      VALUE(1,J) = VAL
      VALUE(2,J) = IP
      VALUE(3,J) = 0
C
C  WRITE OUT THIS NODE.
C
      CALL BTPUT(STACK(SP))
      SP = 0
      RETURN
C
C  WE NEED TO SPLIT THE NODE. SAVE THE CURRENT LAST VALUE.
C
  100 CONTINUE
      VALT = VALUE(1,KEND)
      IBT = VALUE(2,KEND)
      IMT = VALUE(3,KEND)
C
C  PUT THE NEW VALUE IN ITS PLACE.
C
      NV = KEND - J
      CALL BTMOVE(KEND,KEND-1,-NV)
      VALUE(1,J) = VAL
      VALUE(2,J) = IP
      VALUE(3,J) = 0
C
C  NEW VALUE IS IN
C
C  MOVE THE LOW PART
C
      NV = 2 * (LENBF3/3) / 3
      CALL BTGET(LF3REC,N2)
      CALL BTMOVE(N2,IN,NV)
C
C  WRITE OUT THIS NEW NODE.
C
      CALL BTPUT(LF3REC)
      L = N2 + NV - 1
C
C  SAVE IN A NEW NODE POINTER.
C
      VAL = VALUE(1,L)
      IP = -LF3REC
C
C  MOVE THE TOP OF THE OLD NODE TO THE BOTTOM.
C
      NV = (LENBF3/3) - NV
      CALL BTMOVE(IN,KEND-NV+1,NV)
C
C  RESTORE THE OLD LAST VALUE.
C
      L = NV
      VALUE(1,IN+L) = VALT
      VALUE(2,IN+L) = IBT
      VALUE(3,IN+L) = IMT
C
C  ZERO OUT THE REMAINDER OF THE NODE.
C
      NV = (LENBF3/3) - NV - 1
      IF(NV.LE.0) GO TO 300
      J = 3 * (KEND - IN - L)
      CALL ZEROIT(VALUE(1,IN+L+1),J)
  300 CONTINUE
C
C  WRITE OUT THIS NODE AGAIN.
C
      CALL BTPUT(STACK(SP))
      SP = SP - 1
      LF3REC = LF3REC + 1
      IF(SP.NE.0) RETURN
C
C  NEW STARTING NODE.
C
      CALL BTGET(LF3REC,N1)
      VALUE(1,N1) = VAL
      VALUE(2,N1) = IP
      VALUE(3,N1) = 0
      VALUE(1,N1+1) = VALT
      VALUE(2,N1+1) = -STACK(1)
      VALUE(3,N1+1) = 0
      CALL REUSE
C
C  WRITE OUT THIS NEW NODE.
C
      CALL BTPUT(LF3REC)
      START = LF3REC
      LF3REC = LF3REC + 1
      RETURN
      END
      SUBROUTINE BUILD
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  BUILD A KEY INDEX FOR AN ATTRIBUTE IN A RELATION
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:START.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:SRTCOM.BLK
      INCLUDE rin:DCLAR1.BLK
      INTEGER COLUMN
C
      LOGICAL EQKEYW
C
C  SCAN THE COMMAND FOR PROPER SYNTAX.
C
      IF(.NOT.EQKEYW(2,KWKEY,3)) GO TO 7500
      IF(.NOT.EQKEYW(3,KWFOR,3)) GO TO 7500
      IF(.NOT.EQKEYW(5,KWIN,2)) GO TO 7500
      IF(LXITEM(DUM).GT.6) GO TO 7500
C
C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
C
      CALL RMDBLK(DBNAME)
      IF(RMSTAT.EQ.0) GO TO 50
      CALL WARN(RMSTAT,DBNAME,0)
      GO TO 8000
C
C  FIND THE ATTRIBUTE IN THE SPECIFIED RELATION.
C
   50 CONTINUE
      RNAME = BLANK
      CALL LXSREC(6,1,8,RNAME,1)
      ANAME = BLANK
      CALL LXSREC(4,1,8,ANAME,1)
      I = LOCREL(RNAME)
      IF(I.EQ.0) GO TO 100
C
C  UNRECOGIZED RELATION NAME.
C
      CALL WARN(1,RNAME,0)
      GO TO 8000
  100 CONTINUE
C
C  CHECK FOR MODIFY PERMISSION.
C
      I = LOCPRM(RNAME,2)
      IF(I.EQ.0) GO TO 150
      CALL WARN(9,RNAME,0)
      GO TO 8000
C
C  FIND THE ATTRIBUTE IN THE RELATION.
C
  150 CONTINUE
      I = LOCATT(ANAME,RNAME)
      IF(I.EQ.0) GO TO 200
C
C  THIS ATTRIBUTE IS NOT IN THIS RELATION.
C
      CALL WARN(3,ANAME,RNAME)
      GO TO 8000
  200 CONTINUE
C
C  ISSUE A WARNING IF ATTRIBUTE IS ALREADY A KEY.
C
      CALL ATTGET(ISTAT)
      IF(ATTKEY.EQ.0) GO TO 400
	if(nout.eq.6)goto 3144
      WRITE(NOUT,300) ANAME
  300 FORMAT(19H -ERROR- Attribute ,A8,
     X       17H Is Already A KEY )
      GO TO 8000
3144	continue
	write(c128wk,300)
	call atxto
	goto 8000
  400 CONTINUE
C
C  DETERMINE THE COLUMN TO BE USED FOR THIS ATTRIBUTE.
C
      COLUMN = ATTCOL
C
C  INITIALIZE THE BTREE FOR THIS ELEMENT.
C
      CALL BTINIT(ATTKEY)
      START = ATTKEY
      CALL ATTPUT(ISTAT)
C
C  SORT THE KEY VALUES IF THERE ARE MORE THAN 100 OF THEM
C
      IF(NTUPLE.GT.100) GO TO 700
C
C   SCAN THROUGH ALL THE DATA FOR THIS RELATION.
C
  500 CONTINUE
      IF(NID.EQ.0) GO TO 900
      CID = NID
      CALL GETDAT(1,NID,ITUP,LENGTH)
      IF(NID.LT.0) GO TO 900
      IP = ITUP + COLUMN - 1
      IF(ATTWDS.NE.0) GO TO 600
C
C  ATTRIBUTE IS A VARIABLE LENGTH ATTRIBUTE.
C
      IP = BUFFER(IP) + ITUP + 1
  600 CONTINUE
      IF(BUFFER(IP).EQ.NULL) GO TO 500
      CALL BTADD(BUFFER(IP),CID,ATTYPE)
      GO TO 500
C
C  SORT KEY VALUES BEFORE BUILDING THE B-TREE
C
  700 CONTINUE
      LENGTH = 2
      NSOVAR = 1
      NKSORT = 3
      LIMTU = ALL9S
      SORTYP(1) = .TRUE.
      VARPOS(1) = 1
      L = 2
      IF(ATTYPE.EQ.KZTEXT) L = 4
      IF(ATTYPE.EQ.KZINT ) L = 1
      IF(ATTYPE.EQ.KZIVEC) L = 1
      IF(ATTYPE.EQ.KZIMAT) L = 1
      VARTYP(1) = L
      CALL SORT(NKSORT,ierr)
	if(ierr.eq.0)goto 770
	call warn(16)
	goto 8000
770	continue
C
C  READ THE SORTED KEY VALUES AND BUILD THE BTREE
C
      CALL GTSORT(IP,1,-1,LENGTH)
  800 CONTINUE
      CALL GTSORT(IP,1,1,LENGTH)
      IF(RMSTAT.NE.0) GO TO 900
      IF(BUFFER(IP).EQ.NULL) GO TO 800
      CALL BTADD(BUFFER(IP),BUFFER(IP+1),ATTYPE)
      GO TO 800
C
C  ALL DONE.
C
  900 CONTINUE
C
C  RESTORE THE START TO THE BTREE TABLE.
C
      I = LOCATT(ANAME,RNAME)
      CALL ATTGET(ISTAT)
      ATTKEY = START
      CALL ATTPUT(ISTAT)
      GO TO 8000
C
C  SYNTAX ERROR.
C
 7500 CONTINUE
      CALL WARN(4,0,0)
C
C  RETURN
C
 8000 RETURN
      END
      SUBROUTINE CHANGE(MAT,NVAL)
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE PROCESSES A CHANGE IN RIM.
C
C  PARAMETERS:
C         MAT-----SCRATCH ARRAY FOR A TUPLE
C         NVAL----SCRATCH ARRAY FOR A TUPLE
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:SORBUF.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:RULCOM.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:START.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:MISC.BLK
C
C  DIMENSION STATEMENTS.
C
      DIMENSION MAT(*)
      DIMENSION NVAL(*)
      INTEGER RULWHR(14)
      LOGICAL BYPASS
      INTEGER COLUMN
      LOGICAL NE
      LOGICAL SINGLE
      LOGICAL EQKEYW
      INTEGER EXTRA
      INCLUDE rin:DCLAR1.BLK
      NC = 0
      NOPE = 0
C
C  LOOK FOR THE WORD WHERE.
C
      ITEMS = LXITEM(ISTAT)
      J = LFIND(1,ITEMS,KWWHER,5)
      IF(J.NE.0) GO TO 100
	if(nout.eq.6)goto 3145
      WRITE(NOUT,9001)
 9001 FORMAT(48H -ERROR- WHERE Clause Required On CHANGE Command)
      GO TO 9999
3145	continue
	write(c128wk,9001)
	call atxto
	goto 9999
  100 CONTINUE
      NEWL = ATTWDS
      NROW = ATTCHA
C
C     SINGLE INDICATES VEC(I) MAT(I,J) SPECIFICATION
C
      SINGLE = LXWREC(3,1).EQ.K4LPAR
      IF(.NOT.SINGLE) GO TO 200
C
C     CHECK SINGLE SYNTAX
C
      CALL TYPER(ATTYPE,MATV,ITYPE)
      IF(ITYPE.EQ.KZTEXT) GO TO 110
      NDIM = 1
      IF(MATV.EQ.KZMAT) NDIM = 2
      IF(LXWREC((4+NDIM),1).EQ.K4RPAR) GO TO 130
  110 CONTINUE
	if(nout.eq.6)goto 3146
      WRITE (NOUT,120)
  120 FORMAT(45H -ERROR- Bad VEC(I) or MAT(I,J) Specification )
      GO TO 9999
3146	continue
	write(c128wk,120)
	call atxto
	goto 9999
  130 CONTINUE
      IROW = LXIREC(4)
      ICOL = LXIREC(5)
      IF(NDIM.EQ.1) ICOL = 1
      NEWL = 1
      IF(ITYPE.EQ.KZDOUB) NEWL = 2
      ID = 6 + NDIM
C
C  CHECK VALUE SYNTAX (ONLY ONE ITEM ALLOWED)
C
      JJ = ID + 1
      IF(EQKEYW(JJ,KWIN,2)) GO TO 135
      IF(EQKEYW(JJ,KWWHER,5)) GO TO 135
      GO TO 110
  135 CONTINUE
      CALL PARVAL(ID,NVAL,ATTYPE,NEWL,NROW,0,IERR)
      IF(IERR.NE.0) GO TO 9999
      IP = 0
      IF(ATTWDS.EQ.0) GO TO 400
      IF(NROW.EQ.0) NROW = ATTWDS
      IF(IROW.GT.NROW) GO TO 110
      IP = NROW*(ICOL-1) + IROW
      IF(ITYPE.EQ.KZDOUB) IP = 2*IP - 1
      IP = IP + ATTCOL - 1
      IF(MATV.NE.KZMAT) GO TO 400
      IF(IROW*ICOL.GT.ATTWDS) GO TO 110
      GO TO 400
  200 CONTINUE
      ID = 4
      CALL PARVAL(ID,NVAL,ATTYPE,NEWL,NROW,0,IERR)
      IF(IERR.NE.0) GO TO 9999
  400 CONTINUE
C
C  CHECK FOR RULES FOR THIS RELATION
C
      ANAME = ATTNAM
      RNAME = RELNAM
      BYPASS = .TRUE.
      IF(.NOT.RUCK) GO TO 460
      CALL CHKRUL(RNAME)
      I = LOCATT(ANAME,RNAME)
      CALL ATTGET(ISTAT)
      I = LOCREL(RNAME)
      CALL RELGET(ISTAT)
      IF(RMSTAT.LT.110) GO TO 450
	if(nout.eq.6)goto 3147
      IF(RMSTAT.EQ.110) WRITE(NOUT,410)
      IF(RMSTAT.EQ.111) WRITE(NOUT,420)
  410 FORMAT(35H -ERROR- Unrecognized RULE Relation)
  420 FORMAT(50H -ERROR- More Than 10 Rules Apply To This Relation)
      GO TO 9999
3147	continue
      IF(RMSTAT.EQ.110) WRITE(c128wk,410)
      IF(RMSTAT.EQ.111) WRITE(c128wk,420)
	if(rmstat.eq.110.or.rmstat.eq.111)call atxto
	goto 9999
  450 CONTINUE
      IF(RUCK.AND.RULES) BYPASS = .FALSE.
      IF(BYPASS) GO TO 460
C
C  SAVE THE RULE WHERE CLAUSE
C
      RULWHR(1) = NBOO
      RULWHR(2) = BOO(1)
      RULWHR(3) = KATTP(1)
      RULWHR(4) = KATTL(1)
      RULWHR(5) = KATTY(1)
      RULWHR(6) = KOMTYP(1)
      RULWHR(7) = KOMPOS(1)
      RULWHR(8) = KOMLEN(1)
      RULWHR(9) = KOMPOT(1)
      RULWHR(10) = KSTRT
      RULWHR(11) = MAXTU
      RULWHR(12) = LIMTU
      RULWHR(13) = WHRVAL(1)
      RULWHR(14) = WHRLEN(1)
  460 CONTINUE
C
C  PROCESS THE WHERE CLAUSE.
C
      CALL WHERE(J)
      IF(RMSTAT.NE.0) GO TO 9999
      IF(BYPASS) GO TO 480
C
C  USE THE SORT BUFFER TO SAVE THE CHANGE WHERE CLAUSE
C
      CALL BLKMOV(SORBUF,NBOO,484)
  480 CONTINUE
C
C  RESTORE THE TUPLEA POINTERS.
C
      J = LOCATT(ANAME,RNAME)
      CALL ATTGET(ISTAT)
C
C  SEQUENCE THROUGH THE DATA.
C
  500 CONTINUE
      IF(BYPASS) GO TO 510
C
C  RESTORE THE CHANGE WHERE CLAUSE
C
      CALL BLKMOV(NBOO,SORBUF,484)
      CALL RMLOOK(MAT,1,0,LENGTH)
      IF(RMSTAT.NE.0) GO TO 9999
C
C  RESTORE THE RULE WHERE CLAUSE
C
      NBOO = RULWHR(1)
      BOO(1) = RULWHR(2)
      KATTP(1) = RULWHR(3)
      KATTL(1) = RULWHR(4)
      KATTY(1) = RULWHR(5)
      KOMTYP(1) = RULWHR(6)
      KOMPOS(1) = RULWHR(7)
      KOMLEN(1) = RULWHR(8)
      KOMPOT(1) = RULWHR(9)
      KSTRT = RULWHR(10)
      MAXTU = RULWHR(11)
      LIMTU = RULWHR(12)
      WHRVAL(1) = RULWHR(13)
      WHRLEN(1) = RULWHR(14)
      GO TO 520
C
C  NO RULES
C
  510 CONTINUE
      CALL RMLOOK(MAT,1,0,LENGTH)
      IF(RMSTAT.NE.0) GO TO 9999
  520 CONTINUE
      IF(IVAL.GT.NTUPLE) GO TO 9999
      START = ATTKEY
      COLUMN = ATTCOL
C
C  CHANGE IT.
C
      IF(SINGLE) GO TO 5000
      IF(ATTWDS.EQ.0) GO TO 2000
C
C  CHANGE IS TO A FIXED LENGTH ATTRIBUTE.
C
      NEWVAL = 1
      IF(MAT(COLUMN).EQ.NVAL(1)) NEWVAL = 0
      IVOLD = MAT(COLUMN)
      K = COLUMN - 1
      DO 600 L=1,ATTWDS
      MAT(K+L) = NVAL(L)
  600 CONTINUE
  700 CONTINUE
      IF(BYPASS) GO TO 800
C
C  SEE IF THE APPLICABLE RULES ARE SATISFIED
C
      CALL CHKTUP(MAT,ISTAT)
C
C  RESTORE THE TUPLEA POINTERS
C
      IF(ISTAT.GT.0) GO TO 710
      I = LOCATT(ANAME,RNAME)
      CALL ATTGET(XSTAT)
      IF(ISTAT.EQ.0) GO TO 800
      GO TO 720
  710 CONTINUE
	if(nout.eq.6)goto 3148
      WRITE(NOUT,9005) IVAL
	goto 3149
3148	continue
	write(c128wk,9005)ival
	call atxto
3149	continue
      ISNOUT = NOUTR
      NOUTR = NOUT
      CALL PRULE(ISTAT)
      NOUTR = ISNOUT
      GO TO 500
  720 CONTINUE
      ISTAT = -ISTAT
	if(nout.eq.6)goto 3140
      WRITE(NOUT,9006) ISTAT
	goto 3141
3140	continue
	write(c128wk,9006)istat
	call atxto
3141	continue
      GO TO 500
  800 CONTINUE
      IF((START.EQ.0).OR.(NEWVAL.EQ.0)) GO TO 1000
      CALL BTREP(IVOLD,0,CID,ATTYPE)
      IF(MAT(COLUMN).EQ.NULL) GO TO 1000
      ATTKEY = START
      CALL BTADD(MAT(COLUMN),CID,ATTYPE)
      IF(ATTKEY.EQ.START) GO TO 1000
      ATTKEY = START
      CALL ATTPUT(ISTAT)
 1000 CONTINUE
      CALL PUTDAT(1,CID,MAT,LENGTH)
      NC = NC + 1
      GO TO 500
C
C  CHANGE IS TO A VARIABLE LENGTH ATTRIBUTE.
C
 2000 CONTINUE
      NEWVAL = 1
C
C  FIND THE ACTUAL COLUMN FOR VARIABLE LENGTH STUFF.
C
      COLUMN = MAT(ATTCOL)
      KURLEN = MAT(COLUMN)
      IF(KURLEN.LT.NEWL) GO TO 3000
      COLUMN = COLUMN + 2
      IF(MAT(COLUMN).EQ.NVAL(1)) NEWVAL = 0
      IVOLD = MAT(COLUMN)
      K = COLUMN - 1
      DO 2200 L=1,NEWL
      MAT(K+L) = NVAL(L)
 2200 CONTINUE
C
C  RESET THE VARIABLE LENGTH STUFF
C
      MAT(COLUMN-2) = NEWL
      MAT(COLUMN-1) = NROW
      IF(BYPASS) GO TO 2300
C
C  SEE IF THE APPLICABLE RULES ARE SATISFIED
C
      CALL CHKTUP(MAT,ISTAT)
C
C  RESTORE THE TUPLEA POINTERS
C
      IF(ISTAT.GT.0) GO TO 2210
      I = LOCATT(ANAME,RNAME)
      CALL ATTGET(XSTAT)
      IF(ISTAT.EQ.0) GO TO 2300
      GO TO 2220
 2210 CONTINUE
	if(nout.eq.6)goto 3142
      WRITE(NOUT,9005) IVAL
	goto 3143
3142	continue
	write(c128wk,9005)ival
	call atxto
3143	continue
      ISNOUT = NOUTR
      NOUTR = NOUT
      CALL PRULE(ISTAT)
      NOUTR = ISNOUT
      GO TO 500
 2220 CONTINUE
      ISTAT = -ISTAT
	if(nout.eq.6)goto 3144
      WRITE(NOUT,9006) ISTAT
      GO TO 500
3144	continue
	write(c128wk,9006)istat
	call atxto
	goto 500
 2300 CONTINUE
      IF(START.EQ.0) GO TO 2600
      IF(NEWVAL.EQ.0) GO TO 2600
      CALL BTREP(IVOLD,0,CID,ATTYPE)
      IF(MAT(COLUMN).EQ.NULL) GO TO 2600
      ATTKEY = START
      CALL BTADD(MAT(COLUMN),CID,ATTYPE)
      IF(ATTKEY.EQ.START) GO TO 2600
      ATTKEY = START
      CALL ATTPUT(ISTAT)
 2600 CONTINUE
      CALL PUTDAT(1,CID,MAT,LENGTH)
      NC = NC + 1
      GO TO 500
C
C  CHANGE IS TO A VARIABLE LENGTH ATTRIBUTE WITH THE NEW VALUE
C  BIGGER THAN THE OLD VALUE.
C
 3000 CONTINUE
      EXTRA = NEWL - KURLEN
      IF((LENGTH+EXTRA).GT.MAXCOL) GO TO 8100
C
C  NOW FIX UP THE MODIFIED TUPLE.
C
      I = LOCATT(ANAME,RNAME)
      CALL ATTGET(ISTAT)
      COLUMN = MAT(ATTCOL)
      IVOLD = MAT(COLUMN+2)
C
C  FIGURE OUT HOW TO SHIFT THE VARIABLE LENGTH STUFF AROUND.
C
      ISHIFT = KURLEN + 2
      MOVE = LENGTH - ISHIFT - COLUMN + 1
      IF(MOVE.GT.0)
     X CALL BLKMOV(MAT(COLUMN),MAT(COLUMN+ISHIFT),MOVE)
C
C  NOW REBUILD ALL VARIABLE LENGTH POINTERS.
C
      I = LOCATT(BLANK,NAME)
      DO 3500 I=1,NATT
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 3500
      IF(ATTWDS.NE.0) GO TO 3500
      KURCOL = ATTCOL
      IF(MAT(KURCOL).LT.COLUMN) GO TO 3500
C
C  CHANGE THE POINTER TO POINT TO THE NEW LOCATION OF THE DATA.
C
      NEWVAL = 0
      MAT(KURCOL) = MAT(KURCOL) - ISHIFT
 3500 CONTINUE
C
C  PUT THE NEW VALUE IN ITS PLACE.
C
      I = LOCATT(ANAME,RNAME)
      CALL ATTGET(ISTAT)
      MAT(ATTCOL) = LENGTH - ISHIFT + 1
      COLUMN = MAT(ATTCOL)
      MAT(COLUMN) = NEWL
      MAT(COLUMN+1) = NROW
      COLUMN = COLUMN + 2
      K = COLUMN - 1
      DO 3600 L=1,NEWL
      MAT(K+L) = NVAL(L)
 3600 CONTINUE
      IF(BYPASS) GO TO 3900
C
C  SEE IF THE APPLICABLE RULES ARE SATISFIED
C
      CALL CHKTUP(MAT,ISTAT)
C
C  RESTORE THE TUPLEA POINTERS
C
      IF(ISTAT.GT.0) GO TO 3880
      I = LOCATT(ANAME,RNAME)
      CALL ATTGET(XSTAT)
      IF(ISTAT.EQ.0) GO TO 3900
      GO TO 3890
 3880 CONTINUE
	if (nout.eq.6)goto 3245
      WRITE(NOUT,9005) IVAL
	goto 3146
3245	continue
	write(c128wk,9005)ival
3246	continue
      ISNOUT = NOUTR
      NOUTR = NOUT
      CALL PRULE(ISTAT)
      NOUTR = ISNOUT
      GO TO 500
 3890 CONTINUE
      ISTAT = -ISTAT
	if(nout.eq.6)goto 3247
      WRITE(NOUT,9006) ISTAT
      GO TO 500
3247	continue
	write(c128wk,9006)istat
	goto 500
 3900 CONTINUE
C
C  OLD TUPLE MUST BE DELETED AND THE CHANGED ONE ADDED.
C
      CALL DELDAT(1,CID)
C
C  ADD THE NEW TUPLE.
C
      CALL ADDDAT(1,REND,MAT,LENGTH+EXTRA)
C
C  CHANGE THE POINTERS FOR ANY KEY ATTRIBUTES.
C
      I = LOCATT(BLANK,NAME)
      DO 3400 I=1,NATT
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 3400
      IF(ATTKEY.EQ.0) GO TO 3400
      START = ATTKEY
      KSTART = ATTKEY
      COLUMN = ATTCOL
      IF(ATTWDS.NE.0) GO TO 3100
      COLUMN = MAT(COLUMN) + 2
 3100 CONTINUE
      IF(NE(ATTNAM,ANAME)) GO TO 3200
      CALL BTREP(IVOLD,0,CID,ATTYPE)
      GO TO 3400
 3200 CONTINUE
      IF(MAT(COLUMN).NE.NULL) GO TO 3300
      CALL BTREP(MAT(COLUMN),0,CID,ATTYPE)
      GO TO 3400
 3300 CONTINUE
      CALL BTREP(MAT(COLUMN),REND,CID,ATTYPE)
      IF(START.EQ.KSTART) GO TO 3400
      ATTKEY = START
      CALL ATTPUT(ISTAT)
 3400 CONTINUE
C
C  UPDATE THE KEY VALUE FOR THE NEW ATTRIBUTE VALUE
C
      I = LOCATT(ANAME,RNAME)
      CALL ATTGET(ISTAT)
      START = ATTKEY
      IF(START.EQ.0) GO TO 4000
      IF(MAT(COLUMN).EQ.NULL) GO TO 4000
      CALL BTADD(MAT(COLUMN),REND,ATTYPE)
      IF(ATTKEY.EQ.START) GO TO 4000
      ATTKEY = START
      CALL ATTPUT(ISTAT)
 4000 CONTINUE
      IF(CID.EQ.RSTART) RSTART = NID
C
C     ACTUALLY ADD THE TUPLE
C
      CALL PUTDAT(1,REND,MAT,LENGTH+EXTRA)
      NC = NC + 1
      CALL RELPUT
      GO TO 500
 5000 CONTINUE
C
C     CHANGE A SINGLE WORD
C
      IVOLD = MAT(ATTCOL)
      IF(ATTWDS.NE.0) GO TO 5100
      IP = MAT(ATTCOL)
      NW = MAT(IP)
      NR = MAT(IP+1)
      COLUMN = IP + 2
      IVOLD = MAT(COLUMN)
      IF(NR.EQ.0) NR = NW
      IF(IROW.LE.NR) GO TO 5050
      IF(IROW*ICOL.LE.NW) GO TO 5050
C
C     OUT OF RANGE
C
      NOPE = NOPE + 1
      GO TO 500
 5050 CONTINUE
      IJ = NR*(ICOL-1) + IROW
      IF(ITYPE.EQ.KZDOUB) IJ = 2*IJ - 1
      IP = IP + IJ + 1
 5100 CONTINUE
      NEWVAL = 1
      IF(MAT(IP).EQ.NVAL(1)) NEWVAL = 0
      MAT(IP) = NVAL(1)
      IF(ITYPE.EQ.KZDOUB) MAT(IP+1) = NVAL(2)
      IF(IROW.NE.1) NEWVAL = 0
      IF(ICOL.NE.1) NEWVAL = 0
      GO TO 700
C
C  TUPLE LENGTH EXCCEDS MAXCOL
C
 8100 CONTINUE
	if(nout.eq.6)goto 3248
      WRITE(NOUT,8110) MAXCOL
 8110 FORMAT(36H -ERROR- Relation Row Length Exceeds,I5)
      GO TO 9999
3248	continue
	write(c128wk,8110)maxcol
	call atxto
	goto 9999
C
C  DONE
C
 9999 CONTINUE
	if(nout.eq.6)goto 35
      WRITE(NOUT,9003) NC,NAME
 9003 FORMAT(2X,I6,26H ROWS Changed In Relation ,A8)
      IF(NOPE.EQ.0) RETURN
      WRITE(NOUT,9004)NOPE
 9004 FORMAT(11H -WARNING- ,I5,33H Rows Had Incompatible Dimensions )
      RETURN
35	continue
      WRITE(c128wk,9003) NC,NAME
	call atxto
      IF(NOPE.EQ.0) RETURN
      WRITE(c128wk,9004)NOPE
	call atxto
	return
 9005 FORMAT(12H -ERROR- ROW,I4,22H Fails To Satisfy The ,
     X       14HFollowing RULE)
 9006 FORMAT(32H -ERROR- Unable To Process RULE ,I3)
      END
      SUBROUTINE CHKATT(JUNK,NUMELE,ERROR)
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE EDITS THE ATTRIBUTE LIST ON THE RELATION CARDS
C  AND CREATES THE NEW RELATIONS BASED ON THE CARDS.  THE EXISTENCE
C  OF THESE NEW RELATIONS IS RECORDED IN RIMS INTERNAL TABLES.
C
C  PARAMETERS:
C         JUNK----SCRATCH ARRAY WITH NEW ATTRIBUTE NAMES
C         NUMELE--THE NUMBER OF ATTRIBUTES IN JUNK
C         ERROR---COUNT OF THE ERRORS ENCOUNTERED
C
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:MISC.BLK
C
      INTEGER ERROR
      LOGICAL EQ
      INTEGER IFLAG
      INTEGER CSTART
      INTEGER JUNK(5,*)
      INCLUDE rin:DCLAR1.BLK
C
      NCOLS = 0
      IFLAG = 0
C
C  SEARCH THE LIST
C
      ITEMS = LXITEM(IDUMMY)
      RNAME = BLANK
      DO 600 I=3,ITEMS
      ANAME = BLANK
      CALL LXSREC(I,1,8,ANAME,1)
C
C  LOOK FOR THIS ATTRIBUTE AMONG EXISTING ATTRIBUTES.
C
      J = LOCATT(ANAME,RNAME)
      IF(J.NE.0) GO TO 100
      CALL ATTGET(IDUMMY)
      NCHAR = ATTCHA
      NWORDS = ATTWDS
      GO TO 500
C
C  LOOK FOR THIS ATTRIBUTE AMONG NEW ATTRIBUTES.
C
  100 CONTINUE
      IF(NUMELE.EQ.0) GO TO 300
      DO 200 J=1,NUMELE
      IF(EQ(JUNK(1,J),ANAME)) GO TO 400
  200 CONTINUE
C
C  CANNOT FIND THIS ATTRIBUTE.
C
  300 CONTINUE
	if(nout.eq.6)goto 3140
      WRITE(NOUT,9000) ANAME
	goto 3141
3140	continue
	write(c128wk,9000) aname
	call atxto
3141	continue
 9000 FORMAT(9H -ERROR- ,A8,26H is an Undefined Attribute )
      ERROR = ERROR + 1
      IFLAG = 1
      GO TO 600
  400 CONTINUE
      CALL ITOH(NCHAR,NWORDS,JUNK(4,J))
  500 CONTINUE
C
C  THE NUMBER OF WORDS NEEDED DEPEND ON THE ATTRIBUTE TYPE.
C
      IF(NWORDS.EQ.0) NWORDS = 1
      NCOLS = NCOLS + NWORDS
  600 CONTINUE
      IF(IFLAG.EQ.1) GO TO 999
      IF(NCOLS.LE.MAXCOL) GO TO 700
	if(nout.eq.6)goto 3142
      WRITE(NOUT,9001) MAXCOL
	goto 3143
3142	continue
	write(c128wk,9001)maxcol
	call atxto
3143	continue
 9001 FORMAT(36H -ERROR- Relation Row Length Exceeds,I5)
      ERROR = ERROR + 1
      GO TO 999
  700 CONTINUE
C
C  LOAD THIS RELATION USING TUPLER AND TUPLEA.
C
      RNAME = BLANK
      CALL LXSREC(1,1,8,RNAME,1)
      NATT = ITEMS - 2
      CALL ATTNEW(RNAME,NATT)
C
C  SET UP THE NEW TUPLER.
C
      NAME = RNAME
      CALL RMDATE(RDATE)
      NCOL = NCOLS
      NTUPLE = 0
      RSTART = 0
      REND = 0
      RPW = NONE
      MPW = NONE
      CALL RELADD
C
C  NOW ADD TO THE ATTRIBUTE RELATION VIA TUPLEA.
C
      CSTART = 1
      DO 1600 I=3,ITEMS
      ANAME = BLANK
      CALL LXSREC(I,1,8,ANAME,1)
C
C  LOOK FOR THIS ATTRIBUTE AMONG EXISTING ATTRIBUTES.
C
      RNAME = BLANK
      J = LOCATT(ANAME,RNAME)
      IF(J.NE.0) GO TO 1100
      CALL ATTGET(IDUMMY)
      RELNAM = NAME
      ATTCOL = CSTART
      GO TO 1500
C
C  LOOK FOR THIS ATTRIBUTE AMONG NEW ATTRIBUTES.
C
 1100 CONTINUE
      IF(NUMELE.EQ.0) GO TO 1500
      DO 1200 J=1,NUMELE
      IF(EQ(JUNK(1,J),ANAME)) GO TO 1400
 1200 CONTINUE
 1400 CONTINUE
      ATTNAM = ANAME
      RELNAM = NAME
      ATTCOL = CSTART
      ATTLEN = JUNK(4,J)
      ATTYPE = JUNK(3,J)
      ATTKEY = JUNK(5,J)
 1500 CONTINUE
      CALL ITOH(NCHAR,NWORDS,ATTLEN)
      IF(NWORDS.EQ.0) NWORDS = 1
      CSTART = CSTART + NWORDS
      IF(ATTKEY.NE.0) CALL BTINIT(ATTKEY)
      CALL ATTADD
 1600 CONTINUE
C
C  DONE
C
  999 RETURN
      END
      SUBROUTINE CHKREL (PERM,WORD1,ISTAT,NAMOWN)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  CHECKS PERMISSION TO SEE IF USER CAN UNLOAD THIS
C            RELATION.  PERM SET TO TRUE IF USER CAN.
C
C  INPUTS:
C            WORD1-------COMMAND SPECIFIED (ALL,DATA,OR SCHEMA)
C          ISTAT------------WAS THE RELATION GET SUCCESSFUL?
C          NAMOWN-----------USERID
C
C  OUTPUT:
C            PERM-------TRUE IF USER HAS PERMISSION TO UNLOAD
C                       FALSE OTHERWISE
C
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:DCLAR2.BLK
      INCLUDE rin:DCLAR6.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:FLAGS.BLK
      INTEGER ISTAT
      LOGICAL PERM
      PERM = .TRUE.
      CALL RELGET (ISTAT)
      IF (ISTAT .NE. 0) GO TO 10
C
C  CHECK FOR RULES RELATION
C
      IF((NAME.EQ.K8RRC).OR.(NAME.EQ.K8RDT)) GO TO 10
C
C  CHECK FOR OWNER
C
      IF(OWNER.EQ.NAMOWN) GO TO 20
C
C  CHECK FOR MODIFY PASSWORD
C
      IF ((MPW .EQ. K4NONE) .OR. (MPW .EQ. NAMOWN)) GO TO 20
   10 CONTINUE
      PERM = .FALSE.
   20 CONTINUE
      RETURN
      END
      SUBROUTINE CHKRUL(RNAME)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE: CHECK IF RULES APPLY TO THE CURRENT RELATION
C
C  PARAMETERS:  RNAME--RELATION NAME TO CHECK
C
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:RULCOM.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:DCLAR1.BLK
      RULES = .TRUE.
C
C  LOCATE THE RULES RELATION
C
      I = LOCREL(RIMRRC)
      IF(I.EQ.0) GO TO 100
      RULES = .FALSE.
      GO TO 999
C
C  SET UP A WHERE CLAUSE FOR THE RULES RELATION
C
  100 CONTINUE
      NBOO = 0
      I = LOCATT(K8NAM,RIMRRC)
      IF(I.NE.0) GO TO 200
      CALL ATTGET(I)
      IF(I.EQ.0) GO TO 300
C
C  BAD RULES RELATION
C
  200 CONTINUE
      RULES = .FALSE.
      RMSTAT = 110
      GO TO 999
C
C  LOAD WHCOM
C
  300 CONTINUE
      NBOO = 1
      BOO(1) = K4AND
      KATTP(1) = ATTCOL
      KATTL(1) = ATTLEN
      KATTY(1) = ATTYPE
      KOMTYP(1) = 2
      KOMPOS(1) = 1
      KOMLEN(1) = 1
      KOMPOT(1) = 1
      KSTRT = 0
      MAXTU = ALL9S
      LIMTU = ALL9S
      WHRVAL(1) = IBLANK
      CALL STRMOV(RNAME,1,8,WHRVAL,1)
      WHRLEN(1) = ATTLEN
      NS = 0
C
C  RETRIEVE THE RULE NUMBERS THAT APPLY AND STORE IN RULNUM
C
      RULCNT = 0
  400 CONTINUE
      CALL RMLOOK(IP,2,1,LEN)
      IF(RMSTAT.NE.0) GO TO 500
      RULCNT = RULCNT + 1
      IF(RULCNT.LE.10) GO TO 450
C
C  TOO MANY RULES
C
      RULES = .FALSE.
      RMSTAT = 111
      GO TO 999
  450 CONTINUE
      RULNUM(RULCNT) = BUFFER(IP+2)
      GO TO 400
C
C IF RULES APPLY SET UP DATA POINTERS AND WHERE CLAUSE FOR RULE NUMBERS
C
  500 CONTINUE
      IF(RULCNT.NE.0) GO TO 600
      RULES = .FALSE.
      GO TO 999
C
C  SET RELATION POINTERS
C
  600 CONTINUE
      I = LOCREL(RIMRDT)
      IF(I.EQ.0) GO TO 700
      RULES = .FALSE.
      RMSTAT = 110
      GO TO 999
C
C  STORE THE RELATION POINTERS IN RULPTR
C
  700 CONTINUE
      CALL BLKMOV(RULPTR,IVAL,6)
C
C  LOAD WHCOM
C
      I = LOCATT(K8NUM,RIMRDT)
      IF(I.NE.0) GO TO 200
      CALL ATTGET(I)
      IF(I.NE.0) GO TO 200
      KATTP(1) = ATTCOL
      KATTL(1) = ATTLEN
      KATTY(1) = ATTYPE
      WHRVAL(1) = 0
      WHRLEN(1) = ATTLEN
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE CHKTUP(TUPLE,ISTAT)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  THIS ROUTINE SEES IF A TUPLE SATISFIES THE RULE.
C
C  PARAMETERS:
C         TUPLE---DATA MATRIX TUPLE
C         RNAME---RELATION NAME
C         ISTAT---STATUS FLAG  0 FOR OK, 1 FOR NOT OK, -1 FOR TILT
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:RULCOM.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:RELTBL.BLK
C
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:DCLAR1.BLK
C  DIMENSION STATEMENTS.
C
      LOGICAL OK,QUAL
      INTEGER TUPLE(*)
      INTEGER ARRAY(24)
      INTEGER KOM(6)
      INTEGER SAVTUR(13)
      INTEGER SAVTUP(6)
      INTEGER SAVSCR(25)
      EQUIVALENCE (KOM(1),K4KOM(1))
C
C     NO TOLERANCE FOR RULES
C
      TOLSAV = TOL
      TOL = 0.
C
C  SAVE THE DATA FOR THE RELATION BEING LOADED
C
      RNAME = NAME
      MWDS = 5 + ((8-1)/CHPWD + 1)*4
      CALL BLKMOV(SAVTUR,NAME,MWDS)
      CALL BLKMOV(SAVTUP,IVAL,6)
C
C  PROCESS THE RULES
C
      QUAL = .TRUE.
      DO 2000 K=1,RULCNT
C
C  RESTORE THE RULE RELATION POINTERS
C
      CALL BLKMOV(IVAL,RULPTR,6)
      WHRVAL(1) = RULNUM(K)
C
C  SET UP TO FIND THIS RULE.
C
  100 CONTINUE
      CALL RMLOOK(ARRAY,2,0,LEN)
      IF(RMSTAT.NE.0) GO TO 1000
C
C  GET THE ATTRIBUTE NAME.
C
      I = LOCATT(ARRAY(4),RNAME)
      IF(I.NE.0) GO TO 9997
      CALL ATTGET(JSTAT)
      IF(JSTAT.NE.0) GO TO 9997
      NATTP = ATTCOL
      IF(ATTWDS.NE.0) GO TO 200
C
C  VARIABLE LENGTH ATTRIBUTE.
C
      NATTP = TUPLE(NATTP)
      ATTWDS = TUPLE(NATTP)
      ATTCHA = 0
      IF(ATTYPE.EQ.KZTEXT) ATTCHA = TUPLE(NATTP+1)
      IF(ATTYPE.EQ.KZIMAT) ATTCHA = TUPLE(NATTP+1)
      IF(ATTYPE.EQ.KZRMAT) ATTCHA = TUPLE(NATTP+1)
      IF(ATTYPE.EQ.KZDMAT) ATTCHA = TUPLE(NATTP+1)
      NATTP = NATTP + 2
  200 CONTINUE
      ITYPE = ATTYPE
C
C  GET THE BOOLEAN OPERATOR.
C
      NBOOT = LOCBOO(ARRAY(8))
      IF(NBOOT.GT.10) GO TO 300
C
C  VALUE COMPARISON.
C
      OK = .FALSE.
      CALL KOMPXX(TUPLE(NATTP),ARRAY(15),ATTWDS,NBOOT,OK,ITYPE)
      GO TO 600
C
C  ATTRIBUTE COMPARISON.
C  SAVE THE CURRENT RULE POINTERS AND WHERE STUFF
C
  300 CONTINUE
      CALL BLKMOV(SAVSCR,IVAL,6)
      SAVSCR(7) = NBOO
      SAVSCR(8) = BOO(1)
      SAVSCR(9) = KATTP(1)
      SAVSCR(10) = KATTL(1)
      SAVSCR(11) = KATTY(1)
      SAVSCR(12) = KOMTYP(1)
      SAVSCR(13) = KOMPOS(1)
      SAVSCR(14) = KOMLEN(1)
      SAVSCR(15) = KOMPOT(1)
      SAVSCR(16) = KSTRT
      SAVSCR(17) = MAXTU
      SAVSCR(18) = LIMTU
      SAVSCR(19) = WHRVAL(1)
      SAVSCR(20) = WHRVAL(2)
      SAVSCR(21) = WHRLEN(1)
      CALL BLKMOV(SAVSCR(22),LRROW,4)
C
C  PREPARE TO CALL RMLOOK.
C
      NBOOT = NBOOT - 11
      NP = NATTP - 1
      DO 400 I=1,ATTWDS
      WHRVAL(I) = TUPLE(NP+I)
  400 CONTINUE
      CALL HTOI(ATTCHA,ATTWDS,WHRLEN(1))
      RMSTAT = 0
      I = LOCREL(ARRAY(13))
      IF(I.NE.0) GO TO 500
C
C  SET UP A WHERE CLAUSE FOR THE ATTRIBUTE VALUE
C
      NBOO = 0
      I = LOCATT(ARRAY(11),ARRAY(13))
      IF(I.NE.0) GO TO 500
      CALL ATTGET(I)
      IF(I.NE.0) GO TO 500
      NBOO = 1
      BOO(1) = K4AND
      KATTP(1) = ATTCOL
      KATTL(1) = ATTLEN
      KATTY(1) = ATTYPE
      KOMTYP(1) = LOCBOO(KOM(NBOOT))
      KOMPOS(1) = 1
      KOMLEN(1) = 1
      KOMPOT(1) = 1
      CALL RMLOOK(NP,1,1,LEN)
  500 CONTINUE
      OK = .FALSE.
      IF(RMSTAT.EQ.0) OK = .TRUE.
      IF(NBOOT.NE.1) OK = .NOT.OK
C
C  RESTORE THE POINTERS AND THE WHERE CLAUSE
C
      CALL BLKMOV(IVAL,SAVSCR,6)
      NBOO = SAVSCR(7)
      BOO(1) = SAVSCR(8)
      KATTP(1) = SAVSCR(9)
      KATTL(1) = SAVSCR(10)
      KATTY(1) = SAVSCR(11)
      KOMTYP(1) = SAVSCR(12)
      KOMPOS(1) = SAVSCR(13)
      KOMLEN(1) = SAVSCR(14)
      KOMPOT(1) = SAVSCR(15)
      KSTRT = SAVSCR(16)
      MAXTU = SAVSCR(17)
      LIMTU = SAVSCR(18)
      WHRVAL(1) = SAVSCR(19)
      WHRVAL(2) = SAVSCR(20)
      WHRLEN(1) = SAVSCR(21)
      CALL BLKMOV(LRROW,SAVSCR(22),4)
  600 CONTINUE
      IF(ARRAY(2).EQ.K4AND) QUAL = QUAL.AND.OK
      IF(ARRAY(2).EQ.K4OR) QUAL = QUAL.OR.OK
C
C  GO GET THE NEXT CONDITION IN THIS RULE.
C
      GO TO 100
C
C  DONE WITH A RULE.
C
 1000 CONTINUE
      ISTAT = 1
      IF(QUAL) ISTAT = 0
      IF(ISTAT.NE.0) GO TO 9998
 2000 CONTINUE
      GO TO 9999
C
C  TUPLE FAILS TO SATISFY RULE
C
 9998 CONTINUE
      ISTAT = RULNUM(K)
      GO TO 9999
C
C  UNABLE TO PROCESS RULES
C
 9997 CONTINUE
      ISTAT = -RULNUM(K)
 9999 CONTINUE
C
C  RESTORE THE RELATION DATA
C
      CALL BLKMOV(NAME,SAVTUR,MWDS)
      I = LOCREL(NAME)
      LRROW = LRROW + 1
      CALL BLKMOV(IVAL,SAVTUP,6)
      TOL = TOLSAV
      RETURN
      END
      SUBROUTINE CMPUTE
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:    PROCESS COMPUTE COMMANDS
C
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:BUFFER.BLK
C  DATA AND DIMENSION:
      INTEGER FTYPE
      INTEGER KVAL
      REAL RVAL
      EQUIVALENCE (KVAL,RVAL)
      INTEGER LINE(7)
      LOGICAL EQKEYW
      INCLUDE rin:DCLAR1.BLK
      INCLUDE rin:DCLAR6.BLK
C
C  FIND THE ATTRIBUTE IN THE ATTRIBUTE TABLE.
      INTEGER SWITCP
      INTEGER IT(5)
      REAL RIT(5)
      EQUIVALENCE (IT,RIT)
      LIT = (20-1)/CHPWD+1
C
      ANAME = BLANK
      CALL LXSREC(3,1,8,ANAME,1)
      I = LOCATT(ANAME,NAME)
      IF(I.EQ.0) GO TO 100
      CALL WARN(3,ANAME,NAME)
      GO TO 9999
  100 CONTINUE
C
C  GET THE TYPE AND LENGTH FOR THIS ATTRIBUTE.
C
      CALL ATTGET(ISTAT)
      CALL TYPER(ATTYPE,MATVEC,ITYPE)
C
C  DETERMINE THE TYPE OF FUNCTION REQUESTED.
C
      FTYPE = 0
      IF(LXWREC(2,1).EQ.K4MIN ) FTYPE = 1
      IF(LXWREC(2,1).EQ.K4MAX ) FTYPE = 2
      IF(LXWREC(2,1).EQ.K4AVE ) FTYPE = 3
      IF(LXWREC(2,1).EQ.K4SUM ) FTYPE = 4
      IF(EQKEYW(2,KWCOUN,5)) FTYPE = 5
      IF(FTYPE.NE.0) GO TO 300
	if(nout.eq.6)goto 3144
      WRITE(NOUT,9000)
 9000 FORMAT(35H -ERROR- Unrecognized Function Type  )
      GO TO 9999
3144	continue
	write(c128wk,9000)
	call atxto
	goto 9999
C
C  PROCESS THE FUNCTION.
C
  300 CONTINUE
      IF(ATTWDS.LT.LIT) LIT = ATTWDS
      WHAT = BLANK
      CALL LXSREC(2,1,8,WHAT,1)
      IF(FTYPE.GT.2) GO TO 550
C
C  MIN - MAX
C
      IF(ATTWDS.EQ.1) GO TO 320
      IF((ATTWDS.EQ.2).AND.(ITYPE.EQ.KZDOUB)) GO TO 320
      IF((ATTWDS.GT.0).AND.(ITYPE.EQ.KZTEXT)) GO TO 320
      GO TO 8000
C
C  GET THE FIRST TUPLE
C
  320 CONTINUE
      CALL RMLOOK(IP,1,1,LENGTH)
      IPX = IP+ATTCOL-2
  325 CONTINUE
      DO 330 K=1,LIT
      IT(K) = BUFFER(IPX+K)
  330 CONTINUE
  350 CONTINUE
      CALL RMLOOK(IP,1,1,LENGTH)
      IF(RMSTAT.NE.0) GO TO 500
      IPX = IP+ATTCOL-2
      IF(BUFFER(IPX+1).EQ.NULL) GO TO 350
      IF(IT(1).EQ.NULL) GO TO 325
      IF(ITYPE.NE.KZTEXT) GO TO 390
C
C  TEXT COMPARE
C
      DO 360 K=1,LIT
      J = SWITCP(IT(K),BUFFER(IPX+K))
      IF(J.GT.0) GO TO 370
      IF(J.LT.0) GO TO 380
  360 CONTINUE
      GO TO 350
  370 CONTINUE
      IF(FTYPE.EQ.2) GO TO 325
      GO TO 350
  380 CONTINUE
      IF(FTYPE.EQ.1) GO TO 325
      GO TO 350
C
C  REAL,INT,DOUBLE
C
  390 CONTINUE
      IF(ITYPE.NE.KZINT) GO TO 400
      IF((FTYPE.EQ.1).AND.(BUFFER(IPX+1).LT.IT(1))) GO TO 325
      IF((FTYPE.EQ.2).AND.(BUFFER(IPX+1).GT.IT(1))) GO TO 325
      GO TO 350
  400 CONTINUE
      KVAL = BUFFER(IPX+1)
      IF((FTYPE.EQ.1).AND.(RVAL.LT.RIT(1))) GO TO 325
      IF((FTYPE.EQ.2).AND.(RVAL.GT.RIT(1))) GO TO 325
      GO TO 350
  500 CONTINUE
      GO TO 2000
  550 CONTINUE
      IF(FTYPE.GT.4) GO TO 750
C
C  AVE OR SUM.
C
      IF(ITYPE.EQ.KZDOUB) GO TO 560
      IF(ATTWDS.NE.1) GO TO 8000
C
C  DETERMINE IF WE HAVE REAL OR INT TYPE.
C
      IF(ITYPE.EQ.KZINT) GO TO 650
      IF(ITYPE.NE.KZREAL) GO TO 8100
C
C  REAL ATTRIBUTE.
C
  560 CONTINUE
      IF(ATTWDS.GT.2) GO TO 8000
      KOUNT = 0
      TOT = 0.0
  575 CONTINUE
      CALL RMLOOK(IP,1,1,LENGTH)
      IF(RMSTAT.NE.0) GO TO 625
      IF(BUFFER(IP+ATTCOL-1).EQ.NULL) GO TO 600
      KOUNT = KOUNT + 1
      KVAL = BUFFER(IP+ATTCOL-1)
      TOT = TOT + RVAL
  600 CONTINUE
      GO TO 575
  625 CONTINUE
      AVE = NULL
      IF(KOUNT.NE.0) AVE = TOT / FLOAT(KOUNT)
      RVAL = TOT
      IT(1) = KVAL
      IF(FTYPE.NE.3) GO TO 2000
      RVAL = AVE
      IT(1) = KVAL
      GO TO 2000
  650 CONTINUE
C
C  INT ATTRIBUTE.
C
      KOUNT = 0
      ITOT = 0
  675 CONTINUE
      CALL RMLOOK(IP,1,1,LENGTH)
      IF(RMSTAT.NE.0) GO TO 725
      IF(BUFFER(IP+ATTCOL-1).EQ.NULL) GO TO 700
      KOUNT = KOUNT + 1
      ITOT = ITOT + BUFFER(IP+ATTCOL-1)
  700 CONTINUE
      GO TO 675
  725 CONTINUE
      IAVE = NULL
      IF(KOUNT.NE.0) IAVE = ITOT / KOUNT
      IT(1) = ITOT
      IF(FTYPE.EQ.3) IT(1) = IAVE
      GO TO 2000
  750 CONTINUE
C
C  COUNT.
C
      KOUNT = 0
  775 CONTINUE
      CALL RMLOOK(IP,1,1,LENGTH)
      IF(RMSTAT.NE.0) GO TO 800
      KOUNT = KOUNT + 1
      GO TO 775
  800 CONTINUE
      IT(1) = KOUNT
      ITYPE = KZINT
C
C  PRINT OUT THE RESULTS.
C
 2000 CONTINUE
C
C  BLANK FILL LINE
C
      DO 2010 I=1,7
 2010 LINE(I) = IBLANK
      IF(IT(1).NE.NULL) GO TO 2050
C
C  NULL VALUE
C
      CALL STRMOV(NULL,1,3,LINE,7)
      GO TO 2100
C
C  WE HAVE A VALUE
C
 2050 CONTINUE
      IF(ITYPE.EQ.KZINT) CALL ITOC(LINE,7,10,IT,IERR)
      IF(ITYPE.EQ.KZREAL) CALL RTOC(LINE,7,10,IT)
      IF(ITYPE.EQ.KZDOUB) CALL RTOC(LINE,7,10,IT)
      IF(ITYPE.EQ.KZTEXT) CALL STRMOV(IT,1,CHPWD*LIT,LINE,7)
 2100 CONTINUE
	if(noutr.eq.6)goto 3146
      WRITE(NOUTR,9100) WHAT,ANAME
 9100 FORMAT(3X,A6,A8)
      WRITE(NOUTR,9200)
 9200 FORMAT(27H   ------------------------)
      CALL SPOUT(LINE,28)
      GO TO 9999
3146	continue
      WRITE(c128wk,9100) WHAT,ANAME
	call atxto
      WRITE(c128wk,9200)
	call atxto
      CALL SPOUT(LINE,28)
	goto 9999
C
C  ERROR MESSAGES.
C
C  ATTRIBUTE LENGTH IS GREATER THAN 1.
C
 8000 CONTINUE
	if(nout.eq.6)goto 3147
      WRITE(NOUT,9400)
 9400 FORMAT(26H -ERROR- FUNCTION Will Not,
     X       42H Work On Multi-word or VARIABLE Attributes)
      GO TO 9999
3147	continue
	write(c128wk,9400)
	call atxto
	goto 9999
C
C  TYPE IMPROPER FOR THE FUNCTION.
C
 8100 CONTINUE
	if(nout.eq.6)goto 3148
      WRITE(NOUT,9500)
	goto 9999
3148	continue
	write(c128wk,9500)
	call atxto
 9500 FORMAT(32H -ERROR- FUNCTION Type Will Only,
     X       39H Work on REAL,DOUBLE and INT Attributes)
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LEFT(I,J)
C
C  PULL OFF LEFT HALF OF THE J WORD AND PUT INTO I
C
      INTEGER I,J
      INTEGER*2 K(2)
      INTEGER IK
      EQUIVALENCE (IK,K(1))
      IK = J
      I = K(1)
      RETURN
      END
      SUBROUTINE RIGHT(I,J)
C
C  PULL OFF THE RIGHT HALF OF THE J WORD AND PUT INTO I
C
      INTEGER I,J
      INTEGER*2 K(2)
      INTEGER IK
      EQUIVALENCE (IK,K(1))
      IK = J
      I = K(2)
      RETURN
      END
      SUBROUTINE CSC
      INCLUDE rin:TEXT.BLK
C
C  THIS PROGRAM IS THE CONCEPTUAL SCHEMA COMPILER FOR RIM. CSC
C  COMPILES RIM CONCEPTUAL SCHEMAS INTO RIM INTERNAL SCHEMAS. ALL
C  CONCEPTUAL SCHEMAS ARE EXPRESSED IN TERMS OF THE RELATIONAL MODEL.
C
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:MISC.BLK
C
      LOGICAL EQKEYW
      LOGICAL EQ
      INTEGER ERROR
      INTEGER EFLAG,RFLAG
      INTEGER DBSTAT
      INCLUDE rin:DCLAR2.BLK
      INCLUDE rin:DCLAR6.BLK
C
      EFLAG = 0
      RFLAG = 0
      NUMELE  = 0
      ERROR = 0
      NEWCSN = 0
      CALL RMDATE(IDAY)
C
C  SET THE PROMPT CHARACTER TO D (DEFINE)
C
      CALL LXSET(K4PROM,K4DP)
C
C  BEGIN PROCESSING.
C
	if(nout.eq.6)goto 3140
      WRITE (NOUT,9000)
 9000 FORMAT(29H Begin RIM Schema Compilation)
      GO TO 110
3140	continue
	write(c128wk,9000)
	goto 110
C
  100 CONTINUE
C
C  EDIT DATA BASE NAME.
C
      CALL LODREC
C
C  CHECK FOR END,INPUT, OR HELP
C
      IF(EQKEYW(1,KWEND,3)) GO TO 800
  110 CONTINUE
      IF((EQKEYW(1,KWDEFI,6)).AND.(LXITEM(IDUMMY).EQ.2)) GO TO 120
	if(nout.eq.6)goto 3141
      WRITE (NOUT,9001)
	goto 3142
3141	continue
	write(c128wk,9001)
	call atxto
3142	continue
 9001 FORMAT(31H -ERROR- Missing Data Base Name)
      IF(.NOT.BATCH) GO TO 100
      ERROR = ERROR + 1
      IF(ERROR.LT.10) GO TO 100
      GO TO 950
  120 CONTINUE
C
C  CHECK THAT THE NAME IS LESS THAN 6 CHARACTERS.
C
      IF((LXLENC(2).GE.1).AND.(LXLENC(2).LE.6)) GO TO 145
	if(nout.eq.6)goto 3143
      WRITE (NOUT,9002)
	goto 3144
3143	continue
	write(c128wk,9002)
	call atxto
3144	continue
 9002 FORMAT(39H -ERROR- The Database Name Must Be 1-6 ,
     X       23HAlphanumeric Characters)
      IF(.NOT.BATCH) GO TO 100
      ERROR = ERROR + 1
      IF(ERROR.LT.10) GO TO 100
      GO TO 950
C
C  STORE DATA BASE NAME
C
  145 CONTINUE
      NAMDB = BLANK
      CALL LXSREC(2,1,8,NAMDB,1)
C
C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
C
      CALL RMDBLK(NAMDB)
      IF(RMSTAT.NE.0) GO TO 150
      CALL RMDBGT(NAMDB,DBSTAT)
      IF(DBSTAT.NE.0) GO TO 100
      CALL RMOPEN(NAMDB)
      IF((RMSTAT.EQ.15).OR.(RMSTAT.EQ.0)) GO TO 155
  150 CALL WARN(RMSTAT,DBNAME,0)
      GO TO 999
  155 CONTINUE
      NEWCSN = 1
      IF(DFLAG) RFLAG = 1
C
C  EDIT OWNER CLAUSE
C
  200 CONTINUE
      CALL LODREC
C
C  CHECK FOR END,INPUT, OR HELP
C
      IF(EQKEYW(1,KWEND,3)) GO TO 800
      IF(EQKEYW(1,KWOWNE,5)) GO TO 220
      IF((DFLAG).AND.(EQ(OWNER,USERID))) GO TO 350
      GO TO 230
C
  220 CONTINUE
      IF(LXITEM(IDUMMY).EQ.2) GO TO 260
  230 CONTINUE
	if(nout.eq.6)goto 3145
      WRITE (NOUT,9003)
	goto 3146
3145	write(c128wk,9003)
	call atxto
3146	continue
 9003 FORMAT(35H -ERROR- An Owner Must Be Specified)
      IF(.NOT.BATCH) GO TO 200
      ERROR = ERROR + 1
      IF(ERROR.LT.10) GO TO 200
      GO TO 950
C
  260 CONTINUE
      IF(.NOT.DFLAG) GO TO 290
      NAMOWN = BLANK
      CALL LXSREC(2,1,8,NAMOWN,1)
      IF(EQ(OWNER,NAMOWN)) GO TO 300
	if(nout.eq.6)goto 3147
      WRITE (NOUT,9004)
	goto 3148
3147	continue
	write(c128wk,9004)
	call atxto
3148	continue
 9004 FORMAT(59H -ERROR- Unauthorized Access To Data Base Schema Definit
     Xion)
      IF(.NOT.BATCH) GO TO 200
      ERROR = ERROR + 1
      IF(ERROR.LT.10) GO TO 200
      GO TO 950
  290 CONTINUE
      IF((LXLENC(2).GE.1).AND.(LXLENC(2).LE.8)) GO TO 295
      CALL WARN(7,KWOWNE,BLANK)
      IF(.NOT.BATCH) GO TO 200
      ERROR = ERROR + 1
      IF(ERROR.LT.10) GO TO 200
      GO TO 950
  295 CONTINUE
      OWNER = BLANK
      CALL LXSREC(2,1,8,OWNER,1)
C
C  SEARCH FOR ATTRIBUTES, RELATIONS, RULES, PASSWORDS, OR END
C
  300 CONTINUE
      CALL LODREC
  350 CONTINUE
      IF(EQKEYW(1,KWELEM,8)) GO TO 400
      IF(EQKEYW(1,KWATTR,10)) GO TO 400
      IF(EQKEYW(1,KWRELA,9)) GO TO 500
      IF(EQKEYW(1,KWRULS,5)) GO TO 600
      IF(EQKEYW(1,KWPASS,9)) GO TO 700
      IF(EQKEYW(1,KWEND,3)) GO TO 800
C
C  ERROR.
C
      CALL WARN(4,0,0)
      IF(.NOT.BATCH) GO TO 300
      ERROR = ERROR + 1
      IF(ERROR.LT.10) GO TO 300
      GO TO 950
C
C  PROCESS ATTRIBUTES.
C
  400 CONTINUE
      CALL LODELE(NUMELE,ERROR)
      EFLAG = 1
      GO TO 350
C
C
C  PROCESS RELATIONS.
C
  500 CONTINUE
      IF(DFLAG) GO TO 525
      IF(EFLAG.EQ.1) GO TO 525
	if(nout.eq.6)goto 3149
      WRITE (NOUT,9005)
 9005 FORMAT(' -ERROR- No Attributes Defined - Relation Definition i'
     X's Impossible')
C 9005 FORMAT(66H -ERROR- NO ATTRIBUTES DEFINED - RELATION DEFINITION IS
C     XIMPOSSIBLE)
      ERROR = ERROR + 1
      GO TO 300
3149	continue
	write(c128wk,9005)
	call atxto
	error=error+1
	goto 300
  525 CONTINUE
      CALL LODREL(NUMELE,ERROR)
      RFLAG = 1
      GO TO 350
C
C  PROCESS RULES.
C
  600 CONTINUE
      IF(RFLAG.EQ.1) GO TO 625
	if(nout.eq.6)goto 3240
      WRITE (NOUT,9006)
 9006 FORMAT(74H -ERROR- Relations And Attributes Must Be Defined In Ord
     Xer To Define Rules)
      ERROR = ERROR + 1
      GO TO 300
3240	continue
	write(c128wk,9006)
	call atxto
	error = error + 1
	goto 300
C
C
  625 CONTINUE
      CALL LODRUL
      GO TO 350
C
C  PROCESS PASSWORDS.
C
  700 CONTINUE
      IF(RFLAG.EQ.1) GO TO 725
	if(nout.eq.6)goto 3241
      WRITE (NOUT,9007)
 9007 FORMAT(63H -ERROR- Relations Must Be Defined In Order To Assign Pa
     Xsswords)
      ERROR = ERROR + 1
      GO TO 300
3241	continue
	write(c128wk,9007)
	call atxto
	error=error+1
	goto 300
C
  725 CONTINUE
      CALL LODPAS(ERROR)
      GO TO 350
C
C  PROCESS END.
C
  800 CONTINUE
C
C  SET THE RETURN CODE AND MAKE SURE A SCHEMA HAS BEEN DEFINED
C
      NEXTOP = K8RIM
      IF(NEWCSN.EQ.0) GO TO 999
      IF(.NOT.BATCH) ERROR = 0
      IF(ERROR.NE.0) GO TO 950
	if(nout.eq.6)goto 3242
      WRITE (NOUT,9008) DBNAME
 9008 FORMAT(28H RIM Schema Compilation For ,A8,12H Is Complete)
	goto 3243
3242	continue
	write(c128wk,9008) dbname
	call atxto
3243	continue
C
C  BUFFER THE SCHEMA AND DATABASE OUT
C
      DFLAG = .TRUE.
      IFMOD = .TRUE.
      CALL RMOPEN(DBNAME)
      IF(RMSTAT.NE.0) CALL WARN(RMSTAT,DBNAME,0)
      GO TO 999
C
C  ERROR PROCESSING.
C
  950 CONTINUE
	if(nout.eq.6)goto 3244
      WRITE (NOUT,9009)
	goto 3245
3244	continue
	write(c128wk,9009)
	call atxto
3245	continue
 9009 FORMAT(43H -WARNING- Errors In RIM Schema Compilation)
      DFLAG = .TRUE.
      IFMOD = .TRUE.
      CALL RMOPEN(DBNAME)
      IF(RMSTAT.NE.0) CALL WARN(RMSTAT,DBNAME,0)
C
C  RETURN.
C
  999 CONTINUE
C
C RESET THE PROMPT CHARACTER TO R
C
      CALL LXSET(K4PROM,K4RP)
      CALL BLKCLR(10)
      RETURN
      END
      SUBROUTINE DBLOAD
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE IS THE DRIVER FOR LOADING DATA VALUES IN THE
C  RIM DATA BASE.
C
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:RULCOM.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:RIMCOM.BLK
C
      LOGICAL EQKEYW
      INCLUDE rin:DCLAR1.BLK
C
C  CALL RMDBLK TO MAKE SURE THE DATABASE CAN BE MODIFIED
C
      CALL RMDBLK(DBNAME)
      IF(RMSTAT.EQ.0) GO TO 50
      CALL WARN(RMSTAT,DBNAME,0)
      GO TO 1000
   50 CONTINUE
C
C  SET THE PROMPT CHARACTER TO L (LOAD)
C
      CALL LXSET(K4PROM,K4LP)
C
C  LOOK FOR THE RELATION NAME.
C
	if(nout.eq.6)goto 3140
      WRITE(NOUT,9000)
 9000 FORMAT(25H BEGIN -RIM- DATA LOADING )
      GO TO 200
3140	continue
	write(c128wk,9000)
	call atxto
	goto 200
  100 CONTINUE
      CALL LODREC
  200 CONTINUE
      IF(EQKEYW(1,KWLOAD,4)) GO TO 300
      IF(EQKEYW(1,KWEND,3)) GO TO 1000
	if(nout.eq.6)goto 3141
      WRITE(NOUT,9001)
 9001 FORMAT(46H -ERROR- Unrecognized LOAD Command - Retype It)
      GO TO 100
3141	continue
	write(c128wk,9001)
	call atxto
	goto 100
C
C  RELATION NAME SPECIFIED.
C
  300 CONTINUE
      IF(LXITEM(IDUMMY).EQ.2) GO TO 400
	if(nout.eq.6)goto 3142
      WRITE(NOUT,9002)
 9002 FORMAT(46H -ERROR- Missing Relation Name On LOAD Command)
      GO TO 100
3142	continue
	write(c128wk,9002)
	call atxto
	goto 100
  400 CONTINUE
      RNAME = BLANK
      CALL LXSREC(2,1,8,RNAME,1)
C
C  CHECK FOR RULES FOR THIS RELATION
C
      CALL CHKRUL(RNAME)
      IF(RMSTAT.LT.110) GO TO 450
	if(nout.eq.6)goto 35
      IF(RMSTAT.EQ.110) WRITE(NOUT,410)
      IF(RMSTAT.EQ.111) WRITE(NOUT,420)
  410 FORMAT(35H -ERROR- Unrecognized Rule Relation )
  420 FORMAT(50H -ERROR- More Than 10 Rules Apply To This Relation)
      GO TO 1000
35	continue
      IF(RMSTAT.EQ.110) WRITE(c128wk,410)
      IF(RMSTAT.EQ.111) WRITE(c128wk,420)
	if(rmstat.eq.110.or.rmstat.eq.111)call atxto
	goto 1000
  450 CONTINUE
      I = LOCREL(RNAME)
      IF(I.EQ.0) GO TO 600
  500 CONTINUE
C
C  UNRECOGNIZED RELATION NAME.
C
      CALL WARN(1,RNAME,0)
      GO TO 100
  600 CONTINUE
      CALL RELGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 500
C
C  CHECK FOR AUTHORITY.
C
      L = LOCPRM(RNAME,2)
      IF(L.EQ.0) GO TO 700
      CALL WARN(9,RNAME,0)
      GO TO 1000
C
C  CALL LOADIT TO READ THE ACTUAL DATA CARDS.
C
  700 CONTINUE
      CALL BLKDEF(10,1,MAXCOL)
      KQ1 = BLKLOC(10)
      CALL LOADIT(BUFFER(KQ1))
C
C  UPDATE THE DATE OF LAST MODIFICATION.
C
      CALL RMDATE(RDATE)
      CALL RELPUT
      CALL BLKCLR(10)
      GO TO 200
C
C  END OF LOADING.
C
 1000 CONTINUE
	if(nout.eq.6)goto 3145
      WRITE(NOUT,9003)
	goto 3146
3145	continue
	write(c128wk,9003)
	call atxto
3146	continue
 9003 FORMAT(23H End -RIM- Data Loading )
C
C  SET THE PROMPT CHARACTER BACK TO R (RIM)
C
      CALL LXSET(K4PROM,K4RP)
      RETURN
      END
      SUBROUTINE DELDAT(INDEX,ID)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   DELINK A TUPLE FROM THE DATA FILE
C
C  PARAMETERS:
C         INDEX---BLOCK REFERENCE NUMBER
C         ID------PACKED ID WORD WITH OFFSET,IOBN
      INCLUDE rin:F2COM.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:FLAGS.BLK
C
      INTEGER OFFSET
C
C  UNPAC THE ID WORD.
C
      CALL ITOH(OFFSET,IOBN,ID)
C
C  SEE IF THE NEEDED BLOCK IS CURRENTLY IN CORE.
C
      NUMBLK = 0
      DO 200 I=1,3
      IF(IOBN.EQ.CURBLK(I)) NUMBLK = I
  200 CONTINUE
      IF(NUMBLK.NE.0) GO TO 400
      NUMBLK = INDEX
C
C  WE MUST DO PAGING.
C
C  SEE IF THE CURRENT BLOCK NEEDS WRITING.
C
      IF(MODFLG(NUMBLK).EQ.0) GO TO 300
C
C  WRITE OUT THE CURRENT BLOCK.
C
      KQ1 = BLKLOC(NUMBLK)
      CALL RIOOUT(FILE2,CURBLK(NUMBLK),BUFFER(KQ1),LENBF2,IOS)
      IF(IOS.NE.0) RMSTAT = 2200 + IOS
  300 CONTINUE
C
C  READ IN THE NEEDED BLOCK.
C
      CALL BLKCHG(NUMBLK,LENBF2,1)
      KQ1 = BLKLOC(NUMBLK)
      CALL RIOIN(FILE2,IOBN,BUFFER(KQ1),LENBF2,IOS)
      CURBLK(NUMBLK) = IOBN
      IF(IOS.NE.0) RMSTAT = 2200 + IOS
  400 CONTINUE
      MODFLG(NUMBLK) = 1
      IFMOD = .TRUE.
C
C  CHANGE THE ID POINTER.
C
      KQ0 = BLKLOC(NUMBLK) - 1
      BUFFER(KQ0 + OFFSET) = -BUFFER(KQ0 + OFFSET)
      MODFLG(NUMBLK) = 1
      IFMOD = .TRUE.
      IF(BUFFER(KQ0 + OFFSET).NE.0) RETURN
C
C  SPECIAL STUFF FOR DELETING THE LAST TUPLE.
C
      CALL HTOI(1,0,BUFFER(KQ0 + OFFSET))
      BUFFER(KQ0 + OFFSET) = -BUFFER(KQ0 + OFFSET)
      RETURN
      END
      SUBROUTINE DELDUP(MAT)
      INCLUDE rin:TEXT.BLK
C
C     DELETE DUPLICATES ROUTINE
C     MAT IS INPUT STORAGE OF LENGTH AT LEAST (MOST) THE FIXED
C     PORTION OF THE RELATION.  WHEN ATTRIBUTES ARE SPECIFIED, THIS
C     IS USED TO FLAG WHICH ARE NOT TO BE COMPARED (SET MAT TO 0) AND
C     WHICH ARE FIXED TO BE COMPARED (SET MAT TO 1) AND WHICH ARE
C     VARIABLE TO BE COMPARED (SET MAT TO -1).
C
C     METHOD - 1. SET MAT OR ALL
C              2. LOOP ON TUPLES
C                 3. LOOP ON SUBSEQUENT TUPLES
C                    IF NOT DUPLICATE GO TO 3
C                    IF DUPLICATE DELETEI FIRST TUPLE (INCLUDING KEYS)
C                    AND GO TO 2.
C              4. WHEN DONE RESET RSTART AND NTUPLE, PRINT MESSAGE,
C                  AND RETURN
C
      INCLUDE rin:F2COM.BLK
      INCLUDE rin:START.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:BUFFER.BLK
      DIMENSION MAT(*)
      LOGICAL IFALL
      INTEGER COLUMN
      INCLUDE rin:DCLAR1.BLK
C
C     SEE IF THERE IS MORE THAN ONE TUPLE
C
C
C     LOCATE WORD FROM
C
      ITEMS = LXITEM(IDUMMY)
      J = LFIND(1,ITEMS,KWFROM,4)
      IFALL = .TRUE.
      IF(J.EQ.3) GO TO 200
      IFALL = .FALSE.
C
C     SET UP FOR SPECIFIED ATTRIBUTES
C
      DO 10 I=1,NCOL
      MAT(I) = 0
   10 CONTINUE
      II = ITEMS - 2
      DO 100 I=3,II
      ANAME = BLANK
      CALL LXSREC(I,1,8,ANAME,1)
      IF(LOCATT(ANAME,NAME).EQ.0) GO TO 20
      CALL WARN(3,ANAME,NAME)
      GO TO 9999
   20 CONTINUE
      CALL ATTGET(ISTAT)
C
C     GOT ATTRIBUTE - SET MAT
C
      MAT(ATTCOL) = -1
      IF(ATTWDS.EQ.0) GO TO 100
C
C     FIXED SET ALL COLUMNS
C
      NUM = ATTCOL - 1
      DO 60 J=1,ATTWDS
      NUM = NUM + 1
      MAT(NUM) = 1
   60 CONTINUE
  100 CONTINUE
  200 CONTINUE
C
C     DO DOUBLE LOOP ON TUPLES
C     ND COUNTS DELETED TUPLES
C     IID SAVES NEW RSTART
C
      ND = 0
      IF(NTUPLE.LE.1) GO TO 700
C
C  WRITE OUT PAGE 2 IF IT HAS BEEN MODIFIED
C
      IF(MODFLG(2).EQ.0) GO TO 250
      KQ2 = BLKLOC(2)
      CALL RIOOUT(FILE2,CURBLK(2),BUFFER(KQ2),LENBF2,IOS)
      IF(IOS.NE.0) RMSTAT = 2200 + IOS
      MODFLG(2) = 0
      CURBLK(2) = 0
  250 CONTINUE
      IID = NID
  300 CONTINUE
C
C     GET THE FIRST TUPLE
C
      IF(NID.EQ.0) GO TO 600
      CALL ITOH(N1,N2,NID)
      IF(N2.EQ.0) GO TO 600
C
C     FORCE INTO POSITION OTHER THAN 2
C
      ISAVE = CURBLK(2)
      CURBLK(2) = 0
      CID = NID
      CALL GETDAT(1,NID,IP1,LEN1)
      CURBLK(2) = ISAVE
      IF(NID.LT.0) GO TO 600
      IP1 = IP1 - 1
C
C     LOOP ON LATER TUPLES
C
      KNID = NID
      KCID = CID
  400 CONTINUE
C
C     GET THE FOLLOWING TUPLES
C
      IF(KNID.EQ.0) GO TO 300
      CALL ITOH(N1,N2,KNID)
      IF(N2.EQ.0) GO TO 300
      CALL GETDAT(2,KNID,IP2,LEN2)
      IF(KNID.LT.0) GO TO 300
      IP2 = IP2 - 1
C
C     COMPARE THE TWO TUPLES
C
      IF(IFALL) GO TO 500
      DO 490 I=1,NCOL
      IF(MAT(I).EQ.0) GO TO 490
      IF(MAT(I).LT.0) GO TO 450
C
C     FIXED COMPARE
C
      IF(BUFFER(IP1+I).NE.BUFFER(IP2+I)) GO TO 400
      GO TO 490
  450 CONTINUE
C
C     VARIABLE
C
      JP1 = BUFFER(IP1+I) + IP1
      JP2 = BUFFER(IP2+I) + IP2
      IF(BUFFER(JP1) .NE. BUFFER(JP2)) GO TO 400
      NW = BUFFER(JP1) + 1
      DO 460 J=1,NW
      JP1 = JP1 + 1
      JP2 = JP2 + 1
      IF(BUFFER(JP1).NE.BUFFER(JP2)) GO TO 400
  460 CONTINUE
  490 CONTINUE
      GO TO 550
  500 CONTINUE
C
C     CHECK ALL
C
      IF(LEN1.NE.LEN2) GO TO 400
      DO 520 I=1,LEN1
      IF(BUFFER(IP1+I).NE.BUFFER(IP2+I)) GO TO 400
  520 CONTINUE
  550 CONTINUE
C
C     DUPLICATE FOUND - DELINK IT
C
      CALL DELDAT (1,KCID)
C
C     PROCESS ANY KEY ATTRIBUTES
C
      J = LOCATT(BLANK,NAME)
  560 CONTINUE
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 580
      IF(ATTKEY.EQ.0) GO TO 560
      COLUMN = ATTCOL
      IF(ATTWDS.NE.0) GO TO 570
      COLUMN = BUFFER(IP1+ATTCOL) + 2
  570 CONTINUE
      START = ATTKEY
      CALL BTREP(BUFFER(IP1+COLUMN),0,KCID,ATTYPE)
      GO TO 560
  580 CONTINUE
      IF (KCID .EQ. IID) IID = NID
      ND = ND + 1
      GO TO 300
C
C     CHANGE THE STARTING ID IF NEEDED
C
  600 CONTINUE
      CALL RELGET(ISTAT)
      RSTART = IID
      NTUPLE = NTUPLE - ND
      CALL RELPUT
  700 CONTINUE
	if(nout.eq.6)goto 3140
      WRITE (NOUT,9001) ND,NAME
	goto 9999
3140	continue
	write(c128wk,9001)nd,name
	call atxto
 9001 FORMAT(2X,I6,26H ROWS Deleted In Relation ,A8)
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE DELETE(MAT)
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE PROCESSES A DELETE IN RIM.
C
C  PARAMETERS
C         MAT-----ARRAY TO HOLD ONE TUPLE
      INCLUDE rin:START.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:MISC.BLK
      INTEGER COLUMN
C
C  DIMENSION STATEMENTS.
C
      DIMENSION MAT(*)
C
      ND = 0
C
C  PROCESS THE WHERE CLAUSE.
C
      ITEMS = LXITEM(ISTAT)
      LW = LFIND(1,ITEMS,KWWHER,5)
      IF(LW.NE.0) GO TO 100
	if(nout.eq.6)goto 3140
      WRITE(NOUT,9000)
 9000 FORMAT(55H -ERROR- A WHERE Clause is REQUIRED on a DELETE Command)
      GO TO 9999
3140	continue
	write(c128wk,9000)
	call atxto
	goto 9999
  100 CONTINUE
      CALL WHERE(LW)
      IF(RMSTAT.NE.0) GO TO 9999
C
C  SEQUENCE THROUGH THE DATA DELETING TUPLES.
C
      IF(NTUPLE.LE.0) GO TO 9999
      IID = CID
  200 CONTINUE
      CALL RMLOOK(MAT,1,0,LENGTH)
      IF(RMSTAT.NE.0) GO TO 700
C
C  DELINK THIS TUPLE.
C
      CALL DELDAT(1,CID)
C
C  PROCESS ANY KEY ATTRIBUTES.
C
      J = LOCATT(BLANK,NAME)
  400 CONTINUE
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 600
      IF(ATTKEY.EQ.0) GO TO 400
      COLUMN = ATTCOL
      IF(ATTWDS.NE.0) GO TO 500
      COLUMN = MAT(ATTCOL)
      KURLEN = MAT(COLUMN)
      COLUMN = COLUMN + 2
  500 CONTINUE
      START = ATTKEY
      CALL BTREP(MAT(COLUMN),0,CID,ATTYPE)
      GO TO 400
  600 CONTINUE
      IF(CID.EQ.IID) IID = NID
      ND = ND + 1
      GO TO 200
C
C  CHANGE THE STARTING ID IF NEEDED.
C
  700 CONTINUE
      CALL RELGET(ISTAT)
      RSTART = IID
      NTUPLE = NTUPLE - ND
      CALL RELPUT
      RMSTAT = 0
 9999 CONTINUE
	if(nout.eq.6)goto 3142
      WRITE(NOUT,9001) ND,NAME
 9001 FORMAT(2X,I6,26H Rows Deleted In Relation ,A8)
C
C  DONE.
C
      RETURN
3142	continue
	write(c128wk,9001)nd,name
	call atxto
	return
      END
      SUBROUTINE DROPF(IFILE)
      INCLUDE rin:TEXT.BLK
	logical here
	integer fileno
      REAL*8 IFILE
      CHARACTER*8 NFILE
      WRITE(NFILE,100) IFILE
  100 FORMAT(A8)
	inquire(file=nfile,number=fileno,exist=here,iostat=ios)
	if(.not.here)return
C no need to delete a file that is missing
	if(ios.ne.0)fileno=30
	if(fileno.lt.0)fileno=30
      OPEN(UNIT=fileno,FILE=NFILE,STATUS='OLD',IOSTAT=IOS)
      IF(IOS.NE.0) RETURN
      CLOSE(UNIT=fileno,STATUS='DELETE')
      RETURN
      END
      LOGICAL FUNCTION EQ(WORD1,WORD2)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   COMPARE WORD1 AND WORD2 FOR EQ
C
C  PARAMETERS:
C         WORD1---A WORD OF TEXT
C         WORD2---ANOTHER WORD OF TEXT
C         EQ------.TRUE. IF WORD1.EQ.WORD2
C                 .FALSE. IF NOT EQ
      INCLUDE rin:DCLAR6.BLK
C
      EQ = WORD1.EQ.WORD2
      RETURN
      END
      LOGICAL FUNCTION EQKEYW(I,KEYW,LEN)
      INCLUDE rin:TEXT.BLK
C
C     THIS FUNCTION COMPARES KEYW WITH ITEM I WHICH HAS BEEN
C     INPUT THRU LXLREC.
C
C     INPUT - I........ITEM NUMBER
C             KEYW.....STRING WITH KEYWORD IN IT
C             LEN......LENGTH OF FULL KEYWORD
C     OUTPUT- EQKEYW....TRUE. IFF
C                             A. ITEM I IS TEXT
C                         AND B. NUMBER OF CHARACTERS IN ITEM I
C                                IS GE MIN(3,LEN) AND LE LEN.
C                         AND C. ITEM IT MATCHES KEYWORD TO MINIMUM
C                                OF 8 AND THE NUMBER OF CHARACTERS
C                                IN ITEM I.
C
      INCLUDE rin:RMATTS.BLK
      INTEGER KEYW(*)
      EQKEYW = .FALSE.
      IF(LXID(I).NE.KZTEXT) GO TO 1000
      N = LXLENC(I)
      MIN = 3
      IF(LEN.LT.MIN) MIN = LEN
      IF(N.LT.MIN) GO TO 1000
      IF(N.GT.LEN) GO TO 1000
      IF(N.GT.8) N = 8
C
C     COMPARE CHARACTERS
C
      DO 10 J=1,N
      CALL GETT(KEYW,J,ICHAR)
      IF(LXCREC(I,J).NE.ICHAR) GO TO 1000
   10 CONTINUE
      EQKEYW = .TRUE.
 1000 CONTINUE
      RETURN
      END
      SUBROUTINE F1CLO
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   CLOSE THE RIM DIRECTORY FILE - FILE 1
C
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:F1COM.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:ATTBLE.BLK
      INCLUDE rin:RELTBL.BLK
      INCLUDE rin:FLAGS.BLK
C
C  WRITE OUT THE RELATION BUFFER IF IT WAS MODIFIED.
C
      IF(RELMOD.EQ.0) GO TO 100
      CALL RIOOUT(FILE1,CRREC,RELBUF,LENBF1,IOS)
      IF(IOS.NE.0) RMSTAT = 2100 + IOS
  100 CONTINUE
      CRREC = 0
      RELMOD = 0
C
C  WRITE OUT THE ATTRIBUTE BUFFER IF IT WAS MODIFIED.
C
      IF(ATTMOD.EQ.0) GO TO 200
      CALL RIOOUT(FILE1,CAREC,ATTBUF,LENBF1,IOS)
      IF(IOS.NE.0) RMSTAT = 2100 + IOS
  200 CONTINUE
      CAREC = 0
      ATTMOD = 0
C
C  ZERO OUT RELBUF AND MOVE CONTROL VARIABLES THERE.
C
      CALL ZEROIT(RELBUF,LENBF1)
      CALL BLKMOV(RELBUF(1),DBNAME,2)
      CALL BLKMOV(RELBUF(3),K8RMDT,2)
      CALL BLKMOV(RELBUF(5),OWNER,2)
      CALL BLKMOV(RELBUF(7),DBDATE,2)
      CALL BLKMOV(RELBUF(9),DBTIME,2)
      RELBUF(11) = LF1REC
      RELBUF(12) = NRROW
      RELBUF(13) = NAROW
C
C  WRITE OUT THE CONTROL BLOCK.
C
      CALL RIOOUT(FILE1,1,RELBUF,LENBF1,IOS)
      IF(IOS.NE.0) RMSTAT = 2100 + IOS
      RETURN
      END
      SUBROUTINE F1OPN(FILE)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   OPEN THE RIM DIRECTORY FILE - FILE 1
C
C  PARAMETERS:
C         FILE----NAME OF THE FILE TO USE FOR FILE1
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:F1COM.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:ATTBLE.BLK
      INCLUDE rin:RELTBL.BLK
      INCLUDE rin:FLAGS.BLK
      LOGICAL EQ
      INCLUDE rin:DCLAR4.BLK
C
C  OPEN THE DIRECTORY FILE.
C
      CALL RIOOPN(FILE,FILE1,LENBF1,IOS)
      IF(IOS.NE.0) RMSTAT = 2100 + IOS
C
C  READ IN THE FIRST RECORD FROM THIS FILE.
C
      CALL RIOIN(FILE1,1,RELBUF,LENBF1,IOS)
      IF(IOS.NE.0) GO TO 500
      CRREC = 0
C
C  MOVE THE CONTROL DATA TO WHERE IT IS NEEDED.
C
      IF(EQ(RELBUF(3),K8RMDT)) GO TO 100
      RMSTAT = 10
      GO TO 1000
  100 CONTINUE
      IF(EQ(RELBUF(1),DBNAME)) GO TO 200
      RMSTAT = 11
      GO TO 1000
  200 CONTINUE
      CALL BLKMOV(OWNER,RELBUF(5),2)
      CALL BLKMOV(DBDATE,RELBUF(7),2)
      CALL BLKMOV(DBTIME,RELBUF(9),2)
      LF1REC = RELBUF(11)
      NRROW = RELBUF(12)
      NAROW = RELBUF(13)
C
C  SUCCESSFUL OPEN.
C
      DFLAG = .TRUE.
      RMSTAT = 0
      GO TO 9999
C
C  EMPTY FILE 1 - WRITE THE FIRST RECORD ON IT.
C
  500 CONTINUE
      CALL ZEROIT(RELBUF,LENBF1)
      CALL RIOOUT(FILE1,1,RELBUF,LENBF1,IOS)
      LF1REC = 1
      CAREC = 0
      CRREC = 0
      NRROW = 74
      NAROW = 227
      RMSTAT = 15
      GO TO 1000
C
C  UNABLE TO OPEN FILE 1.
C
 1000 CONTINUE
      DFLAG = .FALSE.
 9999 RETURN
      END
      SUBROUTINE F2CLO
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:    CLOSE THE DATA RANDOM IO FILE - FILE 2
C
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:F2COM.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:FLAGS.BLK
C
      INTEGER REC1
C
C  SEQUENCE THROUGH THE BUFFERS LOOKING FOR WRITE FLAGS.
C
      REC1 = 0
      DO 400 NUMB=1,4
      IF(NUMB.EQ.4) GO TO 100
      IF(CURBLK(NUMB).EQ.1) GO TO 100
      IF(MODFLG(NUMB).EQ.0) GO TO 400
C
C  WRITE IT OUT.
C
      KQ1 = BLKLOC(NUMB)
      CALL RIOOUT(FILE2,CURBLK(NUMB),BUFFER(KQ1),LENBF2,IOS)
      IF(IOS.NE.0) RMSTAT = 2200 + IOS
      MODFLG(NUMB) = 0
      CURBLK(NUMB) = 0
      CALL BLKCLR(NUMB)
      GO TO 400
  100 CONTINUE
      IF(REC1.EQ.1) GO TO 400
      IF(NUMB.NE.4) GO TO 200
C
C  READ IN THE CONTROL BLOCK FIRST.
C
      CALL BLKCHG(1,LENBF2,1)
      KQ1 = BLKLOC(1)
      CALL RIOIN(FILE2,1,BUFFER(KQ1),LENBF2,IOS)
      IF(IOS.NE.0) RMSTAT = 2200 + IOS
      GO TO 300
C
C  WRITE OUT THE CONTROL BLOCK.
C
  200 CONTINUE
      KQ1 = BLKLOC(NUMB)
  300 CONTINUE
      KQ0 = KQ1 - 1
      CALL BLKMOV(BUFFER(KQ0 + 1),DBNAME,2)
      CALL BLKMOV(BUFFER(KQ0 + 3),K8RMDT,2)
      CALL BLKMOV(BUFFER(KQ0 + 5),OWNER,2)
      CALL BLKMOV(BUFFER(KQ0 + 7),DBDATE,2)
      CALL BLKMOV(BUFFER(KQ0 + 9),DBTIME,2)
      BUFFER(KQ0 + 11) = LENBF2
      BUFFER(KQ0 + 12) = LF2REC
      BUFFER(KQ0 + 13) = LF2WRD
      CALL RIOOUT(FILE2,1,BUFFER(KQ1),LENBF2,IOS)
      IF(IOS.NE.0) RMSTAT = 2200 + IOS
      REC1 = 1
      IF(NUMB.EQ.4) GO TO 400
      MODFLG(NUMB) = 0
      CURBLK(NUMB) = 0
  400 CONTINUE
      RETURN
      END
      SUBROUTINE F2OPN(FILE)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:    OPEN A DATA RANDOM IO PAGING FILE - FILE 2
C
C  PARAMETERS:
C     INPUT:   FILE----NAME OF THE FILE TO USE FOR FILE 2
C
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:F2COM.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:RIMCOM.BLK
      LOGICAL EQ
      INCLUDE rin:DCLAR4.BLK
C
C  OPEN UP THE PAGED DATA FILE.
C
      CALL RIOOPN(FILE,FILE2,LENBF2,IOS)
      IF(IOS.NE.0) RMSTAT = 2200 + IOS
C
C  SEE IF THE FILE EXISTS YET. IF SO, READ CONTROL DATA.
C
      CALL BLKDEF(1,LENBF2,1)
      KQ1 = BLKLOC(1)
      KQ0 = KQ1 - 1
      CALL RIOIN(FILE2,1,BUFFER(KQ1),LENBF2,IOS)
      IF(IOS.NE.0) GO TO 100
      IF(.NOT.EQ(DBNAME,BUFFER(KQ0 + 1))) GO TO 8000
      IF(.NOT.EQ(K8RMDT,BUFFER(KQ0 + 3))) GO TO 8000
      IF(.NOT.EQ(OWNER,BUFFER(KQ0 + 5))) GO TO 8000
      IF(.NOT.EQ(DBDATE,BUFFER(KQ0 + 7))) GO TO 8000
      IF(.NOT.EQ(DBTIME,BUFFER(KQ0 + 9))) GO TO 8000
      LENBF2 = BUFFER(KQ0 + 11)
      LF2REC = BUFFER(KQ0 + 12)
      LF2WRD = BUFFER(KQ0 + 13)
      GO TO 200
C
C  INITIALIZE THE CONTROL VARIABLES.
C
  100 CONTINUE
      LF2REC = 1
      LF2WRD = 20
C
C  WRITE OUT THE CONTROL BLOCK FOR THE FIRST TIME.
C
      CALL ZEROIT(BUFFER(KQ1),LENBF2)
      CALL BLKMOV(BUFFER(KQ0 + 1),DBNAME,2)
      CALL BLKMOV(BUFFER(KQ0 + 3),K8RMDT,2)
      CALL BLKMOV(BUFFER(KQ0 + 5),OWNER,2)
      CALL BLKMOV(BUFFER(KQ0 + 7),DBDATE,2)
      CALL BLKMOV(BUFFER(KQ0 + 9),DBTIME,2)
      BUFFER(KQ0 + 11) = LENBF2
      BUFFER(KQ0 + 12) = LF2REC
      BUFFER(KQ0 + 13) = LF2WRD
      CALL RIOOUT(FILE2,1,BUFFER(KQ1),LENBF2,IOS)
      IF(IOS.NE.0) RMSTAT = 2200 + IOS
  200 CONTINUE
C
C  INITIALIZE THE CONTROL BLOCKS.
C
      CURBLK(1) = 1
      CURBLK(2) = 0
      CURBLK(3) = 0
      CALL ZEROIT(MODFLG,3)
      RETURN
C
C  CONTROL VALUES DO NOT MATCH VALUES FROM FILE 1.
C
 8000 CONTINUE
      RMSTAT = 12
      RETURN
      END
      SUBROUTINE F3CLO
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:    CLOSE THE B-TREE RANDOM IO FILE - FILE 3
C
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:F3COM.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:BTBUF.BLK
      INCLUDE rin:FLAGS.BLK
C
C  SEQUENCE THROUGH THE INCORE BLOCKS LOOKING FOR WRITE FLAGS.
C
      DO 100 NUMB=1,NUMIC
      IF(ICORE(2,NUMB).EQ.0) GO TO 100
C
C  WRITE IT OUT.
C
      ISTRT = (NUMB-1) * LENBF3 + 1
      CALL RIOOUT(FILE3,ICORE(3,NUMB),CORE(ISTRT),LENBF3,IOS)
      IF(IOS.NE.0) RMSTAT = 2300 + IOS
  100 CONTINUE
C
C  WRITE OUT THE CONTROL BLOCK.
C
      CALL ZEROIT(CORE,LENBF3)
      CALL BLKMOV(CORE(1),DBNAME,2)
      CALL BLKMOV(CORE(3),K8RMDT,2)
      CALL BLKMOV(CORE(5),OWNER,2)
      CALL BLKMOV(CORE(7),DBDATE,2)
      CALL BLKMOV(CORE(9),DBTIME,2)
      CORE(11) = LENBF3
      CORE(12) = LF3REC
      CORE(13) = MOTREC
      CORE(14) = MOTADD
      CALL RIOOUT(FILE3,1,CORE,LENBF3,IOS)
      IF(IOS.NE.0) RMSTAT = 2300 + IOS
      RETURN
      END
      SUBROUTINE F3OPN(FILE)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:    OPEN A B-TREE RANDOM IO PAGING FILE - FILE 3
C
C  PARAMETERS:
C     INPUT:   FILE----NAME OF THE FILE TO USE FOR FILE 3
C
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:F3COM.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:BTBUF.BLK
      INCLUDE rin:START.BLK
      INCLUDE rin:RIMCOM.BLK
      LOGICAL EQ
      INCLUDE rin:DCLAR4.BLK
C
C  OPEN UP THE BTREE AND MOT FILE.
C
      CALL RIOOPN(FILE,FILE3,LENBF3,IOS)
      IF(IOS.NE.0) RMSTAT = 2300 + IOS
C
C  SEE IF THE FILE EXISTS YET. IF SO, READ CONTROL DATA.
C
      CALL RIOIN(FILE3,1,CORE,LENBF3,IOS)
      IF(IOS.NE.0) GO TO 100
      IF(.NOT.EQ(DBNAME,CORE(1))) GO TO 8000
      IF(.NOT.EQ(K8RMDT,CORE(3))) GO TO 8000
      IF(.NOT.EQ(OWNER,CORE(5))) GO TO 8000
      IF(.NOT.EQ(DBDATE,CORE(7))) GO TO 8000
      IF(.NOT.EQ(DBTIME,CORE(9))) GO TO 8000
      LENBF3 = CORE(11)
      LF3REC = CORE(12)
      MOTREC = CORE(13)
      MOTADD = CORE(14)
      GO TO 200
C
C  INITIALIZE THE CONTROL VARIABLES.
C
  100 CONTINUE
      START = 0
      LF3REC = 2
      MOTREC = 0
      MOTADD = LENBF3 + 1
C
C  WRITE OUT THE CONTROL BLOCK FOR THE FIRST TIME.
C
      CALL ZEROIT(CORE,LENBF3)
      CALL BLKMOV(CORE(1),DBNAME,2)
      CALL BLKMOV(CORE(3),K8RMDT,2)
      CALL BLKMOV(CORE(5),OWNER,2)
      CALL BLKMOV(CORE(7),DBDATE,2)
      CALL BLKMOV(CORE(9),DBTIME,2)
      CORE(11) = LENBF3
      CORE(12) = LF3REC
      CORE(13) = MOTREC
      CORE(14) = MOTADD
      CALL RIOOUT(FILE3,1,CORE,LENBF3,IOS)
      IF(IOS.NE.0) RMSTAT = 2300 + IOS
  200 CONTINUE
C
C  INITIALIZE THE TREE COMMON BLOCK.
C
      NUMIC = 0
      LAST = 0
      CALL ZEROIT(ICORE(1,1),60)
      RETURN
C
C  CONTROL VALUES DO NOT MATCH VALUES FROM FILE 1.
C
 8000 CONTINUE
      RMSTAT = 12
      RETURN
      END
      SUBROUTINE FILCH(STRING,CHAR1,NUM,CHAR)
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE STUFFS NUM CHAR'S INTO STRING
C     STARTING AT CHAR1.
C
      INTEGER CHAR,STRING(*)
      INTEGER CHAR1
      DO 10 I=1,NUM
      CALL PUTT(STRING,CHAR1+I-1,CHAR)
   10 CONTINUE
      RETURN
      END
      SUBROUTINE GETDAT(INDEX,ID,LOCTUP,LENGTH)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  GET A TUPLE FROM THE DATA FILE
C
C  PARAMETERS:
C         INDEX---BLOCK REFERENCE NUMBER
C         ID------PACKED ID WORD WITH START,PRU
C         LOCTUP--OFFSET IN BUFFER FOR THE TUPLE
C         LENGTH---LENGTH OF THE TUPLE
      INCLUDE rin:F2COM.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:RIMPTR.BLK
C
      INTEGER OFFSET
C
C  UNPAC THE ID WORD.
C
      CALL ITOH(OFFSET,IOBN,ID)
  100 CONTINUE
C
C  MAKE SURE WE HAVE A VALID ID.
C
      IF(IOBN.GT.LF2REC) GO TO 600
      IF(OFFSET.GT.LENBF2) GO TO 600
C
C  SEE IF THE NEEDED BLOCK IS CURRENTLY IN CORE.
C
      NUMBLK = 0
      DO 200 I=1,3
      IF(IOBN.EQ.CURBLK(I)) NUMBLK = I
  200 CONTINUE
      IF(NUMBLK.NE.0) GO TO 400
      NUMBLK = INDEX
C
C  WE MUST DO PAGING.
C
C  SEE IF THE CURRENT BLOCK NEEDS WRITING.
C
      IF(MODFLG(NUMBLK).EQ.0) GO TO 300
C
C  WRITE OUT THE CURRENT BLOCK.
C
      KQ1 = BLKLOC(NUMBLK)
      CALL RIOOUT(FILE2,CURBLK(NUMBLK),BUFFER(KQ1),LENBF2,IOS)
      IF(IOS.NE.0) RMSTAT = 2200 + IOS
  300 CONTINUE
C
C  READ IN THE NEEDED BLOCK.
C
      CALL BLKCHG(NUMBLK,LENBF2,1)
      KQ1 = BLKLOC(NUMBLK)
      CALL RIOIN(FILE2,IOBN,BUFFER(KQ1),LENBF2,IOS)
      IF(IOS.NE.0) RMSTAT = 2200 + IOS
      CURBLK(NUMBLK) = IOBN
      MODFLG(NUMBLK) = 0
  400 CONTINUE
C
C  MOVE THE DESIRED DATA.
C
      KQ0 = BLKLOC(NUMBLK) - 1
      ID = BUFFER(KQ0 + OFFSET)
      IF(ID.GE.0) GO TO 500
C
C  THIS TUPLE IS NOT ACTIVE. GO TO THE NEXT ONE.
C
      ID = -ID
      CID = ID
      ISOFF = OFFSET
      CALL ITOH(OFFSET,IOBN,ID)
      IF(IOBN.NE.0) GO TO 100
C
C  WE HAVE AN INACTIVE LAST TUPLE.
C
      ID = -ID
      OFFSET = ISOFF
  500 CONTINUE
      LOCTUP = KQ0 + OFFSET + 2
      LENGTH = BUFFER(LOCTUP - 1)
      RETURN
C
C  BAD ID VALUE.
C
  600 CONTINUE
      ID = 0
      RETURN
      END
      SUBROUTINE GETT(STR1,IC1,WORD)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   GET THE IC1 CHARACTER FROM STR1 AND PUT IN WORD
C
C  PARAMETERS:
C     STR1----STRING OF CHARACTERS
C     IC1-----THE CHARACTER WANTED
C     WORD----WORD TO GET THE CHARACTER (LEFT JUSTIFIED, BLANK FILL)
C
      Character*1 STR1(1)
      INTEGER WORD
      INTEGER CHWORD
      Character*1 CHAR(4)
      EQUIVALENCE (CHWORD,CHAR(1))
      INTEGER BLANK
      DATA BLANK /4H    /
      CHWORD = BLANK
      CHAR(1) = STR1(IC1)
      WORD = CHWORD
      RETURN
      END
      SUBROUTINE GTSORT(MAT,INDEX,IFLAG,LENGTH)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  READ IN TUPLES FROM THE SORTED DATA FILE
C
C  PARAMETERS:
C            MAT-----ARRAY TO HOLD ONE TUPLE (IF IFLAG = 1)
C                    POINTER TO TUPLE IN BUFFER (IF IFLAG = 0)
C           INDEX---PAGE BUFFER TO USE
C            IFLAG---0 IF THE TUPLE IS RETURNED IN MAT
C                    1 IF THE BUFFER POINTER IS RETURNED IN MAT
C                   -1 OPEN THE SORT FILE AND INITIALIZE
C            LENGTH--LENGTH OF TUPLE IN WORDS
C            INDPTR--MULTIPLE RMHUNT INDEX - USED TO ASSIGN FILES
C
      INCLUDE rin:SRTCOM.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:F2COM.BLK
      INCLUDE rin:MISC.BLK
C
      DIMENSION MAT(*)
      INTEGER INFIL
      INFIL = 20
C
C  IF IFLAG IS NOT -1 SKIP THE SORT FILE/BUFFER INITIALIZATION
C
      IF(IFLAG.NE.-1) GO TO 500
C
C  FIRST CALL -----
C
C  REWIND THE SORT FILE NEEDED
C
      REWIND INFIL
C
C  ESTABLISH THE BUFFER POINTER
C
C  SEE IF THE CURRENT BLOCK NEEDS WRITING
C
      IF(INDEX.GT.3) GO TO 200
      IF(MODFLG(INDEX).EQ.0) GO TO 100
C
C  WRITE OUT THE CURRENT BLOCK
C
      KQ1 = BLKLOC(INDEX)
      CALL RIOOUT(FILE2,CURBLK(INDEX),BUFFER(KQ1),LENBF2,IOS)
      IF(IOS.NE.0) RMSTAT = 2200 + IOS
  100 MODFLG(INDEX) = 0
      CURBLK(INDEX) = 0
C
C  ESTABLISH THE NEW BUFFER BLOCK
C
  200 CONTINUE
      CALL BLKCHG(INDEX,MAXCOL,1)
C
C  SET THE TUPLES READ COUNTED TO 0
C
      NREAD = 0
C
C  ALL INITIALIZATION COMPLETE -- RETURN
C
      RETURN
C
C  READ IN A TUPLE FROM THE SORT FILE
C
  500 CONTINUE
      CALL BLKCHG(INDEX,MAXCOL,1)
      KQ1 = BLKLOC(INDEX) - 1
      NREAD = NREAD + 1
      IF(NREAD.GT.LIMTU) GO TO 900
      IF(NREAD.GT.NSORT) GO TO 900
      IF(FIXLT) GO TO 600
C
C  VARIABLE LENGTH TUPLES
C
c      READ(INFIL) LENGTH,(BUFFER(KQ1+K),K=1,LENGTH)
      READ(INFIL) LENGTH
      READ(INFIL) (BUFFER(KQ1+K),K=1,LENGTH)
      GO TO 700
C
C  FIXED LENGTH TUPLES
C
  600 CONTINUE
      READ(INFIL) (BUFFER(KQ1+K),K=1,LENGTH)
C
C  TUPLE READ - SET MAT AND RMSTAT
C
  700 CONTINUE
      RMSTAT = 0
      MAT(1) = KQ1 + 1
      IF(IFLAG.NE.0) GO TO 999
C
C  LOAD TUPLE INTO MAT
C
      DO 800 K=1,LENGTH
      MAT(K) = BUFFER(KQ1+K)
  800 CONTINUE
      GO TO 999
C
C  ALL DONE - SET RMSTAT AND CLOSE THE FILE
C
  900 CONTINUE
      RMSTAT = -1
      CALL BLKCLR(INDEX)
      CLOSE(UNIT=INFIL,STATUS='DELETE')
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE HASH(TEMP,N)
      INCLUDE rin:TEXT.BLK
      INTEGER TEMP(8)
      DO 20 I=1,N
      J = TEMP(7)
      TEMP(7) = TEMP(1)
      TEMP(1) = TEMP(4)
      TEMP(4) = TEMP(6)
      TEMP(6) = TEMP(8)
      TEMP(8) = TEMP(3)
      TEMP(3) = TEMP(5)
      TEMP(5) = TEMP(2)
      TEMP(2) = J
   20 CONTINUE
      RETURN
      END
      SUBROUTINE HASHIN(PASS,NUM,HASHP,ICHAR)
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE HASHES AN 8 CHARACTER PASSWORD INTO A 16
C     CHARACTER HASHED PASSWORD.
C     1. ADD 8 CHARACTERS OF GARBAGE EVERY OTHER ONE.
C     2. ADD OLD PASSWORD SWITCHING E'S AND BLANKS.
C     3. CYCLE 1ST AND LAST HALF NUM TIMES.
C     4. PACK INTO OUTPUT STRING
C
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:MISC.BLK
      INTEGER TEMP(16)
      INTEGER PASS(*)
C
C     WORD1 CONTAINS THE HASH SEQUENCE
C
      J = 0
      DO 10 I=2,16,2
      J = J+1
      CALL GETT (K8XXX,J,TEMP(I))
   10 CONTINUE
      J = 0
      DO 20 I=1,15,2
      J = J + 1
      CALL GETT(PASS,J,TEMP(I))
      K = TEMP(I)
      IF (TEMP(I) .EQ. IBLANK) K = K4E
      IF (TEMP(I) .EQ. K4E) K = IBLANK
      TEMP(I) = K
   20 CONTINUE
      CALL HASH(TEMP(1),NUM)
      CALL HASH(TEMP(9),NUM)
      CALL HASH(TEMP(4),NUM)
      DO 30 I=1,16
      CALL PUTT(HASHP,I + ICHAR - 1,TEMP(I))
   30 CONTINUE
      RETURN
      END
      SUBROUTINE GETL(LINE,NUMC)
      DIMENSION LINE(20)
      DIMENSION LINEX(20)
      INTEGER BLANK
      DATA BLANK /1H /
      READ (2,10)LINEX
   10 FORMAT(20A4)
      LINE(1) = BLANK
      LINE(20) = BLANK
      M1 = NSCAN(LINEX,80,-80,1H ,1,1)
      IF(M1.LE.0) M1 = 2
      ISHIFT = 2
      IF(M1.EQ.1) ISHIFT = 1
      IF(LINEX(1).EQ.'ENDD') ISHIFT = 1
      IF(LINEX(1).EQ.'ENDC') ISHIFT = 1
      IF(M1.NE.1) M1 = M1 + 1
      CALL STRMOV(LINEX,1,79,LINE,ISHIFT)
      NUMC = M1
      RETURN
      END
      SUBROUTINE HTOI(I,J,K)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   PACK I AND J INTO K
C
C  OFFSET I BY MULTIPLYING BY 100000.
C
      K = J + (100000 * I)
      RETURN
      END
      INTEGER FUNCTION IEXP(REAL)
      INCLUDE rin:TEXT.BLK
C
C     THIS FUNCTION RETURNS THE BASE TEN EXPONENT OF A REAL
C
      IE = -1000000
      IF(REAL.EQ.0.) GO TO 999
      X = ALOG10(ABS(REAL))
      IE = INT(X) + 1
      IF(X.LT.0.) IE = 1 + (INT(1000.+X)-1000)
  999 CONTINUE
      IEXP = IE
      RETURN
      END
      FUNCTION IFRT(WORD)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   HASH WORD IN TO AN INTEGER
C
C  PARAMETERS:
C         WORD----A WORD OF TEXT
C         IFRT----AN INTEGER WHICH CORRESPONDS TO THE WORD
C
      REAL*8 WORD
      REAL*8 CHWORD
      Character*1 CH(8)
      EQUIVALENCE (CH(1),CHWORD)
      INTEGER POWER
C
      CHWORD = WORD
      NUM = 0
      POWER = 1
C
C  TURN LETTERS INTO NUMBERS.
C
      DO 100 I=1,8
      K = CH(9-I)
      K = K + 10
      NUM = NUM + K * POWER
      POWER = POWER * 10
  100 CONTINUE
      IFRT = NUM
      RETURN
      END
      SUBROUTINE INTCON(INTOPT)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  THIS ROUTINE PROMPTS THE USER FOR THE EXECUTION
C            OPTION DESIRED (CREATE,UPDATE OR QUERY) AND CALLS
C            THE APPROPRIATE SUBROUTINES.
C
C  PARAMETERS: INTOPT - MENU MODE OPTION CODE
C                       4HMENU - DISPLAY MENU
C                       3HCRE -- CREATE MODE
C                       3HUPD -- UPDATE MODE
C                       3HQUE -- QUERY MODE
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:MISC.BLK
C
      INTEGER DBSTAT
      LOGICAL EQKEYW
      INCLUDE rin:DCLAR2.BLK
C
C     ******************************************************
C
C               I N I T I A L I Z A T I O N
C
C     ******************************************************
C
      NAMDB = DBNAME
      IF((INTOPT.EQ.K4CRE).OR.(INTOPT.EQ.K4UPD)) GO TO 150
      IF(INTOPT.EQ.K4LOD) GO TO 255
C
C     REQUEST THE EXECUTION OPTION - IDBT
C       IDBT = 1: CREATE A NEW DATABASE
C       IDBT = 2: UPDATE AN EXISTING DATABASE
C       IDBT = 3: QUERY
C       IDBT = 4: COMMAND MODE
C       IDBT = 5: EXIT
C
      IDBT = 0
  100 CONTINUE
	if(nout.eq.6)goto 1
         WRITE(NOUT,110)
  110 FORMAT(/,1X,35HSelect the execution option desired,/
     1   5X,24H1) CREATE a new database,/
     2   5X,30H2) UPDATE an existing database,/
     3   5X,29H3) QUERY an existing database,/
     4   5X,21H4) Enter COMMAND mode,/
     5   5X, 7H5) Exit,/)
	goto 2
1	continue
	write(c128wk,3140)
3140	format(' Sel opt: 1=CREATE,2=UPDATE,3=QUERY,4=CMDMODE,5=EXIT:')
	call atxto
2	continue
      CALL LXLREC(DUM1,0,LXERR)
      IXID1 = LXID(1)
      IF(IXID1.EQ.K4EOF) GO TO 998
      IXREC1 = 0
      IF(IXID1.EQ.KZINT) IXREC1 = LXIREC(1)
      IF(EQKEYW(1,KWQUIT,4)) GO TO 997
      IF(EQKEYW(1,KWEXIT,4)) GO TO 998
      IDBT = IXREC1
      IF(IDBT.EQ.4) GO TO 400
      IF(IDBT.EQ.5) GO TO 998
      IF(IDBT.GT.0.AND.IDBT.LT.5) GO TO 120
	if(nout.eq.6)goto 3
      WRITE(NOUT,8001)
      GO TO 100

3	continue
	write(c128wk,8001)
	call atxto
	goto 100
C
C     REQUEST THE DATABASE NAME - NAMDB
C
120	continue
	if(nout.eq.6)goto 4
       WRITE(NOUT,130)
	goto 5
4	continue
	write(c128wk,130)
	call atxto
5	continue
  130 FORMAT(1X,31HEnter the NAME of the database:)
      CALL LXLREC(DUM1,0,LXERR)
      IXID1 = LXID(1)
      IF(IXID1.EQ.K4EOF) GO TO 120
      IXREC1 = LXWREC(1,1)
      IF(EQKEYW(1,KWQUIT,4)) GO TO 997
      IXLEN = LXLENC(1)
      IF((IXID1.EQ.KZTEXT).AND.(IXLEN.LE.6)) GO TO 140
	if(nout.eq.6)goto 6
      WRITE(NOUT,8002)
      GO TO 120
6	continue
	write(c128wk,8002)
	call atxto
	goto 120
  140 NAMDB = BLANK
      CALL LXSREC(1,1,8,NAMDB,1)
      IF(IDBT.NE.1) GO TO 180
C
C  CREATE MODE - CALL INTDEF TO DEFINE THE SCHEMA
C
      INTOPT = K4CRE
C
C  CHECK THAT THE DATABASE MAY BE MODIFIED
C
      CALL RMDBLK(NAMDB)
      IF(RMSTAT.NE.0) GO TO 215
      CALL INTDEF(NAMDB,INTOPT)
      IF(INTOPT.EQ.0) GO TO 100
      GO TO 999
C
C  DETERMINE IF THE DATABASE IS TO BE LOADED INTERACTIVELY
C
  150 CONTINUE
C
C     DETERMINE IF THE DATABASE IS TO BE LOADED
C
  160 CONTINUE
      if(nout.eq.6)goto 7
      WRITE(NOUT,170)
	goto 8
7	continue
	write(c128wk,170)
	call atxto
8	continue
  170 FORMAT(1X,42HDo you want to LOAD the database - Y or N:)
      CALL LXLREC(DUM1,0,LXERR)
      IXID1 = LXID(1)
      IF(IXID1.EQ.K4EOF) GO TO 260
      IXREC1 = 0
      IF(IXID1.EQ.KZINT) IXREC1 = LXIREC(1)
      IF(IXID1.EQ.KZTEXT) IXREC1 = LXWREC(1,1)
      IF(EQKEYW(1,KWQUIT,4)) GO TO 997
      IF(IXREC1.EQ.K4Y) GO TO 250
      IF(IXREC1.EQ.K4N) GO TO 260
	if(nout.eq.6)goto 9
      WRITE(NOUT,8004)
      GO TO 160
9	continue
	write(c128wk,8004)
	call atxto
	goto 160
C
C  QUERY AND UPDATE MODE - GET THE DATABASE
C
  180 CONTINUE
      CALL RMDBGT(NAMDB,DBSTAT)
      IF(DBSTAT.EQ.0) GO TO 200
      IF(DBSTAT.EQ.1) GO TO 100
      GO TO 997
  200 CONTINUE
C
C     CHECK THAT USER DATABASE NAME MATCHES THE FILE DATABASE NAME
C
      CALL RMOPEN(NAMDB)
      IF(RMSTAT.EQ.0) GO TO 210
      CALL WARN(RMSTAT,NAMDB,0)
      RMSTAT = 0
      GO TO 120
  210 CONTINUE
      IF(IDBT.EQ.3) GO TO 300
C
C  CHECK THAT THE DATABASE MAY BE MODIFIED
C
      CALL RMDBLK(NAMDB)
      IF(RMSTAT.EQ.0) GO TO 220
  215 CALL WARN(RMSTAT,NAMDB,0)
      RMSTAT = 0
      GO TO 100
C
C     REQUEST THE UPDATE OPTION
C       1 -- DEFINE ADDITIONAL RELATIONS
C            (BRANCH TO THE DEFINE SECTION)
C       2 -- LOAD ADDITIONAL DATA
C            (BRANCH TO THE LOAD SECTION)
C
  220 Continue
	if(nout.eq.6)goto 10
	WRITE(NOUT,230)
  230 FORMAT(/,1X,32HSelect the UPDATE option desired,/
     1      5X,30H1) Define additional relations,/
     2      5X,23H2) Load additional data,/)
	goto 11
10	continue
	write(c128wk,3142)
3142	format(' Select UPDATE option: 1=define more relations,',
     1 '2=load more data:')
	call atxto
11	continue
      CALL LXLREC(DUM1,0,LXERR)
      IXID1 = LXID(1)
      IF(IXID1.EQ.K4EOF) GO TO 220
      IXREC1 = 0
      IF(IXID1.EQ.KZINT) IXREC1 = LXIREC(1)
      IF(IXID1.EQ.KZTEXT) IXREC1 = LXWREC(1,1)
      IF(EQKEYW(1,KWQUIT,4)) GO TO 997
      IF(IXREC1.EQ.1) GO TO 240
      IF(IXREC1.EQ.2) GO TO 250
	if(nout.eq.6)goto 12
      WRITE(NOUT,8003)
      GO TO 220
12	continue
	write(c128wk,8003)
	call atxto
	goto 220
C
C  ADD NEW RELATIONS
C
  240 CONTINUE
      INTOPT = K4UPD
      CALL INTDEF(NAMDB,INTOPT)
      IF(INTOPT.EQ.0) GO TO 100
      GO TO 999
C
C  LOAD ADDITIONAL DATA
C
  250 CONTINUE
      INTOPT = 0
  255 CONTINUE
      CALL INTLOD(INTOPT)
      IF(INTOPT.EQ.K4QUE) GO TO 260
      GO TO 999
C
C  DETERMINE IF THE DATABASE IS TO BE QUERIED
C
  260 CONTINUE
C
C     DETERMINE IF THE DATABASE IS TO BE QUERIED
C
  270 Continue
	if(nout.eq.6)goto 13
	WRITE(NOUT,280) NAMDB
  280 FORMAT(/,1X,5HThe ",A7,35H" Database has been created/updated,/,/,
     1  1X,48HDo you want to QUERY the database at this time -,
     2     7H Y or N,/)
	goto 14
13	continue
	write(c128wk,3145)NAMDB
3145	format(' The "',A7,'" Database is creat/updat. QUERY'
     1  ' it now (Y/N)?')
	call atxto
14	continue
      CALL LXLREC(DUM1,0,LXERR)
      IXID1 = LXID(1)
      IF(IXID1.EQ.K4EOF) GO TO 100
      IXREC1 = 0
      IF(IXID1.EQ.KZINT) IXREC1 = LXIREC(1)
      IF(IXID1.EQ.KZTEXT) IXREC1 = LXWREC(1,1)
      IF(IXREC1.EQ.K4QUIT) GO TO 997
      IF(IXREC1.EQ.K4Y) GO TO 300
      IF(IXREC1.EQ.K4N) GO TO 100
	if(nout.eq.6)goto 15
      WRITE(NOUT,8004)
      GO TO 270
15	continue
	write(c128wk,8004)
	call atxto
	goto 270
C
C  QUERY
C
  300 CONTINUE
	if(nout.eq.6)goto 16
      WRITE(NOUT,310)
  310 FORMAT(/,1X,16HRIM Command mode,/)
	goto 17
16	continue
	write(c128wk,3417)
3417	format(' RIM Command Mode')
	call atxto
17	continue
      INTOPT = K4QUE
      GO TO 999
C
C  COMMAND MODE
C
  400 CONTINUE
      INTOPT = K4COM
	if(nout.eq.6)goto 36
      WRITE(NOUT,310)
      GO TO 999
36	continue
	write(c128wk,3417)
	call atxto
	goto 999
C
C  QUIT
C
  997 CONTINUE
      INTOPT = K4QUIT
      GO TO 999
C
C  EXIT
C
  998 CONTINUE
      INTOPT = K4EXIT
      CALL RMCLOS
  999 CONTINUE
      RETURN
C
C     ERROR MESSAGES ---------------------------------------
C
 8001 FORMAT(1X,49H-ERROR- Either "1","2","3" or "4" must be entered)
 8002 FORMAT(1X,38H-ERROR- The database NAME must be 1-6 ,
     1           23Halphanumeric characters)
 8003 FORMAT(1X,41H-ERROR- Either "1" or "2" must be entered)
 8004 FORMAT(1X,41H-ERROR- Either "Y" or "N" must be entered)
C
      END
      SUBROUTINE INTDEF(NAMDB,INTOPT)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE: THIS ROUTINE PROMPTS THE USER FOR THE INFORMATION
C           REQUIRED TO CREATE A RIM SCHEMA SOURCE FILE.
C           RELATIONS, ATTRIBUTES, AND PASSWORDS ARE DEFINED WITH THIS
C           ROUTINE. RULES ARE NOT CURRENTLY IMPLEMENTED.
C
C  PARAMETERS: NAMDB -- DATABASE NAME IN H FORMAT
C              INTOPT - MENU MODE OPTION CODE - SET TO 0 IF "QUIT"
C
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:RELTBL.BLK
      INCLUDE rin:MISC.BLK
C
      DIMENSION IREL(25,53),IRELX(25),IATT(100),IATTX(100,4),IEDIT(10)
C
C  EQUIVALENCE THE LOCAL ARRAYS TO BUFFER - ALLOW TWO WORDS IN BUFFER
C  FOR EACH WORD IN THE LOCAL ARRAYS - SOLVES THE REAL*8 PROBLEM
C
      EQUIVALENCE (BUFFER(1),IREL(1,1))
      EQUIVALENCE (BUFFER(2651),IRELX(1))
      EQUIVALENCE (BUFFER(2701),IATT(1))
      EQUIVALENCE (BUFFER(2901),IATTX(1,1))
      LOGICAL EQKEYW
      INTEGER TWO
      INTEGER STATUS
      INCLUDE rin:DCLAR1.BLK
      INCLUDE rin:DCLAR2.BLK
      INCLUDE rin:DCLAR3.BLK
      INCLUDE rin:DCLAR5.BLK
C
C  CLEAR OUT ANY PAGE DATA LEFT IN BUFFER
C
      CALL BLKCLN
C
C     ******************************************************
C
C               D E F I N E   S E C T I O N
C
C     ******************************************************
C
      IRCD = 0
      IATC = 0
      TWO = 22
C
C     REQUEST THE DATABASE OWNER - NAMOWN
C
  100 Continue
	if(nout.eq.6)goto 3140
	WRITE(NOUT,110)
	goto 3141
3140	continue
	write(c128wk,110)
	call atxto
3141	continue
  110 FORMAT(1X,37HEnter The Name Of The Database Owner:)
  120 CALL LXLREC(DUM1,0,LXERR)
      IXID1 = LXID(1)
      IF(IXID1.EQ.K4EOF) GO TO 100
      IXREC1 = LXWREC(1,1)
      IF(IXREC1.EQ.K4QUIT) GO TO 998
      IXLEN = LXLENC(1)
      IF((IXID1.EQ.KZTEXT).AND.(IXLEN.LE.8)) GO TO 130
	if(nout.eq.6)goto 3142
      WRITE(NOUT,8002)
      GO TO 100
3142	continue
	write(c128wk,8002)
	call atxto
	goto 100
  130 NAMOWN = BLANK
      CALL LXSREC(1,1,8,NAMOWN,1)
C
C     CHECK THE DATABASE OWNER
C
      IF(INTOPT.EQ.K4CRE) GO TO 140
      IF(NAMOWN.EQ.OWNER) GO TO 140
	if(nout.eq.6)goto 1
      WRITE(NOUT,8028)
      GO TO 120
1	continue
	write(c128wk,8028)
	call atxto
	goto 120
  140 CONTINUE
C
C  OPEN THE SCHEMA SOURCE FILE
C
      OPEN(UNIT=TWO,FILE='SCHEMA',STATUS='UNKNOWN')
      REWIND TWO
  310 IRCD = IRCD + 1
      IF(IRCD.LE.25) GO TO 320
	if(nout.eq.6)goto 2
      WRITE(NOUT,8020)
	goto 3
2	continue
	write(c128wk,8020)
	call atxto
3	continue
      IRCD = 25
      GO TO 830
C
C     REQUEST THE RELATION NAME - IREL(IRCD,1) WHERE
C     IRCD IS THE COUNT OF RELATIONS
C
  320 Continue
	if(nout.eq.6)goto 4
	WRITE(NOUT,330)
	goto 5
4	continue
	write(c128wk,330)
	call atxto
5	continue
  330 FORMAT(1X,41HEnter The Name Assigned To This Relation:)
      CALL LXLREC(DUM1,0,LXERR)
      IXID1 = LXID(1)
      IF(IXID1.EQ.K4EOF) GO TO 320
      IXREC1 = LXWREC(1,1)
      IF(IXREC1.EQ.K4QUIT) GO TO 998
      IXLEN = LXLENC(1)
      IF((IXID1.EQ.KZTEXT).AND.(IXLEN.LE.8)) GO TO 340
	if(nout.eq.6)goto 6
      WRITE(NOUT,8006)
      GO TO 320
6	continue
	write(c128wk,8006)
	call atxto
	goto 320
  340 RNAME = BLANK
      CALL LXSREC(1,1,8,RNAME,1)
      IREL(IRCD,1) = RNAME
C
C     CHECK DUPLICATED RELATIONS
C
      IF(INTOPT.EQ.K4CRE) GO TO 350
      I = LOCREL(RNAME)
      IF(I.NE.0) GO TO 350
	if(Nout.eq.6)goto 7
      WRITE(NOUT,8029) RNAME
      GO TO 320
7	continue
	write(c128wk,8029)rname
	goto 320
  350 CONTINUE
      IF(IRCD.EQ.1) GO TO 380
      JEND = IRCD - 1
      DO 370 J=1,JEND
      IF(RNAME.NE.IREL(J,1)) GO TO 370
	if(nout.eq.6)goto 8
      WRITE(NOUT,8029) RNAME
      GO TO 320
8	continue
	write(c128wk,8029) rname
	call atxto
	goto 320
  370 CONTINUE
  380 CONTINUE
C
C     REQUEST THE RELATION PASSWORDS
C
  390 Continue
	if(nout.eq.6)goto 9
      WRITE(NOUT,400)
	goto 10
  400 FORMAT(1X,42HEnter The READ PASSWORD for This Relation:)
9	continue
	write(c128wk,400)
	call atxto
10	continue
      CALL LXLREC(DUM1,0,LXERR)
      RPW1 = BLANK
      IXID1 = LXID(1)
      IF(IXID1.EQ.K4EOF) GO TO 420
      IXREC1 = LXWREC(1,1)
      IF(IXREC1.EQ.K4QUIT) GO TO 998
      IXLEN = LXLENC(1)
      IF((IXID1.EQ.KZTEXT).AND.(IXLEN.LE.8)) GO TO 410
	if(nout.eq.6)goto 11
      WRITE(NOUT,8017)
      GO TO 390
11	continue
	write(c128wk,8017)
	call atxto
	goto 390
  410 RPW1 = BLANK
      CALL LXSREC(1,1,8,RPW1,1)
  420 Continue
	if(nout.eq.6)goto 12
      WRITE(NOUT,430)
	goto 13
  430 FORMAT(1X,44HEnter the MODIFY PASSWORD for This Relation:)
12	continue
	write(c128wk,430)
	call atxto
13	continue
      CALL LXLREC(DUM1,0,LXERR)
      MPW1 = BLANK
      IXID1 = LXID(1)
      IF(IXID1.EQ.K4EOF) GO TO 450
      IXREC1 = LXWREC(1,1)
      IF(IXREC1.EQ.K4QUIT) GO TO 998
      IXLEN = LXLENC(1)
      IF((IXID1.EQ.KZTEXT).AND.(IXLEN.LE.8)) GO TO 440
	if(nout.eq.6)goto 14
      WRITE(NOUT,8017)
      GO TO 420
14	continue
	write(c128wk,8017)
	call atxto
	goto 420
  440 MPW1 = BLANK
      CALL LXSREC(1,1,8,MPW1,1)
  450 IREL(IRCD,52) = RPW1
      IREL(IRCD,53) = MPW1
C
C     REQUEST THE ATTRIBUTE NAMES, TYPES, LENGTHS,
C     AND WHICH ARE KEYS
C     3HEND INDICATES THAT ALL ATTRIBUTES FOR THE CURRENT
C     RELATION HAVE BEEN DEFINED
C
	if(nout.eq.6)goto 15
      WRITE(NOUT,500)
  500 FORMAT(/,1X,37HENTER THE ATTRIBUTES OF THIS RELATION,/,
     1        1X,23HENTER END WHEN COMPLETE,/,
     2        5X,31HNAME    TYPE    LENGTH (IF > 1)  ,
     3           18H    "KEY" (IF KEY),/)
	goto 16
15	continue
	write(c128wk,3148)
3148	format(' Enter attributes, END when done. NAME, TYPE,'
     1  ' LENGTH (if >1)',
     1  ' "KEY" (if key)')
	call atxto
16	continue
      IATL = 0
  510 CALL LXLREC(DUM1,0,LXERR)
      LENR = 1
      LENC = 1
      KEY = IBLANK
      MTYP = 0
      IXID1 = LXID(1)
      IF(IXID1.EQ.K4EOF) GO TO 800
C
C     CHECK FOR END AND THAT THE ATTRIBUTE NAME IS TEXT
C
      IXREC1 = LXWREC(1,1)
      IF(IXREC1.EQ.K4QUIT) GO TO 998
      IF(IXREC1.EQ.K4END) GO TO 800
      IXLEN = LXLENC(1)
      IF((IXID1.EQ.KZTEXT).AND.(IXLEN.LE.8)) GO TO 520
	if(nout.eq.6)goto 17
      WRITE(NOUT,8007)
      GO TO 510
17	continue
	write(c128wk,8007)
	call atxto
	goto 510
C
C     CHECK ATTRIBUTE TYPE
C
  520 ANAME = BLANK
      CALL LXSREC(1,1,8,ANAME,1)
      LPOS = 3
      IXREC2 = 0
      IF(EQKEYW(2,KWINT ,7)) IXREC2 = KZINT
      IF(EQKEYW(2,KWREAL,4)) IXREC2 = KZREAL
      IF(EQKEYW(2,KWTEXT,4)) GO TO 530
      IF(EQKEYW(2,KWDOUB,6)) IXREC2 = KZDOUB
      IF(EQKEYW(2,KWIVEC,4)) IXREC2 = KZIVEC
      IF(EQKEYW(2,KWRVEC,4)) IXREC2 = KZRVEC
      IF(EQKEYW(2,KWDVEC,4)) IXREC2 = KZDVEC
      IF(IXREC2.NE.0) GO TO 550
      IF(EQKEYW(2,KWIMAT,4)) IXREC2 = KZIMAT
      IF(EQKEYW(2,KWRMAT,4)) IXREC2 = KZRMAT
      IF(EQKEYW(2,KWDMAT,4)) IXREC2 = KZDMAT
      IF(IXREC2.NE.0) GO TO 540
	if(nout.eq.6)goto 18
      WRITE(NOUT,8008)
      GO TO 510
18	continue
	write(c128wk,8008)
	call atxto
	goto 510
C
C  SET DEFAULT TO 8 CHARACTERS FOR TEXT
C
  530 LENR = 8
      IXREC2 = KZTEXT
      GO TO 550
  540 MTYP = 1
  550 CONTINUE
C
C  CHECK ATTRIBUTE LENGTH
C
      IXITEM = LXITEM(NUM)
      IF(IXITEM.EQ.2) GO TO 700
C
C  GET THE FIRST DIMENSION (LENGTH)
C
      IXREC3 = LXWREC(LPOS,1)
      IF(IXREC3.EQ.K4KEY) GO TO 670
      IF(IXREC3.NE.KZVAR) GO TO 610
C
C  VARIABLE LENGTH ATTRIBUTE
C
      LENR = IXREC3
      GO TO 620
C
C  FIXED LENGTH ATTRIBUTE
C
  610 CONTINUE
      IXID3 = LXID(LPOS)
      IF(IXID3.NE.KZINT) GO TO 630
      LENR = LXIREC(LPOS)
      IF((LENR.LE.0).OR.(LENR.GT.MAXCOL)) GO TO 630
      IF(MTYP.EQ.1) GO TO 640
  620 IF(IXITEM.EQ.LPOS) GO TO 700
      GO TO 670
  630 Continue
	if(nout.eq.6)goto 19
	WRITE(NOUT,8009)
      GO TO 510
19	continue
	write(c128wk,8009)
	call atxto
	goto 510
C
C  MATRIX ATTRIBUTE - GET COLUMN DIMENSION
C
  640 CONTINUE
      IXREC3 = LXWREC(LPOS+1,1)
      IF(IXREC3.NE.KZVAR) GO TO 650
C
C  VARIABLE COLUMN DIMENSION
C
      LENC = IXREC3
      GO TO 660
C
C  FIXED LENGTH COLUMN DIMENSION
C
  650 CONTINUE
      IXID3 = LXID(LPOS+1)
      IF(IXID3.NE.KZINT) GO TO 630
      LENC = LXIREC(LPOS+1)
      LEN = LENR*LENC
      IF((LEN.LE.0).OR.(LEN.GT.MAXCOL)) GO TO 630
  660 IF(IXITEM.EQ.(LPOS+1)) GO TO 700
  670 CONTINUE
C
C     CHECK IF KEY ATTRIBUTE
C
      IXRECX = LXWREC(IXITEM,1)
      IF(IXRECX.NE.K4KEY) GO TO 680
      KEY = K4KEY
      GO TO 700
  680 CONTINUE
      IF((MTYP.EQ.1).AND.(IXRECX.EQ.KZVAR)) GO TO 700
	if(nout.eq.6)goto 20
      WRITE(NOUT,8018)
      GO TO 510
20	continue
	write(c128wk,8018)
	call atxto
	goto 510
C
C     STORE THE ATTRIBUTE NAME IN IREL(IRCD,IATL+1) WHERE
C     IRCD IS THE COUNT OF RELATIONS AND IATL IS THE
C     COUNT OF ATTRIBUTES FOR THE CURRENT RELATION
C
  700 IATL = IATL + 1
      IF(IATL.LE.50) GO TO 710
	if(nout.eq.6)goto 21
      WRITE(NOUT,8021)
	goto 22
21	continue
	write(c128wk,8021)
	call atxto
22	continue
      IATL = 50
      GO TO 800
  710 IREL(IRCD,IATL+1) = ANAME
C
C     CHECK IF THIS ATTRIBUTE HAS ALREADY BEEN DEFINED
C     IF IT HAS CHECK THAT A REDEFINITION HAS NOT OCCURED
C
      IF(INTOPT.EQ.K4CRE) GO TO 760
C
C  CHECK EXISTING ATTRIBUTES
C
      I = LOCATT(ANAME,BLANK)
      IF(I.NE.0) GO TO 760
C
C  EXISTING ATTRIBUTE - GET DEFINITION
C
      CALL ATTGET(STATUS)
      IF(STATUS.NE.0) GO TO 760
      IF(IXREC2.NE.ATTYPE) WRITE(NOUT,8014) ATTYPE
      LEN1 = 0
      LEN2 = 0
      IF(LENR.EQ.KZVAR) GO TO 720
      LEN1 = LENR
      IF(LENC.EQ.KZVAR) GO TO 720
      LEN2 = LENR
      IF(ATTYPE.EQ.KZTEXT) LEN2 = ((LENR-1)/CHPWD) + 1
      IF(MTYP.EQ.1) LEN2 = LENR*LENC
      CALL TYPER(ATTYPE,DUM1,LEN)
      IF(LEN.EQ.KZDOUB) LEN2 = 2*LEN2
      IF(ATTYPE.EQ.KZINT ) LEN1 = 0
      IF(ATTYPE.EQ.KZREAL) LEN1 = 0
      IF(ATTYPE.EQ.KZDOUB) LEN1 = 0
  720 CONTINUE
	if(nout.eq.6)goto 23
      IF(LEN1.NE.ATTCHA) WRITE(NOUT,8015) ATTCHA
      IF(LEN2.NE.ATTWDS) WRITE(NOUT,8015) ATTWDS
	goto 24
23	continue
      IF(LEN1.NE.ATTCHA) WRITE(c128wk,8015) ATTCHA
	if(len1.ne.attcha)call atxto
      IF(LEN2.NE.ATTWDS) WRITE(c128wk,8015) ATTWDS
	if(len2.ne.attwds)call atxto
24	continue
C
C  CHECK KEY
C
      LEN = K4KEY
      IF(ATTKEY.EQ.0) LEN = IBLANK
	if(nout.eq.6)goto 25
      IF(KEY.NE.LEN) WRITE(NOUT,8019) IXREC1
      GO TO 510
25	continue
	if(key.eq.len)goto 510
	write(c128wk,8019) ixrec1
	call atxto
	goto 510
  760 CONTINUE
      IF(IATC.EQ.0) GO TO 780
C
C  CHECK NEW ATTRIBUTES
C
      DO 770 J=1,IATC
      IF(ANAME.NE.IATT(J)) GO TO 770
	if(nout.eq.6)goto 26
      IF(IXREC2.NE.IATTX(J,1)) WRITE(NOUT,8014) IATTX(J,1)
      IF(LENR.NE.IATTX(J,2)) WRITE(NOUT,8015) IATTX(J,2)
      IF(LENC.NE.IATTX(J,3)) WRITE(NOUT,8015) IATTX(J,3)
      IF(KEY.NE.IATTX(J,4)) WRITE(NOUT,8019) IXREC1
      GO TO 510
26	continue
      IF(IXREC2.NE.IATTX(J,1)) WRITE(c128wk,8014) IATTX(J,1)
      IF(IXREC2.NE.IATTX(J,1)) call atxto
      IF(LENR.NE.IATTX(J,2)) WRITE(c128wk,8015) IATTX(J,2)
      IF(LENR.NE.IATTX(J,2)) call atxto
      IF(LENC.NE.IATTX(J,3)) WRITE(c128wk,8015) IATTX(J,3)
      IF(LENC.NE.IATTX(J,3)) call atxto
      IF(KEY.NE.IATTX(J,4)) WRITE(c128wk,8019) IXREC1
      IF(KEY.NE.IATTX(J,4)) call atxto
	goto 510
  770 CONTINUE
C
C     STORE THE ATTRIBUTE DATA IN IATT
C       IATT(IATC) = ATTRIBUTE NAME
C       IATTX(IATC,1) = ATTRIBUTE TYPE
C       IATTX(IATC,2) = ATTRIBUTE LENGTH - ROW DIMENSION IF MATRIX
C       IATTX(IATC,3) = COLUMN DIMENSION IF MATRIX
C       IATTX(IATC,4) = KEY INDICATOR (BLANK OR 3HKEY)
C       IATC         = COUNT OF UNIQUE ATTRIBUTES
C
  780 IATC = IATC + 1
      IF(IATC.LE.100) GO TO 790
	if(nout.eq.6)goto 27
      WRITE(NOUT,8022)
      IATC = 100
      GO TO 800
27	continue
	write(c128wk,8022)
	call atxto
	iatc = 100
	goto 800
  790 IATT(IATC) = ANAME
      IATTX(IATC,1) = IXREC2
      IATTX(IATC,2) = LENR
      IATTX(IATC,3) = LENC
      IATTX(IATC,4) = KEY
      GO TO 510
C
C     STORE THE NUMBER OF COLUMNS (NO ATTRIBUTES + 1) FOR
C     THE CURRENT RELATION IN IRELX(IRCD)
C
  800 IRELX(IRCD) = IATL + 1
      IF(IATL.GT.0) GO TO 810
	if(nout.eq.6)goto 28
      WRITE(NOUT,8031) IREL(IRCD,1)
	goto 29
28	continue
	write(c128wk,8031) irel(ircd,1)
	call atxto
29	continue
      IREL(IRCD,1) = BLANK
      IREL(IRCD,52) = BLANK
      IREL(IRCD,53) = BLANK
      IRCD = IRCD - 1
C
C     CHECK FOR ADDITIONAL RELATION DEFINITIONS
C     (BRANCH TO 310 IF YES)
C
  810 Continue
	if(nout.eq.6)goto 30
	WRITE(NOUT,820)
  820 FORMAT(/,1X,45HDO YOU HAVE ADDITIONAL RELATIONS TO DEFINE - ,
     1           6HY OR N,/)
	goto 31
30	continue
	write(c128wk,3340)
3340	format(' Do you have more relations to define [Y/N]:')
	call atxto
31	continue
      CALL LXLREC(DUM1,0,LXERR)
      IXID1 = LXID(1)
      IF(IXID1.EQ.K4EOF) GO TO 830
      IXREC1 = 0
      IF(IXID1.EQ.KZINT) IXREC1 = LXIREC(1)
      IF(IXID1.EQ.KZTEXT) IXREC1 = LXWREC(1,1)
      IF(IXREC1.EQ.K4QUIT) GO TO 998
      IF(IXREC1.EQ.K4Y) GO TO 310
      IF(IXREC1.EQ.K4N) GO TO 830
	if(nout.eq.6)goto 32
      WRITE(NOUT,8010)
      GO TO 810
32	continue
	write(c128wk,8010)
	call atxto
	goto 810
C
C     DEFINE THE RIM SCHEMA SOURCE FILE
C
C     WRITE THE DATABASE NAME AND OWNER
C
  830 Continue
	WRITE(TWO,840) NAMDB,NAMOWN
  840 FORMAT(2X,7HDEFINE ,A8/2X,6HOWNER ,A8)
C
C     WRITE THE LIST OF ELEMENTS (ATTRIBUTES), ELEMENT TYPES,
C     AND LENGTHS
C
      WRITE(TWO,850)
  850 FORMAT(2X,10HATTRIBUTES)
      DO 930 J=1,IATC
      IF(IATTX(J,2).EQ.KZVAR) GO TO 870
      MTYP = IATTX(J,1)
      IF((MTYP.EQ.KZIMAT).OR.(MTYP.EQ.KZRMAT).OR.(MTYP.EQ.KZDMAT))
     1     GO TO 890
      WRITE(TWO,860) IATT(J),IATTX(J,1),IATTX(J,2),IATTX(J,4)
  860 FORMAT(2X,A8,2X,A4,2X,I4,6X,A3)
      GO TO 930
  870 Continue
	WRITE(TWO,880) IATT(J),IATTX(J,1),IATTX(J,2),IATTX(J,4)
  880 FORMAT(2X,A8,2X,A4,3X,A3,6X,A3)
      GO TO 930
C
C MATRIX
C
  890 IF(IATTX(J,3).EQ.KZVAR) GO TO 910
      WRITE(TWO,900) IATT(J),IATTX(J,1),IATTX(J,2),IATTX(J,3),IATTX(J,4)
  900 FORMAT(2X,A8,2X,A4,2X,I4,I4,2X,A3)
      GO TO 930
  910 WRITE(TWO,920) IATT(J),IATTX(J,1),IATTX(J,2),IATTX(J,3),IATTX(J,4)
  920 FORMAT(2X,A8,2X,A4,2X,I4,1X,A3,2X,A3)
  930 CONTINUE
C
C     WRITE THE RELATIONS - IF CONTINUATION IS REQUIRED
C     A + IS INSERTED AT THE END OF THE LINE
C
      IF(IRCD.EQ.0) GO TO 1040
      WRITE(TWO,950)
  950 FORMAT(2X,9HRELATIONS)
      DO 1000 J=1,IRCD
      NUM = IRELX(J) - 1
      K1 = 1
      K2 = 4
  960 IEND = IBLANK
      IF(NUM.GT.4) IEND = K4PLUS
      IF(NUM.LT.4) K2 = NUM
      IF(K1.EQ.1)WRITE(TWO,970)IREL(J,1),(IREL(J,K1+K),K=1,K2),IEND
      IF(K1.GT.1)WRITE(TWO,980) (IREL(J,K1+K),K=1,K2),IEND
  970 FORMAT(2X,A8,5H WITH,4(2X,A8),2X,A1)
  980 FORMAT(15X,4(2X,A8),2X,A1)
      IF(NUM.LE.4) GO TO 1000
      K1 = K1 + 4
      NUM = NUM - 4
      GO TO 960
 1000 CONTINUE
C
C     WRITE THE PASSWORDS
C
      WRITE(TWO,1010)
 1010 FORMAT(2X,9HPASSWORDS)
      DO 1030 J=1,IRCD
      RPW1 = IREL(J,52)
      MPW1 = IREL(J,53)
      IF(RPW1.NE.BLANK) WRITE(TWO,1020) IREL(J,1),RPW1
      IF(MPW1.NE.BLANK) WRITE(TWO,1021) IREL(J,1),MPW1
 1020 FORMAT(2X,4HREAD,14H PASSWORD FOR ,A8,4H IS ,A8)
 1021 FORMAT(2X,6HMODIFY,14H PASSWORD FOR ,A8,4H IS ,A8)
 1030 CONTINUE
C
C     WRITE THE END RECORD
C
 1040 CONTINUE
      WRITE(TWO,1050)
 1050 FORMAT(2X,3HEND)
C
 1110 CONTINUE
      IF(INTOPT.EQ.K4CRE) GO TO 999
      IF(NAMDB.EQ.DBNAME) GO TO 1120
	if(nout.eq.6)goto 33
      WRITE(NOUT,8027) NAMDB
      GO TO 998
33	continue
	write(c128wk,8027)namdb
	call atxto
	goto 998
 1120 IF(NAMOWN.EQ.OWNER) GO TO 999
	if(nout.eq.6)goto 34
      WRITE(NOUT,8030)
      GO TO 998
34	continue
	write(c128wk,8030)
	call atxto
	goto 998
C
C  RETURN AND CALL CSC TO COMPILE THE SCHEMA
C
  998 CONTINUE
      INTOPT = 0
  999 CONTINUE
      REWIND TWO
C
C  CLOSE THE SCHEMA SOURCE FILE
C
      CLOSE(UNIT=TWO)
      RETURN
C
C     ERROR MESSAGES ---------------------------------------
C
 8002 FORMAT(1X,39H-ERROR- The Database Owner Must Be 1-8 ,
     1           23HAlphanumeric Characters)
 8006 FORMAT(1X,36H-ERROR- Relation Names Must Be TEXT ,
     1           16H(1-8 characters))
 8007 FORMAT(1X,37H-ERROR- Attribute Names Must Be TEXT ,
     1           16H(1-8 characters),1X,17HReenter Last Line)
 8008 FORMAT(' Error - Type must be one of INT,REAL,TEXT,DOUB,IVEC',
     1  'RVEC,DVEC,IMAT,RMAT, or DMAT. Reenter line.')
 8009 FORMAT(1X,44H-ERROR- The Number Of Words In An Attribute ,
     1           41HMust Be A Positive Integer Less Than 1023,
     2        1X,17HReenter Last Line)
 8010 FORMAT(1X,41H-ERROR- Either "Y" or "N" Must Be Entered)
 8014 FORMAT(1X,34H-ERROR- Attribute Type Redefined (,A4,
     1           19H Type Will Be Used))
 8015 FORMAT(1X,44H-ERROR- Attribute Length Redefined (Length =,
     1             I3,14H Will Be Used))
 8017 FORMAT(1X,39H-ERROR- The Relation Passwords Must Be ,
     1           23HAlphanumeric Characters)
 8018 FORMAT(1X,32H-ERROR- The KEY Entry Is Illegal,
     1        9X,17HReenter Last Line)
 8019 FORMAT(1X,48H-ERROR- KEY Specification Changed For Attribute ,
     1           A10,1X,27HOriginal Specification Used)
 8020 FORMAT(1X,41H-ERROR- 25 Relations Is The Current Limit,
     1        9X,30HRelation Processing Terminated)
 8021 FORMAT(1X,42H-ERROR- 50 Attributes Is The Current Limit,
     1        9X,30HRelation Processing Terminated)
 8022 FORMAT(1X,50H-ERROR- 100 Unique Attributes Is The Current Limit,
     1       9X,30HRelation Processing Terminated)
 8027 FORMAT(1X,26H-ERROR- The Database Name ,A6,10H Does Not ,
     1           27HMatch The Database Contents)
 8028 FORMAT(1X,36H-ERROR- Unauthorized Access To The ,
     1           9HDatabase ,1X,17HEnter Authorized ,
     2           15HOwner or "QUIT")
 8029 FORMAT(1X,17H-ERROR- Relation ,A10,15H Already Exists)
 8030 FORMAT(1X,35H-ERROR- Unauthorized Access To The ,
     1           15HDatabase Schema)
 8031 FORMAT(1X,19H-WARNING- Relation ,A10,15H Does Not Have ,
     X   20HAny Legal Attributes)
C
      END
      SUBROUTINE INTLOD(INTOPT)
      INCLUDE rin:TEXT.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:DCLAR1.BLK
      INCLUDE rin:DCLAR3.BLK
      INTEGER STATUS
      LOGICAL EQ,NE
      LOGICAL EQKEYW
      IF(INTOPT.EQ.0) GO TO 90
C
C  ASK IF MORE RELATIONS ARE TO BE LOADED
C
   10 Continue
	if(nout.eq.6)goto 3140	
	WRITE(NOUT,20)
	goto 3141
3140	continue
	write(c128wk,20)
	call atxto
3141	continue
   20 FORMAT(51H Do You Have Additional Relations To Load - Y OR N:)
      CALL LXLREC(DUM1,0,LXERR)
      IDX = LXID(1)
      IF(IDX.EQ.K4EOF) GO TO 80
      IF(EQKEYW(1,KWQUIT,4)) GO TO 997
      IF(EQKEYW(1,KWEXIT,4)) GO TO 998
      IRECX = IBLANK
      CALL LXSREC(1,1,1,IRECX,1)
      IF(IRECX.EQ.K4N) GO TO 80
      IF(IRECX.EQ.K4Y) GO TO 90
	if(nout.eq.6)goto 3142
      WRITE(NOUT,8004)
      GO TO 10
3142	continue
	write(c128wk,8004)
	call atxto
	goto 10
C
C  NO MORE RELATIONS TO LOAD
C
   80 CONTINUE
      INTOPT = K4QUE
      GO TO 999
C
C  LOAD A RELATION
C
   90 CONTINUE
C
C  CHECK FOR VALID RELATIONS
C
      I = LOCREL(BLANK)
      IF(I.EQ.0) GO TO 200
	if(nout.eq.6)goto 3143
      WRITE(NOUT,100)
  100 FORMAT(32H -WARNING- Relation Tables Empty )
      INTOPT = K4EXIT
      GO TO 999

3143	continue
	write(c128wk,100)
	call atxto
      INTOPT = K4EXIT
      GO TO 999
C
C  DISPLAY AVAILABLE RELATIONS
C
  200 CONTINUE
	if(nout.eq.6)goto 3144
      WRITE(NOUT,210)
	goto 3145
3144	continue
	write(c128wk,210)
	call atxto
3145	continue
  210 FORMAT(33H Select The Relation To Be Loaded)
      K = 0
  220 CALL RELGET(STATUS)
      IF(STATUS.NE.0) GO TO 250
      IF(EQ(NAME,K8RDT)) GO TO 220
      IF(EQ(NAME,K8RRC)) GO TO 220
      K = K + 1
	if(nout.eq.6)goto 3146
      WRITE(NOUT,230) K,NAME
  230 FORMAT(4X,I2,2H) ,A8)
      GO TO 220
3146	continue
	write(c128wk,230)k,name
	call atxto
	goto 220
C
C  GET THE USERS SELECTION
C
  250 CONTINUE
      CALL LXLREC(DUM1,0,LXERR)
      IDX = LXID(1)
      IF(IDX.EQ.K4EOF) GO TO 10
      IRECX = LXIREC(1)
      IF(EQKEYW(1,KWQUIT,4)) GO TO 997
      IF(EQKEYW(1,KWEXIT,4)) GO TO 998
      IF((IRECX.GE.1).AND.(IRECX.LE.K)) GO TO 260
	if(nout.eq.6)goto 3147
      WRITE(NOUT,8001) K
      GO TO 250
3147	continue
	write(c128wk,8001)k
	call atxto
	goto 250
C
C  LOCATE THE REQUESTED SELECTION
C
  260 CONTINUE
      I = LOCREL(BLANK)
      K = 0
  270 CALL RELGET(STATUS)
      IF(STATUS.NE.0) GO TO 998
      IF(EQ(NAME,K8RDT)) GO TO 270
      IF(EQ(NAME,K8RRC)) GO TO 270
      K = K + 1
      IF(IRECX.EQ.K) GO TO 300
      GO TO 270
C
C  CHECK PERMISSION TO MODIFY THE RELATION
C
  300 CONTINUE
      IF(EQ(MPW,NONE)) GO TO 360
      IF(EQ(MPW,USERID)) GO TO 360
      IF(EQ(USERID,OWNER)) GO TO 360
	if(nout.eq.6)goto 3148
      WRITE(NOUT,310)
  310 FORMAT(45H Enter the MODIFY PASSWORD for This Relation: )
	goto 3149
3148	continue
	write(c128wk,310)
	call atxto
3149	continue
      CALL LXLREC(DUM1,0,LXERR)
      MPW1 = NONE
      IDX = LXID(1)
      IF(IDX.EQ.K4EOF) GO TO 350
      IF(EQKEYW(1,KWQUIT,4)) GO TO 997
      IF(EQKEYW(1,KWEXIT,4)) GO TO 998
      IF((IDX.EQ.KZTEXT).AND.(LXLENC(1).LE.8)) GO TO 340
	if(nout.eq.6)goto 3150
      WRITE(NOUT,8002)
      GO TO 300
3150	continue
	write(c128wk,8002)
	call atxto
	goto 300
C
C  CHECK THE PASSWORD
C
  340 CONTINUE
      MPW1 = BLANK
      CALL LXSREC(1,1,8,MPW1,1)
  350 CONTINUE
      IF(EQ(MPW1,MPW)) GO TO 355
      IF(EQ(MPW1,OWNER)) GO TO 355
	if(nout.eq.6)goto 3151
      WRITE(NOUT,8003) NAME
      GO TO 10
3151	continue
	write(c128wk,8003)name
	call atxto
	goto 10
C
C  GET THE ATTRIBUTES FOR THIS RELATION
C
  355 CONTINUE
      USERID = MPW1
  360 CONTINUE
      I = LOCATT(BLANK,NAME)
	if(nout.eq.6)goto 3152
      WRITE(NOUT,370)
  370 FORMAT(44H Enter The Attribute Values In The Specified,
     X          9H Sequence,24H Enter END When Complete)
	goto 3153
3152	continue
	write(c128wk,370)
	call atxto
3153	continue
      NUM = 0
  400 CALL ATTGET(STATUS)
      IF(STATUS.NE.0) GO TO 450
      NUM = NUM + 1
      NAMES(NUM) = ATTNAM
      IF(NUM.LT.8) GO TO 400
	if(nout.eq.6)goto 3154
      WRITE(NOUT,410) (NAMES(J),J=1,7)
	goto 3155
3154	continue
	write(c128wk,410) (names(j),j=1,7)
	call atxto
3155	continue
  410 FORMAT(7(1X,A8),2X,1H+)
      NUM = 1
      NAMES(1) = NAMES(8)
      GO TO 400
C
C  PRINT LAST LINE OF ATTRIBUTES
C
  450 Continue
	if(nout.eq.6)goto 3156
	WRITE(NOUT,460) (NAMES(J),J=1,NUM)
	goto 3157
3156	continue
	write(c128wk,460) (names(j),j=1,num)
	call atxto
3157	continue
  460 FORMAT(7(1X,A8))
C
C  GO GET THE DATA - CALL DBLOAD
C
      NAMES(1) = BLANK
      NAMES(2) = BLANK
      CALL STRMOV(KWLOAD,1,4,NAMES,1)
      CALL STRMOV(NAME,1,8,NAMES,6)
      CALL LXLREC(NAMES,16,LXERR)
      INTOPT = K4LOD
      GO TO 999
C
C  QUIT
C
  997 CONTINUE
      INTOPT = K4QUIT
      GO TO 999
C
C  EXIT
C
  998 CONTINUE
      INTOPT = K4EXIT
      GO TO 999
C
  999 CONTINUE
      RETURN
C
C  ERROR MESSAGES -----
C
 8001 FORMAT(37H -ERROR- An Integer In The Range 1 To,I3,
     X         16H Must Be Entered)
 8002 FORMAT(43H -ERROR- Passwords Must Be 1-8 Alphanumeric,
     X         11H Characters)
 8003 FORMAT(41H -ERROR- Unauthorized Access To Relation ,A8)
 8004 FORMAT(42H -ERROR- Either "Y" or "N" Must Be Entered)
      END
      INTEGER FUNCTION ISCAN(STR1,IC1,LC1,STR2,IC2,LC2,J1)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   LOCATE THE FIRST CHARACTER IN STR1 WHICH DOES
C             MATCH THE CHARACTERS IN STR2
C
C  PARAMETERS:
C     STR1----FIRST HOLLERITH STRING
C     IC1-----STARTING CHARACTER IN STR1 TO START THE SCAN
C     LC1-----LENGTH OF STR1
C     STR2----SECOND HOLLERITH STRING
C     IC2-----STARTING CHARACTER IN STR2
C     LC2-----LENGTH OF STR2
C     J1------CHARACTER POSITION IN STR1 OF FIRST MATCH
C             0 IF ALL NO MATCH
C     ISCAN---CHARACTER POSITION IN STR2 OF FIRST MATCH
C             0 IF ALL NO MATCH
C
      Character*1 STR1(*)
      Character*1 STR2(*)
C
C  IF LC1 IS NEGATIVE THE SCAN IS RIGHT TO LEFT.
C
      INC = 1
      IF(LC1.LT.0) INC = -1
      LC = INC * LC1
      I1 = IC1
C
C  SCAN STR1.
C
      DO 200 I=1,LC
      I2 = IC2 - 1
      DO 100 J=1,LC2
      I2 = I2 + 1
      IF(STR1(I1).EQ.STR2(I2)) GO TO 300
  100 CONTINUE
      I1 = I1 + INC
  200 CONTINUE
C
C  NO CHARACTERS MATCH.
C
      ISCAN = 0
      J1 = 0
      RETURN
C
C  WE FOUND A MATCHING CHARACTER.
C
  300 CONTINUE
      ISCAN = I2
      J1 = I1
      RETURN
      END
      SUBROUTINE ISECT(RNAME1,RNAME3,MATN3,NCOL3,NATT3,PTABLE,
     XKEYCOL,KEYTYP)
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE PERFORMS THE ACTUAL INTERSECT BETWEEN
C  RELATION 1 AND 2 FORMING 3
C
C  PARAMETERS:
C         NAME1---NAME OF THE FIRST RELATION
C         MATN3---DATA TUPLE FOR RELATION 3
C         NCOL3---NUMBER OF FIXED LENGTH COLUMNS IN MATN3
C         NATT3---NUMBER OF ATTRIBUTES IN MATN3
C         PTABLE--POINTER TABLE FOR THIS INTERSECT
C         KEYCOL--COLUMN OF MATN2 USED FOR SUPPLYING KEY VALUES
C         KEYTYP--ATTRIBUTE TYPE OF MATN1 USED FOR KEY VALUES
      INCLUDE rin:MISC.BLK
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:DCLAR1.BLK
      DIMENSION MATN3(*)
      INTEGER PTABLE(7,*)
      INTEGER ATTLEN
      INTEGER ENDCOL
C
C  INITIALIZE THE MATRIX POINTERS.
C
      IERR = 0
      IDST = 0
      IDNEW = 0
      IDCUR = NID
C
C  GET THE PARAMETERS FOR THE FIRST MATRIX.
C
      I = LOCREL(RNAME1)
      IDM1 = NID
      NSP = 0
      IF(KSTRT.NE.0) NSP = 2
      NTUP3 = 0
C
C  SEQUENCE THROUGH MATN2.
C
  100 CONTINUE
      IF(IDCUR.EQ.0) GO TO 1000
      CALL ITOH(N1,N2,IDCUR)
      IF(N2.EQ.0) GO TO 1000
      CALL GETDAT(2,IDCUR,MATN2,NCOL2)
      IF(IDCUR.LT.0) GO TO 1000
C
C  MOVE THE COMPARISON VALUE INTO THE WHCOM ARRAYS.
C
      CALL ITOH(NCHAR,NWORDS,KATTL(1))
      IP = MATN2 + KEYCOL - 1
      IF(NWORDS.NE.0) GO TO 110
C
C  SPECIAL GYRATIONS FOR VARIABLE LENGTH STUFF.
C
      IP2 = BUFFER(IP)
      IP = MATN2 + IP2 + 1
  110 CONTINUE
      WHRVAL(1) = BUFFER(IP)
      NID = IDM1
      NS = NSP
  200 CONTINUE
      CALL RMLOOK(MATN1,1,1,NCOL1)
      IF(RMSTAT.NE.0) GO TO 100
C
C  CHECK TO SEE IF THE ATTRIBUTES MATCH.
C
      K = 1
  300 CONTINUE
      CALL PTRS(IPT1,IPT2,K,NATT3,PTABLE,LEN,ITYPE)
C
C  IF K IS 0 WE HAVE LOOKED AT ALL THE COMMON ATTRIBUTES.
C
      IF(K.EQ.0) GO TO 400
      I1 = MATN1 + IPT1 - 1
      I2 = MATN2 + IPT2 - 1
      IF(LEN.EQ.0) GO TO 320
      DO 310 I=1,LEN
      IF(BUFFER(I1).NE.BUFFER(I2)) GO TO 200
      I1 = I1 + 1
      I2 = I2 + 1
  310 CONTINUE
C
C  A MATCH. LOOK AT MORE ATTRIBUTES.
C
      GO TO 300
C
C  VARIABLE LENGTH ATTRIBUTE PROCESSING.
C
  320 CONTINUE
      IPT1 = BUFFER(I1)
      IPT2 = BUFFER(I2)
      I1 = MATN1 + IPT1 - 1
      I2 = MATN2 + IPT2 - 1
      IF(BUFFER(I1).NE.BUFFER(I2)) GO TO 200
      LEN = BUFFER(I1)
      I1 = I1 + 2
      I2 = I2 + 2
      DO 340 I=1,LEN
      IF(BUFFER(I1).NE.BUFFER(I2)) GO TO 200
      I1 = I1 + 1
      I2 = I2 + 1
  340 CONTINUE
      GO TO 300
C
C  OKAY -- NOW LOAD THE DATA.
C
  400 CONTINUE
      ENDCOL = NCOL3
      DO 900 KLM=1,NATT3
      KOL1 = PTABLE(3,KLM)
      KOL2 = PTABLE(4,KLM)
      KOL3 = PTABLE(5,KLM)
      ATTLEN = PTABLE(6,KLM)
      CALL ITOH(NCHAR,NWORDS,ATTLEN)
      IF(NWORDS.EQ.0) GO TO 700
      DO 600 I=1,NWORDS
      IF(KOL1.EQ.0) GO TO 500
C
C  LOAD THE ATTRIBUTE FROM MATN1.
C
      I1 = MATN1 + KOL1 - 1
      MATN3(KOL3) = BUFFER(I1)
      KOL3 = KOL3 + 1
      KOL1 = KOL1 + 1
      GO TO 600
  500 CONTINUE
C
C  LOAD THE ATTRIBUTE FROM MATN2.
C
      I2 = MATN2 + KOL2 - 1
      MATN3(KOL3) = BUFFER(I2)
      KOL3 = KOL3 + 1
      KOL2 = KOL2 + 1
  600 CONTINUE
      GO TO 900
  700 CONTINUE
      ENDCOL = ENDCOL + 1
      MATN3(KOL3) = ENDCOL
      IF(KOL1.EQ.0) GO TO 710
C
C  USE POINTERS FROM MATN1.
C
      I1 = MATN1 + KOL1 - 1
      KOL1 = BUFFER(I1)
      I2 = MATN1 + KOL1 - 1
      NWORDS = BUFFER(I2)
      GO TO 720
  710 CONTINUE
C
C  USE POINTERS FROM MATN2.
C
      I2 = MATN2 + KOL2 - 1
      KOL2 = BUFFER(I2)
      I2 = MATN2 + KOL2 - 1
      NWORDS = BUFFER(I2)
  720 CONTINUE
C
C  LOAD UP THE VALUES.
C
      IF((ENDCOL+NWORDS+1).GT.MAXCOL) GO TO 950
      MATN3(ENDCOL) = NWORDS
      NWORDS = NWORDS + 1
      DO 800 I=1,NWORDS
      ENDCOL = ENDCOL + 1
      I2 = I2 + 1
      MATN3(ENDCOL) = BUFFER(I2)
  800 CONTINUE
  900 CONTINUE
      CALL ADDDAT(3,IDNEW,MATN3,ENDCOL)
      IF(IDST.EQ.0) IDST = IDNEW
      NTUP3 = NTUP3 + 1
C
C  LOOK FOR MORE IN MATN1.
C
      GO TO 200
C
C  TUPLE LENGTH EXCEEDS MAXCOL
C
  950 CONTINUE
      IERR = 1
	if(nout.eq.6)goto 3140
      WRITE(NOUT,960) MAXCOL
  960 FORMAT(36H -ERROR- Relation Row Length Exceeds,I5)
	goto 3141
3140	continue
	write(c128wk,960)
	call atxto
3141	continue
C
C  ALL DONE.
C
 1000 CONTINUE
      I = LOCREL(RNAME3)
      CALL RELGET(ISTAT)
      RSTART = IDST
      REND = IDNEW
      NTUPLE = NTUP3
      CALL RELPUT
      NUM = NTUP3
	if(nout.eq.6)goto 3142
      IF(IERR.EQ.0) WRITE(NOUT,9000) NUM
 9000 FORMAT(32H Successful INTERSECT Operation ,
     XI6,15H Rows Generated)
C
C  RETURN
C
      RETURN
3142	continue
      IF(IERR.ne.0)return
	write(c128wk,9000)num
	call atxto
	return
      END
      SUBROUTINE ISREL
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE FINDS THE INTERSECTION OF TWO RELATIONS BASED UPON
C  ATTRIBUTES.  THE RESULT FROM THIS PROCESS IS A PHYSICAL
C  RELATION WHICH HAS TUPLES CONTRUCTED FROM BOTH RELATIONS
C  WHERE COMMON ATTRIBUTES MATCH.
C
C  THE SYNTAX FOR THE INTERSECT COMMAND IS:
C
C   INTERSECT REL1 WITH REL2 FORMING REL3 [USING ATTR1 ATTR2...ATTR-N]
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:MISC.BLK
C
      INTEGER PTABLE
      LOGICAL EQ
      LOGICAL NE
      LOGICAL EQKEYW
      INCLUDE rin:DCLAR1.BLK
      INCLUDE rin:DCLAR3.BLK
C
C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
C
      CALL RMDBLK(DBNAME)
      IF(RMSTAT.EQ.0) GO TO 50
      CALL WARN(RMSTAT,DBNAME,0)
      GO TO 9999
C
C  LOCAL ARRAYS AND VARIABLES :
C
C  PTABLE (MATRIX 10) USED TO CONTROL POINTERS
C        ROWS1,2 -- ATTRIBUTE NAME
C        ROW3 -- ATTRIBUTE LOCATION IN RELATION 1
C        ROW4 -- ATTRIBUTE LOCATION IN RELATION 2
C        ROW5 -- ATTRIBUTE LOCATION IN RELATION 3
C        ROW6 -- LENGTH IN WORDS
C        ROW7 -- ATTRIBUTE TYPE
C
C  EDIT COMMAND SYNTAX
C
   50 CONTINUE
      CALL BLKCLN
      NS = 0
      IF(.NOT.EQKEYW(3,KWWITH,4)) GO TO 9900
      IF(.NOT.EQKEYW(5,KWFORM,7)) GO TO 9900
      ITEMS = LXITEM(IDUMMY)
      IF(ITEMS.GT.6 .AND. .NOT.EQKEYW(7,KWUSIN,5)) GO TO 9900
C
C  KEYWORD SYNTAX OKAY
C
      RNAME1 = BLANK
      CALL LXSREC(2,1,8,RNAME1,1)
      I = LOCREL(RNAME1)
      IF(I.EQ.0) GO TO 100
C
C  MISSING FIRST RELATION.
C
      CALL WARN(1,RNAME1,0)
      GO TO 9999
  100 CONTINUE
C
C  SAVE DATA ABOUT RELATION 1
C
      I1 = LOCPRM(RNAME1,1)
      IF(I1.EQ.0) GO TO 110
      CALL WARN(9,RNAME1,0)
      GO TO 9999
  110 CONTINUE
      NCOL1 = NCOL
      NATT1 = NATT
      RPW1 = RPW
      MPW1 = MPW
      RNAME2 = BLANK
      CALL LXSREC(4,1,8,RNAME2,1)
      I = LOCREL(RNAME2)
      IF(I.EQ.0) GO TO 200
C
C  MISSING SECOND RELATION.
C
      CALL WARN(1,RNAME2,0)
      GO TO 9999
  200 CONTINUE
C
C  SAVE DATA ABOUT RELATION 2
C
      I2 = LOCPRM(RNAME2,1)
      IF(I2.EQ.0) GO TO 210
      CALL WARN(9,RNAME2,0)
      GO TO 9999
  210 CONTINUE
      NCOL2 = NCOL
      NATT2 = NATT
      RPW2 = RPW
      MPW2 = MPW
C
C  CHECK FOR LEGAL RNAME3
C
      IF((LXLENC(6).GE.1).AND.(LXLENC(6).LE.8)) GO TO 250
      CALL WARN(7,KWRELA,BLANK)
      GO TO 9999
  250 CONTINUE
C
C  CHECK FOR DUPLICATE RELATION 3
C
      RNAME3 = BLANK
      CALL LXSREC(6,1,8,RNAME3,1)
      I = LOCREL(RNAME3)
      IF(I.NE.0) GO TO 300
C
C  ERROR
C
	if(nout.eq.6)goto 3140
      WRITE(NOUT,9000)
 9000 FORMAT(55H -ERROR- Resultant Relation Does Not Have A Unique Name)
      GO TO 9999
3140	continue
	write(c128wk,9000)
	call atxto
	goto 9999
C
C  CHECK USER READ SECURITY
C
  300 CONTINUE
      IF((I1.NE.0).OR.(I2.NE.0)) GO TO 9999
C
C  RELATION NAMES OKAY -- CHECK THE ATTRIBUTES
C
C  SET UP PTABLE IN MATRIX POSITION 10
C
      CALL BLKDEF(10,7,NATT1+NATT2)
      PTABLE = BLKLOC(10)
      NATT3 = 0
      IF(ITEMS.EQ.6) GO TO 500
C
C  INTERSECT ON SOME OF THE ATTRIBUTES
C
      IF(ITEMS-7.LE.NATT1+NATT2) GO TO 350
	if(nout.eq.6)goto 3141
      WRITE(NOUT,9001)
 9001 FORMAT(38H -ERROR- Too Many Attributes Specified)
      GO TO 9999
3141	continue
	write(c128wk,9001)
	call atxto
	goto 9999
  350 CONTINUE
      IJ = 1
      DO 400 I=8,ITEMS
C
C  RETRIEVE ATTRIBUTE LENGTH FOR OLD ATTRIBUTE
C
C
C  SEE IF IT FROM RELATION 1.
C
      ANAME = BLANK
      CALL LXSREC(I,1,8,ANAME,1)
      ICHK1 = LOCATT(ANAME,RNAME1)
C
C  SEE IF IT IS FROM RELATION 2.
C
      ICHK2 = LOCATT(ANAME,RNAME2)
      IF((ICHK1.NE.0).AND.(ICHK2.NE.0)) GO TO 450
C
C  ATTRIBUTE IS OKAY -- SET UP PTABLE
C
      IF(ICHK1.EQ.0) ICHK1 = LOCATT(ANAME,RNAME1)
      IF(ICHK2.EQ.0) ICHK2 = LOCATT(ANAME,RNAME2)
      CALL ATTGET(ISTAT)
      NATT3 = NATT3 + 1
      BUFFER(PTABLE) = LXWREC(I,1)
      BUFFER(PTABLE+1) = LXWREC(I,2)
      IF(ICHK2.EQ.0) BUFFER(PTABLE+3) = ATTCOL
      BUFFER(PTABLE+4) = IJ
      NWORDS = ATTWDS
      BUFFER(PTABLE+5) = ATTLEN
      IF(NWORDS.EQ.0) NWORDS = 1
      IJ = IJ + NWORDS
      BUFFER(PTABLE+6) = ATTYPE
      IF(ICHK1.NE.0) GO TO 360
      ICHK1 = LOCATT(ANAME,RNAME1)
      CALL ATTGET(ISTAT)
      BUFFER(PTABLE+2) = ATTCOL
  360 CONTINUE
      PTABLE = PTABLE + 7
C
  400 CONTINUE
      ICT = IJ - 1
      GO TO 555
C
C  ATTRIBUTE WAS NOT IN EITHER RELATION.
C
  450 CONTINUE
	if(nout.eq.6)goto 3143
      WRITE(NOUT,9002) ANAME
 9002 FORMAT(9H -ERROR- ,A8,33H Is Not Common To Either Relation)
      GO TO 9999
3143	continue
	write(c128wk,9002) aname
	call atxto
	goto 9999
C
C  INTERSECT IS ON ALL ATTRIBUTES
C
  500 CONTINUE
      ICT = 1
C
C  STORE DATA FROM RELATION 1 IN PTABLE
C
      I = LOCATT(BLANK,RNAME1)
      DO 515 I=1,NATT1
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 515
      NATT3 = NATT3 + 1
      BUFFER(PTABLE) = IBLANK
      CALL STRMOV(ATTNAM,1,8,BUFFER(PTABLE),1)
      BUFFER(PTABLE+2) = ATTCOL
      BUFFER(PTABLE+4) = ICT
      NWORDS = ATTWDS
      BUFFER(PTABLE+5) = ATTLEN
      IF(NWORDS.EQ.0) NWORDS = 1
      ICT = ICT + NWORDS
      BUFFER(PTABLE+6) = ATTYPE
      PTABLE = PTABLE + 7
  515 CONTINUE
C
C  STORE DATA FROM RELATION 2 IN PTABLE
C
      KATT3 = NATT3
      I = LOCATT(BLANK,RNAME2)
      DO 550 I=1,NATT2
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 550
C
C  FIRST CHECK TO SEE IF ATTRIBUTE IS ALREADY IN PTABLE.
C
      KQ1 = BLKLOC(10) - 7
      DO 520 J=1,KATT3
      KQ1 = KQ1 + 7
      IF(BUFFER(KQ1+3).NE.0) GO TO 520
      IF(EQ(BUFFER(KQ1),ATTNAM)) GO TO 530
  520 CONTINUE
C
C  NOT THERE -- PUT IT IN.
C
      NATT3 = NATT3 + 1
      BUFFER(PTABLE) = IBLANK
      CALL STRMOV(ATTNAM,1,8,BUFFER(PTABLE),1)
      BUFFER(PTABLE+3) = ATTCOL
      BUFFER(PTABLE+4) = ICT
      NWORDS = ATTWDS
      BUFFER(PTABLE+5) = ATTLEN
      IF(NWORDS.EQ.0) NWORDS = 1
      ICT = ICT + NWORDS
      BUFFER(PTABLE+6) = ATTYPE
      PTABLE = PTABLE + 7
      GO TO 550
C
C  ALREADY THERE -- CHANGE THE 2ND POINTER
C
  530 CONTINUE
      BUFFER(KQ1+3) = ATTCOL
  550 CONTINUE
      ICT = ICT - 1
C
C  DONE LOADING PTABLE
C
C  SEE IF THERE ARE ANY COMMON ATTRIBUTES.
C
  555 CONTINUE
      PTABLE = BLKLOC(10)
      DO 570 I = 1,NATT3
      IF((BUFFER(PTABLE+2).NE.0).AND.(BUFFER(PTABLE+3).NE.0)) GO TO 600
      PTABLE = PTABLE + 7
  570 CONTINUE
C
C  NO COMMON ATTRIBUTES
C
	if(nout.eq.6)goto 3144
      WRITE(NOUT,9003) RNAME1,RNAME2
 9003 FORMAT(19H -ERROR- Relations ,A8,5H AND ,A8,
     X26H Have No Common Attributes)
      GO TO 9999
3144	continue
	write(c128wk,9003) rname1,rname2
	call atxto
	goto 9999
C
C  PTABLE IS CONSTRUCTED
C
C  NOW CREATE ATTRIBUTE AND RELATION TABLES AND THE RELATION
C
  600 CONTINUE
      IF(ICT.GT.MAXCOL) GO TO 9800
C
C  SET UP THE WHERE CLAUSE FOR THE INTERSECT.
C  THIS IS A DUMMY WHERE CLAUSE USED ONLY BY THE KEY PROCESSING
C
      KEYCOL = BUFFER(PTABLE+3)
      KEYTYP = BUFFER(PTABLE+6)
      NBOO = -1
      KATTL(1) = BUFFER(PTABLE+5)
      KATTY(1) = KEYTYP
      IF(KEYTYP.EQ.KZIVEC) KATTY(1) = KZINT
      IF(KEYTYP.EQ.KZRVEC) KATTY(1) = KZREAL
      IF(KEYTYP.EQ.KZDVEC) KATTY(1) = KZDOUB
      IF(KEYTYP.EQ.KZIMAT) KATTY(1) = KZINT
      IF(KEYTYP.EQ.KZRMAT) KATTY(1) = KZREAL
      IF(KEYTYP.EQ.KZDMAT) KATTY(1) = KZDOUB
      KOMPOS(1) = 1
      KSTRT = 0
      MAXTU = ALL9S
      LIMTU = ALL9S
C
C  SET UP RELATION TABLE.
C
      NAME = RNAME3
      CALL RMDATE(RDATE)
      NCOL = ICT
      NCOL3 = ICT
      NATT = NATT3
      NTUPLE = 0
      RSTART = 0
      REND = 0
      RPW = RPW1
      MPW = MPW1
      IF(EQ(RPW,NONE).AND.NE(RPW2,NONE)) RPW = RPW2
      IF(EQ(MPW,NONE).AND.NE(MPW2,NONE)) MPW = MPW2
      CALL RELADD
C
      CALL ATTNEW(NAME,NATT)
      PTABLE = BLKLOC(10)
      DO 700 K=1,NATT3
      ATTNAM = BLANK
      CALL STRMOV(BUFFER(PTABLE),1,8,ATTNAM,1)
      RELNAM = NAME
      ATTCOL = BUFFER(PTABLE+4)
      ATTLEN = BUFFER(PTABLE+5)
      ATTYPE = BUFFER(PTABLE+6)
      ATTKEY = 0
      CALL ATTADD
      PTABLE = PTABLE + 7
  700 CONTINUE
C
C  SEE IF WE CAN DO KEY PROCESSING.
C
      PTABLE = BLKLOC(10) - 7
      DO 800 K=1,NATT3
      PTABLE = PTABLE + 7
      IF(BUFFER(PTABLE+2).EQ.0) GO TO 800
      IF(BUFFER(PTABLE+3).EQ.0) GO TO 800
      J = LOCATT(BUFFER(PTABLE),RNAME1)
      IF(J.NE.0) GO TO 800
      CALL ATTGET(ISTAT)
      IF(ATTKEY.EQ.0) GO TO 800
C
C  WE FOUND A KEY ELEMENT IN MATN1 WHICH IS COMMON.
C
      KSTRT = ATTKEY
      NS = 2
      KATTL(1) = BUFFER(PTABLE+5)
      KATTY(1) = BUFFER(PTABLE+6)
      KEYCOL = BUFFER(PTABLE+3)
      GO TO 900
  800 CONTINUE
  900 CONTINUE
C
C  CALL ISECT TO CONSTRUCT MATN3
C
      CALL BLKDEF(11,MAXCOL,1)
      KQ3 = BLKLOC(11)
      PTABLE = BLKLOC(10)
      I = LOCREL(RNAME2)
      CALL ISECT(RNAME1,RNAME3,BUFFER(KQ3),NCOL3,NATT3,BUFFER(PTABLE),
     XKEYCOL,KEYTYP)
      GO TO 9999
C
C  TUPLE LENGTH EXCEEDS MAXCOL
C
 9800 CONTINUE
	if(nout.eq.6)goto 3416
      WRITE(NOUT,9810) MAXCOL
 9810 FORMAT(36H -ERROR- Relation Row Length Exceeds,I5)
      GO TO 9999
3416	continue
	write(c128wk,9810)maxcol
	call atxto
	goto 9999
C
C  SYNTAX ERROR IN INTERSECT COMMAND
C
 9900 CONTINUE
      CALL WARN(4,0,0)
C
C
C  DONE WITH INTERSECT
C
 9999 CONTINUE
      CALL BLKCLR(10)
      CALL BLKCLR(11)
      RETURN
      END
      SUBROUTINE ITOC(STRING,CHAR1,NUMC,INT,IERR)
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE CONVERTS AN INTEGER TO TEXT AND PUTS
C     THE TEXT IN STRING.  IF THE INTEGER WILL NOT FIT, STRING IS
C     BLANKED OUT AND IERR IS RETURNED NON-ZERO.
C
C     STRING....REPOSITORY FOR TEXT OF INT
C     CHAR1.....1'ST CHARACTER POSITION IN STRING TO USE
C     NUMC......NUMBER OF CHARACTERS ALLOWED FOR INT
C               AT MOST 14 CHARACTERS WILL BE USED
C     INT.......INTEGER TO CONVERT.
C     IERR......0 IF INT FITS, 1 OTHERWISE
C
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:MISC.BLK
      INTEGER STRING(*),CHAR1
      INTEGER DIGITS(10),C(14)
      EQUIVALENCE (DIGITS(1),K40)
C
C     BLANK OUT STRING
C
      IC = CHAR1 - 1
      DO 10 I=1,NUMC
      IC = IC + 1
      CALL PUTT(STRING,IC,BLANK)
   10 CONTINUE
C
C     SEE IF INT FITS
C
      NUM = NUMC
      IF(NUM.GT.9) NUM = 9
      IN = IABS(INT)
      IF(INT.LT.0) NUM = NUM - 1
      IERR = 1
      IF(IN.GE.10**NUM) GO TO 1000
C
C     FITS - BUILD STRING OF CHARACTERS IN C
C
      NC = 0
      IERR = 0
   20 CONTINUE
      IN1 = IN/10
      IC = IN - 10*IN1
      NC = NC + 1
      C(NC) = DIGITS(IC+1)
      IN = IN1
      IF(IN.GT.0) GO TO 20
C
C     NOW BUILD STRING
C
      ISTART = CHAR1 + NUMC - NC - 1
      IF(INT.GE.0) GO TO 40
C
C     NEGATIVE - ADD SIGN
C
      CALL PUTT(STRING,ISTART,K4MNUS)
   40 CONTINUE
C
C     MOVE IN STRING
C
      DO 60 I=1,NC
      ISTART = ISTART + 1
      CALL PUTT(STRING,ISTART,C(NC-I+1))
   60 CONTINUE
 1000 CONTINUE
      RETURN
      END
      SUBROUTINE ITOH(I,J,K)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   UNPACK I AND J FROM K
C
C  I WAS MULTIPLIED BY 100000.
C
      I = K / 100000
      J = K - (100000 * I)
      RETURN
      END
      SUBROUTINE JOIN(RNAME1,RNAME3,MATN3,NCOL3,NATT3,PTABLE,
     XKEYCOL,KEYTYP)
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE PERFORMS THE ACTUAL JOIN BETWEEN
C  RELATION 1 AND 2 FORMING 3
C
C  PARAMETERS:
C         NAME1---NAME OF THE FIRST RELATION
C         MATN3---DATA TUPLE FOR RELATION 3
C         NCOL3---NUMBER OF FIXED LENGTH COLUMNS IN MATN3
C         NATT3---NUMBER OF ATTRIBUTES IN MATN3
C         PTABLE--POINTER TABLE FOR THIS INTERSECT
C         KEYCOL--COLUMN OF MATN2 USED FOR SUPPLYING KEY VALUES
C         KEYTYP--ATTRIBUTE TYPE OF MATN1 USED FOR KEY VALUES
      INCLUDE rin:MISC.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:DCLAR1.BLK
      DIMENSION MATN3(*)
      INTEGER PTABLE(7,*)
      INTEGER ATTLEN
      INTEGER ENDCOL
C
C  INITIALIZE THE MATRIX POINTERS.
C
      IERR = 0
      IDST = 0
      IDNEW = 0
      IDCUR = NID
C
C  GET THE PARAMETERS FOR THE FIRST MATRIX.
C
      I = LOCREL(RNAME1)
      IDM1 = NID
      NSP = 0
      IF(KSTRT.NE.0) NSP = 2
      NTUP3 = 0
      ICROW = 0
      NUMWAR = 0
C
C  SEQUENCE THROUGH MATN2.
C
  100 CONTINUE
      IF(IDCUR.EQ.0) GO TO 1000
      CALL ITOH(N1,N2,IDCUR)
      IF(N2.EQ.0) GO TO 1000
      CALL GETDAT(2,IDCUR,MATN2,NCOL2)
      IF(IDCUR.LT.0) GO TO 1000
      ICROW = ICROW + 1
C
C  MOVE THE COMPARISON VALUE INTO THE WHCOM ARRAYS.
C
      CALL ITOH(NCHAR,NWORDS,KATTL(1))
      IP = MATN2 + KEYCOL - 1
      IF(NWORDS.NE.0) GO TO 110
C
C  SPECIAL GYRATIONS FOR VARIABLE LENGTH STUFF.
C
      IP2 = BUFFER(IP)
      IP = MATN2 + IP2 - 1
      NWORDS = BUFFER(IP)
      IF(NWORDS.LE.300) GO TO 105
      NUMWAR = NUMWAR + 1
	if(numwar.ge.100)goto 100
	if(nout.eq.6)goto 2
       WRITE (NOUT,103)ICROW
  103 FORMAT(15H -WARNING- ROW ,I6,
     X       35H IGNORED Because Attribute Too Long)
      GO TO 100
2	continue
	write(c128wk,103)icrow
	call atxto
	goto 100
  105 CONTINUE
      IP = IP + 2
      NCHAR = BUFFER(IP-1)
  110 CONTINUE
      CALL HTOI(NCHAR,NWORDS,WHRLEN(1))
      CALL BLKMOV(WHRVAL(1),BUFFER(IP),NWORDS)
      NID = IDM1
      NS = NSP
  200 CONTINUE
      CALL RMLOOK(MATN1,1,1,NCOL1)
      IF(RMSTAT.NE.0) GO TO 100
C
C  OKAY -- NOW LOAD THE DATA.
C
  400 CONTINUE
      ENDCOL = NCOL3
      DO 900 KLM=1,NATT3
      KOL1 = PTABLE(3,KLM)
      KOL2 = PTABLE(4,KLM)
      KOL3 = PTABLE(5,KLM)
      ATTLEN = PTABLE(6,KLM)
      CALL ITOH(NCHAR,NWORDS,ATTLEN)
      IF(NWORDS.EQ.0) GO TO 700
      DO 600 I=1,NWORDS
      IF(KOL1.EQ.0) GO TO 500
C
C  LOAD THE ATTRIBUTE FROM MATN1.
C
      I1 = MATN1 + KOL1 - 1
      MATN3(KOL3) = BUFFER(I1)
      KOL3 = KOL3 + 1
      KOL1 = KOL1 + 1
      GO TO 600
  500 CONTINUE
C
C  LOAD THE ATTRIBUTE FROM MATN2.
C
      I2 = MATN2 + KOL2 - 1
      MATN3(KOL3) = BUFFER(I2)
      KOL3 = KOL3 + 1
      KOL2 = KOL2 + 1
  600 CONTINUE
      GO TO 900
  700 CONTINUE
      ENDCOL = ENDCOL + 1
      MATN3(KOL3) = ENDCOL
      IF(KOL1.EQ.0) GO TO 710
C
C  USE POINTERS FROM MATN1.
C
      I1 = MATN1 + KOL1 - 1
      KOL1 = BUFFER(I1)
      I2 = MATN1 + KOL1 - 1
      NWORDS = BUFFER(I2)
      GO TO 720
  710 CONTINUE
C
C  USE POINTERS FROM MATN2.
C
      I2 = MATN2 + KOL2 - 1
      KOL2 = BUFFER(I2)
      I2 = MATN2 + KOL2 - 1
      NWORDS = BUFFER(I2)
  720 CONTINUE
C
C  LOAD UP THE VALUES.
C
      IF((ENDCOL+NWORDS+1).GT.MAXCOL) GO TO 950
      MATN3(ENDCOL) = NWORDS
      NWORDS = NWORDS + 1
      DO 800 I=1,NWORDS
      ENDCOL = ENDCOL + 1
      I2 = I2 + 1
      MATN3(ENDCOL) = BUFFER(I2)
  800 CONTINUE
  900 CONTINUE
      CALL ADDDAT(3,IDNEW,MATN3,ENDCOL)
      IF(IDST.EQ.0) IDST = IDNEW
      NTUP3 = NTUP3 + 1
C
C  LOOK FOR MORE IN MATN1.
C
      GO TO 200
C
C  TUPLE LENGTH EXCEEDS MAXCOL
C
  950 CONTINUE
      IERR = 1
	if(nout.eq.6)goto 3
      WRITE(NOUT,960) MAXCOL
  960 FORMAT(36H -ERROR- Relation Row Length Exceeds,I5)
	goto 1000
3	continue
	write(c128wk,960)maxcol
	call atxto
C
C  ALL DONE.
C
 1000 CONTINUE
      I = LOCREL(RNAME3)
      CALL RELGET(ISTAT)
      RSTART = IDST
      REND = IDNEW
      NTUPLE = NTUP3
      CALL RELPUT
      NUM = NTUP3
	if(ierr.ne.0)return
	if(nout.eq.6)goto 4
       WRITE(NOUT,9000) NUM
 9000 FORMAT(27H Successful JOIN Operation ,
     XI6,15H Rows Generated)
C
C  RETURN
C
      RETURN
4	continue
	write(c128wk,9000)num
	call atxto
	return
      END
      SUBROUTINE JOIREL
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE FINDS THE JOIN OF TWO RELATIONS BASED UPON JOINING
C  TWO ATTRIBUTES.  THE RESULT FROM THIS PROCESS IS A PHYSICAL
C  RELATION WHICH HAS TUPLES CONTRUCTED FROM BOTH RELATIONS
C  WHERE THE SPECIFIED ATTRIBUTES MATCH AS REQUESTED.
C
C  THE SYNTAX FOR THE JOIN COMMAND IS:
C
C  JOIN REL1 USING ATT1 WITH REL2 USING ATT2 FORMING REL3 WHERE EQ
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:MISC.BLK
C
      INTEGER PTABLE
      LOGICAL EQ
      LOGICAL NE
      LOGICAL EQKEYW
      INCLUDE rin:DCLAR1.BLK
      INCLUDE rin:DCLAR3.BLK
C
C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
C
      CALL RMDBLK(DBNAME)
      IF(RMSTAT.EQ.0) GO TO 40
      CALL WARN(RMSTAT,DBNAME,0)
      GO TO 9999
C
C  LOCAL ARRAYS AND VARIABLES :
C
C  PTABLE (MATRIX 10) USED TO CONTROL POINTERS
C        ROWS1,2 -- ATTRIBUTE NAME
C        ROW3 -- ATTRIBUTE LOCATION IN RELATION 1
C        ROW4 -- ATTRIBUTE LOCATION IN RELATION 2
C        ROW5 -- ATTRIBUTE LOCATION IN RELATION 3
C        ROW6 -- LENGTH IN WORDS
C        ROW7 -- ATTRIBUTE TYPE
C
C  EDIT COMMAND SYNTAX
C
   40 CONTINUE
      CALL BLKCLN
      IF(.NOT.EQKEYW(3,KWUSIN,5)) GO TO 9900
      IF(.NOT.EQKEYW(5,KWWITH,4)) GO TO 9900
      IF(.NOT.EQKEYW(7,KWUSIN,5)) GO TO 9900
      IF(.NOT.EQKEYW(9,KWFORM,7)) GO TO 9900
      ITEMS = LXITEM(IDUMMY)
C
C  SET DEFAULT WHERE CONDITION (EQ OR NK = 2)
C
      NK = 2
      IF(ITEMS.LE.10) GO TO 50
C
C  CHECK WHERE COMPARISON.
C
      IF(.NOT.EQKEYW(11,KWWHER,5)) GO TO 9900
      NK = LOCBOO(LXWREC(12,1))
      IF(NK.EQ.0) GO TO 9900
      IF(NK.EQ.1) GO TO 9900
   50 CONTINUE
C
C  KEYWORD SYNTAX OKAY
C
      RNAME1 = BLANK
      CALL LXSREC(2,1,8,RNAME1,1)
      I = LOCREL(RNAME1)
      IF(I.EQ.0) GO TO 100
C
C  MISSING FIRST RELATION.
C
      CALL WARN(1,RNAME1,0)
      GO TO 9999
  100 CONTINUE
C
C  SAVE DATA ABOUT RELATION 1
C
      I1 = LOCPRM(RNAME1,1)
      IF(I1.EQ.0) GO TO 110
      CALL WARN(9,RNAME1,0)
      GO TO 9999
  110 CONTINUE
      NCOL1 = NCOL
      NATT1 = NATT
      RPW1 = RPW
      MPW1 = MPW
C
C  CHECK THE COMPARISON ATTRIBUTE.
C
      ANAME1 = BLANK
      CALL LXSREC(4,1,8,ANAME1,1)
      I = LOCATT(ANAME1,RNAME1)
      IF(I.NE.0) CALL WARN(3,ANAME1,RNAME1)
      IF(I.NE.0) GO TO 9999
      RNAME2 = BLANK
      CALL LXSREC(6,1,8,RNAME2,1)
      I = LOCREL(RNAME2)
      IF(I.EQ.0) GO TO 200
C
C  MISSING SECOND RELATION.
C
      CALL WARN(1,RNAME2,0)
      GO TO 9999
  200 CONTINUE
C
C  SAVE DATA ABOUT RELATION 2
C
      I2 = LOCPRM(RNAME2,1)
      IF(I2.EQ.0) GO TO 210
      CALL WARN(9,RNAME2,0)
      GO TO 9999
  210 CONTINUE
      NCOL2 = NCOL
      NATT2 = NATT
      RPW2 = RPW
      MPW2 = MPW
C
C  CHECK THE COMPARISON ATTRIBUTE.
C
      ANAME2 = BLANK
      CALL LXSREC(8,1,8,ANAME2,1)
      I = LOCATT(ANAME2,RNAME2)
      IF(I.NE.0) CALL WARN(3,ANAME2,RNAME2)
      IF(I.NE.0) GO TO 9999
C
C  CHECK FOR LEGAL RNAME3
C
      IF((LXLENC(10).GE.1).AND.(LXLENC(10).LE.8)) GO TO 250
      CALL WARN(7,KWRELA,BLANK)
      GO TO 9999
  250 CONTINUE
C
C  CHECK FOR DUPLICATE RELATION 3
C
      RNAME3 = BLANK
      CALL LXSREC(10,1,8,RNAME3,1)
      I = LOCREL(RNAME3)
      IF(I.NE.0) GO TO 300
C
C  ERROR
C
	if(nout.eq.6)goto 1
      WRITE(NOUT,9000)
 9000 FORMAT(55H -ERROR- Resultant Relation Does Not Have A Unique Name)
      GO TO 9999
1	continue
	write(c128wk,9000)
	call atxto
	goto 9999
C
C  CHECK USER READ SECURITY
C
  300 CONTINUE
      IF((I1.NE.0).OR.(I2.NE.0)) GO TO 9999
C
C  RELATION NAMES OKAY -- CHECK THE ATTRIBUTES
C
C  SET UP PTABLE IN MATRIX POSITION 10
C
      CALL BLKDEF(10,7,NATT1+NATT2)
      PTABLE = BLKLOC(10)
      NATT3 = 0
      ICT = 1
C
C  STORE DATA FROM RELATION 1 IN PTABLE
C
      I = LOCATT(BLANK,RNAME1)
      DO 500 I=1,NATT1
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 500
      NATT3 = NATT3 + 1
      BUFFER(PTABLE) = IBLANK
      CALL STRMOV(ATTNAM,1,8,BUFFER(PTABLE),1)
      BUFFER(PTABLE+2) = ATTCOL
      BUFFER(PTABLE+4) = ICT
      NWORDS = ATTWDS
      BUFFER(PTABLE+5) = ATTLEN
      IF(NWORDS.EQ.0) NWORDS = 1
      ICT = ICT + NWORDS
      BUFFER(PTABLE+6) = ATTYPE
      PTABLE = PTABLE + 7
  500 CONTINUE
C
C  STORE DATA FROM RELATION 2 IN PTABLE
C
      KATT3 = NATT3
      I = LOCATT(BLANK,RNAME2)
      DO 550 I=1,NATT2
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 550
C
C  FIRST CHECK TO SEE IF ATTRIBUTE IS ALREADY IN PTABLE.
C
      KQ1 = BLKLOC(10) - 7
      DO 520 J=1,KATT3
      KQ1 = KQ1 + 7
      IF(BUFFER(KQ1+3).NE.0) GO TO 520
      IF(NE(BUFFER(KQ1),ATTNAM)) GO TO 520
	if(nout.eq.6)goto 3
      WRITE(NOUT,9003) ATTNAM
 9003 FORMAT(11H -WARNING- ,A8,30H is a DUPLICATE attribute name)
      WRITE(NOUT,9004)
 9004 FORMAT(53H You should rename it before doing queries or updates)
      GO TO 530
3	continue
      WRITE(c128wk,9003) ATTNAM
	call atxto
      WRITE(c128wk,9004)
	call atxto
	goto 530
  520 CONTINUE
  530 CONTINUE
C
C  ADD THE DATA TO PTABLE.
C
      NATT3 = NATT3 + 1
      BUFFER(PTABLE) = IBLANK
      CALL STRMOV(ATTNAM,1,8,BUFFER(PTABLE),1)
      BUFFER(PTABLE+3) = ATTCOL
      BUFFER(PTABLE+4) = ICT
      NWORDS = ATTWDS
      BUFFER(PTABLE+5) = ATTLEN
      IF(NWORDS.EQ.0) NWORDS = 1
      ICT = ICT + NWORDS
      BUFFER(PTABLE+6) = ATTYPE
      PTABLE = PTABLE + 7
  550 CONTINUE
      ICT = ICT - 1
C
C  PTABLE IS CONSTRUCTED
C
C  NOW CREATE ATTRIBUTE AND RELATION TABLES AND THE RELATION
C
      IF(ICT.GT.MAXCOL) GO TO 9850
C
C  SET UP THE WHERE CLAUSE FOR THE JOIN.
C
      I = LOCATT(ANAME2,RNAME2)
      CALL ATTGET(ISTAT)
      IF(ATTWDS.GT.300) GO TO 9870
      KEYCOL = ATTCOL
      KEYTYP = ATTYPE
      KEYLEN = ATTLEN
      NBOO = 1
      BOO(1) = K4AND
      I = LOCATT(ANAME1,RNAME1)
      CALL ATTGET(ISTAT)
      KATTP(1) = ATTCOL
      KATTL(1) = ATTLEN
C
C  MAKE SURE THE ATTRIBUTE TYPES MATCH.
C
      IF(KEYTYP.NE.ATTYPE) GO TO 9800
      IF(KEYLEN.NE.ATTLEN) GO TO 9700
      KATTY(1) = ATTYPE
      IF(KEYTYP.EQ.KZIVEC) KATTY(1) = KZINT
      IF(KEYTYP.EQ.KZRVEC) KATTY(1) = KZREAL
      IF(KEYTYP.EQ.KZDVEC) KATTY(1) = KZDOUB
      IF(KEYTYP.EQ.KZIMAT) KATTY(1) = KZINT
      IF(KEYTYP.EQ.KZRMAT) KATTY(1) = KZREAL
      IF(KEYTYP.EQ.KZDMAT) KATTY(1) = KZDOUB
      KOMTYP(1) = NK
      KOMPOS(1) = 1
      KOMLEN(1) = 1
      KOMPOT(1) = 1
      KSTRT = ATTKEY
      IF(NK.NE.2) KSTRT = 0
      MAXTU = ALL9S
      LIMTU = ALL9S
C
C  SET UP RELATION TABLE.
C
      NAME = RNAME3
      CALL RMDATE(RDATE)
      NCOL = ICT
      NCOL3 = ICT
      NATT = NATT3
      NTUPLE = 0
      RSTART = 0
      REND = 0
      RPW = RPW1
      MPW = MPW1
      IF(EQ(RPW,NONE).AND.NE(RPW2,NONE)) RPW = RPW2
      IF(EQ(MPW,NONE).AND.NE(MPW2,NONE)) MPW = MPW2
      CALL RELADD
C
      CALL ATTNEW(NAME,NATT)
      PTABLE = BLKLOC(10)
      DO 700 K=1,NATT3
      ATTNAM = BLANK
      CALL STRMOV(BUFFER(PTABLE),1,8,ATTNAM,1)
      RELNAM = NAME
      ATTCOL = BUFFER(PTABLE+4)
      ATTLEN = BUFFER(PTABLE+5)
      ATTYPE = BUFFER(PTABLE+6)
      ATTKEY = 0
      CALL ATTADD
      PTABLE = PTABLE + 7
  700 CONTINUE
C
C  CALL JOIN TO CONSTRUCT MATN3
C
      CALL BLKDEF(11,MAXCOL,1)
      KQ3 = BLKLOC(11)
      PTABLE = BLKLOC(10)
      I = LOCREL(RNAME2)
      CALL JOIN(RNAME1,RNAME3,BUFFER(KQ3),NCOL3,NATT3,BUFFER(PTABLE),
     XKEYCOL,KEYTYP)
      GO TO 9999
C
C  MISMATCHED DATA TYPES.
C
 9700 CONTINUE
	if(nout.eq.6)goto 4
      WRITE(NOUT,9006)
 9006 FORMAT(46H -ERROR- JOIN attributes are different lengths )
      GO TO 9999
4	continue
	write(c128wk,9006)
	call atxto
	goto 9999
 9800 CONTINUE
	if(nout.eq.6)goto 5
      WRITE(NOUT,9005)
 9005 FORMAT(44H -ERROR- JOIN attributes are different types)
      GO TO 9999
5	continue
	write(c128wk,9005)
	call atxto
	goto 9999
C
C  TUPLE LENGTH EXCEEDS MAXCOL
C
 9850 CONTINUE
	if (nout.eq.6)goto 6
      WRITE(NOUT,9860) MAXCOL
 9860 FORMAT(36H -ERROR- Relation ROW LENGTH Exceeds,I5)
      GO TO 9999
6	continue
	write(c128wk,9860)maxcol
	call atxto
	goto 9999
 9870 CONTINUE
	if(nout.eq.6)goto 7
      WRITE (NOUT,9880)
 9880 FORMAT(32H -ERROR- JOIN attribute too long )
      GO TO 9999
7	continue
	write(c128wk,9880)
	call atxto
	goto 9999
C
C  SYNTAX ERROR IN JOIN COMMAND
C
 9900 CONTINUE
      CALL WARN(4,0,0)
C
C
C  DONE WITH INTERSECT
C
 9999 CONTINUE
      CALL BLKCLR(10)
      CALL BLKCLR(11)
      RETURN
      END
      SUBROUTINE KMPARD(VALUE1,VALUE2,LEN,NK,OK)
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE COMPARES VALUE1 AND VALUE2 TO SEE IF THEY MEET THE
C  DESIRED CONDITIONS.
C
C  PARAMETERS
C         VALUE1--FIRST VALUE
C         VALUE2--SECOND VALUE
C         LEN-----VALUE LENGTHS
C         NK------NUMBER FOR COMPARISON TYPE
C         OK------.FALSE. COMING IN, .TRUE. GOING OUT IF THE CONDITIONS
C                 ARE MET
C
      INCLUDE rin:FLAGS.BLK
      DOUBLE PRECISION TOLL
      DOUBLE PRECISION VALUE1(*),VALUE2(*)
      LOGICAL OK
      TOLL = TOL
C
C  BRANCH ON THE VALUE OF NK.
C
      IF(NK.NE.2) GO TO 30
C  EQ.
      IF(TOL.NE.0.) GO TO 26
      DO 25 I=1,LEN
      IF(VALUE1(I).NE.VALUE2(I)) GO TO 999
   25 CONTINUE
      GO TO 900
   26 CONTINUE
      IF(PCENT) GO TO 28
      DO 27 I=1,LEN
      IF(VALUE1(I).LT.(VALUE2(I)-TOLL)) GO TO 999
      IF(VALUE1(I).GT.(VALUE2(I)+TOLL)) GO TO 999
   27 CONTINUE
      GO TO 900
   28 CONTINUE
      DO 29 I=1,LEN
      IF(VALUE1(I).LT.(VALUE2(I)*(1.-TOLL))) GO TO 999
      IF(VALUE1(I).GT.(VALUE2(I)*(1.+TOLL))) GO TO 999
   29 CONTINUE
      GO TO 900
   30 IF(NK.NE.3) GO TO 40
C  NE.
      IF(TOL.NE.0.) GO TO 36
      DO 35 I=1,LEN
      IF(VALUE1(I).NE.VALUE2(I)) GO TO 900
   35 CONTINUE
      GO TO 999
   36 CONTINUE
      IF(PCENT) GO TO 38
      DO 37 I=1,LEN
      IF(VALUE1(I).LT.(VALUE2(I)-TOLL)) GO TO 900
      IF(VALUE1(I).GT.(VALUE2(I)+TOLL)) GO TO 900
   37 CONTINUE
      GO TO 999
   38 CONTINUE
      DO 39 I=1,LEN
      IF(VALUE1(I).LT.(VALUE2(I)*(1.-TOLL))) GO TO 900
      IF(VALUE1(I).GT.(VALUE2(I)*(1.+TOLL))) GO TO 900
   39 CONTINUE
      GO TO 999
   40 IF((NK.NE.4).AND.(NK.NE.5)) GO TO 60
C  GT AND GE.
      DO 45 I=1,LEN
      IF(VALUE1(I).GT.VALUE2(I)) GO TO 900
      IF(VALUE1(I).LT.VALUE2(I)) GO TO 999
   45 CONTINUE
      IF(NK.EQ.5) GO TO 900
      GO TO 999
   60 IF((NK.NE.6).AND.(NK.NE.7)) GO TO 80
C  LT AND LE.
      DO 65 I=1,LEN
      IF(VALUE1(I).LT.VALUE2(I)) GO TO 900
      IF(VALUE1(I).GT.VALUE2(I)) GO TO 999
   65 CONTINUE
      IF(NK.EQ.7) GO TO 900
      GO TO 999
   80 CONTINUE
      GO TO 999
  900 OK = .TRUE.
  999 RETURN
      END
      SUBROUTINE KMPARI(VALUE1,VALUE2,LEN,NK,OK)
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE COMPARES VALUE1 AND VALUE2 TO SEE IF THEY MEET THE
C  DESIRED CONDITIONS.
C
C  PARAMETERS
C         VALUE1--FIRST VALUE
C         VALUE2--SECOND VALUE
C         LEN-----VALUE LENGTHS
C         NK------NUMBER FOR COMPARISON TYPE
C         OK------.FALSE. COMING IN, .TRUE. GOING OUT IF THE CONDITIONS
C                 ARE MET
C
      INTEGER VALUE1(*),VALUE2(*)
      LOGICAL OK
C
C  BRANCH ON THE VALUE OF NK.
C
      IF(NK.NE.2) GO TO 30
C  EQ.
      DO 25 I=1,LEN
      IF(VALUE1(I).NE.VALUE2(I)) GO TO 999
   25 CONTINUE
      GO TO 900
   30 IF(NK.NE.3) GO TO 40
C  NE.
      DO 35 I=1,LEN
      IF(VALUE1(I).NE.VALUE2(I)) GO TO 900
   35 CONTINUE
      GO TO 999
   40 IF((NK.NE.4).AND.(NK.NE.5)) GO TO 60
C  GT AND GE.
      DO 45 I=1,LEN
      IF(VALUE1(I).GT.VALUE2(I)) GO TO 900
      IF(VALUE1(I).LT.VALUE2(I)) GO TO 999
   45 CONTINUE
      IF(NK.EQ.5) GO TO 900
      GO TO 999
   60 IF((NK.NE.6).AND.(NK.NE.7)) GO TO 80
C  LT AND LE.
      DO 65 I=1,LEN
      IF(VALUE1(I).LT.VALUE2(I)) GO TO 900
      IF(VALUE1(I).GT.VALUE2(I)) GO TO 999
   65 CONTINUE
      IF(NK.EQ.7) GO TO 900
      GO TO 999
   80 CONTINUE
      GO TO 999
  900 OK = .TRUE.
  999 RETURN
      END
      SUBROUTINE KMPARR(VALUE1,VALUE2,LEN,NK,OK)
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE COMPARES VALUE1 AND VALUE2 TO SEE IF THEY MEET THE
C  DESIRED CONDITIONS.
C
C  PARAMETERS
C         VALUE1--FIRST VALUE
C         VALUE2--SECOND VALUE
C         LEN-----VALUE LENGTHS
C         NK------NUMBER FOR COMPARISON TYPE
C         OK------.FALSE. COMING IN, .TRUE. GOING OUT IF THE CONDITIONS
C                 ARE MET
C
      INCLUDE rin:FLAGS.BLK
      REAL VALUE1(*),VALUE2(*)
      LOGICAL OK
C
C  BRANCH ON THE VALUE OF NK.
C
      IF(NK.NE.2) GO TO 30
C  EQ.
      IF(TOL.NE.0.) GO TO 26
      DO 25 I=1,LEN
      IF(VALUE1(I).NE.VALUE2(I)) GO TO 999
   25 CONTINUE
      GO TO 900
   26 CONTINUE
      IF(PCENT) GO TO 28
      DO 27 I=1,LEN
      IF(VALUE1(I).LT.(VALUE2(I)-TOL)) GO TO 999
      IF(VALUE1(I).GT.(VALUE2(I)+TOL)) GO TO 999
   27 CONTINUE
      GO TO 900
   28 CONTINUE
      DO 29 I=1,LEN
      IF(VALUE1(I).LT.(VALUE2(I)*(1.-TOL))) GO TO 999
      IF(VALUE1(I).GT.(VALUE2(I)*(1.+TOL))) GO TO 999
   29 CONTINUE
      GO TO 900
   30 IF(NK.NE.3) GO TO 40
C  NE.
      IF(TOL.NE.0.) GO TO 36
      DO 35 I=1,LEN
      IF(VALUE1(I).NE.VALUE2(I)) GO TO 900
   35 CONTINUE
      GO TO 999
   36 CONTINUE
      IF(PCENT) GO TO 38
      DO 37 I=1,LEN
      IF(VALUE1(I).LT.(VALUE2(I)-TOL)) GO TO 900
      IF(VALUE1(I).GT.(VALUE2(I)+TOL)) GO TO 900
   37 CONTINUE
      GO TO 999
   38 CONTINUE
      DO 39 I=1,LEN
      IF(VALUE1(I).LT.(VALUE2(I)*(1.-TOL))) GO TO 900
      IF(VALUE1(I).GT.(VALUE2(I)*(1.+TOL))) GO TO 900
   39 CONTINUE
      GO TO 999
   40 IF((NK.NE.4).AND.(NK.NE.5)) GO TO 60
C  GT AND GE.
      DO 45 I=1,LEN
      IF(VALUE1(I).GT.VALUE2(I)) GO TO 900
      IF(VALUE1(I).LT.VALUE2(I)) GO TO 999
   45 CONTINUE
      IF(NK.EQ.5) GO TO 900
      GO TO 999
   60 IF((NK.NE.6).AND.(NK.NE.7)) GO TO 80
C  LT AND LE.
      DO 65 I=1,LEN
      IF(VALUE1(I).LT.VALUE2(I)) GO TO 900
      IF(VALUE1(I).GT.VALUE2(I)) GO TO 999
   65 CONTINUE
      IF(NK.EQ.7) GO TO 900
      GO TO 999
   80 CONTINUE
      GO TO 999
  900 OK = .TRUE.
  999 RETURN
      END
      SUBROUTINE KMPART(VALUE1,VALUE2,LEN,NK,OK)
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE COMPARES LEN'S WORTH OF TEXT WORDS TO
C     SEE IF THEY MEET THE SPECIFIED CONDITION.
C     THE ROUTINE SWITCP IS USED TO ACTUALLY COMPARE
C     TWO WORDS.
C
C     PARAMETERS
C       VALUE1....LIST OF WORDS OF TEXT
C       VALUE2....LIST OF WORDS OF TEXT
C       LEN.......LENGTH OF VALUE1,VALUE2
C       NK........VALUE1 NK'S VALUE2
C                 NK IS AN INTEGER WITH THE FOLLOWING VALUES
C                 NK=2   EQ
C                    3   NE
C                    4   GT
C                    5   GE
C                    6   LT
C                    7   LE
C
C       OK........ .FALSE. COMING IN, .TRUE. GOING OUT IF
C                 CONDITION IS SATISFIED.
C
      INTEGER VALUE1(LEN),VALUE2(LEN)
      INTEGER SWITCP
      LOGICAL OK
      IF(NK.LT.2) GO TO 999
      IF(NK.GT.7) GO TO 999
C
C     LOOP ON VALUES TO COMPARE
C
      DO 100 I=1,LEN
C
C  COMPARE TWO VALUES 0=EQ  -1=GT  1=LT
C
      J = SWITCP(VALUE1(I),VALUE2(I))
      IF(J.EQ.0) GO TO 100
      IF(NK.EQ.2) GO TO 999
      K = 5 - J
      IF(NK.EQ.K) GO TO 999
      IF(NK.EQ.K+1) GO TO 999
      GO TO 200
  100 CONTINUE
C
C     EQUAL
C
      IF(NK.EQ.3) GO TO 999
      IF(NK.EQ.4) GO TO 999
      IF(NK.EQ.6) GO TO 999
  200 CONTINUE
      OK = .TRUE.
  999 CONTINUE
      RETURN
      END
      SUBROUTINE KOMPXX(VALUE1,VALUE2,LEN,NK,OK,TYPE)
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE COMPARES VALUE1 AND VALUE2 TO SEE IF THEY MEET THE
C  DESIRED CONDITIONS.
C
C  PARAMETERS
C         VALUE1--FIRST VALUE
C         VALUE2--SECOND VALUE
C         LEN-----VALUE LENGTHS
C         NK------NUMBER FOR COMPARISON TYPE
C         OK------.FALSE. COMING IN, .TRUE. GOING OUT IF THE CONDITIONS
C                 ARE MET
C         TYPE----TYPE OF VALUES BEING COMPARED
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:MISC.BLK
C
      INTEGER VALUE1(*)
      INTEGER VALUE2(*)
      INTEGER TYPE
      LOGICAL OK
      IF(NK.NE.-1) GO TO 10
C  FAILS.
      IF(VALUE1(1).EQ.NULL) OK = .TRUE.
      GO TO 999
   10 CONTINUE
      IF(VALUE1(1).EQ.NULL) GO TO 999
      IF(NK.NE.1) GO TO 20
C  EXISTS
      OK = .TRUE.
      GO TO 999
   20 CONTINUE
      IF(TYPE.EQ.KZINT)
     X CALL KMPARI(VALUE1,VALUE2,LEN,NK,OK)
      IF(TYPE.EQ.KZREAL)
     X CALL KMPARR(VALUE1,VALUE2,LEN,NK,OK)
      IF(TYPE.EQ.KZDOUB)
     X CALL KMPARD(VALUE1,VALUE2,LEN/2,NK,OK)
      IF(TYPE.EQ.KZTEXT)
     X CALL KMPART(VALUE1,VALUE2,LEN,NK,OK)
  999 CONTINUE
      RETURN
      END
      INTEGER FUNCTION LFIND(ITEM1,NUM,KEY,NCHAR)
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE LOOKS FOR A KEYWORD IN THE LXLREC
C     RECORD.  IT RETURNS 0 IF NOT FOUND AND THE ITEM
C     NUMBER IF FOUND.
C
      LOGICAL EQKEYW
      INTEGER KEY(*)
      NEND = ITEM1 + NUM - 1
      DO 10 J=ITEM1,NEND
      IF(EQKEYW(J,KEY,NCHAR)) GO TO 20
   10 CONTINUE
      J = 0
   20 CONTINUE
      LFIND = J
      RETURN
      END
      SUBROUTINE LOADIT(MAT)
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE IS THE FORTRAN ROUTINE FOR LOADING DATA VALUES IN THE
C  RIM DATA BASE.
C
C  PARAMETERS:
C         MAT-----SCRATCH ARRAY FOR BUILDING TUPLES
C
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:RULCOM.BLK
      INCLUDE rin:START.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:FLAGS.BLK
C
C  DIMENSION STATEMENTS.
      INTEGER COLUMN
      LOGICAL EQKEYW
      DOUBLE PRECISION DTEMP
      REAL TEMP(2)
      INTEGER ITEMP(2)
      EQUIVALENCE (DTEMP,TEMP(1))
      EQUIVALENCE (TEMP(1),ITEMP(1))
      INTEGER ENDCOL
      INTEGER MAT(*)
C
C  READ A CARD.
C
  100 CONTINUE
      CALL LODREC
      LSTCMD = K4LOA
      ITEMS = LXITEM(IDUMMY)
      IF(ITEMS.GT.2) GO TO 160
      IF(EQKEYW(1,KWLOAD,4)) GO TO 5000
      IF(ITEMS.GT.1) GO TO 160
      IF(EQKEYW(1,KWCHEC,5)) GO TO 3000
      IF(EQKEYW(1,KWNOCH,7)) GO TO 4000
      IF(EQKEYW(1,KWEND,3)) GO TO 5000
  160 CONTINUE
C
C  ASSUME THIS IS A DATA CARD.
C
C  ZERO OUT THE TUPLE.
C
      CALL ZEROIT(MAT,MAXCOL)
C
C  CHECK EACH ATTRIBUTE AND MOVE IT TO THE TUPLE FROM INPUT.
C
      NUMKEY = 0
      I = LOCATT(BLANK,NAME)
      IF(I.NE.0) GO TO 5000
      J = 1
      ENDCOL = NCOL + 1
      DO 1000 I=1,NATT
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 2300
      COLUMN = ATTCOL
      IF(ATTKEY.NE.0) NUMKEY = NUMKEY + 1
C
C     CALL PARVAL TO CRACH VALUE STRING
C
      IF(ATTWDS.EQ.0) GO TO 200
C
C     FIXED ATTRIBUTE
C
      CALL PARVAL(J,MAT(COLUMN),ATTYPE,ATTWDS,ATTCHA,0,IERR)
      IF(IERR.NE.0) GO TO 100
      GO TO 1000
  200 CONTINUE
C
C     VARIABLE ATTRIBUTE
C
      MAT(COLUMN) = ENDCOL
      NCOLT = ENDCOL + 1
      CALL PARVAL(J,MAT(ENDCOL+2),ATTYPE,ATTWDS,ATTCHA,NCOLT,IERR)
      IF(IERR.NE.0) GO TO 100
      MAT(ENDCOL) = ATTWDS
      MAT(ENDCOL+1) = ATTCHA
      ENDCOL = ENDCOL + ATTWDS + 2
 1000 CONTINUE
      ENDCOL = ENDCOL - 1
      IF(J.LE.ITEMS) GO TO 2400
C
C  SEE IF ALL APPLICABLE RULES ARE SATISFIED.
C
      IF(.NOT.RUCK) GO TO 1100
      IF(.NOT.RULES) GO TO 1100
      CALL CHKTUP(MAT,ISTAT)
      IF(ISTAT.EQ.0) GO TO 1100
      IF(ISTAT.LT.0) GO TO 1050
	if(nout.eq.6)goto 1
      WRITE(NOUT,1010)
 1010 FORMAT(54H -ERROR- The Data Fails To Satisfy The Following Rule:)
	goto 2
1	continue
	write(c128wk,1010)
	call atxto
2	continue
      ISNOUT = NOUTR
      NOUTR = NOUT
      CALL PRULE(ISTAT)
      NOUTR = ISNOUT
      GO TO 100
 1050 CONTINUE
      ISTAT = -ISTAT
	if(nout.eq.6)goto 3
      WRITE(NOUT,1060) ISTAT
 1060 FORMAT(32H -ERROR- Unable To Process RULE ,I4)
      GO TO 100
3	continue
	write(c128wk,1060)istat
	call atxto
	goto 100
 1100 CONTINUE
      NTUPLE = NTUPLE + 1
      CALL ADDDAT(1,REND,MAT,ENDCOL)
      IF(RSTART.EQ.0) RSTART = REND
      CALL RELPUT
C
C  PROCESS ANY KEY ATTRIBUTES.
C
      IF(NUMKEY.EQ.0) GO TO 100
      I = LOCATT(BLANK,NAME)
      DO 1500 I=1,NATT
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 2300
      IF(ATTKEY.EQ.0) GO TO 1500
      START = ATTKEY
      KSTART = ATTKEY
      COLUMN = ATTCOL
      IF(ATTWDS.NE.0) GO TO 1400
      COLUMN = MAT(ATTCOL) + 2
 1400 CONTINUE
      IF(MAT(COLUMN).EQ.NULL) GO TO 1500
      CALL BTADD(MAT(COLUMN),REND,ATTYPE)
      IF(START.EQ.KSTART) GO TO 1500
      ATTKEY = START
      CALL ATTPUT(ISTAT)
 1500 CONTINUE
      GO TO 100
C
C  ATTGET RAN OUT OF ATTRIBUTES TOO SOON.
C
 2300 CONTINUE
	if(nout.eq.6)goto 7
      WRITE(NOUT,9004)
 9004 FORMAT(34H -ERROR- Attribute Table Too Short)
      GO TO 100
7	continue
	write(c128wk,9004)
	call atxto
	goto 100
 2400 CONTINUE
C
C     TOO MANY ITEMS
C
	if(nout.eq.6)goto 8
      WRITE (NOUT,2450)
 2450 FORMAT(33H -ERROR- Too Many Items On Record )
      GO TO 100
8	continue
	write(c128wk,2450)
	call atxto
	goto 100
C
C  CHECK ON.
C
 3000 CONTINUE
      RUCK = .TRUE.
      GO TO 100
C
C  CHECK OFF.
C
 4000 CONTINUE
      RUCK = .FALSE.
      GO TO 100
C
C  ALL DONE.
C
 5000 CONTINUE
      RETURN
      END
      FUNCTION LOCATT(ANAME,RNAME)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   LOOK FOR ATTRIBUTES AND RELATIONS IN THE ATTRIBUTE
C             RELATION
C
C  PARAMETERS:
C         ANAME---NAME OF ATTRIBUTE OR BLANKS
C         RNAME---NAME OF RELATION OR BLANKS
C         LOCATT--STATUS VARIABLE - 0 MEANS OK, 1 MEANS NO WAY
      INCLUDE rin:ATTBLE.BLK
      INCLUDE rin:START.BLK
      INCLUDE rin:MISC.BLK
      LOGICAL EQ
      LOGICAL NE
      INCLUDE rin:DCLAR1.BLK
      INCLUDE rin:DATA1.BLK
      LOCATT = 0
C
C  SEE WHAT THE CALLER WANTS.
C
      IF(EQ(RNAME,BLANK)) GO TO 1000
C
C  RNAME IS SPECIFIED.
C
C
C  FIND THE START FOR THIS RELATION.
C
C
C  GET THE PAGE WITH THE DATA FOR THIS RELATION.
C
  100 CONTINUE
      CRNAME = RNAME
      MRSTRT = MSTRTP
  200 CONTINUE
      CALL ATTPAG(MRSTRT)
C
C  LOOK FOR THE ATTRIBUTE IN THIS RELATION.
C
      I = MRSTRT
  300 CONTINUE
      IF(I.GT.APBUF) GO TO 400
      IF(ATTBLE(1,I).LT.0) GO TO 350
      IF(NE(ATTBLE(4,I),RNAME)) GO TO 350
      IF(ANAME.EQ.BLANK) GO TO 500
      IF(EQ(ATTBLE(2,I),ANAME)) GO TO 500
  350 CONTINUE
      I = I + 1
      GO TO 300
C
C  GET THE NEXT PAGE.
C
  400 CONTINUE
      MRSTRT = ATTBUF(1)
      IF(MRSTRT.EQ.0) GO TO 9000
      GO TO 200
C
C  WE FOUND THE ROW WE ARE LOOKING FOR.
C
  500 CONTINUE
      CANAME = ANAME
      CROW = I
      LROW = 0
      GO TO 9999
C
C  SCAN FOR ATTRIBUTE WITHOUT RELATION SPECIFIED.
C
 1000 CONTINUE
      IF(EQ(ANAME,BLANK)) GO TO 9000
      MRSTRT = MSTRTP
 1100 CONTINUE
      CALL ATTPAG(MRSTRT)
      I = MRSTRT
 1200 CONTINUE
      IF(I.GT.APBUF) GO TO 1400
      IF(ATTBLE(1,I).LT.0) GO TO 1300
      IF(EQ(ATTBLE(2,I),ANAME)) GO TO 1500
 1300 CONTINUE
      I = I + 1
      GO TO 1200
C
C  GET THE NEXT PAGE.
C
 1400 CONTINUE
      MRSTRT = ATTBUF(1)
      IF(MRSTRT.EQ.0) GO TO 9000
      GO TO 1100
C
C  FOUND IT.
C
 1500 CONTINUE
      CRNAME = BLANK
      CANAME = ANAME
      CROW = I
      LROW = 0
      GO TO 9999
C
C  UNABLE TO FIND WHAT WE ARE LOOKING FOR.
C
 9000 CONTINUE
      CRNAME = 0
      CANAME = 0
      LOCATT = 1
      CROW = 0
      LROW = 0
 9999 CONTINUE
      RETURN
      END
      FUNCTION LOCBOO(KOMPAR)
      INCLUDE rin:TEXT.BLK
C
C  FIND THE TYPE OF BOOLEAN COMPARISON THAT KOMPAR IS.
C  JUST CHECK THE FIRST 3 CHARACTERS
C
C  PARAMETERS:
C         KOMPAR--BOOLEAN OPERATOR
C         LOCBOO--CORRESPONDING NUMBER
C
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:MISC.BLK
      INTEGER BOOL(17)
      EQUIVALENCE (BOOL(1),K4BOOL(1))
      CALL FILCH(KOM,1,CHPWD,BLANK)
      CALL STRMOV(KOMPAR,1,3,KOM,1)
      DO 100 I=1,17
      IF(KOM.EQ.BOOL(I)) GO TO 200
  100 CONTINUE
      I = 0
      IF(KOM.EQ.K4CON) I = 9
  200 LOCBOO = I
      IF(I.EQ.8) LOCBOO = -1
      RETURN
      END
      FUNCTION LOCPRM(RNAME,JCODE)
      INCLUDE rin:TEXT.BLK
C
C  CHECK PERMISSION FOR A USERID AGAINST A RELATION.
C
C  PARAMETERS:
C         RNAME---RELATION NAME
C         JCODE---READ/MODIFY CODE
C                 1 FOR READ
C                 2 FOR MODIFY
C         LOCPRM--O FOR OK, 1 FOR NO-WAY
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:MISC.BLK
      LOGICAL EQ
      INCLUDE rin:DCLAR1.BLK
C
C  RETRIEVE THE PASSWORDS.
C
      IF(EQ(RNAME,NAME)) GO TO 100
      GO TO 1500
  100 CONTINUE
C
C  COMPARE THE PASSWORDS.
C
      IF(JCODE.NE.1) GO TO 500
C
C  READ.
C
      IF(EQ(RPW,NONE)) GO TO 1000
      IF(EQ(RPW,USERID)) GO TO 1000
      IF(EQ(MPW,USERID)) GO TO 1000
      IF(EQ(OWNER,USERID)) GO TO 1000
      GO TO 1500
  500 CONTINUE
      IF(JCODE.NE.2) GO TO 1500
C
C  MODIFY.
C
      IF(EQ(MPW,NONE)) GO TO 1000
      IF(EQ(MPW,USERID)) GO TO 1000
      IF(EQ(OWNER,USERID)) GO TO 1000
      GO TO 1500
C
C  OK.
C
 1000 LOCPRM = 0
      RMSTAT = 0
      RETURN
C
C  NO WAY.
C
 1500 CONTINUE
      LOCPRM = 1
      RMSTAT = 90
      RETURN
      END
      FUNCTION LOCREL(RNAME)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   LOOK FOR A RELATION IN THE RELTBL RELATION
C
C  PARAMETERS:
C         RNAME---NAME OF RELATION OR BLANK
C         LOCREL--STATUS VARIABLE - 0 MEANS OK, 1 MEANS NO WAY
      INCLUDE rin:RELTBL.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:RIMPTR.BLK
      LOGICAL EQ
      INCLUDE rin:DCLAR1.BLK
      INCLUDE rin:DATA2.BLK
      LOCREL = 0
C
C  SCAN FOR THIS RELATION.
C
      MRSTRT = MSTRTP
  100 CONTINUE
      CALL RELPAG(MRSTRT)
      I = MRSTRT
  200 CONTINUE
      IF(I.GT.RPBUF) GO TO 400
      IF(RELTBL(1,I).EQ.0) GO TO 9000
      IF(RELTBL(1,I).LT.0) GO TO 300
      IF(EQ(RNAME,BLANK)) GO TO 500
      IF(EQ(RELTBL(2,I),RNAME)) GO TO 500
  300 CONTINUE
      I = I + 1
      GO TO 200
C
C  GET THE NEXT PAGE.
C
  400 CONTINUE
      MRSTRT = RELBUF(1)
      IF(MRSTRT.EQ.0) GO TO 9000
      GO TO 100
C
C  FOUND IT.
C
  500 CONTINUE
      LRROW = I - 1
      CALL BLKMOV(NAME,RELTBL(2,I),2)
      CALL BLKMOV(RDATE,RELTBL(4,I),2)
      NCOL = RELTBL(6,I)
      NATT = RELTBL(7,I)
      NTUPLE = RELTBL(8,I)
      RSTART = RELTBL(9,I)
      REND = RELTBL(10,I)
      CALL BLKMOV(RPW,RELTBL(11,I),2)
      CALL BLKMOV(MPW,RELTBL(13,I),2)
      CNAME = RNAME
C
C  ALSO SET THE VALUES IN THE RIMPTR COMMON BLOCK.
C
      IVAL = 0
      LIMVAL = 0
      CID = RSTART
      NID = CID
      NS = 0
      MID = 0
      GO TO 9999
C
C  UNABLE TO FIND WHAT WE ARE LOOKING FOR.
C
 9000 CONTINUE
      LOCREL = 1
      LRROW = 0
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE LODELE(NUMELE,ERROR)
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE LOADS THE ELEMENT DATA INTO THE SCRATCH RELATION.
C
C  PARAMETERS:
C         NUMELE--NUMBER OF NEWLY DEFINED ATTRIBUTES
C         ERROR---COUNT OF CRUMMY INPUT COMMANDS
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:CONST4.BLK
C
      LOGICAL EQKEYW
      INTEGER ERROR
      INTEGER ROWS
      INTEGER COLUMN
C
C  READ AN ELEMENT RECORD.
C
  100 CONTINUE
      CALL LODREC
      IF(LXITEM(IDUMMY).GT.1) GO TO 200
      IF(EQKEYW(1,KWELEM,8)) GO TO 999
      IF(EQKEYW(1,KWATTR,10)) GO TO 999
      IF(EQKEYW(1,KWRELA,9)) GO TO 999
      IF(EQKEYW(1,KWPASS,9)) GO TO 999
      IF(EQKEYW(1,KWRULS,5)) GO TO 999
      IF(EQKEYW(1,KWEND,3)) GO TO 999
C
C  UNRECOGNIZED GARBAGE.
C
      CALL WARN(4,0,0)
      ERROR = ERROR + 1
      GO TO 100
C
C  EDIT ELEMENT INPUT.
C
  200 CONTINUE
      IATTV = 0
      IF(EQKEYW(2,KWREAL,4)) IATTV = KZREAL
      IF(EQKEYW(2,KWTEXT,4)) IATTV = KZTEXT
      IF(EQKEYW(2,KWINT ,7)) IATTV = KZINT
      IF(EQKEYW(2,KWDOUB,6)) IATTV = KZDOUB
      IF(EQKEYW(2,KWRVEC,4)) IATTV = KZRVEC
      IF(EQKEYW(2,KWIVEC,4)) IATTV = KZIVEC
      IF(EQKEYW(2,KWDVEC,4)) IATTV = KZDVEC
      IF(EQKEYW(2,KWRMAT,4)) IATTV = KZRMAT
      IF(EQKEYW(2,KWIMAT,4)) IATTV = KZIMAT
      IF(EQKEYW(2,KWDMAT,4)) IATTV = KZDMAT
      IF(IATTV.NE.0) GO TO 300
	if(nout.eq.6)goto 1
      WRITE(NOUT,9000)
 9000 FORMAT(36H -ERROR- Illegal Data Type Specified)
      ERROR = ERROR + 1
      GO TO 100
1	continue
	write(c128wk,9000)
	call atxto
	error=error+1
	goto 100
  300 CONTINUE
C
C  MAKE SURE THAT THE ATTRIBUTE NAME IS TEXT.
C
      IF(LXID(1).EQ.KZTEXT) GO TO 400
	if(nout.eq.6)goto 2
      WRITE(NOUT,9001)
 9001 FORMAT(37H -ERROR- Attribute Names Must Be TEXT)
      ERROR = ERROR + 1
      GO TO 100
2	continue
	error=error+1
	write(c128wk,9001)
	call atxto
	goto 100
  400 CONTINUE
      IF(LXLENC(1).LE.8) GO TO 450
      CALL WARN(7,KWATTR,K4E)
      ERROR = ERROR + 1
      GO TO 100
  450 CONTINUE
C
C  LXITEM(IDUMMY) = 2, 3, 4, OR 5 ?
C
      LENGTH = 1
      IF(EQKEYW(2,KWTEXT,4)) LENGTH = 8
      ROWS = 1
      COLUMN = 1
      KEY = 0
      IF(LXITEM(IDUMMY).EQ.2) GO TO 700
      IF(LXITEM(IDUMMY).EQ.3) GO TO 500
      IF(LXITEM(IDUMMY).EQ.4) GO TO 600
      IF(LXITEM(IDUMMY).EQ.5) GO TO 600
      CALL WARN(4,0,0)
      ERROR = ERROR + 1
      GO TO 100
C
C  LXITEM(IDUMMY) = 3.
C
  500 CONTINUE
      IF(EQKEYW(3,KWKEY,3)) GO TO 540
      IF((LXIREC(3).GT.0).AND.(LXIREC(3).LE.MAXCOL)) GO TO 530
      IF(EQKEYW(3,KWVAR,3)) GO TO 550
	if(nout.eq.6)goto 3
      WRITE(NOUT,9002) MAXCOL
 9002 FORMAT(42H -ERROR- Length Must Be A Positive Integer,
     X       18H in the Range 1 to,I5)
	goto 4
3	continue
	write(c128wk,9002)maxcol
	call atxto
4	continue
      ERROR = ERROR + 1
C
  530 CONTINUE
      LENGTH = LXIREC(3)
      ROWS = LENGTH
      GO TO 700
C
  540 CONTINUE
      KEY = 1
      GO TO 700
C
  550 CONTINUE
      LENGTH = 0
      ROWS = 0
      COLUMN = 0
      GO TO 700
C
C  LXITEM(IDUMMY) = 4 OR 5.
C
  600 CONTINUE
      IF((LXID(3).EQ.KZINT).AND.(LXIREC(3).GT.0)) GO TO 620
      IF(EQKEYW(3,KWVAR,3)) GO TO 610
	if(nout.eq.6)goto 5
      WRITE(NOUT,9002) MAXCOL
      ERROR = ERROR + 1
      GO TO 100
5	continue
	error=error+1
	write(c128wk,9002)maxcol
	call atxto
C
  610 CONTINUE
      LENGTH = 0
      ROWS = 0
      GO TO 630
C
  620 CONTINUE
      LENGTH = LXIREC(3)
      ROWS = LENGTH
      IF((LXID(4).EQ.KZINT).AND.(LXIREC(4).GT.0)) GO TO 650
  630 CONTINUE
      IF(EQKEYW(4,KWKEY,3)) GO TO 640
      IF(EQKEYW(4,KWVAR,3)) GO TO 660
      CALL WARN(4,0,0)
      ERROR = ERROR + 1
      GO TO 100
C
  640 CONTINUE
      KEY = 1
      GO TO 700
C
  650 CONTINUE
      COLUMN = LXIREC(4)
      GO TO 670
  660 CONTINUE
      COLUMN = 0
  670 CONTINUE
      IF(EQKEYW(2,KWRMAT,4)) GO TO 680
      IF(EQKEYW(2,KWIMAT,4)) GO TO 680
      IF(EQKEYW(2,KWDMAT,4)) GO TO 680
	if(nout.eq.6)goto 8
      WRITE(NOUT,9003)
 9003 FORMAT(56H -ERROR- MATRIX Data Type Required With Rows And Columns
     X)
      ERROR = ERROR + 1
      GO TO 100
8	continue
      ERROR = ERROR + 1
	write(c128wk,9003)
	call atxto
	goto 100
C
  680 CONTINUE
      IF(LXITEM(IDUMMY).EQ.4) GO TO 700
      IF(EQKEYW(5,KWKEY,3)) GO TO 640
      CALL WARN(4,0,0)
      ERROR = ERROR + 1
      GO TO 100
C
C  STORE THE ELEMENT IN JUNK.
C
  700 CONTINUE
      NUMELE = NUMELE + 1
      CALL BLKCHG(10,5,NUMELE)
      KQ1 = BLKLOC(10)
      KQ1 = KQ1 + (5*(NUMELE-1))
      BUFFER(KQ1) = IBLANK
      CALL LXSREC(1,1,8,BUFFER(KQ1),1)
      BUFFER(KQ1+2) = IATTV
      IF(EQKEYW(2,KWDOUB,6)) LENGTH = LENGTH * 2
      BUFFER(KQ1+3) = LENGTH
      BUFFER(KQ1+4) = KEY
C
C  GET MORE DATA.
C
      IF(BUFFER(KQ1+2).NE.KZTEXT) GO TO 750
C
C  SPECIAL PACKING FOR TEXT ATTRIBUTES.
C
      NWORDS = ((LENGTH - 1) / CHPWD) + 1
      IF(LENGTH.EQ.0) NWORDS = 0
      CALL HTOI(LENGTH,NWORDS,BUFFER(KQ1+3))
      GO TO 100
C
  750 CONTINUE
      IF(BUFFER(KQ1+2).EQ.KZINT ) GO TO 100
      IF(BUFFER(KQ1+2).EQ.KZREAL) GO TO 100
      IF(BUFFER(KQ1+2).EQ.KZDOUB) GO TO 100
C
C  PROCESS VECTOR AND MATRIX ITEMS.
C
      IF(BUFFER(KQ1+2).NE.KZDVEC) GO TO 760
      COLUMN = 2
      GO TO 770
  760 CONTINUE
      IF(BUFFER(KQ1+2).NE.KZDMAT) GO TO 770
      COLUMN = COLUMN * 2
  770 CONTINUE
      CALL HTOI(ROWS,ROWS*COLUMN,BUFFER(KQ1+3))
      GO TO 100
C
C  DONE.
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE LODPAS(ERROR)
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE PROCESS THE PASSWORDS FOR RELATIONS WHEN DEFINING
C  A RIM SCHEMA.  PASSWORD COMMANDS MAY BE ABBREVIATED OR
C  INPUT IN A LONG FORM.  LOADPAS PERFORMS THE EDITING OF THE
C  USER INPUT.
C
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:MISC.BLK
      INTEGER ERROR
      LOGICAL EQKEYW
      INCLUDE rin:DCLAR1.BLK
      INCLUDE rin:DCLAR3.BLK
C
C  READ A PASSWORD.
C
  100 CONTINUE
      CALL LODREC
      IF(EQKEYW(1,KWELEM,8)) GO TO 999
      IF(EQKEYW(1,KWATTR,10)) GO TO 999
      IF(EQKEYW(1,KWRELA,9)) GO TO 999
      IF(EQKEYW(1,KWPASS,9)) GO TO 100
      IF(EQKEYW(1,KWRULS,5)) GO TO 999
      IF(EQKEYW(1,KWEND,3)) GO TO 999
      ITEMS = LXITEM(IDUMMY)
      IF(ITEMS.EQ.5) GO TO 200
      IF(ITEMS.EQ.6) GO TO 300
      CALL WARN(4,0,0)
      ERROR = ERROR + 1
      GO TO 100
C
C  ABBREVIATED FORMAT FOR PASSWORD COMMAND.
C
  200 CONTINUE
      ICODE = 1
      IF(EQKEYW(1,KWRPW,3)) ICODE = 2
      IF(EQKEYW(1,KWMPW,3)) ICODE = 3
      IF(ICODE.NE.1) GO TO 220
C
C  ERROR IN PASSWORD SYNTAX.
C
  215 CONTINUE
      CALL WARN(4,0,0)
      ERROR = ERROR + 1
      GO TO 100
C
  220 CONTINUE
      IF(EQKEYW(2,KWFOR,3)) GO TO 230
      CALL WARN(4,0,0)
      ERROR = ERROR + 1
      GO TO 100
C
  230 CONTINUE
      RNAME = BLANK
      IF(.NOT.EQKEYW(3,KWALL,3)) CALL LXSREC(3,1,8,RNAME,1)
      I = LOCREL(RNAME)
      IF(I.EQ.0) GO TO 240
      CALL WARN(1,RNAME,0)
      ERROR = ERROR + 1
      GO TO 100
C
  240 CONTINUE
      IF(EQKEYW(4,KWIS,2)) GO TO 400
      CALL WARN(4,0,0)
      ERROR = ERROR + 1
      GO TO 100
C
C  LONG VERSION FOR PASSWORD COMMAND.
C
  300 CONTINUE
      ICODE = 1
      IF(EQKEYW(1,KWREAD,4)) ICODE = 2
      IF(EQKEYW(1,KWMODI,6)) ICODE = 3
      IF(ICODE.NE.1) GO TO 330
C
  320 CONTINUE
      CALL WARN(4,0,0)
      ERROR = ERROR + 1
      GO TO 100
C
  330 CONTINUE
      IF(EQKEYW(2,KWPASS,8)) GO TO 340
      CALL WARN(4,0,0)
      ERROR = ERROR + 1
      GO TO 100
C
  340 CONTINUE
      IF(EQKEYW(3,KWFOR,3)) GO TO 350
      CALL WARN(4,0,0)
      ERROR = ERROR + 1
      GO TO 100
C
  350 CONTINUE
      RNAME = BLANK
      IF(.NOT.EQKEYW(4,KWALL,3)) CALL LXSREC(4,1,8,RNAME,1)
      I = LOCREL(RNAME)
      IF(I.EQ.0) GO TO 360
      CALL WARN(1,RNAME,0)
      ERROR = ERROR + 1
      GO TO 100
C
  360 CONTINUE
      IF(EQKEYW(5,KWIS,2)) GO TO 400
      CALL WARN(4,0,0)
      ERROR = ERROR + 1
      GO TO 100
C
C  STORE THE PASSWORD.
C
  400 CONTINUE
      IF(ICODE.EQ.1) GO TO 100
  500 CONTINUE
      CALL RELGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 100
      IF((LXLENC(ITEMS).GE.1).AND.(LXLENC(ITEMS).LE.8)) GO TO 600
	if(nout.eq.6)goto 1
      WRITE(NOUT,550)
  550 FORMAT(44H -ERROR- PASSWORDS Must Be 1-8 Alphanumeric ,
     X       10HCharacters)
      ERROR = ERROR + 1
      GO TO 100
1	continue
	write(c128wk,550)
	call atxto
      ERROR = ERROR + 1
      GO TO 100
  600 CONTINUE
      RPW1 = BLANK
      CALL LXSREC(ITEMS,1,8,RPW1,1)
      IF(ICODE.EQ.2) RPW= RPW1
      IF(ICODE.EQ.3) MPW = RPW1
      CALL RELPUT
C
C  LOOK FOR MORE RELATIONS.
C
      GO TO 500
C
C  END PASSWORD PROCESSING.
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE LODREC
      INCLUDE rin:TEXT.BLK
C
C     COVER ROUTINE FOR LXLREC WHICH HANDLES END-OF-FILES.
C
      INCLUDE rin:LXGEN.BLK
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:MISC.BLK
      LOGICAL EQKEYW
      INCLUDE rin:DCLAR4.BLK
      IF(RMSTAT.GT.1000) GO TO 800
      NUMEOF = 0
	if(noutr.eq.6)goto 25
      IF(ECHO.AND.(NUMREP.EQ.0)) WRITE(NOUTR,10)
	goto 26
25	continue
	if(.not.echo.or.(numrep.ne.0))goto 26
	write(c128wk,10)
	call atxto
26	continue
   10 FORMAT(1X)
    1 CONTINUE
      IF(NUMEOF.GT.10) GO TO 820
      LENREC = 0
      CALL LXLREC(DUM,LENREC,DUM)
      IF(LXID(1).NE.K4EOF) GO TO 100
      NUMEOF = NUMEOF + 1
      IF(BATCH) GO TO 900
      IF(CONNI) GO TO 1
      CALL SETIN(K8IN)
      GO TO 1
  100 CONTINUE
      ITEMS = LXITEM(DUM)
      ISAVE = LSTCMD
      CALL LXSREC(1,1,3,LSTCMD,1)
      IF(ITEMS.GT.3) GO TO 1000
      IF(EQKEYW(1,KWHELP,4)) GO TO 200
      IF(ITEMS.GT.2) GO TO 1000
      IF(EQKEYW(1,KWECHO,4)) GO TO 300
      IF(EQKEYW(1,KWNOEC,6)) GO TO 400
      IF(EQKEYW(1,KWINPU,5)) GO TO 500
      IF(EQKEYW(1,KWOUTP,6)) GO TO 600
      IF(EQKEYW(1,KWQUIT,4)) GO TO 700
      GO TO 1000
  200 CONTINUE
C
C     HELP
C
      IF((ITEMS.GE.2).AND.(LXID(2).NE.KZTEXT)) GO TO 1000
      IF((ITEMS.GE.3).AND.(LXID(3).NE.KZTEXT)) GO TO 1000
      LSTCMD = ISAVE
      CALL RMHELP
      GO TO 1
  300 CONTINUE
C
C     ECHO
C
      IF(ITEMS.EQ.2) GO TO 1000
      ECHO = .TRUE.
      CALL LXSET(KWECHO,K4ON)
      GO TO 1
  400 CONTINUE
C
C     NOECHO
C
      IF(ITEMS.EQ.2) GO TO 1000
      ECHO = .FALSE.
      CALL LXSET(KWECHO,K4OFF)
      GO TO 1
  500 CONTINUE
C
C     INPUT
C
      IF(ITEMS.NE.2) GO TO 1000
      IF(LXID(2).NE.KZTEXT) GO TO 1000
      IFILE = BLANK
      CALL LXSREC(2,1,7,IFILE,1)
      IF(EQKEYW(2,KWTERM,8))IFILE = K8IN
      CALL SETIN(IFILE)
      GO TO 1
  600 CONTINUE
C
C     OUTPUT
C
      IF(ITEMS.NE.2) GO TO 1000
      IF(LXID(2).NE.KZTEXT) GO TO 1000
      IFILE = BLANK
      CALL LXSREC(2,1,7,IFILE,1)
      IF(EQKEYW(2,KWTERM,8))IFILE = K8OUT
      CALL SETOUT(IFILE)
      GO TO 1
  700 CONTINUE
C
C     QUIT
C
      IF(ITEMS.EQ.2) GO TO 1000
      CALL RMCLOS
      GO TO 999
C
C  SYSTEM TYPE FILE/BUFFER ERRORS -- HELP???????????
C
  800 CONTINUE
	if(nout.eq.6)goto 3240
      WRITE(NOUT,810) RMSTAT
  810 FORMAT(13H SYSTEM Error,I5)
      GO TO 900
3240	continue
	write(c128wk,810)rmstat
	call atxto
	goto 900
  820 CONTINUE
C
C     TOO MANY END-OF-FILES ENCOUNTERED
C
	if(nout.eq.6)goto 3241
      WRITE (NOUT,830)
  830 FORMAT(45H -WARNING- End-Of-File Encountered On "INPUT",
     X       11X,28HThe Database Files Are Local)
      GO TO 900
3241	continue
	write(c128wk,830)
	call atxto
  900 CONTINUE
      CALL RMCLOS
  999 CONTINUE
C was STOP here
      return
 1000 CONTINUE
      RETURN
      END
      SUBROUTINE LODREL(NUMELE,ERROR)
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE LOADS THE RELATION DESCRIPTION FROM USER DIRECTIVES
C  IN THE APPROPRIATE RIM TABLES BASED ON THE CSC SCHEMA DEFINITION.
C  A ROUTINE (CHEQLST) DOES THE ACTUAL DATA TRANSFER
C  WITH THIS ROUTINE PERFORMING THE MAJORITY OF THE EDITING.
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:MISC.BLK
C
      LOGICAL EQKEYW
      INTEGER ERROR
      INCLUDE rin:DCLAR1.BLK
C
C  READ RELATION DATA.
C
  100 CONTINUE
      CALL LODREC
      IF(LXITEM(IDUMMY).GT.1) GO TO 150
      IF(EQKEYW(1,KWELEM,8)) GO TO 999
      IF(EQKEYW(1,KWATTR,10)) GO TO 999
      IF(EQKEYW(1,KWRELA,9)) GO TO 999
      IF(EQKEYW(1,KWPASS,9)) GO TO 999
      IF(EQKEYW(1,KWRULS,5)) GO TO 999
      IF(EQKEYW(1,KWEND,3)) GO TO 999
  150 CONTINUE
      IF(LXITEM(IDUMMY).GE.3) GO TO 200
C
C  UNRECOGNIZED GARBAGE.
C
      CALL WARN(4,0,0)
      ERROR = ERROR + 1
      GO TO 100
C
C  CHECK FOR VALID RELATION NAME.
C
  200 CONTINUE
      IF(LXID(1).EQ.KZTEXT) GO TO 300
      if(nout.eq.6)goto 1
      WRITE(NOUT,9000)
 9000 FORMAT(36H -ERROR- Relation Names Must Be TEXT)
      ERROR = ERROR + 1
      GO TO 100
1	continue
	write(c128wk,9000)
	call atxto
2	error=error+1
	goto 100
  300 CONTINUE
      IF(LXLENC(1).LE.8) GO TO 400
      CALL WARN(7,KWRELA,BLANK)
      ERROR = ERROR + 1
      GO TO 100
  400 CONTINUE
      RNAME = BLANK
      CALL LXSREC(1,1,8,RNAME,1)
      I = LOCREL(RNAME)
      IF(I.NE.0) GO TO 500
	if(nout.eq.6)goto 3
      WRITE(NOUT,9001)
 9001 FORMAT(44H -ERROR- Duplicate Relation Name Encountered)
      ERROR = ERROR + 1
      GO TO 100
3	continue
	write(c128wk,9001)
	call atxto
	goto 2
C
C  CHECK ATTRIBUTE NAMES.
C
  500 CONTINUE
      JUNK = 1
      IF(NUMELE.GT.0) JUNK = BLKLOC(10)
      CALL CHKATT(BUFFER(JUNK),NUMELE,ERROR)
      GO TO 100
C
C  END RELATION PROCESSING.
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE LODRUL
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE PROCESSES THE RULES OF A RIM SCHEMA.  THE
C  ACTUAL PARSING OF THE RULES IS DONE IN THIS ROUTINE.  THE
C  ROUTINE SETRUL SETS UP THE APPROPRIATE RELATIONS TO STORE THE
C  RULES.
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:RULCOM.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:DCLAR1.BLK
      INTEGER RTBL(24)
      INTEGER ITEM
      INTEGER VALUE(10)
      REAL RVALUE(10)
      EQUIVALENCE (RVALUE(1),VALUE(1))
      EQUIVALENCE (RTBL(2),ANAME)
      EQUIVALENCE (RTBL(4),ANAME1)
      EQUIVALENCE (RTBL(6),RNAME1)
      EQUIVALENCE (RTBL(8),IBOO)
      EQUIVALENCE (RTBL(10),ITEM)
      EQUIVALENCE (RTBL(11),ANAME2)
      EQUIVALENCE (RTBL(13),RNAME2)
      EQUIVALENCE (RTBL(15),VALUE(1))
      INTEGER RRC(3)
      LOGICAL EQKEYW
      LOGICAL EQ
      LOGICAL NE
      NERROR = 0
C
C  LOOK FOR EXISTING RULES.
C
      I = LOCREL(RIMRRC)
      IF(I.NE.0) GO TO 50
      NUMRUL = 0
      IF(NTUPLE.EQ.0) GO TO 40
      ID = REND
      CALL GETDAT(1,ID,LOC,LENGTH)
      NUMRUL = BUFFER(LOC+2)
   40 CONTINUE
      I = LOCREL(RIMRDT)
      IF(I.EQ.0) GO TO 100
   50 CONTINUE
C
C  SET UP RIMRRC AND RIMRDT FOR THE FIRST TIME.
C
      CALL SETRUL
      NUMRUL = 0
C
C  READ THE RULES.
C
  100 CONTINUE
C
C  DELETE RULE IF THERE WAS AN ERROR
C
      RNAME = RIMRRC
 2000 CONTINUE
      IF(NERROR.LE.0) GO TO 2050
C
C  LOCATE RELATION AND SET UP THE WHERE CLAUSE FOR RULE NUMBER
C
      I = LOCREL(RNAME)
      I = LOCATT(K8NUM,RNAME)
      CALL ATTGET(I)
      NBOO = 1
      BOO(1) = K4AND
      KATTP(1) = ATTCOL
      KATTL(1) = ATTLEN
      KATTY(1) = ATTYPE
      KOMTYP(1) = 2
      KOMPOS(1) = 1
      KOMLEN(1) = 1
      KOMPOT(1) = 1
      KSTRT = 0
      MAXTU = ALL9S
      LIMTU = ALL9S
      WHRVAL(1) = NUMRUL
      WHRLEN(1) = 1
      NS = 0
      IF(NTUPLE.LE.0) GO TO 2030
      IID = CID
      ND = 0
C
C  LOCATE AND DE-LINK THE EFFECTED TUPLES
C
 2010 CONTINUE
      CALL RMLOOK(MAT,1,1,LENGTH)
      IF(RMSTAT.NE.0) GO TO 2020
      ND = ND + 1
      CALL DELDAT(1,CID)
      IF(CID.EQ.IID) IID = NID
      GO TO 2010
 2020 CONTINUE
      IF(ND.EQ.0) GO TO 2030
      CALL RELGET(LENGTH)
      RSTART = IID
      NTUPLE = NTUPLE - ND
      CALL RELPUT
 2030 RMSTAT = 0
      RNAME = RIMRDT
      NERROR = NERROR - 1
      IF(NERROR.EQ.1) GO TO 2000
      NUMRUL = NUMRUL - 1
 2050 CONTINUE
      CALL LODREC
      ITEMS = LXITEM(I)
      IF(EQKEYW(1,KWELEM,8)) GO TO 999
      IF(EQKEYW(1,KWRELA,9)) GO TO 999
      IF(EQKEYW(1,KWATTR,10)) GO TO 999
      IF(EQKEYW(1,KWPASS,9)) GO TO 999
      IF(EQKEYW(1,KWRULS,5)) GO TO 999
      IF(EQKEYW(1,KWEND,3)) GO TO 999
C
C  PROCESS THIS RULE.
C
  110 CONTINUE
      ANAME = K8AND
      J = 1
      IFLAG = 0
      NUMRUL = NUMRUL + 1
      ANAME1 = BLANK
      CALL LXSREC(1,1,8,ANAME1,1)
      RNAME1 = BLANK
      IF(.NOT.EQKEYW(2,KWIN,2)) GO TO 200
C
C  RELATION NAME IS SPECIFIED.
C
      CALL LXSREC(3,1,8,RNAME1,1)
      RNAME = RNAME1
      I = LOCATT(ANAME1,RNAME1)
      IF(I.NE.0) GO TO 150
      CALL ATTGET(ISTAT)
      GO TO 400
  150 CONTINUE
      CALL WARN(3,ANAME1,RNAME1)
      NUMRUL = NUMRUL - 1
      GO TO 100
  200 CONTINUE
C
C  ANY RELATION WITH THIS ATTRIBUTE.
C
      I = LOCATT(ANAME1,RNAME1)
      IF(I.NE.0) GO TO 150
  300 CONTINUE
      IF(EQKEYW(2,KWIN,2)) GO TO 100
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 100
      RNAME = RELNAM
      IFLAG = IFLAG + 1
  400 CONTINUE
C
C  MAKE AN ADDITION TO RIMRRC.
C
      RRC(1) = IBLANK
      RRC(2) = IBLANK
      CALL STRMOV(RNAME,1,8,RRC,1)
      RRC(3) = NUMRUL
      I = LOCREL(RIMRRC)
      CALL RELGET(ISTAT)
      CALL ADDDAT(1,REND,RRC,3)
      IF(RSTART.EQ.0) RSTART = REND
      CALL RMDATE(RDATE)
      NTUPLE = NTUPLE + 1
      CALL RELPUT
C
C  PROCESS THE RULE.
C
  500 CONTINUE
      IF(J.GT.ITEMS) GO TO 300
      ANAME1 = BLANK
      CALL LXSREC(J,1,8,ANAME1,1)
      RNAME3 = BLANK
      IF(.NOT.EQKEYW(J+1,KWIN,2)) GO TO 510
      J = J + 2
      CALL LXSREC(J,1,8,RNAME3,1)
  510 CONTINUE
      IF(RNAME1.EQ.RNAME3) GO TO 530
	if(nout.eq.6)goto 2
      WRITE(NOUT,520)
  520 FORMAT(43H -ERROR- Rule Components Must Apply To The ,
     X   13HSame Relation )
	goto 3
2	continue
	write(c128wk,520)
	call atxto
3	continue
      NERROR = 2
      GO TO 100
  530 CONTINUE
      I = LOCATT(ANAME1,RNAME)
      IF(I.EQ.0) GO TO 600
      CALL WARN(3,ANAME1,RNAME)
      NERROR = 2
      GO TO 100
  600 CONTINUE
      CALL ATTGET(ISTAT)
      J = J + 1
      IBOO = IBLANK
      CALL LXSREC(J,1,4,IBOO,1)
      I = LOCBOO(IBOO)
      IF(I.NE.0) GO TO 700
	if(nout.eq.6)goto 4
      WRITE(NOUT,9000)
 9000 FORMAT(41H -ERROR- Unrecognized Boolean Comparision )
	goto 5
4	continue
	write(c128wk,9000)
	call atxto
5	continue
      NERROR = 2
      GO TO 100
  700 CONTINUE
      J = J + 1
      ANAME2 = BLANK
      RNAME2 = BLANK
      IF(I.LT.10) GO TO 750
C
C  ATTRIBUTE COMPARISION.
C
      CALL HTOI(0,3,ITEM)
      CALL LXSREC(J,1,8,ANAME2,1)
      IF(.NOT.EQKEYW(J+1,KWIN,2)) GO TO 1000
      IF(.NOT.EQKEYW(2,KWIN,2)) GO TO 1000
      CALL LXSREC(J+2,1,8,RNAME2,1)
      LTYPE = ATTYPE
      LLEN = ATTLEN
      DO 705 K=1,10
      VALUE(K) = IBLANK
  705 CONTINUE
      J = J + 2
      I = LOCATT(ANAME2,RNAME2)
      IF(I.NE.0) GO TO 740
      CALL ATTGET(ISTAT)
      IF((LTYPE.NE.KZTEXT).AND.(LLEN.GT.1)) GO TO 720
      IF((LTYPE.EQ.ATTYPE) .AND. (LLEN.EQ.ATTLEN)) GO TO 800
	if(nout.eq.6)goto 6
      WRITE (NOUT,710)
  710 FORMAT(51H -ERROR- Attributes Must Be Of The Same Type/Length)
	goto 7
6	continue
	write(c128wk,710)
	call atxto
7	continue
      NERROR = 2
      GO TO 100
  720 CONTINUE
	if(nout.eq.6)goto 8
      WRITE(NOUT,730)
  730 FORMAT(48H -ERROR- Non-TEXT Attributes Must Be Of Length 1)
	goto 10
8	continue
	write(c128wk,730)
	call atxto
10	continue
      NERROR = 2
      GO TO 100
  740 CONTINUE
      CALL WARN(3,ANAME2,RNAME2)
      NERROR = 2
      GO TO 100
C
C  VALUE COMPARISION.
C
  750 CONTINUE
      IF(LXID(J).EQ.KZTEXT) K = 0
      IF(LXID(J).EQ.KZINT) K = 1
      IF(LXID(J).EQ.KZREAL) K = 2
      I = 0
      IF(K.EQ.0) I = LXLENC(J)
C
C  CHECK APPROPRIENESS OF VALUES
C
      LOP = (40-1)/CHPWD + 1
      IF(K.NE.0) GO TO 770
C
C  TEXT
C
      IF(ATTYPE.NE.KZTEXT) GO TO 790
      IF(I.LE.40) GO TO 764
      I = 40
	if(nout.eq.6)goto 11
      WRITE(NOUT,762)
	goto 764
11	continue
	write(c128wk,762)
	call atxto
  762 FORMAT(50H -WARNING- RULE "VALUE" Truncated To 40 Characters )
  764 CONTINUE
      CALL HTOI(I,K,ITEM)
      CALL LXSREC(J,1,40,VALUE,1)
      GO TO 800
C
C  INTEGER
C
  770 CONTINUE
      IF(K.NE.1) GO TO 780
      IF(ATTYPE.NE.KZINT) GO TO 790
      IF(ATTLEN.NE.1) GO TO 790
      ITEM = K
      DO 772 KK=2,LOP
  772 VALUE(KK) = 0
      VALUE(1) = LXIREC(J)
      GO TO 800
C
C  REAL/DOUBLE
C
  780 CONTINUE
      IF((ATTYPE.NE.KZREAL).AND.(ATTYPE.NE.KZDOUB)) GO TO 790
      IF((ATTYPE.EQ.KZREAL).AND.(ATTLEN.NE.1)) GO TO 790
      IF((ATTYPE.EQ.KZDOUB).AND.(ATTLEN.NE.2)) GO TO 790
      ITEM = K
      DO 782 KK=2,LOP
  782 RVALUE(KK) = 0.
      RVALUE(1) = RXREC(J)
      GO TO 800
C
C  INCOMPATABLE VALUE/ATTRIBUTE
C
  790 CONTINUE
	if(nout.eq.6)goto 12
      WRITE(NOUT,792)
	goto 13
12	continue
	write(c128wk,792)
	call atxto
13	continue
  792 FORMAT(29H -ERROR- Illegal RULE "VALUE" )
      NERROR = 2
      GO TO 100
  800 CONTINUE
      IF((.NOT.EQKEYW(2,KWIN,2)).AND.(IFLAG.NE.1)) GO TO 500
C
C  LOAD THIS RULE.
C
      RTBL(1) = NUMRUL
      I = LOCREL(RIMRDT)
      CALL RELGET(ISTAT)
      I = 14 + ((40-1)/CHPWD + 1)
      CALL ADDDAT(1,REND,RTBL,I)
      IF(RSTART.EQ.0) RSTART = REND
      CALL RMDATE(RDATE)
      NTUPLE = NTUPLE + 1
      CALL RELPUT
      IF(J+1.GT.ITEMS) GO TO 900
      CALL LXSREC(J+1,1,8,ANAME,1)
      IF(EQ(ANAME,K8AND)) GO TO 900
      IF(EQ(ANAME,K8OR)) GO TO 900
	if(nout.eq.6)goto 14
      WRITE(NOUT,9001)
 9001 FORMAT(55H -ERROR- RULES Must Be JOINED With Either "AND" or "OR")
	goto 15
14	continue
	write(c128wk,9001)
	call atxto
15	continue
      NERROR = 2
      GO TO 100
  900 CONTINUE
      J = J + 2
      GO TO 500
C
C  SYNTAX ERRORS.
C
 1000 CONTINUE
	if(nout.eq.6)goto 16
      WRITE(NOUT,9002)
 9002 FORMAT(48H -ERROR- Relation Must Be Specified In This RULE)
	goto 17
16	continue
	write(C128wk,9002)
	call atxto
17	continue
      NERROR = 2
      GO TO 100
C
C  DONE SETTING UP RULES.
C
  999 CONTINUE
C
C  MAKE SURE THE USER ENTERED A KEYWORD - IF ITEMS GT 1 ASSUME A RULE
C
      IF(ITEMS.NE.1) GO TO 110
      RETURN
      END
      SUBROUTINE LSTREL
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE SUMMARIZES THE USERS DEFINITION OF A RELATION
C
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:FILES.BLK
      INTEGER STATUS
      LOGICAL EQ
      LOGICAL NE
      LOGICAL EQKEYW
      INTEGER IRPW
      INTEGER IMPW
      INCLUDE rin:DCLAR1.BLK
      INCLUDE rin:DCLAR6.BLK
      ITEMS = LXITEM(DUM)
      CALL RMDATE(IDAY)
      CALL RMTIME(ITIME)
      I = LOCREL(BLANK)
      NP = 0
      IF(I.EQ.0) GO TO 100
	if(nout.eq.6)goto 1
      WRITE(NOUT,2220)
 2220 FORMAT(32H -WARNING- Relation Tables Empty )
      GO TO 9999
1	continue
	write(c128wk,2220)
	call atxto
	goto 9999
  100 CONTINUE
      IF(ITEMS.GT.2) GO TO 8200
      IF(ITEMS.EQ.2) GO TO 1000
C
C   LISTREL (WITH NO RELATION SPECIFIED)
C
      CALL RELGET(STATUS)
      IF(STATUS.NE.0) GO TO 900
C
C     DONT LISTREL RULE RELATIONS
C
      IF(EQ(NAME,K8RDT)) GO TO 100
      IF(EQ(NAME,K8RRC)) GO TO 100
C
C   VALIDATE USER
C
      IF(EQ(USERID,OWNER)) GO TO 150
      IF(EQ(RPW,NONE)) GO TO 150
      IF(EQ(RPW,USERID)) GO TO 150
      IF(EQ(MPW,USERID)) GO TO 150
      GO TO 100
  150 CONTINUE
      IF(NP.EQ.1) GO TO 200
C
C     WRITE OUT HEADER
C
	if(noutr.eq.6)goto 3
      WRITE(NOUTR,160) IDAY,ITIME
	goto 4
3	continue
	write(c128wk,160)iday,itime
4	continue
  160 FORMAT(10X,25HExisting Relations as of ,A8,3X,A8)
      NP = 1
  200 CONTINUE
	if(noutr.eq.6)goto 5
      WRITE(NOUTR,220) NAME
  220 FORMAT(20X,A8)
      GO TO 100
5	continue
	write(c128wk,220) name
	call atxto
	goto 100
  900 CONTINUE
	if(np.ne.0)goto 9999
	if(nout.eq.6)goto 6
       WRITE(NOUT,1260)
      GO TO 9999
6	continue
	write(C128WK,1260)
	call atxto
	goto 9999
 1000 CONTINUE
C
C   LISTREL RELATION
C
      IF(.NOT.EQKEYW(2,KWALL,3)) GO TO 1050
      I = LOCREL(BLANK)
      IF(I.NE.0) GO TO 8000
      NREL = 0
      GO TO 1100
 1050 CONTINUE
      RNAME = BLANK
      CALL LXSREC(2,1,8,RNAME,1)
      I = LOCREL(RNAME)
      IF(I.EQ.0) GO TO 1100
C
C  REQUESTED RELATION DOES NOT EXIST
C
      CALL WARN(1,RNAME,0)
      GO TO 9999
 1100 CONTINUE
      IF(.NOT.EQKEYW(2,KWALL,3)) GO TO 1200
      CALL RELGET(STATUS)
      IF((NREL.EQ.0).AND.(STATUS.NE.0)) GO TO 8100
      IF(STATUS.NE.0) GO TO 9999
 1200 CONTINUE
C
C     DONT LISTREL RULE RELATIONS
C
      IF(EQ(NAME,K8RDT)) GO TO 1250
      IF(EQ(NAME,K8RRC)) GO TO 1250
C
C   CHECK PERMISSION
C
      IF(EQ(USERID,OWNER)) GO TO 1300
      IF(EQ(RPW,NONE)) GO TO 1300
      IF(EQ(RPW,USERID)) GO TO 1300
      IF(EQ(MPW,USERID)) GO TO 1300
 1250 CONTINUE
      IF(EQKEYW(2,KWALL,3)) GO TO 1100
	if(nout.eq.6)goto 10
      WRITE(NOUT,1260)
 1260 FORMAT(40H -ERROR- Unauthorized Access To Relation ,
     X       20H Data Not Permitted. )
      GO TO 9999
10	continue
	write(c128wk,1260)
	call atxto
	goto 9999
 1300 CONTINUE
C
C  PRINT HEADER.
C
      NREL = NREL + 1
      IRPW = K4NONE
      IMPW = K4NONE
      IF(NE(RPW,NONE)) IRPW = K4YES
      IF(NE(MPW,NONE)) IMPW = K4YES
C
	if(noutr.eq.6)goto 11
      WRITE(NOUTR,1320) NAME
 1320 FORMAT(20X,11HRELATION : ,A8)
      WRITE(NOUTR,1340) RDATE,IRPW
 1340 FORMAT(5X,11HLAST MOD : ,A10,9X,16HREAD PASSWORD : ,A4)
      WRITE(NOUTR,1360) DBNAME,IMPW
 1360 FORMAT(5X,9HSCHEMA : ,A10,10X,19H MODIFY PASSWORD : ,A4)
C
      WRITE(NOUTR,1380)
 1380 FORMAT(7X,4HNAME,10X,4HTYPE,10X,6HLENGTH,10X,3HKEY)
	goto 12
11	continue
      WRITE(c128wk,1320) NAME
	call atxto
      WRITE(c128wk,1340) RDATE,IRPW
	call atxto
      WRITE(c128wk,1360) DBNAME,IMPW
	call atxto
C
      WRITE(NOUTR,1380)
12	continue
C
C  FIND AND PRINT ATTRIBUTE DESCRIPTIONS
C
      I = LOCATT(BLANK,NAME)
      IF(I.EQ.0) GO TO 1500
	if(nout.eq.6)goto 13
      WRITE(NOUT,1400) NAME
 1400 FORMAT(20H -WARNING- Relation ,A8,
     X       26H Has No Attributes Defined )
      GO TO 9999
13	continue
	write(c128wk,1400)name
	call atxto
	goto 9999
 1500 CONTINUE
      CALL ATTGET(STATUS)
      IF(STATUS.NE.0) GO TO 1600
      CALL FILCH(KEY,1,CHPWD,BLANK)
      IF(ATTKEY.NE.0) KEY = K4YES
C
C  RETRIEVE LENGTH OF ATTRIBUTE.
C
      NCHAR = ATTCHA
      NWORDS = ATTWDS
      IF(ATTYPE.EQ.KZDOUB) NWORDS = NWORDS / 2
      IF(ATTYPE.EQ.KZDVEC) NWORDS = NWORDS / 2
      IF(ATTYPE.EQ.KZDMAT) NWORDS = NWORDS / 2
      IF(ATTYPE.NE.KZTEXT) GO TO 1510
	if(noutr.eq.6)goto 14
      IF(NCHAR.NE.0) WRITE(NOUTR,1501) ATTNAM,ATTYPE,NCHAR,KEY
 1501 FORMAT(7X,A8,6X,A4,6X,I5,11H CHARACTERS,4X,A3)
      IF(NCHAR.EQ.0) WRITE(NOUTR,1502) ATTNAM,ATTYPE,KEY
 1502 FORMAT(7X,A8,6X,A4,10X,8HVARIABLE,8X,A3)
      GO TO 1500
14	continue
      IF(NCHAR.NE.0) WRITE(c128wk,1501) ATTNAM,ATTYPE,NCHAR,KEY
	call atxto
      IF(NCHAR.EQ.0) WRITE(c128wk,1502) ATTNAM,ATTYPE,KEY
	call atxto
	goto 1500
 1510 CONTINUE
      IF(ATTYPE.EQ.KZIMAT) GO TO 1520
      IF(ATTYPE.EQ.KZRMAT) GO TO 1520
      IF(ATTYPE.EQ.KZDMAT) GO TO 1520
	if(noutr.eq.6)goto 15
      IF(NWORDS.EQ.0) WRITE(NOUTR,1502) ATTNAM,ATTYPE,KEY
      IF(NWORDS.NE.0) WRITE(NOUTR,1503) ATTNAM,ATTYPE,NWORDS,KEY
 1503 FORMAT(7X,A8,6X,A4,10X,I4,12X,A3)
      GO TO 1500
15	continue
      IF(NWORDS.EQ.0) WRITE(c128wk,1502) ATTNAM,ATTYPE,KEY
      IF(NWORDS.NE.0) WRITE(c128wk,1503) ATTNAM,ATTYPE,NWORDS,KEY
	call atxto
	goto 1500
 1520 CONTINUE
      IF(NWORDS.EQ.0) GO TO 1530
      NC = NWORDS / NCHAR
	if(noutr.eq.6)goto 16
      WRITE(NOUTR,1504) ATTNAM,ATTYPE,NCHAR,NC,KEY
 1504 FORMAT(7X,A8,6X,A4,8X,I4,4H BY ,I4,6X,A3)
      GO TO 1500
16	continue
	write(c128wk,1504)attnam,attype,nchar,nc,key
	call atxto
	goto 1500
 1530 CONTINUE
      IF(NCHAR.EQ.0) GO TO 1540
	if(noutr.eq.6)goto 17
      WRITE(NOUTR,1505) ATTNAM,ATTYPE,NCHAR,KEY
 1505 FORMAT(7X,A8,6X,A4,8X,I4,12H BY VARIABLE,2X,A3)
      GO TO 1500
17	continue
      WRITE(c128wk,1505) ATTNAM,ATTYPE,NCHAR,KEY
	call atxto
	goto 1500
 1540 CONTINUE
	if(noutr.eq.6)goto 18
      WRITE(NOUTR,1506) ATTNAM,ATTYPE,KEY
 1506 FORMAT(7X,A8,6X,A4,4X,20HVARIABLE BY VARIABLE,2X,A3)
      GO TO 1500
18	continue
      WRITE(c128wk,1506) ATTNAM,ATTYPE,KEY
	call atxto
      GO TO 1500
C
 1600 CONTINUE
C
C
	if(noutr.eq.6)goto 19
      WRITE(NOUTR,1620) NTUPLE
 1620 FORMAT(10X,25HCURRENT NUMBER OF ROWS = ,I8)
	goto 20
19	continue
	write(c128wk,1620) ntuple
	call atxto
20	continue
      IF(EQKEYW(2,KWALL,3)) GO TO 1100
      GO TO 9999
 8000 CONTINUE
C
C     NO RELATIONS DEFINED - ALL SPECIFICATION
C
	if(nout.eq.6)goto 21
      WRITE (NOUT,2220)
      GO TO 9999
21	continue
	write(c128wk,2220)
	call atxto
	goto 9999
 8100 CONTINUE
C
C     NO RELATIONS PERMITTED - ALL SPECIFICATION
C
	if(nout.eq.6)goto 22
      WRITE (NOUT,1260)
      GO TO 9999
22	continue
	write(c128wk,1260)
	call atxto
	goto 9999
 8200 CONTINUE
	if(nout.eq.6)goto 23
      WRITE(NOUT,8210)
 8210 FORMAT(35H -ERROR- Too Many Items For Listrel )
      GO TO 9999
23	continue
	write(c128wk,8210)
	call atxto
C
C  ALL DONE.
C
 9999 RETURN
      END
      INTEGER FUNCTION LSTRNG(STR1,IC1,LC1,STR2,IC2,LC2)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   LOCATE ONE STRING OF CHARACTERS IN ANOTHER
C
C  PARAMETERS:
C     STR1----FIRST HOLLERITH STRING
C     IC1-----STARTING CHARACTER IN STR1 TO START THE SCAN
C     LC1-----LENGTH OF STR1
C     STR2----SECOND HOLLERITH STRING
C     IC2-----STARTING CHARACTER IN STR2
C     LC2-----LENGTH OF STR2
C     LSTRNG--CHARACTER POSITION IN STR1 WHERE STR2 WAS FOUND
C             0 IF IT CANNOT FIND IT
C
      Character*1 STR1(*)
      Character*1 STR2(*)
C
C  CHECK THAT THE PARAMETERS ARE GOOD.
C
      L2 = LC2 - 1
      IF(LC2.GT.LC1) GO TO 9000
      I1 = IC1 - 1
      DO 300 I=1,LC1
      I1 = I1 + 1
      IF(STR1(I1).NE.STR2(IC2)) GO TO 300
C
C  MATCHING FIRST CHARACTERS. SCAN THE REST.
C
      IF(L2.EQ.0) GO TO 200
      DO 100 J=1,L2
      IF(STR1(I1+J).NE.STR2(IC2+J)) GO TO 300
  100 CONTINUE
C
C  WE FOUND A MATCH.
C
  200 CONTINUE
      LSTRNG = I1
      RETURN
C
C  KEEP LOOKING.
C
  300 CONTINUE
C
C  NOT THERE.
C
 9000 CONTINUE
      LSTRNG = 0
      RETURN
      END
      SUBROUTINE LXCONS
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE: THIS ROUTINE INITIALIZES THE HOLLERITH CONSTANTS USED
C           BY THE LXLREC ROUTINES. THE CODE IS MACHINE DEPENDENT.
C
      INCLUDE rin:LXGEN.BLK
      INCLUDE rin:LXCON.BLK
      INCLUDE rin:LXCARD.BLK
      INCLUDE rin:LXWRDS.BLK
C
C  VARIABLES USED BY THE LXCON AND LXCARD COMMON BLOCKS
C
      DATA JL0 /1H0/
      DATA JL1 /1H1/
      DATA JL2 /1H2/
      DATA JL3 /1H3/
      DATA JL4 /1H4/
      DATA JL5 /1H5/
      DATA JL6 /1H6/
      DATA JL7 /1H7/
      DATA JL8 /1H8/
      DATA JL9 /1H9/
      DATA JLMNUS /1H-/
      DATA JLPLUS /1H+/
      DATA JLDOT /1H./
      DATA JLDOL /1H$/
      DATA JLSEMI /1H;/
      DATA JLSTAR /1H*/
      DATA JLLPAR /1H(/
      DATA JLRPAR /1H)/
      DATA JLQUOT /1H"/
      DATA JLBLNK /1H /
      DATA JLTEXT /4HTEXT/
      DATA JLREAL /4HREAL/
      DATA JLINT /3HINT/
      DATA JLSAME /2H*N/
      DATA JLASAM /2H**/
      DATA JLREPT /3H*=N/
      DATA JLGENR /3H*+N/
      DATA JLEQS /1H=/
      DATA JLCOMA /1H,/
      DATA JLE /1HE/
      DATA JLNULL /3H-0-/
      DATA JLSLSH /1H//
C
C  VARIABLES USED BY THE LXWRDS COMMON BLOCK
C
      DATA JYA /1HA/
      DATA JYB /1HB/
      DATA JYC /1HC/
      DATA JYD /1HD/
      DATA JYE /1HE/
      DATA JYF /1HF/
      DATA JYH /1HH/
      DATA JYI /1HI/
      DATA JYK /1HK/
      DATA JYL /1HL/
      DATA JYM /1HM/
      DATA JYN /1HN/
      DATA JYO /1HO/
      DATA JYP /1HP/
      DATA JYQ /1HQ/
      DATA JYR /1HR/
      DATA JYS /1HS/
      DATA JYT /1HT/
      DATA JYU /1HU/
      DATA JYON /2HON/
      DATA JYOFF /3HOFF/
      DATA JYEOF /3HEOF/
      DATA JYECHO /4HECHO/
      DATA JYPROM /4HPROM/
      DATA JYINPT /4HINPT/
      DATA JYOTPT /4HOTPT/
      DATA JYDOLL /4HDOLL/
      DATA JYSEMI /4HSEMI/
      DATA JYCOMM /4HCOMM/
      DATA JYBLAN /4HBLAN/
      DATA JYPLUS /4HPLUS/
      DATA JYQUOT /4HQUOT/
      DATA JYPRES /4HPRES/
      DATA JYBLNK /1H /
C
C  SET THE LXGEN VARIABLES
C
      NUMREP= 0
C
C  MACHINE DEPENDENT VARIABLES USED BY THE LXCON COMMON BLOCK
C
      NWORD = 290
      MCHAR = 1160
      NCPW = 4
C
C  SET THE LXCON AND LXCARD VARIABLES
C
      MITEM = 100
      NIN = 5
      NOUT = 6
      NEXT = 1
      NEWN = 0
      OLDN = 0
      ECHO = .TRUE.
      DIGITS(1) = JL0
      DIGITS(2) = JL1
      DIGITS(3) = JL2
      DIGITS(4) = JL3
      DIGITS(5) = JL4
      DIGITS(6) = JL5
      DIGITS(7) = JL6
      DIGITS(8) = JL7
      DIGITS(9) = JL8
      DIGITS(10) = JL9
      MINUS = JLMNUS
      PLUS = JLPLUS
      CONT = JLPLUS
      POINT = JLDOT
      DOLLAR = JLDOL
      SEMI = JLSEMI
      STAR = JLSTAR
      LPAREN = JLLPAR
      RPAREN = JLRPAR
      QUOTES = JLQUOT
      BLANK = JLBLNK
      BLANKS = JLBLNK
      TEXT = JLTEXT
      REAL = JLREAL
      INTGER = JLINT
      SAME = JLSAME
      ALLSAM =JLASAM
      REPEAT = JLREPT
      GENRAT = JLGENR
      EQUALS = JLEQS
      COMMA = JLCOMA
      E = JLE
      NULL = JLNULL
      SLASH = JLSLSH
C
C  SET THE LXWRDS VARIABLES
C
      KYA    = JYA
      KYB    = JYB
      KYC    = JYC
      KYD    = JYD
      KYE    = JYE
      KYF    = JYF
      KYH    = JYH
      KYI    = JYI
      KYK    = JYK
      KYL    = JYL
      KYM    = JYM
      KYN    = JYN
      KYO    = JYO
      KYP    = JYP
      KYQ    = JYQ
      KYR    = JYR
      KYS    = JYS
      KYT    = JYT
      KYU    = JYU
      KYON   = JYON
      KYOFF  = JYOFF
      KYEOF  = JYEOF
      KYECHO = JYECHO
      KYPROM = JYPROM
      KYINPT = JYINPT
      KYOTPT = JYOTPT
      KYDOLL = JYDOLL
      KYSEMI = JYSEMI
      KYCOMM = JYCOMM
      KYBLAN = JYBLAN
      KYPLUS = JYPLUS
      KYQUOT = JYQUOT
      KYPRES = JYPRES
      KYBLNK = JYBLNK
      RETURN
      END
      FUNCTION LXCREC(I,J)
      INCLUDE rin:TEXT.BLK
C
C     THIS FUNCTION RETURNS THE JTH CHARACTER OF THE ITH ITEM
C     LEFT ADJUST BLANK FILL IF POSSIBLE AND ALL BLANKS OTHERWISE.
C
      INCLUDE rin:LXCARD.BLK
      INCLUDE rin:LXCON.BLK
      LXCREC = BLANKS
      IF(I.LT.1) RETURN
      IF(I.GT.NEWN) RETURN
      IF(J.LT.1) RETURN
      IF(TYPE(I).NE.TEXT) RETURN
      LEN = INT(RVAL(I))
      IF(J.GT.LEN) RETURN
      K = INTVAL(I)
      CALL GETT(NEWREC(K),J,LXCREC)
      RETURN
      END
      SUBROUTINE LXEND(LINE,LEN,LOC,MORE,NEWLEN)
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE LOOKS FOR DOLLAR,SEMI OR PLUS AS A NEW
C     END OF LINE.  NOTE - DOLLAR, SEMI OR PLUS ARE NOT NOTED
C     IF IN A QUOTED TEXT OR A COMMENT UNLESS NO END OF QUOTE
C     OR COMMENT IS ENCOUNTERED.
C
C     INPUT  - LINE.....ONE CHARACTER PER WORD
C              LEN......LENGTH OF LINE
C     OUTPUT - LOC......LOCATION OF DOLLAR OR SEMI ELSE 0.
C              MORE......TRUE. IFF PLUS IS END
C              NEWLEN....CHARACTER BEFORE DOLLAR, SEMI OR PLUS ELSE LEN
C
      INCLUDE rin:LXCON.BLK
      DIMENSION LINE(*)
      LOGICAL MORE
C
C     AN IF LOOP ON NUMBER OF CHARACTERS
C
      IC = 0
      IF(LEN.LE.0) GO TO 300
   10 CONTINUE
      IC = IC + 1
      IF(LINE(IC).EQ.DOLLAR) GO TO 100
      IF(LINE(IC).EQ.SEMI) GO TO 100
      IF(LINE(IC).EQ.QUOTES) GO TO 20
      IF(LINE(IC).EQ.STAR) GO TO 50
      IF(IC.GE.LEN) GO TO 300
      GO TO 10
   20 CONTINUE
C
C     POSSIBLE QUOTE - IGNORE IF SO
C
      IF(IC.EQ.LEN) GO TO 300
      IF(IC.EQ.1) GO TO 25
      IF(LINE(IC-1).EQ.BLANK) GO TO 25
      IF(LINE(IC-1).NE.COMMA) GO TO 10
   25 CONTINUE
      ICQ = IC
   30 CONTINUE
      ICQ = ICQ + 1
      IF(ICQ.GE.LEN) GO TO 10
      IF(LINE(ICQ).NE.QUOTES) GO TO 30
      IF(ICQ.EQ.LEN) GO TO 300
      IF(LINE(ICQ+1).NE.QUOTES)IC = ICQ +1
      IF(LINE(ICQ+1).NE.QUOTES) GO TO 10
      ICQ = ICQ + 1
      GO TO 30
   50 CONTINUE
C
C     STAR - POSSIBLE COMMENT
C
      IF(IC.EQ.LEN) GO TO 300
      ENDCOM = NULL
      IF(LINE(IC+1).EQ.LPAREN) ENDCOM = RPAREN
      IF(LINE(IC+1).EQ.SLASH) ENDCOM = SLASH
      IF(ENDCOM.EQ.NULL) GO TO 10
C
C     LOOK FOR END OF COMMENT
C
      ISTART = IC + 2
      IF(ISTART.GT.LEN) GO TO 300
      DO 60 I=ISTART,LEN
      IF(LINE(1).NE.ENDCOM) GO TO 60
      IC = I
      GO TO 10
   60 CONTINUE
      IC = IC + 1
      GO TO 10
  100 CONTINUE
C
C     FOUND A DOLLAR - USED TO BE WORTH SOMETHING
C
      LOC = IC
      MORE = .FALSE.
      NEWLEN = IC - 1
      GO TO 1000
  300 CONTINUE
C
C     MADE IT TO THE END
C
      NEWLEN = LEN
      LOC = 0
      MORE = .FALSE.
      IF(LEN.LE.0) GO TO 1000
      IF(LINE(NEWLEN).NE.CONT) GO TO 1000
      NEWLEN = NEWLEN - 1
      MORE = .TRUE.
 1000 CONTINUE
      RETURN
      END
      SUBROUTINE LXGENR
      INCLUDE rin:TEXT.BLK
C
C     THIS SUBROUTINE INCREMENTS REAL AND INTEGER VALUES BY THE
C     INCREMENTS STORED IN LXGEN FOR GENERATION RECORDS.
C
      INCLUDE rin:LXCARD.BLK
      INCLUDE rin:LXGEN.BLK
      INCLUDE rin:LXCON.BLK
      DO 10 I=1,NEWN
      IF(TYPE(I).EQ.INTGER) INTVAL(I) = INTVAL(I) + INTINC(I)
      IF(TYPE(I).EQ.REAL) RVAL(I) = RVAL(I) + RINC(I)
   10 CONTINUE
      NUMREP = NUMREP - 1
      RETURN
      END
      SUBROUTINE LXGENS(RECORD,LENREC,NUML,LINE,LEN,NEWLEN,
     X                  MORE,LOC,IERR)
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE CRACKS A GENERATION RECORD INTO INTINC,RINC AND NUMRE
C
C     I/O      - RECORD....STRING FROM CALLING PROGRAM
C                LENREC....LENGTH OF RECORD
C                NUML......NUMBER OF READS THIS RECORD
C                LINE......HOLDER FOR USER INPUT
C                LEN.......NUMBER OF CHARACTERS IN LINE
C                NEWLEN....NUMBER CHARACTERS IN LINE THIS RECORD
C                MORE.......TRUE. IFF THIS IS PLUS RECORD
C                LOC.......LOCATION OF EOR
C     OUTPUT   - IERR......ERROR RETURN IF ANY
C
      INCLUDE rin:LXCARD.BLK
      INCLUDE rin:LXCON.BLK
      INCLUDE rin:LXGEN.BLK
      INCLUDE rin:LXCIT.BLK
      DIMENSION LINE(LEN)
      INTEGER RECORD(*)
      LOGICAL MORE
      INTEGER START
      IERR = 0
      NUMGEN = 0
      NUMREP = IVALUE
C
C     BIG LOOP ON ITEMS
C
   10 CONTINUE
      START = LAST + 1
      CALL LXNEXI(LINE,START,NEWLEN)
      IF(FIRST.NE.0) GO TO 100
C
C     OUT OF ITEMS
C
      IF((.NOT.MORE) .AND. (NUMGEN.EQ.OLDN)) GO TO 1000
      IF((.NOT.MORE).AND.(NUMGEN.GT.OLDN)) GO TO 8010
C
C     IF NO MORE - DEFAULT LAST ITEM TO **
C
      IF(.NOT.MORE)TYP = ALLSAM
      IF(.NOT.MORE) GO TO 200
C
C     GET ANOTHER LINE
C
      CALL LXLINE(RECORD,LENREC,NUML,LINE,LEN,LOC)
      IF(LXEOF) GO TO 1000
      CALL LXEND(LINE,LEN,LOC,MORE,NEWLEN)
      LAST = 0
      GO TO 10
  100 CONTINUE
C
C     PARSE THE ITEM
C
      IF(TYP.EQ.COMMA) GO TO 10
      IF(TYP.NE.INTGER) GO TO 150
C
C     INTEGER
C
      NUMGEN = NUMGEN + 1
      IF(NUMGEN.GT.OLDN) GO TO 8010
      IF(TYPE(NUMGEN).EQ.INTGER) GO TO 110
      IF(TYPE(NUMGEN).EQ.REAL) GO TO 8020
      IF(IVALUE.NE.0) GO TO 8020
  110 CONTINUE
      RINC(NUMGEN) = 0.
      INTINC(NUMGEN) = IVALUE
      GO TO 10
  150 CONTINUE
      IF(TYP.NE.REAL) GO TO 200
C
C     REAL
C
      NUMGEN = NUMGEN + 1
      IF(NUMGEN.GT.OLDN) GO TO 8010
      IF(TYPE(NUMGEN).NE.REAL) GO TO 8020
      INTINC(NUMGEN) = 0
      RINC(NUMGEN) = RVALUE
      GO TO 10
  200 CONTINUE
      IF((TYP.NE.SAME) .AND. (TYP.NE.ALLSAM)) GO TO 250
C
C     *N OR **
C
      NUMI = IVALUE
      IF(TYP.EQ.ALLSAM) NUMI = OLDN - NUMGEN
      IF((NUMGEN+NUMI).GT.OLDN) GO TO 8010
      DO 220 I=1,NUMI
      NUMGEN = NUMGEN + 1
      RINC(NUMGEN) = 0.
      INTINC(NUMGEN) = 0
  220 CONTINUE
      IF(FIRST.EQ.0) GO TO 1000
      GO TO 10
  250 CONTINUE
      IF(TYP.NE.REPEAT) GO TO 8050
C
C     *=N+STEP
C
      NUMI = IVALUE
      IF(NUMI.LE.0) GO TO 8030
      IF(NUMGEN.LE.0) GO TO 8040
      IF((NUMI+NUMGEN).GT.OLDN) GO TO 8010
      ICHECK = NULL
      IF(RINC(NUMGEN).NE.0.) ICHECK = REAL
      IF(INTINC(NUMGEN).NE.0) ICHECK = INTGER
      IF((ICHECK.NE.NULL).AND.(ICHECK.NE.TGEN)) GO TO 8020
      IF(TGEN.EQ.NULL) IGEN = 0
      IF(TGEN.EQ.NULL) RGEN = 0.
      IF(TGEN.EQ.REAL) ICHECK = REAL
      IF(IGEN.NE.0) ICHECK = INTGER
      RR = RINC(NUMGEN)
      II = INTINC(NUMGEN)
      DO 270 I=1,NUMI
      NUMGEN = NUMGEN + 1
      IF(ICHECK.EQ.NULL) GO TO 260
      IF(ICHECK.NE.TYPE(NUMGEN)) GO TO 8020
  260 CONTINUE
      II = II + IGEN
      RR = RR + RGEN
      RINC(NUMGEN) = RR
      INTINC(NUMGEN) = II
  270 CONTINUE
      GO TO 10
 1000 CONTINUE
      RETURN
C
C     ERROR MESSAGES
C
 8010 CONTINUE
C
C     TOO MANY ITEMS IN GENERATION RECORD
C
      IERR = 21
      IF(LENREC.NE.0) GO TO 1000
      IF(NOUT.EQ.0) GO TO 1000
	if(nout.eq.6)goto 3140
      WRITE (NOUT,8015)
 8015 FORMAT(17H *** ERROR *** - ,
     X       36HNumber Of Items In Generation Record,
     X 1X,27HMust Match Previous Record  )
      GO TO 1000
3140	continue
	write(c128wk,8015)
	call atxto
	goto 1000
 8020 CONTINUE
C
C     TYPE DIFFERENCE
C
      IERR = 22
      IF(LENREC.NE.0) GO TO 1000
      IF(NOUT.EQ.0) GO TO 1000
	if(nout.eq.6)goto 3141
      WRITE(NOUT,8025)
 8025 FORMAT(17H *** ERROR *** - ,
     X       34HType Mismatch On Generation Record)
      GO TO 1000
3141	continue
	write(c128wk,8025)
	call atxto
	goto 1000
 8030 CONTINUE
C
C     *=N WITH N .LE. 0
C
      IERR = 6
      GO TO 1000
 8040 CONTINUE
C
C     *=N FIRST ITEM
C
      IERR = 4
      GO TO 1000
 8050 CONTINUE
C
C     ILLEGAL TYPE ON GENERATION RECORDS
C
      IERR = 25
      IF(LENREC.NE.0) GO TO 1000
      IF(NOUT.EQ.0) GO TO 1000
	if(nout.eq.6)goto 3142
      WRITE (NOUT,8055)
 8055 FORMAT(17H *** ERROR *** - ,
     X       45HIllegal Text Or *+N ITEM In Generation Record )
      GO TO 1000
3142	continue
	write(c128wk,8055)
	call atxto
	goto 1000
      END
      SUBROUTINE LXGETI(STRING,LEN,IFINT,VALUE)
      INCLUDE rin:TEXT.BLK
C
C     PURPOSE - INTERPRET A STRING OF CHARACTERS AS AN INTEGER.
C
C     INPUT  - STRING....ARRAY OF CHARACTERS ONE PER WORD
C              LEN.......NUMBER OF CHARACTERS IN STRING
C     OUTPUT - IFINT..... .TRUE. IFF STRING REPRESENTS AN INTEGER
C              VALUE.....THE ACTUAL VALUE OF THE INTEGER IN STRING.
C
      INCLUDE rin:LXCON.BLK
      INTEGER VALUE
      INTEGER STRING(LEN)
      LOGICAL IFINT
      NEW = 0
      VALUE = 0
      IFINT = .FALSE.
      IS = 1
      ISIGN = 1
      IF(STRING(1).NE.MINUS) GO TO 5
      ISIGN = -1
      IS = 2
    5 CONTINUE
      IF(STRING(1).NE.PLUS) GO TO 10
      IS = 2
   10 CONTINUE
      IF(IS.GT.LEN) GO TO 1000
C
C     LOOK AT EACH CHARACTER - IF INTEGER ADD IT IN
C
      DO 100 I=IS,LEN
      DO 20 J=1,10
      IF(STRING(I).EQ.DIGITS(J)) GO TO 30
   20 CONTINUE
C
C     NOT INTEGER
C
      GO TO 1000
   30 CONTINUE
      NEW = 10 * NEW + J - 1
  100 CONTINUE
      VALUE = ISIGN*NEW
      IFINT = .TRUE.
 1000 CONTINUE
      RETURN
      END
      SUBROUTINE LXGETR(STRING,LEN,IFREAL,VALUE)
      INCLUDE rin:TEXT.BLK
C
C     PURPOSE - PARSE A REAL NUMBER - DEFINED AS  ?I1.I2E?I3 WHERE
C               ? STANDS FOR EITHER + OR - AND I1,I2,I3 ARE INTEGERS.
C               EITHER THE POINT OR THE "E" MUST BE PRESENT AND THERE
C               MUST BE AT LEAST TWO CHARACTERS.
C               IN ADDITION THERE MUST BE AT LEAST ONE DIGIT.
C
C     INPUT  - STRING...REAL NUMBER ONE CHARACTER PER WORD.
C              LEN......LENGTH OF STRING
C     OUTPUT - IFREAL...TRUE IFF STRING REPRESENTS A REAL NUMBER
C              VALUE....THE REAL REAL NUMBER
C
C     METHOD - I1,I2 AND I3 ARE IDENTIFIED AS SUBSTRINGS AND LXGETI
C              TURNS THEM INTO INTEGERS WHICH ARE FLOATED AND TURNED
C              INTO THE REAL REAL VALUE.
C
      INCLUDE rin:LXCON.BLK
      INTEGER STRING(LEN)
      INTEGER START(3),LENI(3),IN(3)
      REAL R(3)
      LOGICAL IFREAL,IFINT,DOT,EXP
      VALUE = 0.
      IFREAL = .FALSE.
      SIGN1 = 1.
      SIGN2 = 1.
      DO 5 I=1,3
      LENI(I) = 0
      START(I) = 0
      IN(I) = 0
      R(I) = 0.
    5 CONTINUE
      DOT = .FALSE.
      EXP = .TRUE.
C
C     FIND START AND LENGTHS OF THE THREE INTEGERS (MAY BE EMPTY)
C
      IF(LEN.LT.2) GO TO 1000
      START(1) = 1
      IF(STRING(1).EQ.PLUS) START(1) = 2
      IF(STRING(1).EQ.MINUS) START(1) = 2
      IF(STRING(1).EQ.MINUS) SIGN1 = -1.
C
C     LOOK FOR POINT
C
      IS = START(1)
      DO 10 I=IS,LEN
      IF(STRING(I).EQ.POINT) GO TO 20
      IF(STRING(I).EQ.E) GO TO 15
   10 CONTINUE
   15 CONTINUE
      LENI(1) = 0
      START(2) = START(1)
      GO TO 30
   20 CONTINUE
      DOT = .TRUE.
      LENI(1) = I - START(1)
      START(2) = I + 1
   30 CONTINUE
      IS = START(2)
      IF(IS.GT.LEN) GO TO 200
C
C     LOOK FOR E
C
      DO 40 I=IS,LEN
      IF(STRING(I).EQ.E) GO TO 50
      IF(DOT.AND.(STRING(I).EQ.PLUS)) GO TO 50
      IF(DOT.AND.(STRING(I).EQ.MINUS)) GO TO 50
   40 CONTINUE
      I = LEN + 1
      EXP = .FALSE.
   50 CONTINUE
      LENI(2) = I - START(2)
      START(3) = I + 1
      IF(START(3).GT.LEN) GO TO 200
      IS = START(3)
      IF(STRING(IS).EQ.MINUS) SIGN2 = -1.
      IF(STRING(IS).EQ.MINUS) START(3) = IS + 1
      IF(STRING(IS).EQ.PLUS) START(3) = IS + 1
      LENI(3) = LEN - START(3) + 1
  200 CONTINUE
C
C     IF NO EXPONENT OR DECIMAL POINT THEN NOT REAL
C
      IF( (.NOT. DOT) .AND. (.NOT. EXP) ) GO TO 1000
C
C     IF NO NUMBERS THEN NOT REAL
C
      NUM = LENI(1) + LENI(2) + LENI(3)
      IF(NUM.EQ.0) GO TO 1000
C
C  IF NO INTEGER PRECEEDING THE E - ITEM IS TEXT
C
      IF((LENI(1)+LENI(2)).EQ.0) GO TO 1000
C
C      SWITCH I1 AND I2 IF NO DECIMAL POINT FOUND
C
      IF(DOT) GO TO 210
      LENI(1) = LENI(2)
      START(1) = START(2)
      LENI(2) = 0
  210 CONTINUE
C
C     NOW MAKE I1,I2, AND I3 INTO INTEGERS
C
      DO 250 I=1,3
      IF(LENI(I) .EQ. 0) GO TO 250
      IS = START(I)
      CALL LXGETI(STRING(IS),LENI(I),IFINT,IN(I))
      IF(.NOT.IFINT) GO TO 1000
      R(I) = FLOAT(IN(I))
  250 CONTINUE
C
C     NOW MAKE THE REAL REAL NUMBER
C
      LEN2 = LENI(2)
      R(2) = R(2) / (10.**LEN2)
      R(1) = SIGN1 * ( R(1) + R(2) )
      IF( (LENI(1)+LENI(2)) .EQ. 0 ) R(1) = SIGN1
      I3 = IN(3)
C
C  CHECK THE THE EXPONENT IS LEGAL E-38 TO E+38
C
      LENX = LENI(1) - 1
      IF(LENX.LT.0) LENX = 0
      IF((LENX+I3).GT.38) GO TO 1000
      R(3) = 10.**I3
      IF(SIGN2.EQ.-1.) R(3) = 1./R(3)
      VALUE = R(1) * R(3)
      IFREAL = .TRUE.
 1000 CONTINUE
      RETURN
      END
      FUNCTION LXID(I)
      INCLUDE rin:TEXT.BLK
C
C     THIS FUNCTION RETURNS THE ID OF THE ITH ITEM IN THE LAST
C      LXLREC RECORD.
C     ID'S MAY BE 4HTEXT,3HINT,4HREAL, OR 3HEOF
C
      INCLUDE rin:LXCARD.BLK
      INCLUDE rin:LXCON.BLK
      LXID = BLANKS
      IF((I.GT.0) .AND. (I.LE.NEWN)) LXID = TYPE(I)
      RETURN
      END
      FUNCTION LXIREC(I)
      INCLUDE rin:TEXT.BLK
C
C     THIS FUNCTION RETURNS THE INTEGER VALUE OF THE ITH ITEM.
C     LXIREC IS RETURNED 0 IF I IS NOT VALID INTEGER ITEM.
C
      INCLUDE rin:LXCARD.BLK
      INCLUDE rin:LXCON.BLK
      LXIREC = 0
      IF(I.LT.1) RETURN
      IF(I.GT.NEWN) RETURN
      IF(TYPE(I).NE.INTGER) RETURN
      LXIREC = INTVAL(I)
      RETURN
      END
      FUNCTION LXITEM(NUM)
      INCLUDE rin:TEXT.BLK
C
C     THIS FUNCTION RETURNS THE NUMBER OF ITEMS READ IN THE LAST
C      LXLREC RECORD.
C
      INCLUDE rin:LXCARD.BLK
      NUM = NEWN
      LXITEM = NEWN
      RETURN
      END
      FUNCTION LXLENC(I)
      INCLUDE rin:TEXT.BLK
C
C     THIS FUNCTION RETURNS THE LENGTH IN CHARACTERS OF THE ITH ITEM.
C     LXLENC IS RETURNED AS ZERO IF I IS NOT VALID TEXT ITEM.
C
      INCLUDE rin:LXCARD.BLK
      INCLUDE rin:LXCON.BLK
      LXLENC = 0
      IF(I.LT.1) RETURN
      IF(I.GT.NEWN) RETURN
      IF(TYPE(I).EQ.INTGER) RETURN
      IF(TYPE(I).EQ.REAL) RETURN
      LXLENC = INT(RVAL(I))
      RETURN
      END
      FUNCTION LXLENW(I)
      INCLUDE rin:TEXT.BLK
C
C     THIS FUNCTION RETURNS THE LENGTH IN WORDS OF THE ITH ITEM.
C     IF I IS NOT A VALID TEXT ITEM LXLENW IS RETURNED ZERO.
C     WORDS HERE REFERS TO A FORTRAN INTEGER ITEM.
C     (E.G. 10 CHARACTERS ON CYBERS,8 CHARACTERS ON CRAY...)
C
      INCLUDE rin:LXCARD.BLK
      INCLUDE rin:LXCON.BLK
      LXLENW = 0
      IF(I.LT.1) RETURN
      IF(I.GT.NEWN) RETURN
      LXLENW = 1
      IF(TYPE(I).EQ.INTGER) RETURN
      IF(TYPE(I).EQ.REAL) RETURN
      LEN = INT(RVAL(I))
      LXLENW = ((LEN-1)/NCPW) + 1
      RETURN
      END
      SUBROUTINE LXLINE(RECORD,LENREC,NUML,LINE,LEN,LOC)
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE GETS THE NEXT LINE FOR LXLREC TO PARSE.  IF LENREC
C     IS ZERO, FILE NIN IS READ, ELSE THE LINE IS EXTRACTED FROM RECORD.
C     IF LOC IS NOT ZERO NEW LINE IS ALREADY IN LINE, SIMPLY
C     MOVE THE DATA TO THE FRONT OF LINE.
C
      INCLUDE rin:LXCARD.BLK
      INCLUDE rin:PROM.BLK
      INCLUDE rin:LXCON.BLK
      character*208 c128wk,c128rd
	integer*4 nc128,mc128
	common/accmd/c128wk,c128rd,nc128,mc128
c above 3 lines taken from FILES.BLK
      DIMENSION LINE(80)
C following needed on big endian machines
	integer*4 lineel
	character*1 lel(4)
	equivalence(lineel,lel(1))
cc	character*2 cpromq
cc	integer*2 cprom
cc	equivalence(cprom,cpromq)
      INTEGER RECORD(*)
      IF(LOC.NE.0) GO TO 200
      NUML = NUML + 1
      IF(LENREC.NE.0) GO TO 100
C
C     FROM FILE NIN
C
      LEN = 80
C
7001	CONTINUE
C analyticalc change...use vwrt to emit the prompt without crlf
cc	cprom=prom
      IF(NIN.EQ.5) call vwrt(prom,2)
cc      IF(NIN.EQ.5) call vwrt(cpromq,2)
c      IF(NIN.EQ.5) WRITE(6,5) PROM
    5 FORMAT(1X,A2,$)
	if(nin.eq.5)goto 3340
      READ (NIN,10,END=13) LINE
	goto 3341
3340	continue
	call atxti
	read(c128rd,10)line
      if(nin.eq.5)call uvt100(1,1,1)
	if(nin.eq.5)call uvt100(11,0,0)
	lineel=line(1)
	if(ichar(lel(1)).eq.26)goto 13
C explicitly, if we see control-Z treat it as eof.
3341	continue
   10 FORMAT(80A1)
      LXEOF = .FALSE.
C FORCE CHARS FROM TERMINALS TO BE UPPER CASE
	IF(NIN.NE.5)GOTO 14
C ONLY CHANGE CHARS FROM A TTY
C ALSO STOP CHANGING IF WE GET TO A " CHARACTER
C IF 1ST CHAR IS } THEN DO COMMAND...
C system dependent .. commented out code is for small endian
C machines...
c	IF(MOD(LINE(1),256).NE.125)GOTO 12
c	CALL USRCMD(LINE(2))
c	GOTO 7001
c12	CONTINUE
d	DO 11 N=1,80
c	NN=MOD(LINE(N),256)
c	IF(NN.EQ.34)GOTO 14
C 34 IS " CHARACTER IN ASCII
C REPLACE a-z BY A-Z AND LEAVE ALL ELSE ALONE.
C TRY TO LEAVE HIGH PARTS OF INTEGER ALONE.
c	IF(NN.GE.97.AND.NN.LE.122)LINE(N)=(LINE(N)/256)*256+(NN-32)
c11	CONTINUE
C
C Following code for big-endian machines...probably will work on any.
	lineel=line(1)
	if(lel(1).ne.'}')goto 12
	Call usrcmd(line(2))
	goto 7001
12	Continue
	do 11 n=1,80
	lineel=line(n)
	kkk=ichar(lel(1))
	if(kkk.ge.97.and.kkk.le.122)lel(1)=char(kkk-32)
        if(kkk.eq.0)lel(1)=' '
	line(n)=lineel
11	continue
      GO TO 14
   13 CONTINUE
      LXEOF = .TRUE.
   14 CONTINUE
C
      IF(LXEOF) GO TO 1000
      IF(NOUT.EQ.0) GO TO 1000
      IF(.NOT.ECHO) GO TO 1000
	if(nout.eq.6)goto 3140
      WRITE(NOUT,20) LINE
   20 FORMAT(16H Input Line ... ,80A1)
      GO TO 1000
3140	continue
	write(c128wk,20)line
	call atxto
	goto 1000
  100 CONTINUE
C
C     GET LINE FROM RECORD
C
      LEN = 0
      I1 = 80*(NUML-1) + 1
      I2 = 80*NUML
      IF(I1.GT.LENREC) GO TO 1000
      IF(I2.GT.LENREC) I2 = LENREC
      DO 150 I=I1,I2
      LEN = LEN + 1
      CALL GETT(RECORD,I,LINE(LEN))
  150 CONTINUE
      GO TO 1000
  200 CONTINUE
      NEWLEN = LEN - LOC
      IF(NEWLEN.LE.0) GO TO 230
      DO 220 I=1,NEWLEN
      LOC = LOC + 1
      LINE(I) = LINE(LOC)
  220 CONTINUE
  230 CONTINUE
      LEN = NEWLEN
      LOC = 0
 1000 CONTINUE
      IF(LEN.LE.0) RETURN
C
C     IGNORE TRAILING BLANKS
C
      ICHECK = LEN + 1
      DO 1100 I=1,LEN
      ICHECK = ICHECK - 1
      IF(LINE(ICHECK).NE.BLANKS) GO TO 1200
 1100 CONTINUE
      ICHECK = 1
 1200 CONTINUE
      LEN = ICHECK
      RETURN
      END
      SUBROUTINE LXLREC(RECORD,LENREC,IERR)
      INCLUDE rin:TEXT.BLK
C
C     LXLREC BREAKS INPUT STRINGS INTO TEXT,REAL OR INTEGER ITEMS.
C
C     INPUT  - RECORD....ONE RECORD IN A HOLLERITH STRING IN 80
C                        CHARACTER CHUNKS.  IF MORE THAN 80 CHARACTERS
C                        ARE NEEDED ALL BUT THE LAST CHUNK SHOULD END
C                        WITH A PLUS.  THE LAST CHUNK NEED NOT BE A FULL
C                        80 CHARACTERS.
C              LENREC....LENGTH OF RECORD IN CHARS.
C                        IF 0 READ INPUT FROM INPUT
C     OUTPUT - IERR......ERROR RETURN IF LENREC IS NOT ZERO.
C
C
C     LXLREC ERROR RETURNS
C
C     NUMBER         MEANING
C     ------    ---------------------------------------------------
C        1 ..... *N EXTENDS PAST PREVIOUS RECORD
C        2 ..... *N OR ** OPTION REQUESTS LESS THAN ONE ITEM
C        3 ..... TOO MANY ITEMS
C        4 ..... *=N WAS FIRST ITEM
C        5 ..... *+N WAS NOT FIRST ITEM
C        6 ..... *=N WHERE N WAS NOT POSITIVE
C        7 ..... TOO MANY TEXT CHARACTERS
C        8 ..... *=N+STEP DOES NOT AGREE IN TYPE WITH PREVIOUS ITEM
C       21 ..... NUMBER OF ITEMS IN GENERATION RECORD FAILS TO
C                MATCH PREVIOUS RECORD.
C       22 ..... TYPE MISMATCH ON GENERATION RECORD.
C       25 ..... ILLEGAL TEXT OR *+N ITEM ON GENERATION RECORD.
C
      INCLUDE rin:LXCARD.BLK
      INCLUDE rin:LXCON.BLK
      INCLUDE rin:LXCIT.BLK
      INCLUDE rin:LXGEN.BLK
      INCLUDE rin:LXWRDS.BLK
      INTEGER RECORD(*),LINE(80),START
      LOGICAL MORE,TTY,IFSET
      DATA LOC /0/
C
C     BRANCH IF GENERATION
C
      IF(NUMREP.NE.0) GO TO 900
    5 CONTINUE
C
C     MOVE CURRENT TO OLD
C
      DO 10 I=1,NWORD
      OLDREC(I) = NEWREC(I)
      NEWREC(I) = BLANKS
   10 CONTINUE
      OLDN = NEWN
      NEWN = 0
      NEXT = 1
C
C     GET 1ST LINE OF INFORMATION
C
      IERR = 0
      NUML = 0
   15 CONTINUE
      CALL LXLINE(RECORD,LENREC,NUML,LINE,LEN,LOC)
      IF(LXEOF) GO TO 7000
C
C     CHECK FOR *(SET KEYWORD=NEWVALUE) RECORD
C
      CALL LXUSET(LINE,LEN,IFSET)
      IF(IFSET) GO TO 15
C
C     FIND END OF LINE
C
      CALL LXEND(LINE,LEN,LOC,MORE,NEWLEN)
C
C     GET 1ST ITEM
C
      START = 1
      CALL LXNEXI(LINE,START,NEWLEN)
      IF(FIRST.NE.0) GO TO 20
C
C     NO ITEMS IN LINE 1
C
      IF(.NOT.MORE) NOEND = .FALSE.
      MORE = .TRUE.
      GO TO 110
   20 CONTINUE
C
C     CHECK FOR GENERATION RECORD
C
      IF(TYP.EQ.GENRAT) GO TO 800
C
C     BUILD A STRAIGHTFORWARD RECORD
C
   30 CONTINUE
      IF((TYP.NE.SAME) .AND. (TYP.NE.ALLSAM)) GO TO 50
C
C     *N OR **
C
      NUMI = IVALUE
      IF(TYP.EQ.ALLSAM) NUMI = OLDN - NEWN
      IF((NUMI+NEWN).GT.OLDN) GO TO 8010
      IF(NUMI.LE.0) GO TO 8020
      IF((NUMI+NEWN).GT.MITEM) GO TO 8030
      L = NEWN
      DO 40 J=1,NUMI
      I = L + J
      LA = INT(RVAL(I))
      LB = INTVAL(I)
      IF(TYPE(I).EQ.TEXT) GO TO 35
      LA = 1
      LB = 1
   35 CONTINUE
      CALL LXSTOR(TYPE(I),INTVAL(I),RVAL(I),OLDREC(LB),1,LA,.TRUE.)
      IF(NEWN.GT.MITEM) GO TO 8030
      IF(NEXT.GT.MCHAR) GO TO 8070
   40 CONTINUE
      GO TO 100
   50 CONTINUE
      IF(TYP.NE.REPEAT) GO TO 70
C
C     *=N
C
      NUMI = IVALUE
      IF(NUMI.LE.0) GO TO 8060
      IF(NEWN.LE.0) GO TO 8040
      L = NEWN
      IF(TGEN.EQ.NULL)IGEN = 0
      IF(TGEN.EQ.NULL)RGEN = 0.
      IF((TGEN.NE.NULL).AND.(TGEN.NE.TYPE(L))) GO TO 8080
      IF((NEWN+NUMI).GT.MITEM) GO TO 8030
      LA = INT(RVAL(L))
      LB = INTVAL(L)
      IF(TYPE(L).EQ.TEXT) GO TO 55
      LA = 1
      LB = 1
   55 CONTINUE
      RR = RVAL(L)
      II = INTVAL(L)
      DO 60 I=1,NUMI
      RR = RR + RGEN
      II = II + IGEN
      CALL LXSTOR(TYPE(L),II,RR,NEWREC(LB),1,LA,.TRUE.)
      IF(NEWN.GT.MITEM) GO TO 8030
      IF(NEXT.GT.MCHAR) GO TO 8070
   60 CONTINUE
      GO TO 100
   70 CONTINUE
      IF(TYP.NE.COMMA) GO TO 80
C
C     TYP = COMMA      GENERATE -NULL- TEXT ITEM
C
      CALL LXSTOR(TEXT,0,0.,NULL,1,3,.TRUE.)
      GO TO 100
   80 CONTINUE
      IF(TYP.EQ.GENRAT) GO TO 8050
      CALL LXSTOR(TYP,IVALUE,RVALUE,LINE,FIRST,LAST,.FALSE.)
      IF(NEWN.GT.MITEM) GO TO 8030
      IF(NEXT.GT.MCHAR) GO TO 8070
  100 CONTINUE
      START = LAST + 1
      IF(START.GT.NEWLEN) GO TO 110
      CALL LXNEXI(LINE,START,NEWLEN)
      IF(FIRST.NE.0) GO TO 30
  110 CONTINUE
      IF((.NOT.MORE) .AND. (NEWN.NE.0)) GO TO 1000
C
C     GET ANOTHER LINES WORTH
C
      CALL LXLINE(RECORD,LENREC,NUML,LINE,LEN,LOC)
      IF(LXEOF) GO TO 7000
      CALL LXEND(LINE,LEN,LOC,MORE,NEWLEN)
      START = 1
      IF(NOEND) GO TO 120
      CALL LXNEXI(LINE,START,NEWLEN)
      IF(FIRST.NE.0) GO TO 30
      GO TO 110
  120 CONTINUE
C
C     WE EITHER HAVE TO STORE TO THE END OF A QUOTE OR
C     SKIP TO THE END OF A COMMENT.
C
      IF(NEWLEN.LE.0) GO TO 110
      NOEND = .FALSE.
      IF(FIRST.NE.0) GO TO 140
C
C     COMMENT
C
      DO 130 I=1,NEWLEN
      LAST = I
      IF(LINE(I).EQ.ENDCOM) GO TO 100
  130 CONTINUE
      IF(MORE) NOEND = .TRUE.
      GO TO 110
  140 CONTINUE
C
C     CONTINUED QUOTE
C
      NEXT = INTVAL(NEWN)*NCPW - NCPW + 1 + IFIX(RVAL(NEWN))
      I = 1
  150 CONTINUE
      IF(I.GT.NEWLEN) GO TO 170
      IF(LINE(I).NE.QUOTES) GO TO 160
      IF(I.EQ.NEWLEN) GO TO 170
      IF(LINE(I+1).NE.QUOTES) GO TO 170
      I = I + 1
  160 CONTINUE
      CALL PUTT(NEWREC,NEXT,LINE(I))
      I = I + 1
      NEXT = NEXT + 1
       GO TO 150
  170 CONTINUE
      N = NEXT - INTVAL(NEWN)*NCPW + NCPW - 1
      RVAL(NEWN) = FLOAT(N)
      LAST = I
      NEXT = 1 + NCPW*(1+(NEXT-2)/NCPW)
      IF(MORE.AND.(LAST.GE.NEWLEN)) NOEND = .TRUE.
      IF(LINE(LAST).EQ.QUOTES) NOEND = .FALSE.
      GO TO 100
  800 CONTINUE
C
C     PARSE GENERATION RECORD
C
      NEWN = OLDN
      DO 810 I=1,NWORD
      NEWREC(I) = OLDREC(I)
  810 CONTINUE
      CALL LXGENS(RECORD,LENREC,NUML,LINE,LEN,NEWLEN,
     X         MORE,LOC,IERR)
      IF(LXEOF) GO TO 7000
      IF(IERR.EQ.0) GO TO 900
      NUMREP = 0
      IF(IERR.EQ.4) GO TO 8040
      IF(IERR.EQ.6) GO TO 8060
      IF(LENREC.NE.0) GO TO 1000
      GO TO 9000
  900 CONTINUE
C
C     STUFF GENERATION RECORD
C
      CALL LXGENR
 1000 CONTINUE
      RETURN
 7000 CONTINUE
C
C     END OF FILE ENCOUNTERED
C     RETURN ONE ITEM OF TYPE 3HEOF
C
      NEWN = 1
      TYPE(1) = KYEOF
      GO TO 1000
 8000 CONTINUE
C
C     ERROR MESSAGES
C
 8010 CONTINUE
C
C     *N PAST PREVIOUS RECORD
C
      IERR = 1
      IF(LENREC.NE.0) GO TO 1000
      IF(NOUT.EQ.0) GO TO 9000
	if(nout.eq.6)goto 3143
      WRITE (NOUT,8015)
 8015 FORMAT(17H *** ERROR *** - ,31H*N Extends Past Previous Record)
      GO TO 9000
3143	continue
	write(c128wk,8015)
	call atxto
	goto 9000
 8020 CONTINUE
C
C     *N OR ** OPTION REQUESTS ZERO OR FEWER ITEMS
C
      IERR = 2
      IF(LENREC.NE.0) GO TO 1000
      IF(NOUT.EQ.0) GO TO 9000
	if(nout.eq.6)goto 3144
      WRITE (NOUT,8025)
 8025 FORMAT(17H *** ERROR *** -
     X       ,43H*N or ** Option Requests Less Than One Item)
      GO TO 9000
3144	continue
	write(c128wk,8025)
	call atxto
	goto 9000
 8030 CONTINUE
C
C     MORE THAN MITEM RECORDS
C
      IERR = 3
      IF(LENREC.NE.0) GO TO 1000
      IF(NOUT.EQ.0) GO TO 9000
	if(nout.eq.6)goto 3145
      WRITE (NOUT,8035)MITEM
 8035 FORMAT(17H *** ERROR *** - ,7HMax Of ,I3,15H Items Exceeded)
      GO TO 9000
3145	continue
	write(c128wk,8035)mitem
	call atxto
	goto 9000
 8040 CONTINUE
C
C     *=N FIRST ITEM
C
      IERR = 4
      IF(LENREC.NE.0) GO TO 1000
      IF(NOUT.EQ.0) GO TO 9000
	if(nout.eq.6)goto 3146
      WRITE (NOUT,8045)
 8045 FORMAT(17H *** ERROR *** - ,25H*=N May Not Be First Item)
      GO TO 9000
3146	continue
	write(c128wk,8045)
	call atxto
	goto 9000
 8050 CONTINUE
C
C     *+N NOT FIRST ITEM IN RECORD
C
      IERR = 5
      IF(LENREC.NE.0) GO TO 1000
      IF(NOUT.EQ.0) GO TO 9000
	if(nout.eq.6)goto 3147
      WRITE (NOUT,8055)
 8055 FORMAT(17H *** ERROR *** - ,32H*+N Must Be First Item In Record)
      GO TO 9000
3147	continue
	write(c128wk,8055)
	call atxto
	goto 9000
 8060 CONTINUE
C
C     *=N WITH 0 OR NEGATIVE N
C
      IERR = 6
      IF(LENREC.NE.0) GO TO 1000
      IF(NOUT.EQ.0) GO TO 9000
	if(nout.eq.6)goto 3148
      WRITE (NOUT,8065)
 8065 FORMAT(17H *** ERROR *** - ,28HFOR *=N ITEM N Must Positive)
      GO TO 9000
3148	continue
	write(c128wk,8065)
	call atxto
	goto 9000
 8070 CONTINUE
C
C     TOTAL TEXT CHARACTERS EXCEEDS MCHAR
C
      IERR = 7
      IF(LENREC.NE.0) GO TO 1000
      IF(NOUT.EQ.0) GO TO 9000
	if(nout.eq.6)goto 3149
      WRITE (NOUT,8075)MCHAR
 8075 FORMAT(17H *** ERROR *** -
     X        ,40HTotal Text Characters For Record Exceeds ,I4)
      GO TO 9000
3149	continue
	write(c128wk,8075)mchar
	call atxto
	goto 9000
 8080 CONTINUE
C
C     *=N?VALUE DOES NOT AGREE IN TYPE WITH PREVIOUS ITEM.
C
      IERR = 8
      IF(LENREC.NE.0) GO TO 1000
      IF(NOUT.EQ.0) GO TO 9000
	if(nout.eq.6)goto 3150
      WRITE (NOUT,8085)
 8085 FORMAT(17H *** ERROR *** -
     X       ,51H*=N Value Does Not Agree In Type With Previous Item)
	goto 9000
3150	continue
	write(c128wk,8085)
	call atxto
 9000 CONTINUE
      NEWN = 0
      IF(.NOT.MORE) GO TO 5
      IF(TTY(DUM)) GO TO 5
      CALL LXLINE(RECORD,LENREC,NUML,LINE,LEN,LOC)
      IF(LXEOF) GO TO 7000
      CALL LXEND(LINE,LEN,LOC,MORE,NEWLEN)
      GO TO 9000
      END
      FUNCTION LXMASK(NAMEIN)
      INCLUDE rin:TEXT.BLK
      DATA IBLANK /1H /
      NEW = 0
      DO 10 I=1,8
      CALL GETT(NAMEIN,I,L)
      IF(L.NE.IBLANK) CALL PUTT(NEW,I,L)
   10 CONTINUE
      LXMASK = NEW
      RETURN
      END
      SUBROUTINE LXNEXI(LINE,START,LEN)
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE PARSES THE INPUT LINE RETRIEVING THE NEXT ITEM, IF
C     ANY, AND DETERMINES THE TYPE AND A VALUE IF NOT A TEXT ITEM.
C     ITEMS ARE DELIMITED BY BLANKS OR COMMAS.
C
C     INPUT  - LINE.....HOLLERITH ARRAY, ONE CHARACTER/WORD.
C              START....STARTING POINT IN LINE
C              LEN......LENGTH OF LINE
C
      INCLUDE rin:LXCIT.BLK
      INCLUDE rin:LXCON.BLK
      DIMENSION LINE(*)
      LOGICAL IFINT,IFREAL
      INTEGER START
C
C     LOCATE 1ST CHARACTER
C
      NCOMMA = 0
      NOEND = .FALSE.
      FIRST = START - 1
      TYP = TEXT
   10 CONTINUE
      FIRST = FIRST + 1
      LAST = FIRST
      IF(FIRST.GT.LEN) GO TO 900
      IF(LINE(FIRST).EQ.BLANK) GO TO 10
      IF(LINE(FIRST).NE.COMMA) GO TO 12
      NCOMMA = NCOMMA + 1
      IF(NCOMMA.LE.1) GO TO 10
      FIRST = FIRST - 1
      LAST = FIRST
      TYP = COMMA
      GO TO 1000
   12 CONTINUE
      IF(LINE(FIRST).EQ.EQUALS) GO TO 1000
      IF(LINE(FIRST).EQ.LPAREN) GO TO 1000
      IF(LINE(FIRST).EQ.RPAREN) GO TO 1000
      IF(LINE(FIRST).NE.STAR) GO TO 20
C
C     MIGHT BE COMMENT
C
      IF(FIRST.EQ.LEN) GO TO 20
      ENDCOM = NULL
      IF(LINE(FIRST+1).EQ.LPAREN) ENDCOM = RPAREN
      IF(LINE(FIRST+1).EQ.SLASH) ENDCOM = SLASH
      IF(ENDCOM.EQ.NULL) GO TO 20
C
C     TIS - GO UNTIL ")"
C
      NOEND = .TRUE.
      FIRST = FIRST + 1
   15 CONTINUE
      FIRST = FIRST + 1
      IF(FIRST.GT.LEN) GO TO 900
      IF(LINE(FIRST).NE.ENDCOM) GO TO 15
      NOEND = .FALSE.
      GO TO 10
   20 CONTINUE
C
C     LOCATE LAST - 1ST CHECK IF QUOTED STRING
C
      IF(LINE(FIRST).EQ.QUOTES) GO TO 50
      LAST = FIRST
   30 CONTINUE
C
C     LOOK FOR BLANK OR COMMA
C
      LAST = LAST + 1
      IF(LAST.GT.LEN) GO TO 100
      IF(LINE(LAST).EQ.BLANK) GO TO 100
      IF(LINE(LAST).EQ.COMMA) GO TO 100
      IF(LINE(LAST).EQ.LPAREN) GO TO 100
      IF(LINE(LAST).EQ.RPAREN) GO TO 100
      IF(LINE(LAST).NE.EQUALS) GO TO 30
C
C     SPECIAL CASE *=
C
      IF(LAST.NE.(FIRST+1)) GO TO 100
      IF(LINE(FIRST).NE.STAR) GO TO 100
      GO TO 30
   50 CONTINUE
C
C     QUOTED STRING
C
      NOEND = .TRUE.
      TYP = TEXT
      LAST = FIRST
   60 CONTINUE
      IF(LAST.GE.LEN) GO TO 1000
      LAST = LAST + 1
      IF(LINE(LAST).NE.QUOTES) GO TO 60
      IF(LAST.EQ.LEN) GO TO 70
      IF(LINE(LAST+1).NE.QUOTES)GO TO 70
      LAST = LAST + 1
      GO TO 60
   70 CONTINUE
      NOEND = .FALSE.
      GO TO 1000
  100 CONTINUE
C
C     TEST FOR REAL OR INTEGER
C
      LAST = LAST -1
      TYP = INTGER
      CALL LXGETI(LINE(FIRST),LAST-FIRST+1,IFINT,IVALUE)
      IF(IFINT) GO TO 1000
      IVALUE = 0
      TYP = REAL
      CALL LXGETR(LINE(FIRST),LAST-FIRST+1,IFREAL,RVALUE)
      IF(IFREAL) GO TO 1000
      RVALUE = 0.
C
C     TRY FOR SPECIALTY TYPES
C
      TYP = TEXT
      IF(LINE(FIRST).NE.STAR) GO TO 1000
      IF(FIRST.NE.LAST) GO TO 105
C
C     SINGLE *
C
      TYP = SAME
      IVALUE = 1
      GO TO 1000
  105 CONTINUE
      IF(LINE(FIRST+1).NE.STAR) GO TO 110
      IF(LAST.NE.FIRST+1) GO TO 110
C
C     **, *=N, *+N THEN *N
C
      TYP = ALLSAM
      GO TO 1000
  110 CONTINUE
      IF((LAST-FIRST).LE.1) GO TO 130
      IF(LINE(FIRST+1).NE.EQUALS) GO TO 120
C
C     *=N - SEE IF *=N?VALUE
C
      TGEN = NULL
      IGEN = 0
      RGEN = 0.
      NUM = LAST - FIRST - 2
      IF(NUM.LE.0) GO TO 114
      LOOK = FIRST + 2
      DO 112 I=1,NUM
      LOOK = LOOK + 1
      IF(LINE(LOOK) .EQ. PLUS) GO TO 200
      IF(LINE(LOOK) .EQ. MINUS) GO TO 200
  112 CONTINUE
  114 CONTINUE
C
C     PLAIN *=N
C
      CALL LXGETI(LINE(FIRST+2),LAST-FIRST-1,IFINT,IVALUE)
      TYP = REPEAT
      IF(IFINT) GO TO 1000
      TYP = TEXT
      IVALUE = 0
      GO TO 1000
  120 CONTINUE
      IF(LINE(FIRST+1).NE.PLUS) GO TO 130
      CALL LXGETI(LINE(FIRST+2),LAST-FIRST-1,IFINT,IVALUE)
      TYP = GENRAT
      IF(IFINT) GO TO 1000
  130 CONTINUE
C
C     *N
C
      TYP = SAME
      CALL LXGETI(LINE(FIRST+1),LAST-FIRST,IFINT,IVALUE)
      IF(IFINT) GO TO 1000
      TYP = TEXT
      IVALUE = 0
      GO TO 1000
  200 CONTINUE
C
C     *=N?VALUE
C
      TYP = REPEAT
      CALL LXGETI(LINE(FIRST+2),LOOK-FIRST-2,IFINT,IVALUE)
      IF(.NOT.IFINT) GO TO 250
      TGEN = INTGER
      CALL LXGETI(LINE(LOOK),LAST-LOOK+1,IFINT,IGEN)
      IF(IFINT) GO TO 1000
      TGEN = REAL
      CALL LXGETR(LINE(LOOK),LAST-LOOK+1,IFREAL,RGEN)
      IF(IFREAL) GO TO 1000
  250 CONTINUE
      TYP = TEXT
      IVALUE = 0
      GO TO 1000
  900 CONTINUE
C
C     COULDNT FIND AN ITEM
C
      FIRST = 0
 1000 CONTINUE
      RETURN
      END
      SUBROUTINE LXSET(WHAT,NEWVAL)
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE IS USED TO RESET PARAMETERS FOR THE LXLREC
C     GROUP OF ROUTINES.
C
C     INPUT  - WHAT.....WHICH PARAMETER TO RESET
C              NEWVAL...NEW VALUE FOR PARAMETER
C
C     POSSIBLE VALUES FOR WHAT
C       WHAT                                      NEWVAL
C       ----                                      ------
C     4HECHO                                      2HON,3HOFF
C     4HPROM                                      PROMPT CHARACTERS
C     4HINPT                                      INFIL NAME/NUMBER
C     4HOTPT                                      OUTFILE NAME/NUMBER
C     4HDOLL (DOLLAR END-OF-RECORD)               SEE NOTE
C     4HCOMM (COMMA ITEM DELIMETER)               SEE NOTE
C     4HSEMI (SEMI-COLON END-OF-RECORD)           SEE NOTE
C     4HBLAN (BLANK ITEM DELIMITER)               SEE NOTE
C     4HPLUS (PLUS CONTINUATION CHARACTER)        SEE NOTE
C     4HQUOT (TEXT ITEM DELIMETER)                SEE NOTE
C
C     NOTE - FOR CHARACTER PARAMETERS SUCH AS DOLLAR, THE CHARRACTER
C            PARAMETER WILL BE REPLACED WITH THE 1ST CHARACTER IN
C            NEWVAL UNLESS NEWVAL IS NULL.  IN THAT CASE, DOLLAR
C            WILL NOT BE AN END-OF-RECORD CHARACTER AND WILL NOT BE
C            REPLACED BY ANY OTHER CHARACTER.
C
      INCLUDE rin:LXCON.BLK
      INCLUDE rin:PROM.BLK
      INCLUDE rin:LXCARD.BLK
      INCLUDE rin:LXWRDS.BLK
      LOGICAL IFNULL
      INTEGER WHAT
      DATA ISAVPR /1/
      DATA JSAVPR /1/
      IF(WHAT.NE.KYECHO) GO TO 10
C
C     ECHO OPTION
C
      IF(NEWVAL.EQ.KYON) ECHO = .TRUE.
      IF(NEWVAL.EQ.KYOFF) ECHO = .FALSE.
      GO TO 1000
   10 CONTINUE
      IF(WHAT.NE.KYPROM) GO TO 15
C
C     PROMPT OPTION
C
      JSAVPR = ISAVPR
      ISAVPR = NEWVAL
      PROM = NEWVAL
      GO TO 1000
   15 CONTINUE
      IF(WHAT.NE.KYINPT) GO TO 20
C
C     INPUT FILE NAME
C
      NIN = NEWVAL
      GO TO 1000
   20 CONTINUE
      IF(WHAT.NE.KYOTPT) GO TO 30
C
C     OUTPUT FILE NAME
C
      NOUT = NEWVAL
      GO TO 1000
   30 CONTINUE
      IFNULL = .FALSE.
      IF(NEWVAL.EQ.NULL) IFNULL = .TRUE.
      CALL GETT(NEWVAL,1,ICHAR)
      IF(WHAT.NE.KYDOLL) GO TO 40
C
C     DOLLAR
C
      DOLLAR = ICHAR
      IF(IFNULL)DOLLAR = NULL
      GO TO 1000
   40 CONTINUE
      IF(WHAT.NE.KYSEMI) GO TO 50
C
C     SEMI-COLON
C
      SEMI = ICHAR
      IF(IFNULL)SEMI = NULL
      GO TO 1000
   50 CONTINUE
      IF(WHAT.NE.KYCOMM) GO TO 60
C
C     COMMA
C
      COMMA = ICHAR
      IF(IFNULL)COMMA = NULL
      GO TO 1000
   60 CONTINUE
      IF(WHAT.NE.KYBLAN) GO TO 70
C
C     BLANK
C
      BLANK = ICHAR
      IF(IFNULL)BLANK = NULL
      GO TO 1000
   70 CONTINUE
      IF(WHAT.NE.KYPLUS) GO TO 80
C
C     PLUS
C
      CONT = ICHAR
      IF(IFNULL)CONT = NULL
      GO TO 1000
   80 CONTINUE
C
C     QUOTES
C
      IF(WHAT.NE.KYQUOT) GO TO 90
      QUOTES = ICHAR
      IF(IFNULL) QUOTES = NULL
      GO TO 1000
   90 CONTINUE
      IF(WHAT.NE.KYPRES) GO TO 100
      IF(JSAVPR.EQ.1) GO TO 100
      PROM = JSAVPR
      ITEMP = JSAVPR
      JSAVPR = ISAVPR
      ISAVPR = ITEMP
      GO TO 1000
  100 CONTINUE
 1000 CONTINUE
      RETURN
      END
      SUBROUTINE LXSREC(I,CHAR1,NUMC,STRING,START)
      INCLUDE rin:TEXT.BLK
C
C     THIS SUBROUTINE PUTS NUMC CHARACTERS FROM THE I'TH
C     ITEM INTO STRING STARTING WITH CHAR1 IN ITEM AND
C     START IN STRING.  THE STRING IS BLANK FILLED IF
C     THERE IS NOT ENOUGH ITEM OR SET TO ALL BLANKS IF
C     ITEM IS NOT A VALID TEXT ITEM.
C
      INCLUDE rin:LXCON.BLK
      INCLUDE rin:LXCARD.BLK
      INTEGER CHAR1,START,STRING(*)
      NUMB = NUMC
      ISB = START
      IF(I.LT.1) GO TO 1000
      IF(I.GT.NEWN) GO TO 1000
      IF(CHAR1.LT.1) GO TO 100
      IF(START.LT.1) GO TO 100
      IF(TYPE(I).NE.TEXT) GO TO 1000
      LEN = INT(RVAL(I))
      IF(CHAR1.GT.LEN) GO TO 100
      ISC = INTVAL(I)
      NUM = LEN - CHAR1 + 1
      IF(NUMC.LT.NUM) NUM = NUMC
      NUMB = NUMC - NUM
      ISB = START + NUM
      CALL STRMOV(NEWREC(ISC),CHAR1,NUM,STRING,START)
  100 CONTINUE
C
C     BLANK FILL
C
      DO 110 II=1,NUMB
      CALL PUTT(STRING,ISB,BLANKS)
      ISB = ISB + 1
  110 CONTINUE
      RETURN
 1000 CONTINUE
C
C     PUT -0- IN TEXT STRING
C
      NUM = 3
      IF(NUMC.LT.NUM) NUM = NUMC
      CALL STRMOV(NULL,1,NUM,STRING,START)
      NUMB = NUMC - NUM
      ISB = START + NUM
      IF(NUMB.GT.0) GO TO 100
      RETURN
      END
      SUBROUTINE LXSTOR(TYP,I,R,LINE,FIRST,LAST,STRING)
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE STORES AN ITEM IN NEWREC.
C
C     INPUT - TYP.....ITEM TYP
C             I.......ITEM INTEGER VALUE IF INTGER
C             R.......ITEM REAL VALUE IF REAL
C             LINE....TEXT STRING
C             FIRST...FIRST CHARACTER OF TEXT IN LINE
C             LAST....LAST CHARACTER OF TEXT IN LINE
C             STRING..LOGICAL .TRUE. IF LINE IS PACKED.
C                             .FALSE. IF LINE IS ONE CHAR PER WORD.
C
      INCLUDE rin:LXCARD.BLK
      INCLUDE rin:LXCON.BLK
      LOGICAL STRING
      INTEGER TYP,FIRST,LAST
      DIMENSION LINE(*)
      NEWN = NEWN + 1
      IF(NEWN.GT.MITEM) GO TO 1000
      TYPE(NEWN) = TYP
      IF(TYP.NE.INTGER) GO TO 50
C
C     INTEGER
C
      INTVAL(NEWN) = I
      RVAL(NEWN) = 0.
      GO TO 1000
   50 CONTINUE
      IF(TYP.NE.REAL) GO TO 100
C
C     REAL
C
      RVAL(NEWN) = R
      INTVAL(NEWN) = 0
      GO TO 1000
  100 CONTINUE
      IF(TYP.NE.TEXT) GO TO 1000
C
C     TEXT - BRANCH IF STRING OR ONE CHAR. PER WORD
C
      IF(STRING) GO TO 200
C
C     CHECK FOR LEADING AND TRAILING QUOTES
C
      I1 = FIRST
      I2 = LAST
      IF(LINE(I1).EQ.QUOTES) I1 = I1 + 1
      IF(LINE(I2).EQ.QUOTES) I2 = I2 - 1
      INTVAL(NEWN) = 1 + NEXT/NCPW
      IF(I1.GT.I2) GO TO 150
      J = I1 - 1
  110 CONTINUE
      J = J + 1
      IF(J.EQ.I2) GO TO 120
      IF(LINE(J) .NE. QUOTES) GO TO 120
      IF(LINE(J+1) .NE. QUOTES) GO TO 120
      J = J + 1
  120 CONTINUE
      CALL PUTT(NEWREC,NEXT,LINE(J))
      NEXT = NEXT + 1
      IF(NEXT.GT.MCHAR) GO TO 1000
      IF(J.LT.I2) GO TO 110
  150 CONTINUE
      GO TO 270
  200 CONTINUE
C
C     STRING - JUST MOVE IT
C
      INTVAL(NEWN) = 1 + NEXT/NCPW
      DO 250 J=FIRST,LAST
      CALL GETT(LINE,J,IWORD)
      CALL PUTT(NEWREC,NEXT,IWORD)
      NEXT = NEXT + 1
      IF(NEXT.GT.MCHAR) GO TO 1000
  250 CONTINUE
  270 CONTINUE
      LEN = NEXT - INTVAL(NEWN)*NCPW + NCPW - 1
      RVAL(NEWN) = FLOAT(LEN)
      NEXT = 1 + NCPW*(1+(NEXT-2)/NCPW)
 1000 CONTINUE
      RETURN
      END
      SUBROUTINE LXUSET(LINE,LEN,IFSET)
      INCLUDE rin:TEXT.BLK
C
C     THSI ROUTINE CHECKS LINE FOR A USER SET COMMENT.  THESE COMMENTS
C     ARE OF THE FORM  *(SET KEYWORD=NEWVALUE)
C     WHERE KEYWORD CAN BE    DOLLAR
C                             SEMI
C                             QUOTES
C                             BLANK
C                             PLUS
C                             COMMA
C                             ECHO
C     NEWVALUE IS EITHER THE NEW CHARACTER OR THE WORD NULL EXCEPT
C     ECHO WHICH TAKES ON OR OFF.
C
C     INPUT  - LINE - ONE CHARACTER PER WORD
C              LEN  - LENGTH OF LINE
C     OUTPUT - IFSET- .TRUE. IF LEN IS BETWEEN 13 AND 18 AND
C                     THE LINE START *(SET  AND ENDS WITH ).
C
      INCLUDE rin:LXCON.BLK
      INCLUDE rin:LXCARD.BLK
      INCLUDE rin:LXWRDS.BLK
      LOGICAL IFSET
      DIMENSION LINE(LEN)
      IFSET = .FALSE.
C
C     ELIMINATE ANYTHING ELSE
C
      IF(LEN.LT.13) GO TO 1000
      IF(LEN.GT.18) GO TO 1000
      IF(LINE(1).NE.STAR) GO TO 1000
      IF(LINE(2).NE.LPAREN) GO TO 1000
      IF(LINE(3).NE.KYS) GO TO 1000
      IF(LINE(4).NE.E) GO TO 1000
      IF(LINE(5).NE.KYT) GO TO 1000
      IF(LINE(6).NE.BLANKS) GO TO 1000
      IF(LINE(LEN).NE.RPAREN) GO TO 1000
C
C     FOUND A SET COMMAND
C
      IFSET = .TRUE.
C
C     SEE IF ECHO COMMAND
C
      IF(LINE(7).NE.E) GO TO 5
      IF(LINE(8).NE.KYC) GO TO 5
      IF(LINE(9).NE.KYH) GO TO 5
      IF(LINE(10).EQ.KYO) GO TO 800
    5 CONTINUE
C
C     LOOK BETWEEN = AND END FOR NULL OR SINGLE CHARACTER
C
      IE = 10
      DO 10 I=1,3
      IE = IE + 1
      IF(LINE(IE).EQ.EQUALS) GO TO 20
   10 CONTINUE
      GO TO 900
   20 CONTINUE
      NUM = LEN - IE - 1
      NEWVAL = LINE(IE+1)
      IF(NUM.EQ.1) GO TO 50
      IF(NUM.NE.4) GO TO 900
C
C     CHECK FOR NULL
C
      NEWVAL = NULL
      IF(LINE(IE+1).NE.KYN) GO TO 900
      IF(LINE(IE+2).NE.KYU) GO TO 900
      IF(LINE(IE+3).NE.KYL) GO TO 900
      IF(LINE(IE+4).NE.KYL) GO TO 900
   50 CONTINUE
      IF(LINE(7).NE.KYC) GO TO 100
C
C     COMMA
C
      IF(LINE(8).NE.KYO) GO TO 900
      IF(LINE(9).NE.KYM) GO TO 900
      IF(LINE(10).NE.KYM) GO TO 900
      IF(LINE(11).NE.KYA) GO TO 900
      COMMA = NEWVAL
      GO TO 1000
  100 CONTINUE
      IF(LINE(7).NE.KYD) GO TO 150
C
C     DOLLAR
C
      IF(LINE(8).NE.KYO) GO TO 900
      IF(LINE(9).NE.KYL) GO TO 900
      IF(LINE(10).NE.KYL) GO TO 900
      IF(LINE(11).NE.KYA) GO TO 900
      IF(LINE(12).NE.KYR) GO TO 900
      DOLLAR = NEWVAL
      GO TO 1000
  150 CONTINUE
      IF(LINE(7).NE.KYB) GO TO 200
C
C     BLANK
C
      IF(LINE(8).NE.KYL) GO TO 900
      IF(LINE(9).NE.KYA) GO TO 900
      IF(LINE(10).NE.KYN) GO TO 900
      IF(LINE(11).NE.KYK) GO TO 900
      BLANK = NEWVAL
      GO TO 1000
  200 CONTINUE
      IF(LINE(7).NE.KYP) GO TO 250
C
C     PLUS
C
      IF(LINE(8).NE.KYL) GO TO 900
      IF(LINE(9).NE.KYU) GO TO 900
      IF(LINE(10).NE.KYS) GO TO 900
      PLUS = NEWVAL
      GO TO 1000
  250 CONTINUE
      IF(LINE(7).NE.KYQ) GO TO 300
C
C     QUOTES
C
      IF(LINE(8).NE.KYU) GO TO 900
      IF(LINE(9).NE.KYO) GO TO 900
      IF(LINE(10).NE.KYT) GO TO 900
      IF(LINE(11).NE.KYE) GO TO 900
      IF(LINE(12).NE.KYS) GO TO 900
      QUOTES = NEWVAL
      GO TO 1000
  300 CONTINUE
C
C     SEMI
C
      IF(LINE(7).NE.KYS) GO TO 900
      IF(LINE(8).NE.E) GO TO 900
      IF(LINE(9).NE.KYM) GO TO 900
      IF(LINE(10).NE.KYI) GO TO 900
      SEMI = NEWVAL
      GO TO 1000
  800 CONTINUE
C
C     ECHO
C
      IF(LINE(12).NE.KYO) GO TO 900
      IF(LINE(13).NE.KYF) GO TO 850
C
C     OFF
C
      IF(LEN.NE.15) GO TO 900
      IF(LINE(14).NE.KYF) GO TO 900
      ECHO = .FALSE.
      GO TO 1000
  850 CONTINUE
C
C     ON
C
      IF(LEN.NE.14) GO TO 900
      IF(LINE(13).NE.KYN) GO TO 900
      ECHO = .TRUE.
      GO TO 1000
  900 CONTINUE
C
C     UNRECOGNIZABLE SET COMMAND
C
	if(nout.eq.6)goto 3140
      IF(NOUT.NE.0)WRITE(NOUT,910)
  910 FORMAT(46H *** WARNING *** Did NOT Recognize SET Command)
 1000 CONTINUE
      RETURN
3140	continue
	write(c128wk,910)
	call atxto
	return
      END
      FUNCTION LXWREC(I,J)
      INCLUDE rin:TEXT.BLK
C
C     THIS FUNCTION RETURNS THE JTH WORD OF ITEM I IF TEXT
C     IF I IS NOT A VALID TEXT ITEM BLANKS ARE RETURNED.
C
      INCLUDE rin:LXCARD.BLK
      INCLUDE rin:LXCON.BLK
      LXWREC = BLANKS
      IF(I.LT.1) RETURN
      IF(I.GT.NEWN) RETURN
      IF(J.LT.1) RETURN
      IF(TYPE(I).NE.TEXT) RETURN
      LEN = INT(RVAL(I))
      I1 = (J-1)*NCPW
      IF(I1.GE.LEN) RETURN
      K = INTVAL(I) + J - 1
      LXWREC = NEWREC(K)
      RETURN
      END
      SUBROUTINE MINMAX(MMVAL,MMTYP)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  PROCESS THE MIN/MAX REQUESTS
C
C  PARAMETERS: MMVAL--MIN/MAX VALUE
C              MMTYP--3HMIN OR 3HMAX (REQUEST TYPE)
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:BTBUF.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:F3COM.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:MISC.BLK
C
      DIMENSION MMVAL(*)
      EQUIVALENCE (IMVAL,RMVAL)
      EQUIVALENCE (IV,RV)
      CALL TYPER(ATTYPE,MATVEC,ITYPE)
      MMVAL(1) = NULL
C
C  CHECK FOR A KEYED ATTRIBUTE
C
      IF(ATTKEY.NE.0) GO TO 300
C
C  NON-KEYED ATTRIBUTE -- PROCESS THE FUNCTION
C
  100 CALL RMLOOK(IP,1,1,LEN)
      IF(RMSTAT.NE.0) GO TO 998
      MMVAL(1) = BUFFER(IP+ATTCOL-1)
      MMVAL(2) = BUFFER(IP+ATTCOL)
      IF(MMVAL(1).EQ.NULL) GO TO 100
  200 CALL RMLOOK(IP,1,1,LEN)
      IF(RMSTAT.NE.0) GO TO 998
      IV = BUFFER(IP+ATTCOL-1)
      IF(IV.EQ.NULL) GO TO 200
      IF((ITYPE.EQ.KZDOUB).OR.(ITYPE.EQ.KZREAL)) GO TO 210
      IF((MMTYP.EQ.K4MIN).AND.(IV.GT.MMVAL(1))) GO TO 200
      IF((MMTYP.EQ.K4MAX).AND.(IV.LT.MMVAL(1))) GO TO 200
      GO TO 220
  210 CONTINUE
      IMVAL = MMVAL(1)
      IF((MMTYP.EQ.K4MIN).AND.(RV.GT.RMVAL)) GO TO 200
      IF((MMTYP.EQ.K4MAX).AND.(RV.LT.RMVAL)) GO TO 200
  220 CONTINUE
      MMVAL(1) = IV
      MMVAL(2) = BUFFER(IP+ATTCOL)
      GO TO 200
C
C  KEYED ATTRIBUTE -- PROCESS THE FUNCTION
C
  300 IF(MMTYP.EQ.K4MAX) GO TO 400
C
C  GET THE MIN VALUE FROM THE BTREE
C
      KSTART = ATTKEY
  310 CALL BTGET(KSTART,IN)
      IF(VALUE(2,IN).GE.0) GO TO 320
C
C  GET THE NEXT NODE
C
      KSTART = -VALUE(2,IN)
      GO TO 310
C
C  WE FOUND THE MINIMUM
C
  320 CONTINUE
      MMVAL(1) = VALUE(1,IN)
      IF(ATTYPE.NE.KZDOUB) GO TO 998
      CALL GETDAT(1,VALUE(2,IN),IP,LEN)
      MMVAL(1) = BUFFER(IP+ATTCOL-1)
      MMVAL(2) = BUFFER(IP+ATTCOL)
      GO TO 998
C
C  GET THE MAXIMUM VALUE FROM THE BTREE
C
  400 CONTINUE
      KSTART = ATTKEY
  410 CALL BTGET(KSTART,IN)
      KEND = IN + (LENBF3/3) - 1
      DO 420 J=IN,KEND
      IF(VALUE(1,J).EQ.ENDWRD) GO TO 430
  420 CONTINUE
      GO TO 998
C
C  CHECK IF WE REACHED THE BOTTOM NODE
C
  430 CONTINUE
      IF(VALUE(2,J).GE.0) GO TO 440
C
C  GET THE NEXT NODE
C
      KSTART = -VALUE(2,J)
      GO TO 410
C
C  FOUND THE MAXIMUM NODE
C
  440 CONTINUE
      MMVAL(1) = VALUE(1,J-1)
      IF(ATTYPE.NE.KZDOUB) GO TO 998
      CALL GETDAT(1,VALUE(2,J-1),IP,LEN)
      MMVAL(1) = BUFFER(IP+ATTCOL-1)
      MMVAL(2) = BUFFER(IP+ATTCOL)
      GO TO 998
C
C  CHECK THAT A VALUE WAS OBTAINED
C
  998 CONTINUE
      RMSTAT = 0
      IF(MMVAL(1).NE.NULL) GO TO 999
C
C  ERROR - NULL VALUE
C
      RMSTAT = 44
  999 CONTINUE
      RETURN
      END
      SUBROUTINE MODIFY
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE IS THE DRIVER FOR MODIFY OF THE RIM DATA BASE.
C
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:ATTBLE.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:MISC.BLK
      LOGICAL EQKEYW
      LOGICAL NE
      LOGICAL EQ
      INCLUDE rin:DCLAR1.BLK
      INCLUDE rin:DCLAR6.BLK
      NEXTOP = K8READ
C
C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
C
      CALL RMDBLK(DBNAME)
      IF(RMSTAT.EQ.0) GO TO 200
      CALL WARN(RMSTAT,DBNAME,0)
      GO TO 5000
C
C  READ A CARD
C
  100 CONTINUE
      CALL LODREC
C
C  SCAN A COMMAND.
C
  200 CONTINUE
      IFMOD = .TRUE.
      ITEMS = LXITEM(NUM)
      IF(EQKEYW(1,KWCHAN,6)) GO TO 400
      IF(EQKEYW(1,KWRENA,6)) GO TO 1000
      IF(EQKEYW(1,KWREMO,6)) GO TO 2000
      IF(EQKEYW(1,KWDELE,6)) GO TO 3000
C
C  UNRECOGNIZED COMMAND.
C
  300 CONTINUE
      NEXTOP = K8USE
      GO TO 5000
C
C  *************************
C  CHANGE COMMAND.
C  *************************
C
  400 CONTINUE
      IF(ITEMS.LT.4) GO TO 4000
      ITO = LFIND(1,ITEMS,KWTO,2)
      IF(ITO.LT.3) GO TO 4000
      IF(ITO.GT.7) GO TO 4000
C
C     LOOK FOR CHANGE OWNER
C
      IF(EQKEYW(2,KWOWNE,5)) GO TO 1005
C
C  SEE IF THIS IS A CHANGE FOR PASSWORDS.
C
      IF(EQKEYW(2,KWRPW,3)) GO TO 410
      IF(EQKEYW(2,KWMPW,3)) GO TO 410
      GO TO 450
C
C  CHANGE THE PASSWORDS.
C
  410 CONTINUE
      IF(ITO.NE.3) GO TO 4000
      IF(.NOT.EQKEYW(5,KWFOR,3)) GO TO 4000
      IF(ITEMS.NE.6) GO TO 4000
      RNAME = BLANK
      CALL LXSREC(6,1,8,RNAME,1)
      I = LOCREL(RNAME)
      IF(I.EQ.0) GO TO 420
      CALL WARN(1,RNAME,0)
      GO TO 100
  420 CONTINUE
      L = LOCPRM(RNAME,2)
      IF(L.NE.0) GO TO 4500
      IF((LXLENC(4).GE.1).AND.(LXLENC(4).LE.8)) GO TO 425
	if(nout.eq.6)goto 3140
      WRITE(NOUT,422)
  422 FORMAT(44H -ERROR- PASSWORDS Must Be 1-8 Alphanumeric ,
     X       10HCharacters)
      GO TO 100
3140	continue
	write(c128wk,422)
	call atxto
	goto 100
  425 CONTINUE
      CALL RELGET(ISTAT)
C
C  CHANGE THE PASSWORD.
C
      IF(.NOT.EQKEYW(2,KWRPW,3)) GO TO 430
      RPW = BLANK
      CALL LXSREC(4,1,8,RPW,1)
      GO TO 440
  430 CONTINUE
      MPW = BLANK
      CALL LXSREC(4,1,8,MPW,1)
  440 CONTINUE
      CALL RELPUT
      GO TO 100
  450 CONTINUE
C
C  DEFINE THE BUFFERS FOR CHANGE
C
      CALL BLKDEF(10,MAXCOL,1)
C
C  USE HALF PAGE BUFFER FOR NEW ATTRIBUTE VALUE
C
      NCOLU = MAXCOL/2
      CALL BLKDEF(11,NCOLU,1)
C
C  SCAN FOR THE WORD FROM OR IN.
C
      IFLAG = 0
      J = LFIND(1,ITEMS,KWIN,2)
      RNAME = BLANK
      CALL LXSREC(J+1,1,8,RNAME,1)
      IF(J.NE.0) GO TO 460
      J = LFIND(1,ITEMS,KWFROM,4)
      RNAME = BLANK
      CALL LXSREC(J+1,1,8,RNAME,1)
      IF(J.NE.0) GO TO 460
C
C  ALL RELATIONS.
C
      IFLAG = 1
      RNAME = BLANK
  460 CONTINUE
C
C  SCAN THROUGH THE ATTRIBUTE TABLE LOOKING FOR THE ATTRIBUTE.
C
      NAC = 0
      NA = 0
      ANAME = BLANK
      CALL LXSREC(2,1,8,ANAME,1)
      I = LOCATT(ANAME,RNAME)
      IF(I.EQ.0) GO TO 500
      CALL WARN(3,ANAME,RNAME)
      GO TO 100
  500 CONTINUE
      NA = NA + 1
      I = LOCATT(ANAME,RNAME)
      DO 550 I=1,NA
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 800
  550 CONTINUE
C
C  FIND THE RELATION NAME IN RELATION TABLE.
C
      I = LOCREL(RELNAM)
      IF(I.EQ.0) GO TO 600
C
C  UNRECOGNIZED RELATION NAME.
C
      CALL WARN(1,RELNAM,0)
      GO TO 100
  600 CONTINUE
      CALL RELGET(ISTAT)
C
C  CHECK FOR AUTHORIZATION.
C
      L = LOCPRM(RELNAM,2)
      IF(L.EQ.0) GO TO 700
      IF(IFLAG.EQ.1) GO TO 500
      GO TO 4500
  700 CONTINUE
C
C  CALL CHANGE TO FINISH PROCESSING THE COMMAND.
C
      KQ1 = BLKLOC(10)
      KQ11 = BLKLOC(11)
      CALL RMDATE(RDATE)
      NAC = NAC + 1
      CALL CHANGE(BUFFER(KQ1),BUFFER(KQ11))
      IF(IFLAG.EQ.0) GO TO 100
      GO TO 500
  800 CONTINUE
	if(nac.ne.0)goto 100
	if(nout.eq.6)goto 3141
       WRITE(NOUT,9001)
 9001 FORMAT(20H      0 ROWS CHANGED )
      GO TO 100
3141	continue
	write(c128wk,9001)
	call atxto
	goto 100
C
C  *************************
C  RENAME COMMAND.
C  *************************
C
 1000 CONTINUE
C
C  CHECK RENAME SYNTAX
C
      IF(EQKEYW(2,KWRELA,8)) GO TO 1100
      IATT = 2
      IF(EQKEYW(2,KWATTR,9)) GO TO 1050
      IATT = 1
      GO TO 1050
 1005 CONTINUE
C
C  CHANGE THE OWNER.
C
      IF(NE(USERID,OWNER)) GO TO 1010
      IF(ITEMS.NE.4) GO TO 4000
      IF((LXLENC(4).GE.1).AND.(LXLENC(4).LE.8)) GO TO 1008
      CALL WARN(7,KWOWNE,BLANK)
      GO TO 100
 1008 CONTINUE
      OWNER = BLANK
      CALL LXSREC(4,1,8,OWNER,1)
      GO TO 100
C
C  UNABLE TO CHANGE THE OWNER.
C
 1010 CONTINUE
	if(nout.eq.6)goto 3142
      WRITE(NOUT,9002)
 9002 FORMAT(41H -ERROR- Unauthorized To Change The OWNER)
      GO TO 100
3142	continue
	write(c128wk,9002)
	call atxto
	goto 100
 1050 CONTINUE
C
C     RENAME ATTRIBUTE
C
      CALL RNAMEA(IATT)
      GO TO 100
 1100 CONTINUE
C
C     RENAME RELATION
C
      CALL RNAMER
      GO TO 100
C+  MAKE SURE THAT THE RULES GET CHANGED AS NEEDED
C
C  *************************
C  REMOVE COMMAND.
C  *************************
C
 2000 CONTINUE
      RNAME = BLANK
      CALL LXSREC(2,1,8,RNAME,1)
      IF(ITEMS.NE.2) GO TO 4000
C
C  FIND THE RELATION NAME IN THE RELATION TABLE.
C
      I = LOCREL(RNAME)
      IF(I.EQ.0) GO TO 2200
C
C  UNRECOGNIZED RELATION NAME.
C
      CALL WARN(1,RNAME,0)
      GO TO 100
 2200 CONTINUE
C
C  CHECK FOR AUTHORIZATION.
C
      L = LOCPRM(RNAME,2)
      IF(L.NE.0) GO TO 4500
C
C  CHANGE THE RELATION TABLE.
C
      CALL RELGET(ISTAT)
      CALL RELDEL
C
C  CHANGE THE ATTRIBUTE TABLE.
C
      I = LOCATT(BLANK,RNAME)
      IF(I.NE.0) GO TO 100
 2300 CONTINUE
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 100
      CALL ATTDEL(ISTAT)
      IF(ISTAT.NE.0) GO TO 100
      GO TO 2300
C
C  *************************
C  DELETE COMMAND.
C  *************************
C
 3000 CONTINUE
      IF(EQKEYW(2,KWKEY,3)) GO TO 3600
      IF(EQKEYW(2,KWRULE,4)) GO TO 3900
C
C   FIND THE WORD FROM OR IN
C
      J = LFIND(1,ITEMS,KWFROM,4)
      IF(J.NE.0) GO TO 3100
      J = LFIND(1,ITEMS,KWIN,2)
      IF(J.EQ.0) GO TO 4000
 3100 CONTINUE
      IF(EQKEYW(2,KWTUPL,6)) GO TO 3200
      IF(EQKEYW(2,KWROWS,4)) GO TO 3200
      IF(EQKEYW(2,KWDUPL,10)) GO TO 3200
      GO TO 4000
 3200 CONTINUE
C
C  FIND THE RELATION NAME IN THE RELATION TABLE.
C
      RNAME = BLANK
      CALL LXSREC(J+1,1,8,RNAME,1)
      I = LOCREL(RNAME)
      IF(I.EQ.0) GO TO 3300
C
C  UNRECOGNIZED RELATION NAME.
C
      CALL WARN(1,RNAME,0)
      GO TO 100
 3300 CONTINUE
C
C  CHECK FOR AUTHORIZATION.
C
      L = LOCPRM(RNAME,2)
      IF(L.NE.0) GO TO 4500
      IF(EQKEYW(2,KWDUPL,10)) GO TO 3500
C
C  CALL DELETE TO FINISH PROCESSING THE COMMAND.
C
      CALL BLKDEF(10,MAXCOL,1)
      KQ1 = BLKLOC(10)
      CALL DELETE(BUFFER(KQ1))
      CALL BLKCLR(10)
      GO TO 100
C
C  CALL DELDUP TO DELETE ALL DUPLICATES FROM THE RELATION.
C
 3500 CONTINUE
      CALL BLKDEF(10,MAXCOL,1)
      KQ1 = BLKLOC(10)
      CALL DELDUP(BUFFER(KQ1))
      CALL BLKCLR(10)
      GO TO 100
C
C  REMOVE THE KEY FOR AN ATTRIBUTE.
C
 3600 CONTINUE
      IF(ITEMS.GT.6) GO TO 4000
      RNAME = BLANK
      CALL LXSREC(6,1,8,RNAME,1)
      I = LOCREL(RNAME)
      IF(I.EQ.0) GO TO 3700
C
C  UNRECOGNIZED RELATION NAME.
C
      CALL WARN(1,RNAME,0)
      GO TO 100
 3700 CONTINUE
C
C  CHECK FOR AUTHORIZATION.
C
      L = LOCPRM(RNAME,2)
      IF(L.NE.0) GO TO 4500
      NAMOLD = BLANK
      CALL LXSREC(4,1,8,NAMOLD,1)
      I = LOCATT(NAMOLD,RNAME)
      IF(I.EQ.0) GO TO 3800
      CALL WARN(3,NAMOLD,RNAME)
      GO TO 100
 3800 CONTINUE
C
C  CHANGE THE KEY POINTER TO 0.
C
      CALL ATTGET(ISTAT)
      ATTKEY = 0
      CALL ATTPUT(ISTAT)
      GO TO 100
C
C  DELETE A RULE.
C
 3900 CONTINUE
C
C  CHECK FOR PERMISSION
C
      IF(EQ(USERID,OWNER)) GO TO 3950
	if(nout.eq.6)goto 3145
      WRITE(NOUT,3910)
 3910 FORMAT(41H -ERROR- Unauthorized Access To The RULES )
      GO TO 100
3145	continue
	write(c128wk,3910)
	call atxto
	goto 100
C
C  GET THE RULE NUMBER AND CALL RULDEL
C
 3950 CONTINUE
      NUMRUL = LXIREC(3)
      RNAME = K8RRC
      CALL RULDEL(RNAME,NUMRUL)
      IF(RMSTAT.EQ.110) GO TO 100
      RNAME = K8RDT
      CALL RULDEL(RNAME,NUMRUL)
      GO TO 100
C
C  SYNTAX ERRORS.
C
 4000 CONTINUE
      CALL WARN(4,0,0)
      GO TO 100
C
C  ILLEGAL RELATION ACCESS - WRONG PASSWORD
C
 4500 CONTINUE
      CALL WARN(9,RNAME,0)
      RMSTAT = 0
      GO TO 100
C
C  FINAL PRINT.
C
 5000 CONTINUE
      CALL BLKCLR(10)
      CALL BLKCLR(11)
      RETURN
      END
      SUBROUTINE MOTSCN(MOTID,IPTR)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  SCAN THROUGH A MULTIPLE OCCURENCE TABLE (MOT)
C
C  PARAMETERS
C    INPUT:  MOTID---ID FOR THIS WORD
C    OUTPUT: MOTID---ID FOR MOT WORD NEXT TIME OR 0
C                    (0 IMPLIES THIS IS THE LAST VALUE)
C            IPTR----USER POINTER DESIRED
C
C  DECLARATIVES
      INCLUDE rin:BTBUF.BLK
C
C  CHECK FOR END OF MOT LIST.
C
  100 CONTINUE
      IF(MOTID.EQ.0) RETURN
C
C  GET THE MOT BLOCK THAT IS NEEDED.
C
      CALL ITOH(MOTIND,MOTIDP,MOTID)
      CALL BTGET(MOTIDP,IN)
      IND = 3 * IN - 3
      MOTIND = MOTIND + IND
C
C  RETRIEVE THE NEEDED WORD.
C
      MOTID = CORE(MOTIND)
      IPTR = CORE(MOTIND+1)
      IF(IPTR.EQ.0) GO TO 100
C
C  RETURN WITH THE VALUES.
C
      RETURN
      END
      LOGICAL FUNCTION NE(WORD1,WORD2)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   COMPARE WORD1 AND WORD2 FOR NE
C
C  PARAMETERS:
C         WORD1---A WORD OF TEXT
C         WORD2---ANOTHER WORD OF TEXT
C         NE------.TRUE. IF WORD1.NE.WORD2
C                 .FALSE. IF NOT NE
      INCLUDE rin:DCLAR6.BLK
C
      NE = WORD1.NE.WORD2
      RETURN
      END
      INTEGER FUNCTION NSCAN(STR1,IC1,LC1,STR2,IC2,LC2)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   LOCATE THE FIRST CHARACTER IN STR1 WHICH DOES
C             NOT MATCH THE CHARACTERS IN STR2
C
C  PARAMETERS:
C     STR1----FIRST HOLLERITH STRING
C     IC1-----STARTING CHARACTER IN STR1 TO START THE SCAN
C     LC1-----LENGTH OF STR1
C     STR2----SECOND HOLLERITH STRING
C     IC2-----STARTING CHARACTER IN STR2
C     LC2-----LENGTH OF STR2
C     NSCAN---CHARACTER POSITION IN STR1 OF FIRST MISMATCH
C             0 IF ALL MATCH
C
      Character*1 STR1(*)
      Character*1 STR2(*)
C
C  IF LC1 IS NEGATIVE THE SCAN IS RIGHT TO LEFT.
C
      INC = 1
      IF(LC1.LT.0) INC = -1
      LC = INC * LC1
      I1 = IC1
C
C  SCAN STR1.
C
      DO 200 I=1,LC
      I2 = IC2 - 1
      DO 100 J=1,LC2
      I2 = I2 + 1
      IF(STR1(I1).NE.STR2(I2)) GO TO 300
  100 CONTINUE
      I1 = I1 + INC
  200 CONTINUE
C
C  ALL CHARACTERS MATCH.
C
      NSCAN = 0
      RETURN
C
C  WE FOUND A NON-MATCHING CHARACTER.
C
  300 CONTINUE
      NSCAN = I1
      RETURN
      END
      SUBROUTINE PARVAL(ID,MAT,ATYPE,NWORDS,ROW,NCOLT,IERR)
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE PARSES A VALUE SPECIFICATION AND STORES THE
C     VALUE IN MAT.
C
C     PARAMETERS.......
C     ID.......INPUT - STARTING LXLREC ITEM NUMBER
C              OUTPUT- 1+ITEM NUMBER OF LAST ITEM IN VALUE
C     MAT......OUTPUT- ARRAY OF VALUES
C     ATYPE....INPUT - RVEC,IMAT,DOUB STUFF
C     NWORDS...INPUT - NWORDS PART OF ATTLEN
C              OUTPUT- ACTUAL NWORDS
C     ROW......INPUT - OTHER PART OF ATTLEN
C              OUTPUT- ACTUAL VALUE
C     IERR.....OUTPUT- ERROR FLAG
C                      0 MEANS OK
C                      1 IF TYPE MISMATCH
C                      2 IF COUNT MISMATCH
C                      3 IF PAREN MISMATCH
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:MISC.BLK
      INTEGER ATYPE,VECMAT,TYPE,ROW
      EQUIVALENCE (IR,RR)
      DIMENSION MAT(*)
      IF(NCOLT.GT.MAXCOL) GO TO 8300
      ITEMS = LXITEM(IDUMMY)
      IERR = 0
      CALL TYPER(ATYPE,VECMAT,JTYPE)
      TYPE = JTYPE
      IF(TYPE.EQ.KZDOUB) TYPE = KZREAL
      IF(LXWREC(ID,1).EQ.NULL) GO TO 600
      NWORD = NWORDS
      IF(JTYPE.EQ.KZDOUB) NWORD = NWORDS/2
      IF(TYPE.NE.KZTEXT) GO TO 100
C
C     TEXT STUFF
C
      IF(LXID(ID).NE.KZTEXT) GO TO 8000
      NW = LXLENW(ID)
      IF(NWORD.EQ.0) GO TO 50
C
C     FIXED TEXT
C
      IF(LXLENC(ID).GT.ROW) GO TO 8100
      NW = NWORD
      GO TO 80
   50 CONTINUE
C
C     VARIABLE TEXT
C
      IF((NCOLT+NW).GT.MAXCOL) GO TO 8300
      NWORD = NW
      ROW = LXLENC(ID)
   80 CONTINUE
      DO 90 I=1,NW
      MAT(I) = LXWREC(ID,I)
   90 CONTINUE
      ID = ID + 1
      NWORDS = NWORD
      RETURN
  100 CONTINUE
      NUMI = ITEMS - ID + 1
      IF(NWORD.GT.NUMI) GO TO 8100
C
C     NON-TEXT STUFF
C
      IF(LXWREC(ID,1).NE.K4LPAR) GO TO 500
C
C     WE HAVE PARENS
C
      IF(VECMAT.EQ.KZMAT) GO TO 300
C
C     VECTOR
C
      IF(NWORD.EQ.0) GO TO 200
C
C     FIXED LENGTH VECTOR
C
      IF(LXWREC(ID+NWORD+1,1).NE.K4RPAR) GO TO 8100
      DO 150 I=1,NWORD
      IF(LXID(ID+I).NE.TYPE) GO TO 8000
  150 CONTINUE
      IS = ID + 1
      NW = NWORD
      ID = ID + NWORD + 2
      GO TO 1000
  200 CONTINUE
C
C     VARIABLE
C
      L = LFIND(ID,ITEMS-ID+1,K4RPAR,1)
      IF(L.EQ.0) GO TO 8200
      NW = L - ID - 1
      IF((NCOLT+NW).GT.MAXCOL) GO TO 8300
      NWORD = NW
      ROW = 1
      DO 250 I=1,NWORD
      IF(LXID(ID+I).NE.TYPE) GO TO 8000
  250 CONTINUE
      IS = ID + 1
      ID = L +  1
      GO TO 1000
  300 CONTINUE
      IF(NWORD.EQ.0) GO TO 400
C
C     FIXED MATRIX
C
      ISKIP = ROW + 2
      NCOLS = NWORD/ROW
      IP = ID + 1
      DO 320 I=1,NCOLS
      IF(LXWREC(IP,1).NE.K4LPAR) GO TO 8200
      DO 310 J=1,ROW
      IF(LXID(IP+J).NE.TYPE) GO TO 8000
  310 CONTINUE
      IF(LXWREC(IP+ROW+1,1).NE.K4RPAR) GO TO 8200
      IP = IP + ISKIP
  320 CONTINUE
      IF(LXWREC(IP-1,1).NE.K4RPAR) GO TO 8200
      IS = ID + 2
      NW = ISKIP*NCOLS
      ID = IS + NW
      GO TO 1000
  400 CONTINUE
C
C     VARIABLE MATRIX - SET NWORD AND ROW THEN USE FIXED CODE
C
      L = LFIND(ID,ITEMS-ID+1,K4RPAR,1)
      IF(L.EQ.0) GO TO 8200
      IROW = L - ID - 2
      IF(IROW.LE.0) GO TO 8100
      IF(ROW.EQ.0) ROW = IROW
      IF(IROW.NE.ROW) GO TO 8100
      ISKIP = ROW + 2
      IS = ID + 1
      NCOLS = 0
      DO 420 I=IS,ITEMS,ISKIP
      IF(LXWREC(I,1).EQ.K4RPAR) GO TO 450
      NCOLS = NCOLS + 1
  420 CONTINUE
      GO TO 8200
  450 CONTINUE
      NWX = ROW*NCOLS
      IF(JTYPE.EQ.KZDOUB) NWX = 2*NWX
      IF((NCOLT+NWX).GT.MAXCOL) GO TO 8300
      NWORD = ROW*NCOLS
      GO TO 300
  500 CONTINUE
C
C     NO PARENS
C
      IF(NWORD.EQ.0) GO TO 8200
      DO 550 I=1,NWORD
      IF(LXID(ID+I-1).NE.TYPE) GO TO 8000
  550 CONTINUE
      IS = ID
      NW = NWORD
      ID = ID + NWORD
      GO TO 1000
  600 CONTINUE
C
C     NULL VALUES
C
      ID = ID + 1
      IF(NWORDS .EQ.0) GO TO 650
C
C     FIXED NULL
C
      NW = NWORDS
      DO 620 I=1,NW
      MAT(I) = IBLANK
  620 CONTINUE
      MAT(1) = NULL
      GO TO 9999
  650 CONTINUE
C
C VARIABLE NULL
C
      IF((NCOLT+1).GT.MAXCOL) GO TO 8300
      MAT(1) = NULL
      NWORDS = 1
      ROW = 1
      IF(ATYPE.EQ.KZTEXT) ROW = 3
      IF(JTYPE.NE.KZDOUB) GO TO 9999
      IF((NCOLT+2).GT.MAXCOL) GO TO 8300
      NWORDS = 2
      MAT(2) = IBLANK
      GO TO 9999
 1000 CONTINUE
C
C     DUMP STUFF INTO MAT
C
      NW = NW + IS - 1
      MATIN = 1
      IF(JTYPE.EQ.KZDOUB) GO TO 1200
      IF(TYPE.EQ.KZINT) GO TO 1100
C
C     REAL AND SINGLE WORD DOUBLE
C
      DO 1050 I=IS,NW
      IF(LXID(I).EQ.KZTEXT) GO TO 1050
      RR = RXREC(I)
      MAT(MATIN) = IR
      MATIN = MATIN + 1
 1050 CONTINUE
      GO TO 9990
 1100 CONTINUE
C
C     INTEGER
C
      DO 1150 I=IS,NW
      IF(LXID(I).EQ.KZTEXT) GO TO 1150
      MAT(MATIN) = LXIREC(I)
      MATIN = MATIN + 1
 1150 CONTINUE
      GO TO 9990
 1200 CONTINUE
C
C     TWO WORD DOUBLE
C
      DO 1250 I=IS,NW
      IF(LXID(I).EQ.KZTEXT) GO TO 1250
      RR = RXREC(I)
      MAT(MATIN) = IR
      MAT(MATIN+1) = 0
      MATIN = MATIN + 2
 1250 CONTINUE
      GO TO 9990
 8000 CONTINUE
	if(nout.eq.6)goto 3140
      WRITE (NOUT,8010) ID
 8010 FORMAT(50H -ERROR- Type Mismatch For Value Starting At Item ,I3)
      IERR = 1
      GO TO 9999
3140	write(c128wk,8010) ID
	call atxto
	ierr=1
	goto 9999
 8100 CONTINUE
	if(nout.eq.6)goto 3141
      WRITE (NOUT,8110)ID
 8110 FORMAT(
     X 53H -ERROR- Incorrect Length For Value Starting At Item ,I3)
      IERR = 2
      GO TO 9999
3141	continue
	write(c128wk,8110)ID
	call atxto
	ierr=2
	goto 9999
 8200 CONTINUE
	if (nout.eq.6)goto 3142
      WRITE (NOUT,8210) ID
 8210 FORMAT(
     X 51H -ERROR- Paren Mismatch For Value Starting At Item ,I3)
      IERR = 3
      GO TO 9999
3142	continue
	write(c128wk,8210)ID
	call atxto
	ierr=3
	goto 9999
 8300 CONTINUE
	if(nout.eq.6)goto 3143
      WRITE(NOUT,8310) MAXCOL
 8310 FORMAT(36H -ERROR- Relation Row Length Exceeds,I5)
      IERR = 2
      GO TO 9999
3143	continue
	write(c128wk,8310)MAXCOL
	call atxto
	ierr=2
	goto 9999
 9990 CONTINUE
C
C     RESET NWORDS
C
      NWORDS = NWORD
      IF(JTYPE.EQ.KZDOUB) NWORDS = 2*NWORD
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE PJECT
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE PERFORMS PHYSICAL PROJECTIONS ON EXISTING RELATIONS.
C  THE SYNTAX OF THE PROJECT COMMAND IS :
C
C     PROJECT RNAME2 FROM RNAME1 USING ATTR1 ATTR2...ATTRN
C     -------        ----        -----
C
C
C     INPUTS :
C        LODREC(1) = 'PROJECT'
C        LODREC(2) = NEW RELATION NAME
C        LODREC(3) = 'FROM'
C        LODREC(4) = OLD RELATION NAME
C        LODREC(5) = 'USING'
C        LODREC(6) = ATTRIBUTE 1
C        LODREC(7) = ATTRIBUTE 2
C           .             .
C           .             .
C        LODREC(N) = ATTRIBUTE N-5
C
C
C     OUTPUTS :
C        NEW RELATION TABLES AND DATA TABLES FOR RNAME2
C
C
C
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:FLAGS.BLK
C
C
      INTEGER STATUS
      LOGICAL EQKEYW
      INTEGER ATNCOL
      INCLUDE rin:DCLAR1.BLK
C
C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
C
      CALL RMDBLK(DBNAME)
      IF(RMSTAT.EQ.0) GO TO 1000
      CALL WARN(RMSTAT,DBNAME,0)
      GO TO 9999
C
C  KEYWORD SYNTAX IS OKAY - NOW CHECK RELATION NAMES
C
 1000 CONTINUE
      CALL BLKCLN
      IF(.NOT.EQKEYW(3,KWFROM,4)) GO TO 9900
      IF(.NOT.EQKEYW(5,KWUSIN,5)) GO TO 9900
      RNAME1 = BLANK
      CALL LXSREC(4,1,8,RNAME1,1)
      I = LOCREL(RNAME1)
      LENF = NCOL
      IF(I.EQ.0) GO TO 1100
C
C  RNAME1 DOES NOT EXIST
C
      CALL WARN(1,RNAME1,0)
      GO TO 9999
C
C
 1100 CONTINUE
      IF((LXLENC(2).GE.1).AND.(LXLENC(2).LE.8)) GO TO 1200
      CALL WARN(7,KWRELA,BLANK)
      GO TO 9999
 1200 CONTINUE
      RNAME2 = BLANK
      CALL LXSREC(2,1,8,RNAME2,1)
      I = LOCREL(RNAME2)
      IF(I.NE.0) GO TO 1400
C
C  DUPLICATE RELATION NAME ENCOUNTERED
C
	if(nout.eq.6)goto 3140
      WRITE (NOUT,1220)
 1220 FORMAT(
     X 55H -ERROR- Resultant Relation Does Not Have A Unique Name )
      GO TO 9999
3140	continue
	write(c128wk,1220)
	call atxto
	goto 9999
C
C  CHECK USER READ SECURITY
C
 1400 CONTINUE
      I = LOCREL(RNAME1)
      I = LOCPRM(RNAME1,1)
      IF(I.EQ.0) GO TO 1410
      CALL WARN(9,RNAME1,0)
      GO TO 9999
 1410 CONTINUE
      NS = 0
      NID = RSTART
C
C  SET UP THE WHERE CLAUSE
C
      ITEMS = LXITEM(NUM)
      K = LFIND(1,ITEMS,KWWHER,5)
      NBOO = 0
      LIMTU = ALL9S
      RMSTAT = 0
      KKX = K
      IF(K.NE.0) CALL WHERE(KKX)
      IF(RMSTAT.NE.0) GO TO 9999
C
C  CHECK THE ATTRIBUTES AND BUILD POINTER ARRAY - POS. 10
C
      NOATTS = 0
      CALL BLKDEF(10,LENF,1)
      KQ10 = BLKLOC(10) - 1
      NOCOLS = 0
      II = ITEMS
      IF(K.NE.0) II = K - 1
      IFALL = 0
      IF(II.NE.6) GO TO 1450
      IF(.NOT.EQKEYW(6,KWALL,3)) GO TO 1450
C
C     ALL
C
      II = NATT + 5
      IFALL = 1
      GO TO 1470
 1450 CONTINUE
C
C  CHECK THAT ALL ATTRIBUTES ARE LEGAL
C
      IERR = 0
      DO 1460 I=6,II
      ANAME = BLANK
      CALL LXSREC(I,1,8,ANAME,1)
      IF(LOCATT(ANAME,NAME).EQ.0) GO TO 1460
      CALL WARN(3,ANAME,NAME)
      IERR = 1
 1460 CONTINUE
      IF(IERR.EQ.1) GO TO 9999
 1470 CONTINUE
      CALL ATTNEW(RNAME2,II-5)
      DO 1600 I=6,II
      IF(IFALL.EQ.0) GO TO 1490
      NUM = I - 5
      STATUS = LOCATT(BLANK,NAME)
      DO 1480 J=1,NUM
      CALL ATTGET(STATUS)
      IF(STATUS.NE.0) GO TO 1600
 1480 CONTINUE
      GO TO 1500
 1490 CONTINUE
      ANAME = BLANK
      CALL LXSREC(I,1,8,ANAME,1)
      IERR = LOCATT(ANAME,NAME)
 1500 CONTINUE
      IF(IFALL.EQ.0) CALL ATTGET(STATUS)
      NOATTS = NOATTS + 1
      ATNCOL = NOCOLS + 1
      IF(ATTWDS.LE.0) GO TO 1540
C
C     FIXED LENGTH
C
      KQ = KQ10 + ATTCOL
      DO 1520 KK=1,ATTWDS
      NOCOLS = NOCOLS + 1
      BUFFER(KQ) = NOCOLS
      KQ = KQ + 1
 1520 CONTINUE
      GO TO 1560
 1540 CONTINUE
C
C     VARIABLE LENGTH
C
      NOCOLS = NOCOLS + 1
      BUFFER(KQ10+ATTCOL) = -NOCOLS
 1560 CONTINUE
      RELNAM = RNAME2
      ATTCOL = ATNCOL
      ATTKEY = 0
      CALL ATTADD
 1600 CONTINUE
C
C  SET UP RELTBLE
C
      NAME = RNAME2
      CALL RMDATE(RDATE)
      NCOL = NOCOLS
      NATT = NOATTS
      NTUPLE = 0
      RSTART = 0
      REND = 0
      CALL RELADD
C
C     1 IS INPUT BUFFER, 2 IS OUTPUT BUFFER, 11 IS OUTPUT TUPLE
C
      LPAG = MAXCOL + 2
      CALL BLKDEF(11,LPAG,1)
      KQ11 = BLKLOC(11)
C
C     LOOP THRU THOSE TUPLES
C
      RMSTAT = 0
      I = LOCREL(RNAME1)
      KNEW = 0
      MSTART = 0
      MEND = 0
 1700 CONTINUE
      CALL RMLOOK(IPOINT,1,1,LENGTH)
      IF(RMSTAT.NE.0) GO TO 1800
      CALL PRJTUP(BUFFER(KQ10+1),LENF,NOCOLS,BUFFER(IPOINT),
     X            BUFFER(KQ11),LENT)
      CALL ADDDAT(2,MEND,BUFFER(KQ11),LENT)
      IF(MSTART.EQ.0)MSTART = MEND
      KNEW = KNEW + 1
      GO TO 1700
 1800 CONTINUE
      I = LOCREL(RNAME2)
      CALL RELGET(STATUS)
      NTUPLE = KNEW
      RSTART = MSTART
      REND = MEND
      CALL RELPUT
	if(nout.eq.6)goto 3144
      WRITE (NOUT,2180) KNEW
 2180 FORMAT(30H Successful PROJECT Operation ,I5,
     X       15H Rows Generated  )
      GO TO 9999
3144	continue
	write(c128wk,2180) KNEW
	call atxto
	goto 9999
C
C
 9900 CONTINUE
      CALL WARN(4,0,0)
C
 9999 CONTINUE
      CALL BLKCLR(10)
      CALL BLKCLR(11)
      RETURN
      END
      SUBROUTINE PRJTUP(POINTS,LENP,LENNEW,OLDTUP,NEWTUP,LENT)
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE BUILDS A NEW TUPLE FROM AN OLD TUPLE USING
C     POINTS AS A GUIDING ARRAY.
C
C   INPUT
C     POINTS  - ARRAY THE LENGTH OF THE FIXED PORTION OF OLDREL.
C               EACH WORD CONTAINS A ZERO OR THE RECIEVING ADDRESS
C               IN NEW TUPLE (ZERO MEANS NOT IN NEW TUPLE)
C               IF ATTRIBUTE IS VARIABLE ADDRESS IS STORED AS NEGATIVE
C     LENP    - LENGTH OF POINTS
C     LENNEW  - LENGTH OF FIXED PORTION OF NEW TUPLE
C     OLDTUP  - OLD TUPLE
C   OUTPUT
C     NEWTUP  - NEW TUPLE
C     LENT    - LENGTH OF NEW TUPLE
C
      INTEGER POINTS(LENP),OLDTUP(LENP),NEWTUP(LENP)
      LENT = LENNEW
      DO 100 I=1,LENP
      IF(POINTS(I).EQ.0) GO TO 100
      IF(POINTS(I).GT.0) GO TO 50
C
C     VARIABLE ATTRIBUTE
C
      IADD = OLDTUP(I)
      NOCOLS = -POINTS(I)
      NEWTUP(NOCOLS) = LENT + 1
      LEN = OLDTUP(IADD) + 2
      DO 40 K=1,LEN
      LENT = LENT + 1
      NEWTUP(LENT) = OLDTUP(IADD)
      IADD = IADD + 1
   40 CONTINUE
      GO TO 100
   50 CONTINUE
C
C     FIXED ATTRIBUTE
C
      NUM = POINTS(I)
      NEWTUP(NUM) = OLDTUP(I)
  100 CONTINUE
      RETURN
      END
      SUBROUTINE PRULE(NUMRUL)
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE DUMPS OUT RULES ASSOCIATED WITH A RIM DATABASE
C
C  PARAMETERS:
C     NUMRUL--NUMBER OF THE RULE TO PRINT
C
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:RELTBL.BLK
C
      DIMENSION MAT(24)
      DIMENSION LINE(18)
      INTEGER SAVSCR(21)
      INTEGER SAVTUR(13)
      INTEGER ANDOR
      LOGICAL EQ
C
C  PRINT HEADING.
C
	if(noutr.eq.6)goto 3140
      WRITE(NOUTR,9000) NUMRUL
 9000 FORMAT(13H RULE NUMBER ,I5)
	goto 3141
3140	continue
	write(c128wk,9000) NUMRUL
	call atxto
3141	continue
C
C  PROCESS THIS RULE.
C
      MWDS = 5 + ((8-1)/CHPWD + 1)*4
      CALL BLKMOV(SAVTUR,NAME,MWDS)
      CALL BLKMOV(SAVSCR,IVAL,6)
      SAVSCR(7) = NBOO
      SAVSCR(8) = BOO(1)
      SAVSCR(9) = KATTP(1)
      SAVSCR(10) = KATTL(1)
      SAVSCR(11) = KATTY(1)
      SAVSCR(12) = KOMTYP(1)
      SAVSCR(13) = KOMPOS(1)
      SAVSCR(14) = KOMLEN(1)
      SAVSCR(15) = KOMPOT(1)
      SAVSCR(16) = KSTRT
      SAVSCR(17) = MAXTU
      SAVSCR(18) = LIMTU
      SAVSCR(19) = WHRVAL(1)
      SAVSCR(20) = WHRVAL(2)
      SAVSCR(21) = WHRLEN(1)
C
C  PREPARE TO CALL RMLOOK.
C
      I = LOCREL(K8RDT)
      IF(I.NE.0) GO TO 9999
C
C  SET UP A WHERE CLAUSE FOR THE ATTRIBUTE VALUE
C
      RMSTAT = 0
      NBOO = 0
      I = LOCATT(K8NUM,K8RDT)
      IF(I.NE.0) GO TO 9999
      CALL ATTGET(I)
      IF(I.NE.0) GO TO 9999
      NBOO = 1
      BOO(1) = K4AND
      KATTP(1) = ATTCOL
      KATTL(1) = ATTLEN
      KATTY(1) = ATTYPE
      KOMTYP(1) = 2
      KOMPOS(1) = 1
      KOMLEN(1) = 1
      KOMPOT(1) = 1
      WHRVAL(1) = NUMRUL
      WHRLEN(1) = 1
      KSTRT = 0
      MAXTU = ALL9S
      LIMTU = ALL9S
      CALL RMLOOK(MAT,2,0,LEN)
  100 CONTINUE
      IF(RMSTAT.NE.0) GO TO 9999
C
C  BLANK FILL THE LINE.
C
      CALL FILCH(LINE,1,72,BLANK)
      CALL STRMOV(MAT(4),1,8,LINE,2)
      IF(EQ(MAT(6),BLANK)) GO TO 300
C
C  THERE IS AN 'IN' CLAUSE.
C
      CALL STRMOV(BLANK,1,4,LINE,10)
      CALL STRMOV(KWIN,1,2,LINE,11)
      CALL STRMOV(MAT(6),1,8,LINE,14)
      GO TO 400
C
C  NO 'IN' CLAUSE.
C
  300 CONTINUE
      CALL STRMOV(BLANK,1,4,LINE,10)
      CALL STRMOV(BLANK,1,8,LINE,14)
C
C  IS RELNAME2 BLANK ?
C
  400 CONTINUE
      CALL STRMOV(BLANK,1,5,LINE,22)
      CALL STRMOV(MAT(8),1,3,LINE,23)
      CALL ITOH(NCHAR,ITYPE,MAT(10))
      IF(ITYPE.NE.3) GO TO 500
C
C  OBJECT IS AN ATTRIBUTE.
C
      CALL STRMOV(MAT(11),1,8,LINE,27)
      CALL STRMOV(BLANK,1,4,LINE,35)
      CALL STRMOV(KWIN,1,2,LINE,36)
      CALL STRMOV(MAT(13),1,8,LINE,39)
      GO TO 700
C
C  OBJECT IS A VALUE .
C
  500 CONTINUE
      IF(ITYPE.EQ.0) CALL STRMOV(MAT(15),1,NCHAR,LINE,27)
      IF(ITYPE.EQ.1) CALL ITOC(LINE,27,10,MAT(15),IERR)
      IF(ITYPE.EQ.2) CALL RTOC(LINE,27,10,MAT(15))
C
  700 CONTINUE
      CALL STRMOV(BLANK,1,4,ANDOR,1)
      CALL RMLOOK(MAT,2,0,LEN)
      IF(RMSTAT.EQ.0) ANDOR = MAT(2)
C
C  WRITE OUT THE ACTUAL RULE.
C
      LEN = 38
      IF(ITYPE.EQ.0) LEN = 68
      IF(ITYPE.EQ.3) LEN = 50
      CALL STRMOV(ANDOR,1,3,LINE,LEN)
      CALL SPOUT(LINE,70)
      GO TO 100
C
C  RESTORE THE POINTERS AND RETURN
C
 9999 CONTINUE
      CALL BLKMOV(NAME,SAVTUR,MWDS)
      I = LOCREL(NAME)
      LRROW = LRROW + 1
      CALL BLKMOV(IVAL,SAVSCR,6)
      NBOO = SAVSCR(7)
      BOO(1) = SAVSCR(8)
      KATTP(1) = SAVSCR(9)
      KATTL(1) = SAVSCR(10)
      KATTY(1) = SAVSCR(11)
      KOMTYP(1) = SAVSCR(12)
      KOMPOS(1) = SAVSCR(13)
      KOMLEN(1) = SAVSCR(14)
      KOMPOT(1) = SAVSCR(15)
      KSTRT = SAVSCR(16)
      MAXTU = SAVSCR(17)
      LIMTU = SAVSCR(18)
      WHRVAL(1) = SAVSCR(19)
      WHRVAL(2) = SAVSCR(20)
      WHRLEN(1) = SAVSCR(21)
      RETURN
      END
      SUBROUTINE PTRS(IP1,IP2,K,NATT3,PTABLE,LEN,ITYPE)
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE LOCATES THE PAIRS OF POINTERS TO COMMON
C  ATTRIBUTES FOR A SUBTRACT OR INTERSECT
C
      INTEGER PTABLE(7,*)
C
      IF(K.GT.NATT3) GO TO 500
C
  100 CONTINUE
      I = K
      IF(PTABLE(3,I).EQ.0) GO TO 200
      IF(PTABLE(4,I).EQ.0) GO TO 200
      IP1 = PTABLE(3,I)
      IP2 = PTABLE(4,I)
      CALL ITOH(IDUM,LEN,PTABLE(6,I))
      ITYPE = PTABLE(7,I)
      K = K + 1
      GO TO 9999
  200 CONTINUE
      K = K + 1
      IF(K.GT.NATT3) GO TO 500
      GO TO 100
  500 CONTINUE
C
C  DONE GOING THROUGH THE POINTERS.
C
      K = 0
      LEN = 0
 9999 RETURN
      END
      SUBROUTINE PUTDAT(INDEX,ID,ARRAY,LENGTH)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   REPLACE A TUPLE ON THE DATA FILE
C
C  PARAMETERS:
C         INDEX---BLOCK REFERENCE NUMBER
C         ID------PACKED ID WORD WITH OFFSET,IOBN
C         ARRAY---ARRAY TO RECEIVE THE TUPLE
C         LENGTH--LENGTH OF THE TUPLE
      INCLUDE rin:F2COM.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:FLAGS.BLK
C
      INTEGER OFFSET
      INTEGER ARRAY(*)
C
C  UNPAC THE ID WORD.
C
      CALL ITOH(OFFSET,IOBN,ID)
C
C  SEE IF THE NEEDED BLOCK IS CURRENTLY IN CORE.
C
      NUMBLK = 0
      DO 200 I=1,3
      IF(IOBN.EQ.CURBLK(I)) NUMBLK = I
  200 CONTINUE
      IF(NUMBLK.NE.0) GO TO 400
      NUMBLK = INDEX
C
C  WE MUST DO PAGING.
C
C  SEE IF THE CURRENT BLOCK NEEDS WRITING.
C
      IF(MODFLG(NUMBLK).EQ.0) GO TO 300
C
C  WRITE OUT THE CURRENT BLOCK.
C
      KQ1 = BLKLOC(NUMBLK)
      CALL RIOOUT(FILE2,CURBLK(NUMBLK),BUFFER(KQ1),LENBF2,IOS)
      IF(IOS.NE.0) RMSTAT = 2200 + IOS
  300 CONTINUE
C
C  READ IN THE NEEDED BLOCK.
C
      CALL BLKCHG(NUMBLK,LENBF2,1)
      KQ1 = BLKLOC(NUMBLK)
      CALL RIOIN(FILE2,IOBN,BUFFER(KQ1),LENBF2,IOS)
      IF(IOS.NE.0) RMSTAT = 2200 + IOS
      CURBLK(NUMBLK) = IOBN
  400 CONTINUE
      MODFLG(NUMBLK) = 1
      IFMOD = .TRUE.
C
C  MOVE THE TUPLE TO THE PAGE.
C
      KQ0 = BLKLOC(NUMBLK) - 1
      LEN = BUFFER(KQ0 + OFFSET + 1)
      IF(LEN.NE.LENGTH) RMSTAT = 1002
      CALL BLKMOV(BUFFER(KQ0 + OFFSET + 2),ARRAY(1),LEN)
C
C  ALL DONE.
C
      RETURN
      END
      SUBROUTINE PUTT(STR1,IC1,WORD)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   PUT THE FIRST CHARACTER OF WORD IN STR1 AT IC1
C
C  PARAMETERS:
C     STR1----STRING OF CHARACTERS
C     IC1-----THE CHARACTER WANTED
C     WORD----WORD WITH THE CHARACTER (LEFT JUSTIFIED, BLANK FILL)
C
      Character*1 STR1(*)
      Character*1 WORD(*)
      STR1(IC1) = WORD(1)
      RETURN
      END
      SUBROUTINE QUERY
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE IS THE DRIVER FOR QUERY OF THE RIM DATA BASE.
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:SRTCOM.BLK
      LOGICAL EQKEYW
      LOGICAL SAORD
      INCLUDE rin:DCLAR1.BLK
C
C  READ A CARD
C
      NEXTOP = K8READ
      GO TO 200
  100 CONTINUE
      CALL LODREC
C
C  SCAN A COMMAND.
C
  200 CONTINUE
      ITEMS = LXITEM(IDUMMY)
      NS = 0
      IF(EQKEYW(1,KWSELE,6)) GO TO 400
      IF(EQKEYW(1,KWTALL,5)) GO TO 400
      IF(EQKEYW(1,KWCOMP,7)) GO TO 400
      IF(EQKEYW(1,KWNEWP,7)) GO TO 1600
C
C  UNRECOGNIZED COMMAND.
C
      NEXTOP = K8USE
      GO TO 2000
C
C  ERROR IN COMMAND.
C
  350 CONTINUE
      CALL WARN(4,0,0)
      GO TO 100
C
C  PRINT COMMAND.
C
  400 CONTINUE
C
C  SCAN FOR THE WORD FROM.
C
      J = LFIND(1,ITEMS,KWFROM,4)
      IF(J.EQ.0) GO TO 350
      IF(EQKEYW(1,KWSELE,6)) GO TO 410
      IF(EQKEYW(1,KWTALL,5)) GO TO 440
      IF(EQKEYW(1,KWCOMP,7)) GO TO 470
C
C  CHECK SELECT SYNTAX
C
  410 CONTINUE
      IF(J.LT.3) GO TO 350
      IF((EQKEYW(2,KWALL,3)).AND.(J.NE.3)) GO TO 350
      IF(J.EQ.ITEMS) GO TO 350
      JS = LFIND(1,ITEMS,KWSORT,6)
      JW = LFIND(1,ITEMS,KWWHER,5)
      IF(JS.EQ.0) GO TO 420
      IF((JS+1).GE.ITEMS) GO TO 350
      IF((JS-J).NE.2) GO TO 350
      IF(.NOT.EQKEYW(JS+1,KWBY,2)) GO TO 350
      IF(JW.EQ.0) GO TO 499
      IF((JW-JS).LT.3) GO TO 350
      GO TO 499
  420 IF(JW.EQ.0) GO TO 430
      IF((JW-J).NE.2) GO TO 350
      GO TO 499
  430 IF((J+1).NE.ITEMS) GO TO 350
      GO TO 499
C
C  CHECK TALLY SYNTAX
C
  440 CONTINUE
      IF((J.NE.3).AND.(J.NE.5)) GO TO 350
  450 JW = LFIND(1,ITEMS,KWWHER,5)
      IF(JW.NE.0) GO TO 460
      IF((J+1).NE.ITEMS) GO TO 350
      GO TO 499
  460 IF((JW-J).NE.2) GO TO 350
      GO TO 499
C
C  CHECK COMPUTE SYNTAX
C
  470 CONTINUE
      IF(J.NE.4) GO TO 350
      GO TO 450
  499 CONTINUE
      RNAME = BLANK
      CALL LXSREC(J+1,1,8,RNAME,1)
C
C  FIND THE RELATION NAME IN RELTBLE.
C
      I = LOCREL(RNAME)
      IF(I.EQ.0) GO TO 500
C
C  UNRECOGNIZED RELATION NAME.
C
      CALL WARN(1,RNAME,0)
      GO TO 100
  500 CONTINUE
C
C  CHECK FOR READ PERMISSION.
C
      L = LOCPRM(NAME,1)
      IF(L.EQ.0) GO TO 510
      CALL WARN(9,NAME,0)
      GO TO 100
C
C  GET THE RELATION DATA.
C
C
C  SEE IF ANY TUPLES EXIST.
C
  510 CONTINUE
      IF(NTUPLE.GT.0) GO TO 700
	if(nout.eq.6)goto 3240
      WRITE (NOUT,602)
  602 FORMAT(43H -WARNING- No Data Exists For This Relation )
      GO TO 100
3240	continue
	write(c128wk,602)
	call atxto
	goto 100
C
C  SEE IF THERE IS A WHERE CLAUSE.
C
  700 CONTINUE
      K = LFIND(1,ITEMS,KWWHER,5)
      NBOO = 0
      LIMTU = ALL9S
      IF(K.EQ.0) GO TO 1000
      CALL WHERE(K)
      IF(RMSTAT.NE.0) GO TO 100
C
C  SEE IF ANY TUPLES SATISFY THE WHERE CLAUSE.
C
      CALL RMLOOK(IDUMMY,1,1,LENGTH)
      IF(RMSTAT.EQ.0) GO TO 900
	if(nout.eq.6)goto 3241
      WRITE (NOUT,720)
  720 FORMAT(43H -WARNING- No Rows Satisfy The WHERE Clause )
      GO TO 100
3241	continue
	write(c128wk,720)
	call atxto
	goto 100
  900 CONTINUE
      NID = CID
      IVAL = IVAL - 1
      LIMVAL = 0
      IF(NS.EQ.3) NS = 2
C
C  SEE IF SORTING IS NEEDED OR ASKED FOR.
C
 1000 CONTINUE
      IF(EQKEYW(1,KWCOMP,7)) GO TO 1500
      IF(EQKEYW(1,KWTALL,5)) GO TO 1100
      IF(.NOT.EQKEYW(J+2,KWSORT,6)) GO TO 1300
C
C  SORTING IS NEEDED. NATT IS THE ATTRIBUTE NAME.
C
C  SEE HOW MANY ATTRIBUTES ARE SPECIFIED IN THE SORT.
C
      NKSORT = 1
      I = J + 3
      L = LFIND(I,ITEMS,KWWHER,5)
      IF(L.EQ.0) L = ITEMS + 1
      NUMV = L - I - 1
      GO TO 1150
C
C  TALLY SORT - SET VARIABLES
C
 1100 CONTINUE
      NKSORT = 2
      I = 1
      NUMV = J-2
 1150 CONTINUE
C
C  NUMV IS THE NUMBER OF SORT ITEMS WE HAVE.
C  I IS THE START OF ATTRIBUTE SORT LIST - 1
C
      NSOVAR = 0
      N = 0
 1155 N = N + 1
      SAORD = .TRUE.
      ANAME = BLANK
      CALL LXSREC(I+N,1,8,ANAME,1)
C
C  CHECK FOR ASCENDING OR DESCENDING SORT
C
      IEQ = IBLANK
      CALL LXSREC(I+N+1,1,1,IEQ,1)
      IF(IEQ.NE.K4EQS) GO TO 1158
      N = N + 2
      CALL LXSREC(I+N,1,1,IEQ,1)
      IF((IEQ.NE.K4A).AND.(IEQ.NE.K4D)) GO TO 350
      IF(IEQ.EQ.K4D) SAORD = .FALSE.
C
C  GET THE ATTRIBUTE DATA
C
 1158 CONTINUE
      K = LOCATT(ANAME,NAME)
      CALL ATTGET(K)
      IF(K.EQ.0) GO TO 1160
      CALL WARN(3,ANAME,NAME)
      GO TO 100
C
C  SET UP THE ATTRIBUTE SORT DATA
C
 1160 CONTINUE
      NUMCOL = ATTCOL - 1
      IF(NKSORT.EQ.2) NUMCOL = 0
C
C  CHECK FOR VARIABLE LENGTH - SORTING ON VARIABLE LENGTH
C  ATTRIBUTES IS CURRENTLY NOT ALLOWED
C
      IF(ATTWDS.NE.0) GO TO 1170
	if(nout.eq.6)goto 3242
      WRITE(NOUT,1165)
 1165 FORMAT(41H -WARNING- VARiable Length Attributes May,
     1       25H Not Be SORTed or TALLIED)
      GO TO 1200
3242	continue
	write(C128wk,1165)
	call atxto
	goto 1200
 1170 CONTINUE
C
C  IF TEXT ATTRIBUTE DETERMINE THE NUMBER OF WORDS TO SORT ON - THIS
C  IS BASED ON THE NUMBER OF CHARACTERS (CURRENTLY 20) AND THE WORD
C  SIZE.
C     32 BIT WORDS - 20 CHARACTERS (5 WORDS)
C     60 BIT WORDS - 20 CHARACTERS (2 WORDS)
C     64 BIT WORDS - 16 CHARACTERS (2 WORDS)
C
      LSL = 1
      IF(ATTYPE.NE.KZTEXT) GO TO 1172
C
C  TEXT - DETERMINE SORT WORDS
C
      LSL = 20/CHPWD
      IF(ATTWDS.LT.LSL) LSL = ATTWDS
C
C  LOAD THE SORT ARRAYS
C
 1172 CONTINUE
      DO 1190 K=1,LSL
      NUMCOL = NUMCOL + 1
      NSOVAR = NSOVAR + 1
C
C  CHECK ON THE NUMBER OF SORT WORDS - CURRENTLY 10
C  THIS MAY WANT TO BE UPPER FOR THE SMALLER MACHINES
C
      IF(NSOVAR.LE.NSORTW) GO TO 1180
	if(nout.eq.6)goto 3243
      WRITE(NOUT,1175)
 1175 FORMAT(44H -ERROR- Illegal Number Of Sorted Attributes)
      GO TO 100
3243	continue
	write(c128wk,1175)
	call atxto
	goto 100
C
C  LOAD ARRAYS
C
 1180 CONTINUE
      SORTYP(NSOVAR) = SAORD
      VARPOS(NSOVAR) = NUMCOL
      IF(ATTYPE.EQ.KZINT) L=1
      IF(ATTYPE.EQ.KZREAL) L=2
      IF(ATTYPE.EQ.KZDOUB) L=3
      IF(ATTYPE.EQ.KZTEXT) L=4
      IF(ATTYPE.EQ.KZIVEC) L=1
      IF(ATTYPE.EQ.KZRVEC) L=2
      IF(ATTYPE.EQ.KZDVEC) L=3
      IF(ATTYPE.EQ.KZIMAT) L=1
      IF(ATTYPE.EQ.KZRMAT) L=2
      IF(ATTYPE.EQ.KZDMAT) L=3
      VARTYP(NSOVAR) = L
 1190 CONTINUE
 1200 CONTINUE
      IF(N.LT.NUMV) GO TO 1155
C
C  DO THE SORT.
C
      IF(NSOVAR.EQ.0) GO TO 100
      CALL SORT(NKSORT,ierr)
	if(ierr.eq.0)goto 1299
	call warn(16)
	goto 100
1299	continue
      NS = 1
C
C  CALL SELECT OR TALLY AS NEEDED.
C
 1300 CONTINUE
      IF(EQKEYW(1,KWTALL,5)) GO TO 1400
      CALL SELECT
      GO TO 100
 1400 CONTINUE
      CALL TALLY
      GO TO 100
C
C  CALL CMPUTE.
C
 1500 CONTINUE
      CALL CMPUTE
      GO TO 100
C
C  NEWPAGE COMMAND.
C
 1600 CONTINUE
      if(noutr.ne.6)WRITE(NOUTR,1610)
 1610 FORMAT(1H1)
      GO TO 100
 2000 CONTINUE
      RETURN
      END
      SUBROUTINE RELADD
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   ADD A NEW TUPLE TO THE RELTBL RELATION
C
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:RELTBL.BLK
      INCLUDE rin:F1COM.BLK
      INCLUDE rin:FLAGS.BLK
C
C  GET THE PAGE FOR ADDING NEW TUPLES.
C
      MRSTRT = NRROW
      CALL RELPAG(MRSTRT)
      I = MRSTRT
      NRROW = NRROW + 1
      IF(I.EQ.RPBUF) NRROW = (RPBUF * LF1REC) + 1
C
C  MOVE THE DATA FROM THE TUPLE TO THE BUFFER.
C
      RELTBL(1,I) = NRROW
      CALL BLKMOV(RELTBL(2,I),NAME,2)
      CALL BLKMOV(RELTBL(4,I),RDATE,2)
      RELTBL(6,I) = NCOL
      RELTBL(7,I) = NATT
      RELTBL(8,I) = NTUPLE
      RELTBL(9,I) = RSTART
      RELTBL(10,I) = REND
      CALL BLKMOV(RELTBL(11,I),RPW,2)
      CALL BLKMOV(RELTBL(13,I),MPW,2)
      RELMOD = 1
      IFMOD = .TRUE.
      LRROW = 0
      IF(I.LT.RPBUF) RETURN
C
C  WE JUST FILLED A BUFFER. MAKE SURE RELTBL GETS THE NEXT ONE.
C
      RELBUF(1) = NRROW
      MRSTRT = NRROW
      CALL RELPAG(MRSTRT)
      RETURN
      END
      SUBROUTINE RELDEL
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   DELETE THE CURRENT TUPLE FROM THE RELTBL RELATION
C             BASED ON CONDITIONS SET UP IN LOCREL
C
      INCLUDE rin:RELTBL.BLK
      IF(LRROW.EQ.0) GO TO 9999
C
C  CHANGE THE TUPLE STATUS FLAG TO DELETED.
C
      RELTBL(1,LRROW) = -RELTBL(1,LRROW)
      RELMOD = 1
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE RELGET(STATUS)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   GET THE NEXT TUPLE IN THE RELTBL RELATION
C
C  PARAMETERS:
C         STATUS--STATUS VARIABLE - 0 MEANS OK, 1 MEANS NO WAY
      INCLUDE rin:RELTBL.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:MISC.BLK
      INTEGER STATUS
      LOGICAL EQ
      STATUS = 0
C
C  SCAN FOR THE NEXT RELATION.
C
      I = LRROW + 1
      GO TO 200
  100 CONTINUE
      CALL RELPAG(MRSTRT)
      I = MRSTRT
  200 CONTINUE
      IF(I.GT.RPBUF) GO TO 400
      IF(RELTBL(1,I).EQ.0) GO TO 9000
      IF(RELTBL(1,I).LT.0) GO TO 300
      IF(EQ(CNAME,BLANK)) GO TO 500
      IF(EQ(RELTBL(2,I),CNAME)) GO TO 500
  300 CONTINUE
      I = I + 1
      GO TO 200
C
C  GET THE NEXT PAGE.
C
  400 CONTINUE
      MRSTRT = RELBUF(1)
      IF(MRSTRT.EQ.0) GO TO 9000
      GO TO 100
C
C  FOUND IT.
C
  500 CONTINUE
      LRROW = I
      CALL BLKMOV(NAME,RELTBL(2,I),2)
      CALL BLKMOV(RDATE,RELTBL(4,I),2)
      NCOL = RELTBL(6,I)
      NATT = RELTBL(7,I)
      NTUPLE = RELTBL(8,I)
      RSTART = RELTBL(9,I)
      REND = RELTBL(10,I)
      CALL BLKMOV(RPW,RELTBL(11,I),2)
      CALL BLKMOV(MPW,RELTBL(13,I),2)
      GO TO 9999
C
C  UNABLE TO FIND WHAT WE ARE LOOKING FOR.
C
 9000 CONTINUE
      STATUS = 1
      LRROW = 0
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE RELOAD
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   RELOAD THE DATA BASE TO RECOVER LOST SPACE FROM
C             DELETIONS.
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:START.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:SRTCOM.BLK
      INCLUDE rin:F2COM.BLK
      INCLUDE rin:F3COM.BLK
      INCLUDE rin:DCLAR1.BLK
      INCLUDE rin:DCLAR4.BLK
C
C  DIMENSION AND DATA
C
      INTEGER FILE4
      LOGICAL EQ
      INTEGER COLUMN
      INTEGER OFFSET
      integer lenbfb
      CHARACTER*8 FNAME
C
C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
C
      FILE = K8ZFIL
      IFMOD = .TRUE.
      CALL RMDBLK(DBNAME)
      IF(RMSTAT.EQ.0) GO TO 50
      CALL WARN(RMSTAT,DBNAME,0)
      GO TO 9999
   50 CONTINUE
      IFMOD = .TRUE.
C
C  SET UP THE NEW DATA FILE.
C
C
C  FORM THE NAMES FOR FILE2 AND FILE3.
C
      DO 10 I=1,7
      CALL GETT(DBNAME,I,IT)
      IF(IT.EQ.IBLANK) GO TO 20
   10 CONTINUE
      I = 7
   20 CONTINUE
      RIMDB2 = BLANK
      CALL STRMOV(DBNAME,1,I,RIMDB2,1)
      CALL PUTT(RIMDB2,I,K42)
      RIMDB3 = RIMDB2
      CALL PUTT(RIMDB3,I,K43)
      FILE = RIMDB2
      FILE4 = 34
      WRITE(FNAME,30) FILE
   30 FORMAT(A8)
      lenbfb=lenbf2*4
c buff length in bytes
	if(lenbfb.gt.1024)lenbfb=1024
c amiga fortran can't do over 10214 bytes/rec
      OPEN(UNIT=FILE4, FILE=FNAME, ACCESS='DIRECT',
     X     RECL=LENBFb,
     X     STATUS='NEW', IOSTAT=IOS)
C
C  INITIALIZE THIS FILE.
C
      CALL BLKCHG(4,LENBF2,1)
      KQ4 = BLKLOC(4)
      CALL ZEROIT(BUFFER(KQ4),LENBF2)
      CALL RIOOUT(FILE4,1,BUFFER(KQ4),LENBF2,IOS)
      KF4REC = 1
      IF(IOS.NE.0) RMSTAT = 2400 + IOS
      LF4REC = 1
      LF4WRD = 20
C
C  CYCLE THROUGH THE RELATIONS.
C
      I = LOCREL(BLANK)
      IF(I.NE.0) GO TO 9999
  100 CONTINUE
      CALL RELGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 1000
      IF(NTUPLE.EQ.0) GO TO 100
C
C  START LOADING.
C
      NSTART = 0
      ID = NSTART
      NTUPLE = 0
      IDOLD = RSTART
C
C  GET A ROW FROM THE RELATION.
C
  200 CONTINUE
      IF(IDOLD.EQ.0) GO TO 600
      CALL ITOH(N1,N2,IDOLD)
      IF(N2.EQ.0) GO TO 600
      CALL GETDAT(1,IDOLD,LOCTUP,LENGTH)
      IF(IDOLD.LT.0) GO TO 200
      NTUPLE = NTUPLE + 1
C
C  UNPAC THE ID WORD.
C
      CALL ITOH(OFFSET,IOBN,ID)
C
C  CALCULATE THE NEW ID VALUE.
C
      IF(LF4WRD + LENGTH + 1 .LE. LENBF2) GO TO 300
      LF4REC = LF4REC + 1
      LF4WRD = 1
  300 CONTINUE
      CALL HTOI(LF4WRD,LF4REC,ID)
      IF(IOBN.EQ.0) GO TO 400
C
C  FIX UP THE ID POINTER SO IT POINTS TO THE NEXT TUPLE.
C
      KQ0 = BLKLOC(4) - 1
      ISIGN = 1
      BUFFER(KQ0 + OFFSET) = ISIGN * ID
C
C  NOW MOVE THE NEW TUPLE.
C
  400 CONTINUE
      CALL ITOH(OFFSET,IOBN,ID)
C
      IF(IOBN.EQ.KF4REC) GO TO 500
C
C  WE MUST DO PAGING.
C
C  WRITE OUT THE CURRENT BLOCK.
C
      KQ4 = BLKLOC(4)
      CALL RIOOUT(FILE4,KF4REC,BUFFER(KQ4),LENBF2,IOS)
      IF(IOS.NE.0) RMSTAT = 2400 + IOS
C
C  SET UP THE NEW BLOCK.
C
      CALL ZEROIT(BUFFER(KQ4),LENBF2)
      KF4REC = IOBN
C
C  WRITE OUT THE RECORD FOR THE FIRST TIME.
C
      CALL RIOOUT(FILE4,IOBN,BUFFER(KQ4),LENBF2,IOS)
      IF(IOS.NE.0) RMSTAT = 2400 + IOS
  500 CONTINUE
C
C  MOVE THE TUPLE TO THE PAGE.
C
      KQ0 = BLKLOC(4) - 1
      BUFFER(KQ0 + OFFSET) = 0
      BUFFER(KQ0 + OFFSET + 1) = LENGTH
      CALL BLKMOV(BUFFER(KQ0 + OFFSET + 2),BUFFER(LOCTUP),LENGTH)
      LF4WRD = LF4WRD + LENGTH + 2
C
C  ALL DONE RELOADING ONE TUPLE.
C
      IF(NSTART.EQ.0) NSTART = ID
      GO TO 200
  600 CONTINUE
C
C  RESET THE TUPLER VALUES.
C
      RSTART = NSTART
      REND = ID
      CALL RELPUT
      GO TO 100
C
C  DUMP THE LAST BUFFER FULL.
C
 1000 CONTINUE
      KQ4 = BLKLOC(4)
      CALL RIOOUT(FILE4,KF4REC,BUFFER(KQ4),LENBF2,IOS)
      CALL BLKCLR(4)
C
C  READ RECORD 1 BACK INTO INDEX BUFFER 1.
C
      CALL BLKCHG(1,LENBF2,1)
      KQ1 = BLKLOC(1)
      CALL RIOIN(FILE4,1,BUFFER(KQ1),LENBF2,IOS)
C
C  RESET THE OLD FLAGS IN F2COM.
C
      LF2REC = LF4REC
      LF2WRD = LF4WRD
      CURBLK(1) = 1
      CURBLK(2) = 0
      CURBLK(3) = 0
      MODFLG(1) = 1
      MODFLG(2) = 0
      MODFLG(3) = 0
      ITEMP = FILE2
      CLOSE(UNIT=FILE2,IOSTAT=IOS)
      FILE2 = FILE4
      CALL F2CLO
      CLOSE(UNIT=FILE4,IOSTAT=IOS)
      FILE2 = ITEMP
      CALL F2OPN(RIMDB2)
C
C  NOW REMAKE THE BTREE FILE.
C
      CLOSE(FILE3,STATUS='DELETE',IOSTAT=IOS)
      CALL F3OPN(RIMDB3)
C
C  CYCLE THROUGH THE RELATIONS.
C
      I = LOCREL(BLANK)
C
C  GET A RELATION.
C
 2000 CONTINUE
      CALL RELGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 3100
      RNAME = NAME
      NID = RSTART
      IID = NID
      I = LOCATT(BLANK,RNAME)
      IF(I.NE.0) GO TO 2000
 2100 CONTINUE
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 2000
      IF(ATTKEY.EQ.0) GO TO 2100
      ANAME = ATTNAM
      NID = IID
C
C  DETERMINE THE COLUMN TO BE USED FOR THIS ATTRIBUTE.
C
      COLUMN = ATTCOL
C
C  INITIALIZE THE BTREE FOR THIS ELEMENT.
C
      CALL BTINIT(ATTKEY)
      START = ATTKEY
      CALL ATTPUT(ISTAT)
C
C  SORT THE KEY VALUES IF THERE ARE MORE THAN 100 OF THEM
C
      IF(NTUPLE.GT.100) GO TO 2700
C
C   SCAN THROUGH ALL THE DATA FOR THIS RELATION.
C
 2500 CONTINUE
      IF(NID.EQ.0) GO TO 2900
      CALL ITOH(N1,N2,NID)
      IF(N2.EQ.0) GO TO 2900
      CID = NID
      CALL GETDAT(1,NID,ITUP,LENGTH)
      IF(NID.LT.0) GO TO 2900
      IP = ITUP + COLUMN - 1
      IF(ATTWDS.NE.0) GO TO 2600
C
C  ATTRIBUTE IS A VARIABLE LENGTH ATTRIBUTE.
C
      IP = BUFFER(IP) + ITUP + 1
 2600 CONTINUE
      IF(BUFFER(IP).EQ.NULL) GO TO 2500
      CALL BTADD(BUFFER(IP),CID,ATTYPE)
      GO TO 2500
C
C  SORT KEY VALUES BEFORE BUILDING THE B-TREE
C
 2700 CONTINUE
      LENGTH = 2
      NSOVAR = 1
      NKSORT = 3
      SORTYP(1) = .TRUE.
      VARPOS(1) = 1
      L = 2
      IF(ATTYPE.EQ.KZTEXT) L = 4
      IF(ATTYPE.EQ.KZINT ) L = 1
      IF(ATTYPE.EQ.KZIVEC) L = 1
      IF(ATTYPE.EQ.KZIMAT) L = 1
      VARTYP(1) = L
      CALL SORT(NKSORT)
C
C  READ THE SORTED KEY VALUES AND BUILD THE BTREE
C
      CALL GTSORT(IP,1,-1,LENGTH)
 2800 CONTINUE
      CALL GTSORT(IP,1,1,LENGTH)
      IF(RMSTAT.NE.0) GO TO 2900
      IF(BUFFER(IP).EQ.NULL) GO TO 2800
      CALL BTADD(BUFFER(IP),BUFFER(2),ATTYPE)
      GO TO 2800
C
C  ALL DONE.
C
 2900 CONTINUE
C
C  RESTORE THE START TO THE BTREE TABLE.
C
      I = LOCATT(ANAME,RNAME)
      CALL ATTGET(ISTAT)
      ATTKEY = START
      CALL ATTPUT(ISTAT)
C
C  RESET OUR LOCATION GOING THROUGH THE ATTRIBUTES FOR RNAME.
C
      I = LOCATT(BLANK,RNAME)
 3000 CONTINUE
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 2000
      IF(EQ(ATTNAM,ANAME)) GO TO 2100
      GO TO 3000
C
C  COPY THE NEW BTREE FILE OVER THE OLD ONE.
C
 3100 CONTINUE
C
C  RETURN
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE RELPAG(THEROW)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   DO PAGING AS NEEDED FOR THE RELTBL RELATION
C
C  PARAMETERS:
C         THEROW--INPUT - ROW WANTED
C                 OUTPUT - ACTUAL ROW TO USE IN THE BUFFER
      INCLUDE rin:RELTBL.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:F1COM.BLK
      INTEGER THEROW
C
C  TURN THE REQUESTED ROW INTO A RECORD AND OFFSET.
C
      NNREC = ((THEROW - 1) / RPBUF) + 1
      NNROW = THEROW - ((NNREC - 1) * RPBUF)
C
C  SEE IF WE ALREADY HAVE THIS RECORD IN THE BUFFER.
C
      IF(NNREC.EQ.CRREC) GO TO 300
C
C  WE MUST DO PAGING.
C
C  SEE IF THE CURRENT RECORD IN THE BUFFER HAS BEEN MODIFIED.
C
      IF(RELMOD.EQ.0) GO TO 100
C
C  WRITE OUT THE CURRENT RECORD.
C
      CALL RIOOUT(FILE1,CRREC,RELBUF,LENBF1,IOS)
      IF(IOS.NE.0) RMSTAT = 2100 + IOS
C
C  READ IN THE NEEDED RECORD.
C
  100 CONTINUE
      RELMOD = 0
      IF(NNREC.GT.LF1REC) GO TO 150
      CALL RIOIN(FILE1,NNREC,RELBUF,LENBF1,IOS)
      IF(IOS.EQ.0) GO TO 200
C
C  THERE WAS NO DATA ON THE FILE - WRITE SOME.
C
  150 CONTINUE
      CALL ZEROIT(RELBUF,LENBF1)
      CALL RIOOUT(FILE1,NNREC,RELBUF,LENBF1,IOS)
      IF(IOS.NE.0) RMSTAT = 2100 + IOS
      LF1REC = LF1REC + 1
  200 CONTINUE
      CRREC = NNREC
C
C  SET THE POINTER TO THE ACTUAL ROW IN THE BUFFER.
C
  300 CONTINUE
      THEROW = NNROW
      RETURN
      END
      SUBROUTINE RELPUT
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   REPLACE THE CURRENT TUPLE FROM THE RELTBL RELATION
C             BASED ON CONDITIONS SET UP IN LOCREL
C
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:RELTBL.BLK
      IF(LRROW.EQ.0) GO TO 9999
C
C  MOVE THE STUFF TO ROW LRROW.
C
      CALL BLKMOV(RELTBL(2,LRROW),NAME,2)
      CALL BLKMOV(RELTBL(4,LRROW),RDATE,2)
      RELTBL(6,LRROW) = NCOL
      RELTBL(7,LRROW) = NATT
      RELTBL(8,LRROW) = NTUPLE
      RELTBL(9,LRROW) = RSTART
      RELTBL(10,LRROW) = REND
      CALL BLKMOV(RELTBL(11,LRROW),RPW,2)
      CALL BLKMOV(RELTBL(13,LRROW),MPW,2)
      RELMOD = 1
      IFMOD = .TRUE.
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE REUSE
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:    RESET THE USAGE FLAGS TO OFF IN THE ICORE FLAGS
C
      INCLUDE rin:F3COM.BLK
      DO 100 NUMB=1,NUMIC
      ICORE(1,NUMB) = 0
  100 CONTINUE
      RETURN
      END
      SUBROUTINE RIM
      INCLUDE rin:TEXT.BLK
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:SELCOM.BLK
C
      LOGICAL EQKEYW
      INTEGER IDT(2)
      INTEGER DBSTAT
      INCLUDE rin:DCLAR4.BLK
C
C  ACCEPT USER INPUT
C
      NEXTOP = K8READ
 1000 CONTINUE
      IF(NEXTOP.NE.K8READ) GO TO 1100
      CALL LODREC
 1100 CONTINUE
      NEXTOP = K8READ
C
C  CHECK COMMAND ON CARD
C
      IF(.NOT.EQKEYW(1,KWLIST,7)) GO TO 1300
C                                   LISTREL
      IF(.NOT.DFLAG) GO TO 1550
      CALL LSTREL
      GO TO 1000
 1300 CONTINUE
      IF(.NOT.EQKEYW(1,KWSELE,6)) GO TO 1305
C                                   SELECT
      IF(.NOT.DFLAG) GO TO 1550
      CALL QUERY
      GO TO 1000
 1305 CONTINUE
      IF(.NOT.EQKEYW(1,KWCHAN,6)) GO TO 1310
C                                   CHANGE
      IF(.NOT.DFLAG) GO TO 1550
      CALL MODIFY
      GO TO 1000
 1310 CONTINUE
      IF(.NOT.EQKEYW(1,KWCOMP,7)) GO TO 1315
C                                   COMPUTE
      IF(.NOT.DFLAG) GO TO 1550
      CALL QUERY
      GO TO 1000
 1315 CONTINUE
      IF(.NOT.EQKEYW(1,KWTALL,5)) GO TO 1320
C                                   TALLY
      IF(.NOT.DFLAG) GO TO 1550
      CALL QUERY
      GO TO 1000
 1320 CONTINUE
      IF(.NOT.EQKEYW(1,KWRETU,6)) GO TO 1322
C                                   return
C note one wants to use the RETURN command instead of EXIT where
C the database should be left open...
	NextOp=KWRetu
	RETURN
 1322 CONTINUE
      IF(.NOT.EQKEYW(1,KWEXIT,4)) GO TO 1325
C                                   EXIT
      GO TO 3000
 1325 CONTINUE
      IF(.NOT.EQKEYW(1,KWLOAD,4)) GO TO 1330
C                                   LOAD
      IF(.NOT.DFLAG) GO TO 1550
      NEXTOP = K8LOAD
      GO TO 5000
 1330 CONTINUE
      IF(.NOT.EQKEYW(1,KWOPEN,4)) GO TO 1335
C                                   OPEN
      IF(LXITEM(DBSTAT).LT.2) GO TO 1495
      IF((LXLENC(2).GE.1).AND.(LXLENC(2).LE.6)) GO TO 1334
	if(nout.eq.6)goto 3245
      WRITE (NOUT,1332)
 1332 FORMAT(39H -ERROR- The Database Name Must Be 1-6 ,
     X       23HAlphanumeric Characters)
      GO TO 1000
3245	continue
	write(c128wk,1332)
	call atxto
	goto 1000
 1334 CONTINUE
      CALL RMCLOS
      DBNAME = BLANK
      CALL LXSREC(2,1,8,DBNAME,1)
      CALL RMDBGT(DBNAME,DBSTAT)
      IF(DBSTAT.NE.0) GO TO 1000
      CALL RMOPEN(DBNAME)
      IF(RMSTAT.NE.0) CALL WARN(RMSTAT,DBNAME,0)
      GO TO 1000
 1335 CONTINUE
      IF(.NOT.EQKEYW(1,KWEXHI,7)) GO TO 1345
C                                   EXHIBIT
      IF(.NOT.DFLAG) GO TO 1550
      CALL XHIBIT
      GO TO 1000
 1345 CONTINUE
      IF(.NOT.EQKEYW(1,KWDEFI,6)) GO TO 1350
C                                   DEFINE
      GO TO 2000
 1350 CONTINUE
      IF(.NOT.EQKEYW(1,KWECHO,4)) GO TO 1355
C                                   ECHO
      CALL LXSET(KWECHO,K4ON)
      ECHO = .TRUE.
      GO TO 1000
 1355 CONTINUE
      IF(.NOT.EQKEYW(1,KWNOEC,6)) GO TO 1360
C                                   NOECHO
      CALL LXSET(KWECHO,K4OFF)
      ECHO = .FALSE.
      GO TO 1000
 1360 CONTINUE
      IF(.NOT.EQKEYW(1,KWNEWP,7)) GO TO 1365
C                                   NEWPAGE
      If(noutr.ne.6)WRITE (NOUTR,1367)
c ignore newpage cmd for spreadsheet window
 1367 FORMAT(1H1)
      GO TO 1000
 1365 CONTINUE
      IF(.NOT.EQKEYW(1,KWUSER,4)) GO TO 1370
C                                   USER
      IF((LXLENC(2).GE.1).AND.(LXLENC(2).LE.8)) GO TO 1369
	if(nout.eq.6)goto 3246
      WRITE(NOUT,1368)
 1368 FORMAT(44H -ERROR- PASSWORDS Must Be 1-8 Alphanumeric ,
     X       10HCharacters)
      GO TO 1000
3246	continue
	write(c128wk,1368)
	call atxto
	goto 1000
 1369 CONTINUE
      USERID = BLANK
      CALL LXSREC(2,1,8,USERID,1)
      GO TO 1000
 1370 CONTINUE
      IF(.NOT.EQKEYW(1,KWRENA,6)) GO TO 1375
C                                   RENAME
      IF(.NOT.DFLAG) GO TO 1550
      CALL MODIFY
      GO TO 1000
 1375 CONTINUE
      IF(.NOT.EQKEYW(1,KWDELE,6)) GO TO 1380
C                                   DELETE
      IF(.NOT.DFLAG) GO TO 1550
      CALL MODIFY
      GO TO 1000
 1380 CONTINUE
      IF(.NOT.EQKEYW(1,KWREMO,6)) GO TO 1385
C                                   REMOVE
      IF(.NOT.DFLAG) GO TO 1550
      CALL MODIFY
      GO TO 1000
 1385 CONTINUE
      IF(.NOT.EQKEYW(1,KWQUIT,4)) GO TO 1390
C                                   QUIT
      GO TO 3000
 1390 CONTINUE
      IF(.NOT.EQKEYW(1,KWCLOS,5)) GO TO 1395
C                                   CLOSE
      IF(.NOT.DFLAG) GO TO 1550
      CALL RMCLOS
      GO TO 1000
 1395 CONTINUE
      IF(.NOT.EQKEYW(1,KWPRIN,5)) GO TO 1400
C                                   PRINT
      IF(.NOT.DFLAG) GO TO 1550
      CALL RULES
      GO TO 1000
 1400 CONTINUE
      IF(.NOT.EQKEYW(1,KWINTS,9)) GO TO 1405
C                                   INTERSECT
      IF(.NOT.DFLAG) GO TO 1550
      CALL ISREL
      GO TO 1000
 1405 CONTINUE
      IF(.NOT.EQKEYW(1,KWPROJ,7)) GO TO 1410
C                                   PROJECT
      IF(.NOT.DFLAG) GO TO 1550
      CALL PJECT
      GO TO 1000
 1410 CONTINUE
      IF(.NOT.EQKEYW(1,KWSUBT,8)) GO TO 1415
C                                   SUBTRACT
      IF(.NOT.DFLAG) GO TO 1550
      CALL SUBREL
      GO TO 1000
 1415 CONTINUE
      IF(.NOT.EQKEYW(1,KWJOIN,4)) GO TO 1420
C                                   JOIN
      IF(.NOT.DFLAG) GO TO 1550
      CALL JOIREL
      GO TO 1000
 1420 CONTINUE
      IF(.NOT.EQKEYW(1,KWBUIL,5)) GO TO 1430
C                                   BUILD
      IF(.NOT.DFLAG) GO TO 1550
      CALL BUILD
      GO TO 1000
 1430 CONTINUE
      IF(.NOT.EQKEYW(1,KWRELO,6)) GO TO 1435
C                                   RELOAD
      IF(.NOT.DFLAG) GO TO 1550
      CALL RELOAD
      GO TO 1000
 1435 CONTINUE
      IF(.NOT.EQKEYW(1,KWINPU,5)) GO TO 1440
C                                   INPUT
      GO TO 1600
 1440 CONTINUE
      IF(.NOT.EQKEYW(1,KWOUTP,6)) GO TO 1445
C                                   OUTPUT
      GO TO 1700
 1445 CONTINUE
      IF(.NOT.EQKEYW(1,KWTITL,5)) GO TO 1450
C                                   TITLE
      GO TO 2100
 1450 CONTINUE
      IF(.NOT.EQKEYW(1,KWDATE,4)) GO TO 1455
C                                   DATE
      GO TO 2200
 1455 CONTINUE
      IF(.NOT.EQKEYW(1,KWBLAN,5)) GO TO 1460
C                                   BLANK
      GO TO 2300
 1460 CONTINUE
      IF(.NOT.EQKEYW(1,KWUNLO,6)) GO TO 1465
C                                   UNLOAD
      IF(.NOT.DFLAG) GO TO 1550
      CALL UNLOAD
      GO TO 1000
 1465 CONTINUE
      IF(.NOT.EQKEYW(1,KWLINE,5)) GO TO 1470
C                                   LINES
      IF(LXID(2).NE.KZINT) GO TO 2301
      ULPP = LXIREC(2)
      IF(ULPP.GE.0) GO TO 1000
      ULPP = 0
	if(nout.eq.6)goto 3247
      WRITE(NOUT,1466)
 1466 FORMAT(50H -WARNING- Lines Entered Is Out Of Range, Reset To,
     X        8H Default,/)
      GO TO 1000
3247	continue
	write(c128wk,1466)
	call atxto
	goto 1000
 1470 CONTINUE
      IF(.NOT.EQKEYW(1,KWWIDT,5)) GO TO 1475
C                                   WIDTH
      IF(LXID(2).NE.KZINT) GO TO 2301
      UMCPL = LXIREC(2)
      IF(UMCPL.LT.0) UMCPL = 0
      IF(((UMCPL.GE.20).AND.(UMCPL.LE.132)).OR.(UMCPL.EQ.0)) GO TO 1000
C
C  ILLEGAL WIDTH SPECIFICATION
C
      IF(UMCPL.GT.132) UMCPL = 132
      IF(UMCPL.LT.20)  UMCPL = 20
	if(nout.eq.6)goto 3248
      WRITE(NOUT,1472) UMCPL
 1472 FORMAT(51H -WARNING- Width Entered Is Out Of Range, Reset To ,
     X    I4,/)
      GO TO 1000
3248	continue
	write(c128wk,1472)UMCPL
	call atxto
	goto 1000
 1475 CONTINUE
C                                     MENU
      IF(.NOT.EQKEYW(1,KWMENU,4)) GO TO 1480
      NEXTOP = K8MENU
      IF(.NOT.BATCH) GO TO 3500
	if(nout.eq.6)goto 3249
      WRITE(NOUT,1476)
 1476 FORMAT(39H -ERROR- MENU Mode Not Allowed In BATCH )
3249      NEXTOP = K8READ
      GO TO 1000
 1480 CONTINUE
C                                    TOLERANCE
      IF(.NOT.EQKEYW(1,KWTOLE,9)) GO TO 1485
      IF(LXID(2).NE.KZREAL) GO TO 1495
      TOL = RXREC(2)
      PCENT = .FALSE.
      IF(.NOT.EQKEYW(3,KWPERC,7)) GO TO 1000
      TOL = TOL/100.
      PCENT = .TRUE.
      GO TO 1000
 1485 CONTINUE
C                                    CHECK
      IF(.NOT.EQKEYW(1,KWCHEC,5)) GO TO 1490
      RUCK = .TRUE.
      GO TO 1000
 1490 CONTINUE
C                                    NOCHECK
      IF(.NOT.EQKEYW(1,KWNOCH,7)) GO TO 1495
      RUCK = .FALSE.
      GO TO 1000
 1495 CONTINUE
C
C     NOT IDENTIFIABLE COMMAND
C
	if(nout.eq.6)goto 3250
      WRITE (NOUT,1499)
 1499 FORMAT(37H -ERROR- Invalid Command - Retype It  )
 1500 CONTINUE
      GO TO 1000
3250	continue
	write(c128wk,1499)
	call atxto
	goto 1000
 1550 CONTINUE
C
C     NO RELATIONS YET
C
	if(nout.eq.6)goto 3251
      WRITE (NOUT,1560)
 1560 FORMAT(53H -ERROR- No Relations Defined Yet For This Data Base )
      GO TO 1000
3251	continue
	write(c128wk,1560)
	call atxto
	goto 1000
C
C     PROCESS THE INPUT COMMAND
C
 1600 CONTINUE
      IF((LXLENC(2).GE.1).AND.(LXLENC(2).LE.7)) GO TO 1610
	if(nout.eq.6)goto 3252
      WRITE(NOUT,1800)
      GO TO 1000
3252	continue
	write(c128wk,1800)
	call atxto
	goto 1000
 1610 CONTINUE
      IFILE = BLANK
      CALL LXSREC(2,1,LXLENC(2),IFILE,1)
      CALL SETIN(IFILE)
      GO TO 1000
C
C     PROCESS THE OUTPUT COMMAND
C
 1700 CONTINUE
      IF((LXLENC(2).GE.1).AND.(LXLENC(2).LE.7)) GO TO 1710
	if(nout.eq.6)goto 3252
      WRITE(NOUT,1800)
      GO TO 1000
 1710 CONTINUE
      IFILE = BLANK
      CALL LXSREC(2,1,LXLENC(2),IFILE,1)
      CALL SETOUT(IFILE)
      GO TO 1000
 1800 FORMAT(45H -ERROR- File Names Must Be 1-7 Alphanumeric ,
     X       10HCharacters)
C
C  GO TO THE DEFINE MODULE.
C
 2000 CONTINUE
      NEXTOP = K8DEFI
      GO TO 3500
C
C  PROCESS THE TITLE COMMAND
C
 2100 CONTINUE
      KOL = 78
      IF(.NOT.CONNO) KOL = 132
      IF(UMCPL.NE.0) KOL = UMCPL
      KOLW = ((KOL-1)/CHPWD + 1)*CHPWD
      CALL FILCH(LINE,1,KOLW,BLANK)
      KCHAR = LXLENC(2)
      IF(KCHAR.LE.KOL) GOTO 2150
      KCHAR = KOL-2
	if(nout.eq.6)goto 3253
      WRITE(NOUT,100)
 100  FORMAT(53H -WARNING- Title Entered Was Too Long And Will Be Tru,
     X 6Hncated )
C
	goto 2150
3253	continue
	write(c128wk,100)
	call atxto
c
 2150 CONTINUE
      KSTRT = (KOL-KCHAR)/2 + 1
      CALL LXSREC(2,1,KCHAR,LINE,KSTRT)
      CALL SPOUT(LINE,KOL)
      GO TO 1000
C
C  PROCESS THE DATE COMMAND
C
 2200 CONTINUE
      KOL = 78
      IF(.NOT.CONNO) KOL = 132
      IF(UMCPL.NE.0) KOL = UMCPL
      KOLW = ((KOL-1)/CHPWD + 1)*CHPWD
      CALL FILCH(LINE,1,KOLW,BLANK)
      KSTRT = KOL/2 - 4
      CALL RMDATE(IDT)
      CALL STRMOV(IDT,1,8,LINE,KSTRT)
      CALL SPOUT(LINE,KOL)
      GO TO 1000
C
C  PROCESS THE BLANK COMMAND
C
 2300 CONTINUE
      IF(LXITEM(ITEM).EQ.1) GO TO 2303
      IF(LXID(2).EQ.KZINT) GO TO 2303
 2301 CONTINUE
	if(nout.eq.6)goto 3254
      WRITE(NOUT,2302)
 2302 FORMAT(34H -ERROR- Item 2 Must Be An INTEGER)
      GO TO 1000
3254	continue
	write(c128wk,2302)
	call atxto
	goto 1000
 2303 CONTINUE
      KOL = 1
      IF(LXITEM(ITEM).EQ.2) KOL = LXIREC(2)
      IF(KOL.LE.0) KOL = 1
      DO 2310 K=1,KOL
c ignore blank commandto screen too.
      if(noutr.ne.6)WRITE (NOUTR,2305)
 2305 FORMAT(1H )
 2310 CONTINUE
      GO TO 1000
C
C  CLOSE THE DATA BASE AND EXIT.
C
 3000 CONTINUE
      NEXTOP = K8EXIT
 3500 CONTINUE
      CALL RMCLOS
 5000 CONTINUE
      RETURN
      END
      SUBROUTINE RIOIN(FILE,RECORD,BUFFER,NWDS,IOS)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   COVER ROUTINE FOR RANDOM INPUT - VAX VERSION
C
C  PARAMETERS:
C         FILE----ARRAY WITH A FET
C         RECORD--RECORD NUMBER WANTED
C         BUFFER--BUFFER TO READ INTO
C         NWDS----NUMBER OF WORDS PER BUFFER
C         IOS-----STATUS VARIABLE - 0 MEANS SUCCESS, ELSE TILT
C
      INTEGER FILE
      INTEGER RECORD
	logical isitin
	integer filsiz,isz,lnbyt
      INTEGER BUFFER(*)
C handle new files that may be empty
	ios=1
	inquire(unit=file,exist=isitin,size=filsiz)
	if(.not.ISITIN)return
	isz=record*4*nwds
	if(filsiz.lt.isz)return
c this returns ios nonzero if the file hasn't got the data desired
C even if the file exists.
	ik=nwds/256
c amiga limit=1024 bytes/rec direct access
	if(ik.lt.1)ik=1
	irl=1+(record-1)*ik
	ibl=1
	ibh=min0(256,nwds)
	do 150 n150=1,ik
      READ(FILE,REC=irl,IOSTAT=IOS) (BUFFER(I),I=ibl,ibh)
	ibl=ibl+256
	ibh=ibh+256
	irl=irl+1
150	continue
      RETURN
      END
      SUBROUTINE RIOOPN(FNAME,FILE,NWDS,IOS)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   COVER ROUTINE TO OPEN A RANDOM FILE
C
C  PARAMETERS:
C         FNAME---NAME OF THE FILE TO OPEN
C         FILE----ARRAY WITH A FET
C         NWDS----NUMBER OF WORDS PER RECORD
C         IOS-----STATUS VARIABLE - O MEANS SUCCESS, ELSE TILT
C
      INCLUDE rin:RIO.BLK
      REAL*8 FNAME
      integer reclb
      CHARACTER*8 NAME
      INTEGER FILE
      WRITE(NAME,100) FNAME
  100 FORMAT(A8)
      reclb=NWDS*4
C      OPEN(UNIT=FILE, FILE=NAME, ACCESS='DIRECT',
C     X     RECL=NWDS, ORGANIZATION='SEQUENTIAL',
C     X     STATUS='UNKNOWN',IOSTAT=IOS,SHARED)
C
C OPEN FOR EXCLUSIVE ACCESS, OMITTING THE "SHARED" KEYWORD
	if(reclb.gt.1024)reclb=1024
c amiga fortran limit is 1024 bytes/rec for direct access
c so read multiple records as needed
      OPEN(UNIT=FILE, FILE=NAME, ACCESS='DIRECT',
     X     RECL=reclb,
     X     STATUS='UNKNOWN',IOSTAT=IOS)
      IUN = FILE - 29
      IRECPS(IUN) = 0
      RETURN
      END
      SUBROUTINE RIOOUT(FILE,RECORD,BUFFER,NWDS,IOS)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   COVER ROUTINE FOR RANDOM OUTPUT - VAX VERSION
C
C  PARAMETERS:
C         FILE----ARRAY WITH A FET
C         RECORD--RECORD NUMBER WANTED
C         BUFFER--BUFFER TO WRITE FROM
C         NWDS----NUMBER OF WORDS PER BUFFER
C         IOS-----STATUS VARIABLE - 0 MEANS SUCCESS, ELSE TILT
C
      INCLUDE rin:RIO.BLK
      INTEGER FILE
      INTEGER RECORD
      INTEGER BUFFER(*)
      IUN = FILE - 29
      IRECPS(IUN) = IRECPS(IUN) + 1
	ik=nwds/256
	if(ik.lt.1)ik=1
c ik is count to read
	irl=1+(record-1)*ik
	ibl=1
	ibh=min0(256,nwds)
      IF(RECORD.EQ.0) GO TO 100
	do 130 n150=1,ik
      WRITE(FILE,REC=irl,IOSTAT=IOS) (BUFFER(I),I=ibl,ibh)
	ibl=ibl+256
	ibh=ibh+256
	irl=irl+1
130	continue
      RETURN
  100 CONTINUE
      N = IRECPS(IUN)
	irl=1+(n-1)*ik
	do 150 n150=1,ik
      WRITE(FILE,REC=irl,IOSTAT=IOS) (BUFFER(I),I=ibl,ibh)
	ibl=ibl+256
	ibh=ibh+256
	irl=irl+1
150	continue
      RETURN
      END
      SUBROUTINE RMCLOS
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   CLOSE A RIM DATABASE.
C
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:DCLAR4.BLK
C
C  CLOSE THE MULTIPLE RMFIND SAVE FILE - ZZRIMZZ
C
      FILE = K8ZFIL
      CALL DROPF(FILE)
C
C  DO NOT CLOSE THE DATABASE IF THERE WERE NO MODIFICATIONS
C
      RMSTAT = 0
      IF(.NOT.DFLAG) RETURN
      DFLAG = .FALSE.
      IF(.NOT.IFMOD) RETURN
C
C  RESET THE DATABASE DATE AND TIME.
C
      CALL RMDATE(DBDATE)
      CALL RMTIME(DBTIME)
C
C  CLOSE THE THREE DATABASE FILES.
C
      CALL F1CLO
      CALL F2CLO
      CALL F3CLO
      DFLAG = .FALSE.
      IFMOD = .FALSE.
      RETURN
      END
      SUBROUTINE RMCONS
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  THIS ROUTINE INITIALIZES THE HOLLERITH CONSTANTS USED
C            BY RIM. THE CODE IS MACHINE DEPENDENT.
C
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RMKEYW.BLK
      REAL*8  J8RRC,J8RDT,J8NAM,J8NUM,J8AOR,J8AN1,
     X        J8RN1,J8OPR,J8TYP,J8AN2,J8RN2,J8VAL,J8XXX,J8AND,J8OR,
     X        J8ZFIL,J8HDB,J8COMM,J8SCH,J8RC,J8DBA,J8RMDT,J8RIM,
     X        J8BEGI,J8READ,J8USE,J8LOAD,J8DEFI,J8MENU,J8EXIT,J8IN,
     X        J8OUT,J8LIM,J8ROWS,J8DATA,J8ALL,J8ZZ98,J8ZZ99
      REAL*8  JWBY,JWEQ,JWIN,JWIS,JWTO,
     X        JWALL,JWEND,JWFOR,JWINT,JWKEY,JWMPW,JWRPW,JWVAR,JWZIP,
     X        JWDATE,JWDMAT,JWDVEC,JWECHO,JWEXIT,JWFROM,JWHELP,JWIMAT,
     X        JWIVEC,JWJOIN,JWLOAD,JWMENU,JWOPEN,JWQUIT,JWREAD,JWREAL,
     X        JWRMAT,JWROWS,JWRULE,JWRVEC,JWTEXT,JWUSER,JWWITH,JWBLAN,
     X        JWBUIL,JWCHEC,JWCLOS,JWCOUN,JWINPU,JWLIMI,JWLINE,JWOWNE,
     X        JWPRIN,JWRULS,JWTALL,JWTITL,JWUSIN,JWWHER,JWWIDT,JWCHAN,
     X        JWDEFI,JWDELE,JWDOUB,JWMODI,JWNOEC,JWOUTP,JWRELO,JWREMO,
     X        JWRENA,JWSELE,JWSORT,JWTUPL,JWUNLO,JWCOMP,JWEXHI,JWFORM,
     X        JWLIST,JWNEWP,JWNOCH,JWPERC,JWPROJ,JWATTR,JWDUPL,JWELEM,
     X        JWINTS,JWPASS,JWRELA,JWSUBT,JWTERM,JWTOLE,JWRETU
      REAL*8  J8CON1,J8CON2,J8CON3
      DIMENSION J4KOM(6),J4BOOL(17),J4HEAD(6)
C
C  VARIABLES USED BY THE FLAGS AND MISC COMMON BLOCKS
C
      DATA J8CON1 /4HNONE/
      DATA J8CON2 /1H /
      DATA J8CON3 /3H-0-/
      DATA J4CON1 /1H /
      DATA J4CON2 /3HRIM/
      DATA J4CON3 /3H-0-/
      DATA J4CON4 /4H*END/
C
C  VARIABLES USED BY THE CONST4 COMMON BLOCK
C
      DATA J4DP /2HD>/
      DATA J4RP /2HR>/
      DATA J4LP /2HL>/
      DATA J4HP /2HH>/
      DATA J4IS /2HIS/
      DATA J4EQ /2HEQ/
      DATA J4ON /2HON/
      DATA J4OR /2HOR/
      DATA J4OFF /3HOFF/
      DATA J4AND /3HAND/
      DATA J4MIN /3HMIN/
      DATA J4MAX /3HMAX/
      DATA J4AVE /3HAVE/
      DATA J4SUM /3HSUM/
      DATA J4END /3HEND/
      DATA J4DIM /3HDIM/
      DATA J4CRE /3HCRE/
      DATA J4UPD /3HUPD/
      DATA J4EOF /3HEOF/
      DATA J4LOD /3HLOD/
      DATA J4QUE /3HQUE/
      DATA J4COM /3HCOM/
      DATA J4CON /3HCON/
      DATA J4KEY /3HKEY/
      DATA J4YES /3HYES/
      DATA J4FOR /3HFOR/
      DATA J4LOA /3HLOA/
      DATA J4QUIT /4HQUIT/
      DATA J4EXIT /4HEXIT/
      DATA J4ECHO /4HECHO/
      DATA J4LOAD /4HLOAD/
      DATA J4DATA /4HDATA/
      DATA J4NONE /4HNONE/
      DATA J4PROM /4HPROM/
      DATA J4PRES /4HPRES/
      DATA J4INPT /4HINPT/
      DATA J4OTPT /4HOTPT/
      DATA J4WITH /4HWITH/
      DATA J4HASH /4HHASH/
      DATA J4A /1HA/
      DATA J4D /1HD/
      DATA J4Y /1HY/
      DATA J4N /1HN/
      DATA J4E /1HE/
      DATA J4M /1HM/
      DATA J40 /1H0/
      DATA J41 /1H1/
      DATA J42 /1H2/
      DATA J43 /1H3/
      DATA J44 /1H4/
      DATA J45 /1H5/
      DATA J46 /1H6/
      DATA J47 /1H7/
      DATA J48 /1H8/
      DATA J49 /1H9/
      DATA J4DOT /1H./
      DATA J4COL /1H:/
      DATA J4EQS /1H=/
      DATA J4STAR /1H*/
      DATA J4QUOT /1H"/
      DATA J4COMA /1H,/
      DATA J4LPAR /1H(/
      DATA J4RPAR /1H)/
      DATA J4PLUS /1H+/
      DATA J4MNUS /1H-/
      DATA J4KOM /2HEQ,2HEQ,2HGE,2HGT,2HLE,2HLT/
      DATA J4BOOL /3HEXI,2HEQ,2HNE,2HGT,2HGE,2HLT,2HLE,
     X             3HFAI,3HEQS,0,0,
     X             3HEQA,3HNEA,3HGTA,3HGEA,3HLTA,3HLEA/
      DATA J4HEAD /4HNUMB,4HER O,4HF OC,4HCURR,4HENCE,4HS   /
C
C  VARIABLES USED BY THE CONST8 COMMON BLOCK
C
      DATA J8RRC /8HRMRULRRC/
      DATA J8RDT /8HRMRULRDT/
      DATA J8NAM /8HRMRULNAM/
      DATA J8NUM /8HRMRULNUM/
      DATA J8AOR /8HRMRULAOR/
      DATA J8AN1 /8HRMRULAN1/
      DATA J8RN1 /8HRMRULRN1/
      DATA J8OPR /8HRMRULOPR/
      DATA J8TYP /8HRMRULTYP/
      DATA J8AN2 /8HRMRULAN2/
      DATA J8RN2 /8HRMRULRN2/
      DATA J8VAL /8HRMRULVAL/
      DATA J8XXX /8HASDFGHJK/
      DATA J8AND /3HAND/
      DATA J8OR   /2HOR/
      DATA J8ZFIL /7HZZRIMZZ/
      DATA J8HDB  /6HHELPDB/
      DATA J8COMM /7HCOMMAND/
      DATA J8SCH  /6HSCHEMA/
      DATA J8RC   /8H ROW COL/
      DATA J8DBA  /6HRIMDBA/
      DATA J8RMDT /7HRIMDATA/
      DATA J8RIM  /3HRIM/
      DATA J8BEGI /5HBEGIN/
      DATA J8READ /4HREAD/
      DATA J8USE  /3HUSE/
      DATA J8LOAD /4HLOAD/
      DATA J8DEFI /6HDEFINE/
      DATA J8MENU /4HMENU/
      DATA J8EXIT /4HEXIT/
      DATA J8IN   /5HINPUT/
      DATA J8OUT  /6HOUTPUT/
      DATA J8LIM  /5HLIMIT/
      DATA J8ROWS /4HROWS/
      DATA J8DATA /4HDATA/
      DATA J8ALL  /3HALL/
      DATA J8ZZ98 /4HZZ98/
      DATA J8ZZ99 /4HZZ99/
C
C  VARIABLES USED BY THE RMATTS COMMON BLOCK
C
      DATA JZVEC  /3HVEC/
      DATA JZMAT  /3HMAT/
      DATA JZVAR  /3HVAR/
      DATA JZINT  /3HINT/
      DATA JZREAL /4HREAL/
      DATA JZDOUB /4HDOUB/
      DATA JZTEXT /4HTEXT/
      DATA JZIVEC /4HIVEC/
      DATA JZRVEC /4HRVEC/
      DATA JZDVEC /4HDVEC/
      DATA JZIMAT /4HIMAT/
      DATA JZRMAT /4HRMAT/
      DATA JZDMAT /4HDMAT/
C
C  VARIABLES USED BY THE RMKEYW COMMON BLOCK
C
      DATA JWBY   / 2HBY       /
      DATA JWEQ   / 2HEQ     /
      DATA JWIN   / 2HIN       /
      DATA JWIS   / 2HIS       /
      DATA JWTO   / 2HTO       /
      DATA JWALL  / 3HALL      /
      DATA JWEND  / 3HEND      /
      DATA JWFOR  / 3HFOR      /
      DATA JWINT  / 7HINTEGER  /
      DATA JWKEY  / 3HKEY      /
      DATA JWMPW  / 3HMPW      /
      DATA JWRPW  / 3HRPW      /
      DATA JWVAR  / 3HVAR      /
      DATA JWZIP  / 3HZIP      /
      DATA JWDATE / 4HDATE     /
      DATA JWDMAT / 4HDMAT     /
      DATA JWDVEC / 4HDVEC     /
      DATA JWECHO / 4HECHO     /
      DATA JWEXIT / 4HEXIT     /
      DATA JWFROM / 4HFROM     /
      DATA JWHELP / 4HHELP     /
      DATA JWIMAT / 4HIMAT     /
      DATA JWIVEC / 4HIVEC     /
      DATA JWJOIN / 4HJOIN     /
      DATA JWLOAD / 4HLOAD     /
      DATA JWMENU / 4HMENU     /
      DATA JWOPEN / 4HOPEN     /
      DATA JWQUIT / 4HQUIT     /
      DATA JWREAD / 4HREAD     /
      DATA JWREAL / 4HREAL     /
      DATA JWRMAT / 4HRMAT     /
      DATA JWROWS / 4HROWS     /
      DATA JWRULE / 4HRULE     /
      DATA JWRVEC / 4HRVEC     /
      DATA JWTEXT / 4HTEXT     /
      DATA JWUSER / 4HUSER     /
      DATA JWWITH / 4HWITH     /
      DATA JWBLAN / 5HBLANK    /
      DATA JWBUIL / 5HBUILD    /
      DATA JWCHEC / 5HCHECK    /
      DATA JWCLOS / 5HCLOSE    /
      DATA JWCOUN / 5HCOUNT    /
      DATA JWINPU / 5HINPUT    /
      DATA JWLIMI / 5HLIMIT    /
      DATA JWLINE / 5HLINES    /
      DATA JWOWNE / 5HOWNER    /
      DATA JWPRIN / 5HPRINT    /
      DATA JWRULS / 5HRULES    /
      DATA JWTALL / 5HTALLY    /
      DATA JWTITL / 5HTITLE    /
      DATA JWUSIN / 5HUSING    /
      DATA JWWHER / 5HWHERE    /
      DATA JWWIDT / 5HWIDTH    /
      DATA JWCHAN / 6HCHANGE   /
      DATA JWRETU / 6HRETURN   /
      DATA JWDEFI / 6HDEFINE   /
      DATA JWDELE / 6HDELETE   /
      DATA JWDOUB / 6HDOUBLE   /
      DATA JWMODI / 6HMODIFY   /
      DATA JWNOEC / 6HNOECHO   /
      DATA JWOUTP / 6HOUTPUT   /
      DATA JWRELO / 6HRELOAD   /
      DATA JWREMO / 6HREMOVE   /
      DATA JWRENA / 6HRENAME   /
      DATA JWSELE / 6HSELECT   /
      DATA JWSORT / 6HSORTED   /
      DATA JWTUPL / 6HTUPLES   /
      DATA JWUNLO / 6HUNLOAD   /
      DATA JWCOMP / 7HCOMPUTE  /
      DATA JWEXHI / 7HEXHIBIT  /
      DATA JWFORM / 7HFORMING  /
      DATA JWLIST / 7HLISTREL  /
      DATA JWNEWP / 7HNEWPAGE  /
      DATA JWNOCH / 7HNOCHECK  /
      DATA JWPERC / 7HPERCENT  /
      DATA JWPROJ / 7HPROJECT  /
      DATA JWATTR / 8HATTRIBUT /
      DATA JWDUPL / 8HDUPLICAT /
      DATA JWELEM / 8HELEMENTS /
      DATA JWINTS / 8HINTERSEC /
      DATA JWPASS / 8HPASSWORD /
      DATA JWRELA / 8HRELATION /
      DATA JWSUBT / 8HSUBTRACT /
      DATA JWTERM / 8HTERMINAL /
      DATA JWTOLE / 8HTOLERANC /
C
C  SET THE FLAGS AND MISC VARIABLES
C
      USERID = J8CON1
      NONE = J8CON1
      BLANK = J8CON2
      DBNAME = J8CON3
      IBLANK = J4CON1
      LSTCMD = J4CON2
      NULL = J4CON3
      ENDWRD = J4CON4
      DFLAG = .FALSE.
C
C  SET THE CONST4 VARIABLES
C
      K4DP   = J4DP
      K4RP   = J4RP
      K4LP   = J4LP
      K4HP   = J4HP
      K4IS   = J4IS
      K4EQ   = J4EQ
      K4ON   = J4ON
      K4OR   = J4OR
      K4OFF  = J4OFF
      K4AND  = J4AND
      K4MIN  = J4MIN
      K4MAX  = J4MAX
      K4AVE  = J4AVE
      K4SUM  = J4SUM
      K4END  = J4END
      K4DIM  = J4DIM
      K4CRE  = J4CRE
      K4UPD  = J4UPD
      K4EOF  = J4EOF
      K4LOD  = J4LOD
      K4QUE  = J4QUE
      K4COM  = J4COM
      K4CON  = J4CON
      K4KEY  = J4KEY
      K4YES  = J4YES
      K4FOR  = J4FOR
      K4LOA  = J4LOA
      K4QUIT = J4QUIT
      K4EXIT = J4EXIT
      K4ECHO = J4ECHO
      K4LOAD = J4LOAD
      K4DATA = J4DATA
      K4NONE = J4NONE
      K4PROM = J4PROM
      K4PRES = J4PRES
      K4INPT = J4INPT
      K4OTPT = J4OTPT
      K4WITH = J4WITH
      K4HASH = J4HASH
      K4A    = J4A
      K4D    = J4D
      K4Y    = J4Y
      K4N    = J4N
      K4E    = J4E
      K4M    = J4M
      K40    = J40
      K41    = J41
      K42    = J42
      K43    = J43
      K44    = J44
      K45    = J45
      K46    = J46
      K47    = J47
      K48    = J48
      K49    = J49
      K4DOT  = J4DOT
      K4COL  = J4COL
      K4EQS  = J4EQS
      K4STAR = J4STAR
      K4QUOT = J4QUOT
      K4COMA = J4COMA
      K4LPAR = J4LPAR
      K4RPAR = J4RPAR
      K4PLUS = J4PLUS
      K4MNUS = J4MNUS
      DO 100 K = 1,6
      K4KOM(K) = J4KOM(K)
      K4HEAD(K) = J4HEAD(K)
  100 CONTINUE
      DO 200 K = 1,17
      K4BOOL(K) = J4BOOL(K)
  200 CONTINUE
C
C  SET THE CONST8 VARIABLES
C
      K8RRC  = J8RRC
      K8RDT  = J8RDT
      K8NAM  = J8NAM
      K8NUM  = J8NUM
      K8AOR  = J8AOR
      K8AN1  = J8AN1
      K8RN1  = J8RN1
      K8OPR  = J8OPR
      K8TYP  = J8TYP
      K8AN2  = J8AN2
      K8RN2  = J8RN2
      K8VAL  = J8VAL
      K8XXX  = J8XXX
      K8AND  = J8AND
      K8OR   = J8OR
      K8ZFIL = J8ZFIL
      K8HDB  = J8HDB
      K8COMM = J8COMM
      K8SCH  = J8SCH
      K8RC   = J8RC
      K8DBA  = J8DBA
      K8RMDT = J8RMDT
      K8RIM  = J8RIM
      K8BEGI = J8BEGI
      K8READ = J8READ
      K8USE  = J8USE
      K8LOAD = J8LOAD
      K8DEFI = J8DEFI
      K8MENU = J8MENU
      K8EXIT = J8EXIT
      K8IN   = J8IN
      K8OUT  = J8OUT
      K8LIM  = J8LIM
      K8ROWS = J8ROWS
      K8DATA = J8DATA
      K8ALL  = J8ALL
      K8ZZ98 = J8ZZ98
      K8ZZ99 = J8ZZ99
C
C  SET THE RMATTS VARIABLES
C
      KZVEC  = JZVEC
      KZMAT  = JZMAT
      KZVAR  = JZVAR
      KZINT  = JZINT
      KZREAL = JZREAL
      KZDOUB = JZDOUB
      KZTEXT = JZTEXT
      KZIVEC = JZIVEC
      KZRVEC = JZRVEC
      KZDVEC = JZDVEC
      KZIMAT = JZIMAT
      KZRMAT = JZRMAT
      KZDMAT = JZDMAT
C
C  SET THE RMKEYW VARIABLES
C
      KWBY   = JWBY
      KWEQ   = JWEQ
      KWIN   = JWIN
      KWIS   = JWIS
      KWTO   = JWTO
      KWALL  = JWALL
      KWEND  = JWEND
      KWFOR  = JWFOR
      KWINT  = JWINT
      KWKEY  = JWKEY
      KWMPW  = JWMPW
      KWRPW  = JWRPW
      KWVAR  = JWVAR
      KWZIP  = JWZIP
      KWDATE = JWDATE
      KWDMAT = JWDMAT
      KWDVEC = JWDVEC
      KWECHO = JWECHO
      KWEXIT = JWEXIT
      KWRETU = JWRETU
      KWFROM = JWFROM
      KWHELP = JWHELP
      KWIMAT = JWIMAT
      KWIVEC = JWIVEC
      KWJOIN = JWJOIN
      KWLOAD = JWLOAD
      KWMENU = JWMENU
      KWOPEN = JWOPEN
      KWQUIT = JWQUIT
      KWREAD = JWREAD
      KWREAL = JWREAL
      KWRMAT = JWRMAT
      KWROWS = JWROWS
      KWRULE = JWRULE
      KWRVEC = JWRVEC
      KWTEXT = JWTEXT
      KWUSER = JWUSER
      KWWITH = JWWITH
      KWBLAN = JWBLAN
      KWBUIL = JWBUIL
      KWCHEC = JWCHEC
      KWCLOS = JWCLOS
      KWCOUN = JWCOUN
      KWINPU = JWINPU
      KWLIMI = JWLIMI
      KWLINE = JWLINE
      KWOWNE = JWOWNE
      KWPRIN = JWPRIN
      KWRULS = JWRULS
      KWTALL = JWTALL
      KWTITL = JWTITL
      KWUSIN = JWUSIN
      KWWHER = JWWHER
      KWWIDT = JWWIDT
      KWCHAN = JWCHAN
      KWDEFI = JWDEFI
      KWDELE = JWDELE
      KWDOUB = JWDOUB
      KWMODI = JWMODI
      KWNOEC = JWNOEC
      KWOUTP = JWOUTP
      KWRELO = JWRELO
      KWREMO = JWREMO
      KWRENA = JWRENA
      KWSELE = JWSELE
      KWSORT = JWSORT
      KWTUPL = JWTUPL
      KWUNLO = JWUNLO
      KWCOMP = JWCOMP
      KWEXHI = JWEXHI
      KWFORM = JWFORM
      KWLIST = JWLIST
      KWNEWP = JWNEWP
      KWNOCH = JWNOCH
      KWPERC = JWPERC
      KWPROJ = JWPROJ
      KWATTR = JWATTR
      KWDUPL = JWDUPL
      KWELEM = JWELEM
      KWINTS = JWINTS
      KWPASS = JWPASS
      KWRELA = JWRELA
      KWSUBT = JWSUBT
      KWTERM = JWTERM
      KWTOLE = JWTOLE
      RETURN
      END
      SUBROUTINE RMDATE(IT)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   RETURN THE CURRENT DATE IN YY/MM/DD FORMAT
C
C  PARAMETERS:
C         IT------THE CURRENT DATE
C
      INCLUDE rin:MISC.BLK
      INTEGER MONTH,DAY,YEAR
      REAL*8 IT
      Character*1 SLASH
      DATA SLASH /1H//
c      CALL IDATE(DAY,MONTH,YEAR)
	CALL DATE(month,day,year)
c	call idate(month,day,year)
	if(year.gt.1900)year=year-1900
100	if(year.gt.100)year=year-100
       if(year.gt.100)goto 100
      IF(MONTH.LT.10) MONTH = MONTH + 100
      IF(DAY.LT.10) DAY = DAY + 100
      CALL ITOC(IT,1,2,YEAR,IERR)
      CALL ITOC(IT,3,3,MONTH,IERR)
      CALL ITOC(IT,6,3,DAY,IERR)
      CALL PUTT(IT,3,SLASH)
      CALL PUTT(IT,6,SLASH)
      RETURN
      END
      SUBROUTINE RMDBGT(NAMDB,DBSTAT)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE: THIS ROUTINE WILL GET A RIM DATA BASE FROM PERMANENT
C           FILE. THE DATA BASE MAY BE DIRECT OR INDIRECT AND MAY
C           RESIDE ON AN ALTERNATE ACCOUNT. THIS ROUTINE HAS TWO
C           SECTIONS - AN MENU MODE SECTION WHERE THE DATA BASE
C           FILE DATA IS REQUESTED FROM THE USER, A COMMAND MODE SECTION
C           WHERE THE "OPEN DBNAME ....." COMMAND IS PROCESSED TO GET
C           THE FILE DATA.
C
C  SYSTEM: CDC CYBER (BOEING)
C
C  PARAMETERS: NAMDB -- DATABASE NAME IN H FORMAT (6HDBNAME)
C              DBSTAT - 0 IF SUCCESSFULL DATABASE RETRIEVAL
C                       1 IF UNSUCCESSFULL
C                       2 IF "QUIT"
C
      INTEGER DBSTAT
      DBSTAT = 0
      RETURN
      END
      SUBROUTINE RMDBLK(NAMDB)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE: THIS ROUTINE CHECKS FOR MODIFY PERMISSION ON A GIVEN
C           DATABASE FILE. CHECKS FOR WRITE MODE ON DIRECT ACCESS
C           AND CHECKS THE LOCKING FILE FOR INDIRQECT ACCESS FILES.
C
C  SYSTEM:  CDC CYBER (BOEING)
C
C  PARAMETERS: NAMDB -- DATABASE NAME IN H FORMAT
C
      INCLUDE rin:RIMCOM.BLK
      RMSTAT = 0
      RETURN
      END
      SUBROUTINE RMDBPT
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE: THIS ROUTINE RETURNS THE RIM DATABASES THAT HAVE BEEN
C           MODIFIED. THE ROUTINE IS DUMMY FOR DIRECT ACCESS
C           DATABASES, USER MANAGED DATABASES AND DATABASES THAT
C           HAVE NOT BEEN MODIFIED. NEW DATABASE (DEFINE) MAY BE
C           SAVED AS INDIRECT OR DIRECT ACCESS FILES (PRIVATE).
C
C  SYSTEM: CDC CYBER (BOEING)
C
C  PARAMETERS: NONE
C
      RETURN
      END
      SUBROUTINE RMDEL(INDPTR)
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE DELETES THE CURRENT ROW.
C
C  PARAMETERS:
C         INDPTR--INDEX TO SAVE BLOCK (RANGE OF 0 TO 9)
      INCLUDE rin:KEYDAT.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:START.BLK
      INTEGER COLUMN
      RMSTAT = 0
C
C         MAKE SURE DB IS DEFINED
C
      IF(DFLAG) GOTO 10
      RMSTAT = 16
      GOTO 9999
C
   10 CONTINUE
C
C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
C
      CALL RMDBLK(DBNAME)
      IF(RMSTAT.NE.0) GO TO 9999
C
C  RESTORE THE BLOCKS AS NEEDED.
C
      CALL RMRES(INDPTR)
      IF(RMSTAT.NE.0) GO TO 9999
C
C  CHECK FOR WRITE PERMISSION ON THIS RELATION.
C
      I = LOCPRM(NAME,2)
      IF(RMSTAT.NE.0) GO TO 9999
C
C  CHECK THAT RMGET WAS CALLED
C
      IF((IVAL.GT.0).AND.(IVAL.LT.ALL9S)) GO TO 200
C
C  RMGET WAS NOT CALLED BEFORE RMPUT
C
      RMSTAT = 60
      GO TO 9999
C
C  RETRIEVE THE CURRENT ROW IN A SCRATCH TUPLE.
C
  200 CONTINUE
      CALL BLKCHG(11,MAXCOL,1)
      KQ1 = BLKLOC(11)
      NID = CID
      INDEX = INDPTR
      IF(INDEX.EQ.0) INDEX = 1
      IF(INDEX.GT.3) INDEX = 3
      LNS = NS
      NS = 0
      CALL RMLOOK(BUFFER(KQ1),INDEX,0,KURLEN)
      IVAL = IVAL - 1
      NS = LNS
      IF(RMSTAT.EQ.0) GO TO 300
C
C  NO DATA AVAILABLE
C
      RMSTAT = 60
      GO TO 9999
C
C  DELETE THE CURRENT ROW OF THE RELATION.
C
  300 CONTINUE
      CALL DELDAT(INDEX,CID)
      RDATE = DBDATE
      NTUPLE = NTUPLE - 1
      CALL RELPUT
C
C  CHANGE THE POINTERS FOR ANY KEY ELEMENTS.
C
      IF(NUMKEY.EQ.0) GO TO 9999
      I = 0
      IF(NUMKEY.LE.5) GO TO 380
      I = LOCATT(BLANK,NAME)
  380 CONTINUE
      IF(NUMKEY.GT.5) GO TO 390
      I = I + 1
      IF(I.GT.NUMKEY) GO TO 9999
      START = KEYDAT(1,I)
      COLUMN = KEYDAT(2,I)
      ATTWDS = KEYDAT(3,I)
      ATTYPE = KEYDAT(4,I)
      GO TO 395
  390 CONTINUE
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 9999
      IF(ATTKEY.EQ.0) GO TO 380
      START = ATTKEY
      COLUMN = ATTCOL
  395 CONTINUE
      IF(ATTWDS.NE.0) GO TO 400
      COLUMN = BUFFER(KQ1+COLUMN-1) + 2
  400 CONTINUE
      IF(BUFFER(KQ1+COLUMN-1).EQ.NULL) GO TO 380
      CALL BTREP(BUFFER(KQ1+COLUMN-1),0,CID,ATTYPE)
      GO TO 380
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE RMFIND(INDPTR,RNAME)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE: LOCATE THE TUPLES FOR RELATION RNAME
C
C  PARAMETERS: INDPTR--MULTIPLE RELATION POSITION INDICATOR
C              RNAME---RELATION NAME
C
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:VARDAT.BLK
      INCLUDE rin:KEYDAT.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:PTRCOM.BLK
      INCLUDE rin:RULCOM.BLK
      INCLUDE rin:WHCOM.BLK
C
      LOGICAL EQ
      INCLUDE rin:DCLAR1.BLK
C
C  INITIALIZE
C
      RMSTAT = 0
C         MAKE SURE DB IS DEFINED
C
      IF(DFLAG) GOTO 10
      RMSTAT = 16
      GOTO 999
C
   10 CONTINUE
      IF(INDCUR.NE.NULL) GO TO 50
C
C     FIRST TIME IN - CHECK INDPTR
C
      IF((INDPTR.GE.0).AND.(INDPTR.LE.9)) GO TO 100
      RMSTAT = 70
      GO TO 999
   50 CONTINUE
C
C  SAVE THE CURRENT POINTERS
C
      IF(INDCUR.NE.INDPTR) CALL RMSAV(INDCUR)
      IF(RMSTAT.NE.0) GO TO 999
C
C  CHECK FOR RULES FOR THIS RELATION
C
  100 RULES = .FALSE.
      I = LOCREL(RIMRRC)
      IF(I.NE.0) GO TO 140
      CALL CHKRUL(RNAME)
      IF(RMSTAT.GE.110) GO TO 999
      RMSTAT = 0
C
C  LOCATE THE RELATION
C
  140 CONTINUE
      I = LOCREL(RNAME)
      IF(I.NE.0) GO TO 150
      CALL RELGET(I)
      IF(I.EQ.0) GO TO 200
  150 CONTINUE
      RMSTAT = 20
      GO TO 999
C
C  SET CURRENT BLOCK AND CHECK READ PERMISSION
C
  200 INDCUR = INDPTR
      NS = 0
      IF(EQ(USERID,OWNER)) GO TO 300
      IF(EQ(RPW,NONE)) GO TO 300
      IF(EQ(RPW,USERID)) GO TO 300
      IF(EQ(MPW,USERID)) GO TO 300
      RMSTAT = 90
      GO TO 999
  300 CONTINUE
C
C  SET NUMBER OF WHERE CONDITIONS AND TUPLE LIMIT
C
      NBOO = 0
      LIMTU = ALL9S
      MAXGET(INDPTR+1) = NTUPLE
C
C  CHECK FOR VARIABLE LENGTH ATTRIBUTES
C
      NUMVAR = 0
      NUMKEY = 0
      I = LOCATT(BLANK,RNAME)
      DO 500 J=1,NATT
      CALL ATTGET(ISTATX)
      IF(ISTATX.NE.0) GO TO 999
      IF(ATTKEY.EQ.0) GO TO 400
      NUMKEY = NUMKEY + 1
      IF(NUMKEY.GT.5) GO TO 400
      KEYDAT(1,NUMKEY) = ATTKEY
      KEYDAT(2,NUMKEY) = ATTCOL
      KEYDAT(3,NUMKEY) = ATTWDS
      KEYDAT(4,NUMKEY) = ATTYPE
      CALL BLKMOV(KEYDAT(5,NUMKEY),ATTNAM,2)
  400 CONTINUE
      IF(ATTWDS.NE.0) GO TO 500
      NUMVAR = NUMVAR + 1
      IF(NUMVAR.GT.5) GO TO 500
      POSVAR(1,NUMVAR) = ATTCOL
      POSVAR(2,NUMVAR) = ATTYPE
  500 CONTINUE
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE RMGATT(ANAME,TYPE,MATVEC,VAR,LEN1,LEN2,COL,KEY)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE: THIS ROUTINE GETS THE DATA FOR THE CURRENT ATTRIBUTE
C           FOR THE CURRENT RELATION.
C           (FORTRAN INTERFACE COVER ROUTINE FOR GETATT)
C
C  PARAMETERS: ANAME---ATTRIBUTE NAME
C              TYPE----ATTRIBUTE TYPE - INT,REAL,TEXT,DOUB
C              MATVEC--ATTRIBUTE TYPE - MAT OR VEC (OTHERWISE BLANK)
C              VAR-----VARIABLE LENGTH ATTRIBUTE - .TRUE. OR .FALSE.
C              LEN1----ATTRIBUTE LENGTH DATA
C                      TEXT = NUMBER OF CHARACTERS
C                      INT,REAL,DOUBLE,VECTORS = NUMBER OF ITEMS
C                      MATRIX = ROW DIMENSION
C              LEN2----COLUMN DIMENSION OF MATRICES OR 0
C              COL-----ATTRIBUTE COLUMN IN THE RELATION
C              KEY-----KEYED ATTRIBUTE - .TRUE. OR .FALSE.
C
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:MISC.BLK
      INTEGER STATUS
      LOGICAL EQ
      INTEGER TYPE
      INTEGER MATVEC
      INTEGER LEN1,LEN2
      INTEGER COL
      LOGICAL VAR
      LOGICAL KEY
      INCLUDE rin:DCLAR1.BLK
C
      RMSTAT = 0
      INDCUR = NULL
C
C         MAKE SURE DB IS DEFINED
C
      IF(DFLAG) GOTO 10
      RMSTAT = 16
      GOTO 999
C
   10 CONTINUE
      CALL ATTGET(STATUS)
      IF(STATUS.EQ.0) GO TO 200
C
C  NO MORE ATTRIBUTES
C
      RMSTAT = -1
      GO TO 999
C
C   VALIDATE USER
C
  200 CONTINUE
      IF(EQ(USERID,OWNER)) GO TO 300
      IF(EQ(RPW,NONE)) GO TO 300
      IF(EQ(RPW,USERID)) GO TO 300
      IF(EQ(MPW,USERID)) GO TO 300
      RMSTAT = 90
      GO TO 999
C
C  TRANSFER THE ATTRIBUTE DATA TO THE PROPER ARGUMENTS
C
  300 CONTINUE
      ANAME = ATTNAM
      CALL TYPER(ATTYPE,MATVEC,TYPE)
      LEN1 = ATTWDS
      LEN2 = 0
      IF(TYPE.EQ.KZTEXT) LEN1 = ATTCHA
      IF(TYPE.EQ.KZDOUB) LEN1 = LEN1/2
      IF(MATVEC.NE.KZMAT) GO TO 400
      LEN2 = LEN1/ATTCHA
      IF(LEN1.NE.0) LEN1 = ATTCHA
  400 CONTINUE
      VAR = .FALSE.
      IF(LEN1.EQ.0) VAR = .TRUE.
      KEY = .FALSE.
      IF(ATTKEY.NE.0) KEY = .TRUE.
      COL = ATTCOL
  999 RETURN
      END
      SUBROUTINE RMGET(INDPTR,TUPLE)
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE GETS THE NEXT ROW FROM A RELATION AND STORES
C  IT IN TUPLE.
C
C  PARAMETERS:
C         INDPTR--INDEX TO SAVE BLOCK (RANGE OF 0 TO 9)
C         TUPLE---USER ARRAY TO HOLD ONE COMPLETE TUPLE
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:VARDAT.BLK
      INCLUDE rin:PTRCOM.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:MISC.BLK
C
      INTEGER TUPLE(*)
      RMSTAT = 0
C         MAKE SURE DB IS DEFINED
C
      IF(DFLAG) GOTO 10
      RMSTAT = 16
      GOTO 9999
C
   10 CONTINUE
C
C  RESTORE THE BLOCKS AS NEEDED.
C
      CALL RMRES(INDPTR)
      IF(RMSTAT.NE.0) GO TO 9999
C
C  LOCATE THE NEXT ROW.
C
      INDEX = INDPTR
      IF(INDEX.EQ.0) INDEX = 1
      IF(INDEX.GT.3) INDEX = 3
      IF(NS.EQ.1) GO TO 50
C
C  UNSORTED RETRIEVAL
C
      CALL RMLOOK(MAT,INDEX,1,LENGTH)
      IF(IVAL.GT.MAXGET(INDPTR+1)) GO TO 75
      IF(RMSTAT.EQ.0) GO TO 100
C
C  END OF DATA.
C
      GO TO 75
C
C  SORTED RETRIEVAL
C
   50 CONTINUE
      LENGTH = NCOL + 1
      CALL RMGTSO(MAT,10,1,LENGTH,INDPTR)
      CID = BUFFER(MAT)
      MAT = MAT + 1
      LENGTH = LENGTH - 1
      IF(RMSTAT.EQ.0) GO TO 100
C
C  END OF DATA
C
   75 CONTINUE
      RMSTAT = -1
      IVAL = ALL9S
      GO TO 9999
C
C  MOVE THE DATA.
C
  100 CONTINUE
      CALL BLKMOV(TUPLE,BUFFER(MAT),LENGTH)
      IF(NUMVAR.EQ.0) GO TO 9999
      CALL RMVARC(-1,TUPLE)
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE RMGREL(RNAME,LRPW,LMPW,LASTMD,NUMATT,NUMTUP)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE: THIS ROUTINE GETS THE DATA FOR THE CURRENT RELATION
C           (FORTRAN INTERFACE COVER ROUTINE FOR GETREL)
C
C  PARAMETERS: RNAME---RELATION NAME
C              RPW-----RELATION READ PASSWORD - .TRUE. OR .FALSE.
C              MPW-----RELATION MODIFY PASSWORD - .TRUE. OR .FALSE.
C              LASTMD--DATE OF LAST RELATION MODIFICATION
C              NUMATT--NUMBER OF ATTRIBUTES
C              NUMTUP--NUMBER OF CURRENTLY DEFINED TUPLES (ROWS)
C
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:MISC.BLK
      INTEGER STATUS
      INTEGER NUMATT
      INTEGER NUMTUP
      LOGICAL LRPW
      LOGICAL LMPW
      LOGICAL EQ
      INCLUDE rin:DCLAR1.BLK
      INCLUDE rin:DCLAR6.BLK
C
      RMSTAT = 0
      INDCUR = NULL
C
C         MAKE SURE DB IS DEFINED
C
      IF(DFLAG) GOTO 10
      RMSTAT = 16
      GOTO 999
C
   10 CONTINUE
  100 CONTINUE
      CALL RELGET(STATUS)
      IF(STATUS.EQ.0) GO TO 200
C
C  NO MORE RELATIONS
C
      RMSTAT = -1
      GO TO 999
C
C   VALIDATE USER
C
  200 CONTINUE
      IF(EQ(NAME,K8RDT)) GO TO 100
      IF(EQ(NAME,K8RRC)) GO TO 100
      IF(EQ(USERID,OWNER)) GO TO 300
      IF(EQ(RPW,NONE)) GO TO 300
      IF(EQ(RPW,USERID)) GO TO 300
      IF(EQ(MPW,USERID)) GO TO 300
      GO TO 100
C
C  TRANSFER THE RELATION DATA TO THE PROPER ARGUMENTS
C
  300 CONTINUE
      RNAME = NAME
      LRPW =.TRUE.
      IF(EQ(RPW,NONE)) LRPW= .FALSE.
      LMPW = .TRUE.
      IF(EQ(MPW,NONE)) LMPW = .FALSE.
      LASTMD = RDATE
      NUMATT = NATT
      NUMTUP = NTUPLE
  999 RETURN
      END
      SUBROUTINE RMGTSO(MAT,INDEX,IFLAG,LENGTH,INDPTR)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  READ IN TUPLES FROM THE SORTED DATA FILE
C
C  PARAMETERS:
C            MAT-----ARRAY TO HOLD ONE TUPLE (IF IFLAG = 1)
C                    POINTER TO TUPLE IN BUFFER (IF IFLAG = 0)
C           INDEX---PAGE BUFFER TO USE
C            IFLAG---0 IF THE TUPLE IS RETURNED IN MAT
C                    1 IF THE BUFFER POINTER IS RETURNED IN MAT
C                   -1 OPEN THE SORT FILE AND INITIALIZE
C            LENGTH--LENGTH OF TUPLE IN WORDS
C            INDPTR--MULTIPLE RMHUNT INDEX - USED TO ASSIGN FILES
C
      INCLUDE rin:SRTCOM.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:F2COM.BLK
      INCLUDE rin:MISC.BLK
C
      DIMENSION MAT(*)
      INFIL = 20 + INDPTR
C
C  IF IFLAG IS NOT -1 SKIP THE SORT FILE/BUFFER INITIALIZATION
C
      IF(IFLAG.NE.-1) GO TO 500
C
C  FIRST CALL -----
C
C  REWIND THE SORT FILE NEEDED
C
      REWIND INFIL
C
C  ESTABLISH THE BUFFER POINTER
C
C  SEE IF THE CURRENT BLOCK NEEDS WRITING
C
      IF(INDEX.GT.3) GO TO 200
      IF(MODFLG(INDEX).EQ.0) GO TO 100
C
C  WRITE OUT THE CURRENT BLOCK
C
      KQ1 = BLKLOC(INDEX)
      CALL RIOOUT(FILE2,CURBLK(INDEX),BUFFER(KQ1),LENBF2,IOS)
      IF(IOS.NE.0) RMSTAT = 2200 + IOS
  100 MODFLG(INDEX) = 0
      CURBLK(INDEX) = 0
C
C  ESTABLISH THE NEW BUFFER BLOCK
C
  200 CONTINUE
      CALL BLKCHG(INDEX,MAXCOL,1)
C
C  SET THE TUPLES READ COUNTED TO 0
C
      NREAD = 0
C
C  ALL INITIALIZATION COMPLETE -- RETURN
C
      RETURN
C
C  READ IN A TUPLE FROM THE SORT FILE
C
  500 CONTINUE
      CALL BLKCHG(INDEX,MAXCOL,1)
      KQ1 = BLKLOC(INDEX) - 1
      NREAD = NREAD + 1
      IF(NREAD.GT.LIMTU) GO TO 900
      IF(NREAD.GT.NSORT) GO TO 900
      IF(FIXLT) GO TO 600
C
C  VARIABLE LENGTH TUPLES
C
c      READ(INFIL) LENGTH,(BUFFER(KQ1+K),K=1,LENGTH)
      READ(INFIL) LENGTH
      READ(INFIL) (BUFFER(KQ1+K),K=1,LENGTH)
      GO TO 700
C
C  FIXED LENGTH TUPLES
C
  600 CONTINUE
      READ(INFIL) (BUFFER(KQ1+K),K=1,LENGTH)
C
C  TUPLE READ - SET MAT AND RMSTAT
C
  700 CONTINUE
      RMSTAT = 0
      MAT(1) = KQ1 + 1
      IF(IFLAG.NE.0) GO TO 999
C
C  LOAD TUPLE INTO MAT
C
      DO 800 K=1,LENGTH
      MAT(K) = BUFFER(KQ1+K)
  800 CONTINUE
      GO TO 999
C
C  ALL DONE - SET RMSTAT AND CLOSE THE FILE
C
  900 CONTINUE
      RMSTAT = -1
      CALL BLKCLR(INDEX)
      CLOSE(UNIT=INFIL,STATUS='DELETE')
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE RMHELP
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE PROCESSES THE RIM HELP
C     COMMAND.  THE HELP DATA BASE HAS 3 ATTRIBUTES -
C     KEY3    - A 3 CHARACTER FIELD FOR FINDING THE LAST COMMAND
C               DOES NOT ALLOW DISCRIMINATION BETWEEN DIFFERENT
C               RENAMES OR DELETES
C     VERBAGE - A VARIABLE TEXT FIELD WITH A LINE OF STUFF. A ONE
C               CHARACTER FIELD IS A FLAG FOR END OF PAGE.
C     COMMAND - A 20 CHARACTER FIELD WITH THE FULL COMMAND NAME.
C
C     THE CURRENT DATA BASE FILE IS CLOSED AND THE HELP FILES OPENED.
C     THE CURRENT COMMAND IS LOCATED IN THE DATA BASE UNLESS
C     SOMETHING ELSE IS REQUESTED.  AFTER PROCESSING HELP COMMANDS,
C     THE HELP DATA BASE IS CLOSED AND THE USERS DATA BASE IS REOPENED.
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:SELCOM.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:DCLAR4.BLK
      INCLUDE rin:CONST8.BLK
      INTEGER SULPP,SUMCPL
      LOGICAL SPCENT,SRUCK
      LOGICAL ISAVE
C
C     SET PROMPT CHARACTER TO H FOR HELPPPPPPPP
C
      CALL LXSET(K4PROM,K4HP)
      STOL = TOL
      SPCENT = PCENT
      SRUCK = RUCK
      SULPP = ULPP
      SUMCPL = UMCPL
C
C     CLOSE EXISTING DATA BASE
C
      IFILE = DBNAME
      ISAVE = DFLAG
      CALL RMOPEN(K8HDB)
C
C     SET UP PRELIMINARY WHERE CLAUSE
C
      NBOO = 1
      BOO(1) = K4AND
      KOMTYP(1) = 2
      KOMPOS(1) = 1
      KOMLEN(1) = 1
      KOMPOT(1) = 1
      LIMTU = ALL9S
      MAXTU = ALL9S
      KSTRT = 0
      NS = 0
      ITEMS = LXITEM(IDUM)
      IP = 2
      IF(ITEMS.GT.1) GO TO 1100
C
C     USE LAST COMMAND VIA KEY3 ATTRIBUTE
C
      CALL HTOI(3,1,KATTL(1))
      CALL HTOI(3,1,WHRLEN(1))
      WHRVAL(1) = LSTCMD
      KATTP(1) = 1
      KATTY(1) = KZTEXT
      I = LOCREL(KWHELP)
      IF(I.NE.0) GO TO 8000
      I = LOCATT(BLANK,NAME)
      IF(I.NE.0) GO TO 8000
      CALL ATTGET(ISTAT)
      KSTRT = ATTKEY
      IF(KSTRT.NE.0) NS = 2
C
C     GO PRINT VERBAGE
C
      GO TO 2000
 1000 CONTINUE
      IP = 1
C
C     GET NEXT INPUT
C
	if(nout.eq.6)goto 2
      WRITE (NOUT,1005)
 1005 FORMAT(32H Enter END To End HELP or a RIM ,
     X       19HKeyword to Continue )
	goto 3
2	continue
	write(c128wk,1005)
	call atxto
3	continue
      CALL LXLREC(IDUM,0,IDUM)
      ITEMS = LXITEM(IDUM)
      IF(ITEMS.GT.1) GO TO 1100
      IF(LXID(1).EQ.K4EOF) GO TO 9000
      IF(LXID(1).NE.KZTEXT) GO TO 8100
      IF(LXWREC(1,1).EQ.K4END) GO TO 9000
 1100 CONTINUE
C
C     SET UP WHERE CLAUSE FOR USER ENTERD COMMAND
C
      I = LOCREL(KWHELP)
      IF(I.NE.0) GO TO 8000
      I = LOCATT(K8COMM,NAME)
      IF(I.NE.0) GO TO 8000
      CALL ATTGET(ISTAT)
      KATTP(1) = ATTCOL
      KATTL(1) = ATTLEN
      KATTY(1) = ATTYPE
      KSTRT = ATTKEY
      IF(KSTRT.NE.0) NS = 2
      IF(LXID(IP).NE.KZTEXT) GO TO 8100
      NC = LXLENC(IP)
      CALL FILCH(WHRVAL,1,20,BLANK)
      CALL LXSREC(IP,1,NC,WHRVAL,1)
      IP = IP + 1
      IF(IP.GT.ITEMS) GO TO 1150
C
C     GET ANOTHER ITEM
C
      MC = LXLENC(IP)
      IF(LXID(IP).NE.KZTEXT) GO TO 8100
      CALL LXSREC(IP,1,MC,WHRVAL,NC+2)
 1150 CONTINUE
      WHRLEN(1) = ATTLEN
 2000 CONTINUE
C
C     LOOP THRU RECORDS AND DISPLAY
C
      CALL RMLOOK(ITUP,1,1,LENGTH)
      IF(RMSTAT.EQ.0) GO TO 2100
	if(nout.eq.6)goto 4
      WRITE (NOUT,2050)
 2050 FORMAT(42H Unable To Find Help For Requested Command )
      Go TO 1000
4	continue
	write(c128wk,2050)
	call atxto
	goto 1000
 2100 CONTINUE
      ITEXT = ITUP + BUFFER(ITUP+1)
      NC = BUFFER(ITEXT)
      NW = BUFFER(ITEXT-1)
	if(nout.eq.6)goto 5
      IF(NC.NE.1) WRITE(NOUT,2150)(BUFFER(ITEXT+I),I=1,NW)
 2150 FORMAT(20A4)
	goto 6
5	continue
      IF(NC.NE.1) WRITE(c128wk,2150)(BUFFER(ITEXT+I),I=1,NW)
	call atxto
6	continue
      IF(NC.NE.1) GO TO 2300
C
C     PAGE BREAK
C
	if(nout.eq.6)goto 7
      WRITE (NOUT,2250)
 2250 FORMAT(28H More Text Follows - Enter * ,
     X       28H to Continue or QUIT to STOP )
	goto 8
7	continue
	write(c128wk,2250)
	call atxto
8	continue
      CALL LXLREC(IDUM,0,IDUM)
      IF(LXID(1).EQ.K4EOF) GO TO 2300
      IF(LXWREC(1,1).EQ.K4QUIT) GO TO 1000
 2300 CONTINUE
      CALL RMLOOK(ITUP,1,1,LENGTH)
      IF(RMSTAT.EQ.0) GO TO 2100
      GO TO 1000
 8000 CONTINUE
C
C     HELP NOT AVAILABLE
C
	if(nout.eq.6)goto 9
      WRITE (NOUT,8005)
 8005 FORMAT(32H HELP is NOT currently available )
      GO TO 9000
9	continue
	write(c128wk,8005)
	call atxto
	goto 9000
 8100 CONTINUE
C
C     NON TEXT INPUT
C
	if(nout.eq.6)goto 10
      WRITE (NOUT,8105)
 8105 FORMAT(28H HELP requires text commands )
      GO TO 1000
10	continue
	write(c128wk,8105)
	call atxto
	goto 1000
 9000 CONTINUE
C
C     TRY TO REVERT TO ENTRY CONDITIONS
C
      CALL RMCLOS
      IF(ISAVE) CALL RMOPEN(IFILE)
      CALL LXSET(K4PRES,IDUM)
      TOL = STOL
      PCENT = SPCENT
      RUCK = SRUCK
      SULPP = ULPP
      SUMCPL = UMCPL
	if(nout.eq.6)goto 11
      WRITE (NOUT,9005)
 9005 FORMAT(20H Enter Next Command )
      RETURN
11	continue
	write(c128wk,9005)
	call atxto
	return
      END
      SUBROUTINE RMLATT(RNAME)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE: THIS ROUTINE SETS THE POINTERS TO THE FIRST ATTRIBUTE
C           OF RELATION RNAME
C           (FORTRAN INTERFACE COVER ROUTINE FOR LOCATT)
C
C  PARAMETERS: RNAME--RELATION NAME
C
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:MISC.BLK
      INTEGER STATUS
      LOGICAL EQ
      INCLUDE rin:DCLAR1.BLK
C
      RMSTAT = 0
      INDCUR = NULL
C
C         MAKE SURE DB IS DEFINED
C
      IF(DFLAG) GOTO 10
      RMSTAT = 16
      GOTO 999
C
   10 CONTINUE
      IF(RNAME.EQ.NAME) GO TO 200
      I = LOCREL(RNAME)
      IF(I.EQ.0) GO TO 100
      RMSTAT = 20
      GO TO 999
C
C  GET THE RELATION PASSWORDS
C
  100 CONTINUE
      CALL RELGET(STATUS)
      IF(STATUS.NE.0) GO TO 999
C
C   CHECK PERMISSION
C
      IF(EQ(USERID,OWNER)) GO TO 200
      IF(EQ(RPW,NONE)) GO TO 200
      IF(EQ(RPW,USERID)) GO TO 200
      IF(EQ(MPW,USERID)) GO TO 200
      RMSTAT = 90
      GO TO 999
  200 CONTINUE
      J = LOCATT(BLANK,RNAME)
  999 RETURN
      END
      SUBROUTINE RMLOAD(INDPTR,TUPLE)
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE LOADS DATA FROM TUPLE INTO THE CURRENT RELATION.
C
C  PARAMETERS:
C         INDPTR--INDEX TO SAVE BLOCK (RANGE OF 0 TO 9)
C         TUPLE---USER ARRAY WITH REPLACEMENT TUPLE
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:VARDAT.BLK
      INCLUDE rin:KEYDAT.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:RULCOM.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:START.BLK
      INTEGER COLUMN
C
      INTEGER TUPLE(*)
      RMSTAT = 0
C         MAKE SURE DB IS DEFINED
C
      IF(DFLAG) GOTO 10
      RMSTAT = 16
      GOTO 9999
C
   10 CONTINUE
C
C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
C
      CALL RMDBLK(DBNAME)
      IF(RMSTAT.NE.0) GO TO 9999
C
C  RESTORE THE BLOCKS AS NEEDED.
C
      CALL RMRES(INDPTR)
      IF(RMSTAT.NE.0) GO TO 9999
C
C  SET THE INDEX POINTER
C
      INDEX = INDPTR
      IF(INDEX.EQ.0) INDEX = 1
      IF(INDEX.GT.3) INDEX = 3
C
C  CHECK FOR WRITE PERMISSION ON THIS RELATION.
C
      I = LOCPRM(NAME,2)
      IF(RMSTAT.NE.0) GO TO 9999
      NEWL = NCOL
C
C  CONVERT THE VARIABLE ATTRIBUTE HEADERS FROM USER TO INTERNAL
C
      IF(NUMVAR.EQ.0) GOTO 360
      CALL RMVARC(1,TUPLE)
      IF(RMSTAT.NE.0) GO TO 9999
C
C  FIND OUT HOW LONG THE NEW TUPLE IS.
C
  200 CONTINUE
      I = LOCATT(BLANK,NAME)
      NEWL = 0
  320 CONTINUE
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 360
      NWORDS = ATTWDS
      IF(ATTWDS.NE.0) GO TO 340
C
C  VARIABLE LENGTH ATTRIBUTE.
C
      COLUMN = TUPLE(ATTCOL)
      IF((COLUMN.LE.1).OR.(COLUMN.GT.MAXCOL)) GO TO 800
      NWORDS = TUPLE(COLUMN) + 3
      IF(NWORDS.LE.3) GO TO 800
  340 CONTINUE
      NEWL = NEWL + NWORDS
      GO TO 320
  360 CONTINUE
      IF(NEWL.GT.MAXCOL) GO TO 800
C
C  SEE IF ANY APPLICABLE RULES ARE MET.
C
      IF(.NOT.RUCK) GO TO 440
      IF(.NOT.RULES) GO TO 440
C
C  SAVE THE CURRENT POSITION DATA
C
      CALL RMSAV(INDCUR)
C
C  LOAD THE RULE WHERE CLAUSE
C
      NBOO = 1
      BOO(1) = K4AND
      KATTP(1) = 1
      KATTL(1) = 1
      KATTY(1) = KZINT
      KOMTYP(1) = 2
      KOMPOS(1) = 1
      KOMLEN(1) = 1
      KOMPOT(1) = 1
      KSTRT = 0
      MAXTU = ALL9S
      LIMTU = ALL9S
      WHRVAL(1) = 0
      WHRLEN(1) = 1
      CALL CHKTUP(TUPLE,ISTAT)
      RMSTAT = 0
      IF(ISTAT.GT.0) RMSTAT = 200 + ISTAT
      IF(ISTAT.LT.0) RMSTAT = 112
C
C  RESTORE THE CURRENT POSITION DATA
C
      INDCUR = 0
      CALL RMRES(INDPTR)
      IF(RMSTAT.EQ.0) GO TO 440
      GO TO 9999
C
C  ADD THE NEW TUPLE.
C
  440 CONTINUE
      CALL ADDDAT(INDEX,REND,TUPLE,NEWL)
      IF(RSTART.EQ.0) RSTART = REND
      RDATE = DBDATE
      NTUPLE = NTUPLE + 1
      CALL RELPUT
      IF(NUMKEY.EQ.0) GO TO 9999
C
C  FIX UP THE KEYS FOR THE ADDED TUPLE.
C
      I = 0
      IF(NUMKEY.LE.5) GO TO 460
      I = LOCATT(BLANK,NAME)
  460 CONTINUE
      IF(NUMKEY.GT.5) GO TO 465
      I  = I + 1
      IF(I.GT.NUMKEY) GO TO 9999
      START = KEYDAT(1,I)
      KSTART = KEYDAT(1,I)
      COLUMN = KEYDAT(2,I)
      ATTWDS = KEYDAT(3,I)
      ATTYPE = KEYDAT(4,I)
      GO TO 470
  465 CONTINUE
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 9999
      IF(ATTKEY.EQ.0) GO TO 460
      START = ATTKEY
      KSTART = ATTKEY
      COLUMN = ATTCOL
  470 CONTINUE
      IF(ATTWDS.NE.0) GO TO 480
      COLUMN = TUPLE(COLUMN) + 2
  480 CONTINUE
      IF(TUPLE(COLUMN).EQ.NULL) GO TO 460
      CALL BTADD(TUPLE(COLUMN),REND,ATTYPE)
      IF(START.EQ.KSTART) GO TO 460
      IF(NUMKEY.LE.5) GO TO 490
      ATTKEY = START
      CALL ATTPUT(ISTAT)
      GO TO 460
  490 CONTINUE
      ISTAT = LOCATT(KEYDAT(5,I),NAME)
      CALL ATTGET(ISTAT)
      ATTKEY = START
      CALL ATTPUT(ISTAT)
      KEYDAT(1,I) = START
      GO TO 460
C
C  NEW TUPLE HAS VARIABLE LENGTH POINTERS WHICH ARE WIERD.
C
  800 CONTINUE
      RMSTAT = 100
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE RMLOOK(MAT,INDEX,IFLAG,LENGTH)
      INCLUDE rin:TEXT.BLK
C
C   LOCATE NEXT DESIRED TUPLE
C
C  PARAMETERS:
C         MAT-----ARRAY TO HOLD ONE TUPLE
C                 IF(IFLAG.NE.0) MAT IS POINTER TO TUPLE
C                 IN INPUT BUFFER.
C         INDEX---PAGE BUFFER TO USE
C         IFLAG---0 IFF TUPLE IS RETURNED
C                 ELSE POINTER TO TUPLE IS RETURNED IN MAT
C         LENGTH--LENGTH OF TUPLE IN WORDS
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:START.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:FLAGS.BLK
C
      DIMENSION MAT(*)
      LOGICAL QUAL,OK,BTEST
      LOGICAL EQTEST
C
C  SCAN MAT.
C
      RMSTAT = 0
    1 CONTINUE
C
C  SEE IF WE ARE USING A KEY VALUE.
C
      IF(NS.EQ.0) GO TO 30
      IF(NS.EQ.3) GO TO 10
C
C  FIRST TIME THROUGH. USE BTLOOK TO FIND THE TUPLES.
C
      START = KSTRT
      NBOOX = IABS(NBOO)
      NUMP = KOMPOS(NBOOX)
      IF(KATTY(NBOOX).EQ.KZINT ) CALL BTLKI(WHRVAL(NUMP),NID,MID)
      IF(KATTY(NBOOX).EQ.KZREAL) CALL BTLKR(WHRVAL(NUMP),NID,MID)
      IF(KATTY(NBOOX).EQ.KZDOUB) CALL BTLKR(WHRVAL(NUMP),NID,MID)
      IF(KATTY(NBOOX).EQ.KZTEXT) CALL BTLKT(WHRVAL(NUMP),NID,MID)
      NS = 3
      IF(NID.NE.0) GO TO 20
   10 CONTINUE
      IF(MID.EQ.0) GO TO 1300
      CALL MOTSCN(MID,NID)
      IF(NID.NE.0) GO TO 20
      GO TO 10
   20 CONTINUE
      CID = NID
      CALL GETDAT(INDEX,NID,ITUP,LENGTH)
      GO TO 40
   30 CONTINUE
      IF(NID.EQ.0) GO TO 1300
      CALL ITOH(N1,N2,NID)
      IF(N2.EQ.0) GO TO 1300
      CID = NID
      CALL GETDAT(INDEX,NID,ITUP,LENGTH)
      IF(NID.LT.0) GO TO 1300
C
C  SCAN THROUGH EACH BOOLEAN CONDITION OF THE WHERE CLAUSE.
C
   40 CONTINUE
      IVAL = IVAL + 1
      IF(NBOO.LE.0) GO TO 1200
      IF(IVAL.GT.MAXTU) GO TO 1300
      QUAL = .TRUE.
      DO 1000 J=1,NBOO
      ITYPE = KATTY(J)
      IF(ITYPE.EQ.0)ITYPE = KZINT
      OK = .FALSE.
      CALL ITOH(NR,LEN,KATTL(J))
      NUM = KOMLEN(J)
      NK = KOMTYP(J)
      NUMP = KOMPOS(J)
      IP = ITUP + KATTP(J) - 1
      IF(KATTP(J).NE.0) GO TO 100
C
C  TUPLE NUMBERS
C
      OK = .TRUE.
      IF(NK.EQ.2) OK = .FALSE.
      DO 80 JJ=1,NUM
      BTEST = .FALSE.
      CALL KOMPXX(IVAL,WHRVAL(JJ+NUMP-1),1,NK,BTEST,ITYPE)
      IF(NK.EQ.2) OK = OK .OR. BTEST
      IF(NK.NE.2) OK = OK .AND. BTEST
   80 CONTINUE
      GO TO 900
  100 CONTINUE
      IF(NK.LT.10) GO TO 300
C
C  ATTRIBUTE - ATTRIBUTE COMPARISON
C
      KP = ITUP + NUMP - 1
C
C  DUMMY TOLERANCE FOR ATTRIBUTE TO ATTRIBUTE
C
      IF(LEN.NE.0) GO TO 120
C
C     SET POINTER FOR VARIABLE ATTRIBUTES
C
      IP = BUFFER(IP) + ITUP - 1
      KP = BUFFER(KP) + ITUP - 1
      IF(NK.EQ.13) OK = .TRUE.
      LEN = BUFFER(IP)
      IF(BUFFER(KP).NE.BUFFER(IP)) GO TO 900
      IF(BUFFER(KP+1).NE.BUFFER(IP+1)) GO TO 900
      OK = .FALSE.
      IP = IP + 2
      KP = KP + 2
  120 CONTINUE
      TTOL = TOL
      TOL = 0.
      NK = NK - 10
      CALL KOMPXX(BUFFER(IP),BUFFER(KP),LEN,NK,OK,ITYPE)
      TOL = TTOL
      GO TO 900
  300 CONTINUE
      IF(LEN.NE.0) GO TO 320
C
C     SET POINTER FOR VARIABLE ATTRIBUTE
C
      IP = BUFFER(IP) + ITUP - 1
      LEN = BUFFER(IP)
      NR = BUFFER(IP+1)
      IP = IP + 2
  320 CONTINUE
C
C     REGULAR ATTRIBUTE
C
      NPOS = KOMPOS(J)
      NPOT = KOMPOT(J)
      OK = .TRUE.
      EQTEST = .FALSE.
      IF((NK.EQ.2).OR.(NK.EQ.9)) EQTEST = .TRUE.
      IF(EQTEST) OK = .FALSE.
      DO 400 JJ=1,NUM
      BTEST = .FALSE.
      CALL ITOH(NNR,NW,WHRLEN(NPOT))
      IF(NK.LE.1) GO TO 350
      IF(BUFFER(IP).EQ.NULL) GO TO 350
      IF((LEN.EQ.NW).AND.(NR.EQ.NNR)) GO TO 350
C
C     COMPARE OF DIFFERENT LENGTHS
C
      IF(NK.EQ.9) GO TO 350
      IF(NK.NE.3) GO TO 375
      OK = .TRUE.
      GO TO 900
  350 CONTINUE
      IF(NK.NE.9)CALL KOMPXX(BUFFER(IP),WHRVAL(NPOS),NW,NK,BTEST,ITYPE)
      IF(NK.NE.9) GO TO 375
C
C     CONTAINS
C
      M1 = LSTRNG(BUFFER(IP),1,NR,WHRVAL(NPOS),1,NNR)
      IF(M1.GT.0) BTEST = .TRUE.
  375 CONTINUE
      IF(EQTEST) OK = OK.OR.BTEST
      IF(.NOT.EQTEST) OK = OK.AND.BTEST
      IF(OK.AND.EQTEST) GO TO 900
      NPOS = NPOS + NW
      NPOT = NPOT + 1
  400 CONTINUE
  900 CONTINUE
      IF(BOO(J).EQ.K4AND) QUAL = QUAL .AND. OK
      IF(BOO(J).EQ.K4OR ) QUAL = QUAL .OR.  OK
 1000 CONTINUE
      IF(.NOT.QUAL) GO TO 1
C
C  FOUND IT.
C
 1200 CONTINUE
      LIMVAL = LIMVAL + 1
      IF(LIMVAL.GT.LIMTU) GO TO 1300
      MAT(1) = ITUP
      IF(IFLAG.NE.0) RETURN
      IP = ITUP
      DO 1250 I=1,LENGTH
      MAT(I) = BUFFER(IP)
      IP = IP + 1
 1250 CONTINUE
      RMSTAT = 0
      RETURN
C
C  END OF DATA.
C
 1300 CONTINUE
      NS = 0
      RMSTAT = -1
      RETURN
      END
      SUBROUTINE RMLREL
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE: THIS ROUTINE SETS THE POINTERS TO THE FIRST RELATION
C           (FORTRAN INTERFACE COVER ROUTINE FOR LOCREL)
C
C  PARAMETERS: NONE
C
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:TUPLER.BLK
      INTEGER STATUS
      LOGICAL EQ
      RMSTAT = 0
      INDCUR = NULL
C
C         MAKE SURE DB IS DEFINED
C
      IF(DFLAG) GOTO 10
      RMSTAT = 16
      GOTO 999
C
   10 CONTINUE
      I = LOCREL(BLANK)
      NP = 0
      IF(I.EQ.0) GO TO 100
      RMSTAT = 20
      GO TO 999
  100 CONTINUE
C
C  GET THE RELATION PASSWORDS
C
      CALL RELGET(STATUS)
      IF(STATUS.NE.0) GO TO 900
C
C   VALIDATE USER
C
      IF(EQ(USERID,OWNER)) NP = 1
      IF(EQ(RPW,NONE)) NP = 1
      IF(EQ(RPW,USERID)) NP = 1
      IF(EQ(MPW,USERID)) NP = 1
      GO TO 100
C
C  CHECK FOR UNAUTHORIZED RELATION ACCESS
C
  900 CONTINUE
      IF(NP.EQ.0) RMSTAT = 90
C
C  RMLREL COMPLETE
C
  999 CONTINUE
      I = LOCREL(BLANK)
      RETURN
      END
      SUBROUTINE RMOPEN(IFILE)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  OPEN A RIM DATABASE.
C
C  PARAMETERS:
C         IFILE---NAME OF THE DATABASE
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:ATTBLE.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:DCLAR4.BLK
      DATA ICALLS /0/
      IF(ICALLS.EQ.0) DFLAG = .FALSE.
      ICALLS = ICALLS + 1
      RMSTAT = 0
C
C  CLOSE ANY EXISTING DATABASES AND INITIALIZE
C
      IF(DFLAG) CALL RMCLOS
      CALL RMSTRT
C
C  SET THE NEW DATABASE NAME, DATE, AND TIME
C
      DBNAME = IFILE
      CALL RMDATE(DBDATE)
      CALL RMTIME(DBTIME)
C
C  FIND THE LAST NON-BLANK CHARACTER.
C
      DO 100 I=1,7
      CALL GETT(IFILE,I,IT)
      IF(IT.EQ.IBLANK) GO TO 200
  100 CONTINUE
      I = 7
  200 CONTINUE
C
C  FIX UP THE FILE NAMES.
C
      FILE = BLANK
      CALL STRMOV(IFILE,1,I,FILE,1)
      RIMDB1 = FILE
      CALL PUTT(RIMDB1,I,K41)
      RIMDB2 = FILE
      CALL PUTT(RIMDB2,I,K42)
      RIMDB3 = FILE
      CALL PUTT(RIMDB3,I,K43)
C
C  OPEN FILE 1.
C
      CALL F1OPN(RIMDB1)
      IF((RMSTAT.NE.0).AND.(RMSTAT.NE.15)) GO TO 999
C
C  OPEN FILE 2.
C
      CALL F2OPN(RIMDB2)
      IF((RMSTAT.NE.0).AND.(RMSTAT.NE.15)) GO TO 999
C
C  OPEN FILE 3.
C
      CALL F3OPN(RIMDB3)
      IF((RMSTAT.NE.0).AND.(RMSTAT.NE.15)) GO TO 999
C
C  IF THIS IS A NEW DATABASE WE NEED TO SET UP THE FIRST BTREE.
C
      IF(DFLAG) CALL RMDATE(DBDATE)
  999 RETURN
      END
      SUBROUTINE RMPUT(INDPTR,TUPLE)
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE PUTS DATA FROM TUPLE INTO THE CURRENT ROW.
C
C  PARAMETERS:
C         INDPTR--INDEX TO SAVE BLOCK (RANGE OF 0 TO 9)
C         TUPLE---USER ARRAY WITH REPLACEMENT TUPLE
      INCLUDE rin:KEYDAT.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:VARDAT.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:RULCOM.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:START.BLK
      INTEGER COLUMN
C
      INTEGER TUPLE(*)
      RMSTAT = 0
C         MAKE SURE DB IS DEFINED
C
      IF(DFLAG) GOTO 10
      RMSTAT = 16
      GOTO 9999
C
   10 CONTINUE
C
C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
C
      CALL RMDBLK(DBNAME)
      IF(RMSTAT.NE.0) GO TO 9999
C
C  RESTORE THE BLOCKS AS NEEDED.
C
      CALL RMRES(INDPTR)
      IF(RMSTAT.NE.0) GO TO 9999
C
C  CHECK FOR WRITE PERMISSION ON THIS RELATION.
C
      I = LOCPRM(NAME,2)
      IF(RMSTAT.NE.0) GO TO 9999
C
C  CHECK THAT RMGET WAS CALLED
C
      IF((IVAL.GT.0).AND.(IVAL.LT.ALL9S)) GO TO 200
C
C  RMGET WAS NOT CALLED BEFORE RMPUT
C
      RMSTAT = 60
      GO TO 9999
C
C  CONVERT THE VARIABLE ATTRIBUTE HEADERS FROM USER TO INTERNAL
C
  200 CONTINUE
      IF(NUMVAR.EQ.0) GO TO 250
      CALL RMVARC(1,TUPLE)
      IF(RMSTAT.NE.0) GO TO 9999
  250 CONTINUE
C
C  CHECK FOR RULES
C
      IF(.NOT.RUCK) GO TO 290
      IF(.NOT.RULES) GO TO 290
C
C  SAVE THE CURRENT POSITION DATA
C
      CALL RMSAV(INDCUR)
C
C  LOAD THE RULE WHERE CLAUSE
C
      NBOO = 1
      BOO(1) = K4AND
      KATTP(1) = 1
      KATTL(1) = 1
      KATTY(1) = KZINT
      KOMTYP(1) = 2
      KOMPOS(1) = 1
      KOMLEN(1) = 1
      KOMPOT(1) = 1
      KSTRT = 0
      MAXTU = ALL9S
      LIMTU = ALL9S
      WHRVAL(1) = 0
      WHRLEN(1) = 1
      CALL CHKTUP(TUPLE,ISTAT)
      RMSTAT = 0
      IF(ISTAT.GT.0) RMSTAT = 200 + ISTAT
      IF(ISTAT.LT.0) RMSTAT = 112
C
C  RESTORE THE CURRENT POSITION DATA
C
      INDCUR = 0
      CALL RMRES(INDPTR)
      IF(RMSTAT.EQ.0) GO TO 290
      GO TO 9999
C
C  RETRIEVE THE CURRENT ROW IN A SCRATCH TUPLE.
C
  290 CONTINUE
      CALL BLKCHG(11,MAXCOL,1)
      KQ1 = BLKLOC(11)
      NID = CID
      INDEX = INDPTR
      IF(INDEX.EQ.0) INDEX = 1
      IF(INDEX.GT.3) INDEX = 3
      LNBOO = NBOO
      NBOO = 0
      LNS = NS
      NS = 0
      CALL RMLOOK(BUFFER(KQ1),INDEX,0,KURLEN)
      NS = LNS
      NBOO = LNBOO
      IVAL = IVAL - 1
      IF(RMSTAT.EQ.0) GO TO 300
C
C  NO DATA AVAILABLE
C
      RMSTAT = 60
      GO TO 9999
C
C  SEE IF THE NEW TUPLE IS LONGER THAN THE OLD ONE.
C
  300 CONTINUE
      NEWL = KURLEN
      IF(NUMVAR.EQ.0) GO TO 370
      I = LOCATT(BLANK,NAME)
      NEWL = 0
  320 CONTINUE
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 360
      NWORDS = ATTWDS
      IF(ATTWDS.NE.0) GO TO 340
C
C  VARIABLE LENGTH ATTRIBUTE.
C
      COLUMN = TUPLE(ATTCOL)
      IF((COLUMN.LE.1).OR.(COLUMN.GT.MAXCOL)) GO TO 800
      NWORDS = TUPLE(COLUMN) + 3
      IF(NWORDS.LT.3) GO TO 800
  340 CONTINUE
      NEWL = NEWL + NWORDS
      GO TO 320
  360 CONTINUE
      IF(NEWL.GT.MAXCOL) GO TO 800
  370 CONTINUE
      IF(NEWL.LE.KURLEN) GO TO 500
C
C  NEW TUPLE IS LONGER THAN THE OLD ONE.
C  OLD TUPLE MUST BE DELETED AND THE CHANGED ONE ADDED.
C
      CALL DELDAT(INDEX,CID)
C
C  CHANGE THE POINTERS FOR ANY KEY ELEMENTS.
C
      IF(NUMKEY.EQ.0) GO TO 440
      I = 0
      IF(NUMKEY.LE.5) GO TO 380
      I = LOCATT(BLANK,NAME)
  380 CONTINUE
      IF(NUMKEY.GT.5) GO TO 390
      I = I + 1
      IF(I.GT.NUMKEY) GO TO 440
      START = KEYDAT(1,I)
      COLUMN = KEYDAT(2,I)
      ATTWDS = KEYDAT(3,I)
      ATTYPE = KEYDAT(4,I)
      GO TO 395
  390 CONTINUE
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 440
      IF(ATTKEY.EQ.0) GO TO 380
      START = ATTKEY
      COLUMN = ATTCOL
  395 CONTINUE
      IF(ATTWDS.NE.0) GO TO 400
      COLUMN = BUFFER(KQ1+COLUMN-1) + 2
  400 CONTINUE
      IF(BUFFER(KQ1+COLUMN-1).EQ.NULL) GO TO 380
      CALL BTREP(BUFFER(KQ1+COLUMN-1),0,CID,ATTYPE)
      GO TO 380
C
C  ADD THE NEW TUPLE.
C
  440 CONTINUE
      IF(CID.EQ.RSTART) RSTART = NID
      CALL ADDDAT(INDEX,REND,TUPLE,NEWL)
      RDATE = DBDATE
      CALL RELPUT
C
C  FIX UP THE KEYS FOR THE ADDED TUPLE.
C
      IF(NUMKEY.EQ.0) GO TO 9999
      I = 0
      IF(NUMKEY.LE.5) GO TO 460
      I = LOCATT(BLANK,NAME)
  460 CONTINUE
      IF(NUMKEY.GT.5) GO TO 470
      I = I + 1
      IF(I.GT.NUMKEY) GO TO 9999
      START = KEYDAT(1,I)
      COLUMN = KEYDAT(2,I)
      ATTWDS = KEYDAT(3,I)
      ATTYPE = KEYDAT(4,I)
      GO TO 475
  470 CONTINUE
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 9999
      IF(ATTKEY.EQ.0) GO TO 460
      START = ATTKEY
      KSTART = ATTKEY
      COLUMN = ATTCOL
  475 CONTINUE
      IF(ATTWDS.NE.0) GO TO 480
      COLUMN = TUPLE(COLUMN) + 2
  480 CONTINUE
      IF(TUPLE(COLUMN).EQ.NULL) GO TO 460
      CALL BTADD(TUPLE(COLUMN),REND,ATTYPE)
      IF(START.EQ.KSTART) GO TO 460
      IF(NUMKEY.LE.5) GO TO 490
      ATTKEY = START
      CALL ATTPUT(ISTAT)
      GO TO 460
  490 CONTINUE
      ISTAT = LOCATT(KEYDAT(5,I),NAME)
      CALL ATTGET(ISTAT)
      ATTKEY = START
      CALL ATTPUT(ISTAT)
      GO TO 460
C
C  NEW TUPLE WILL FIT IN PLACE.
C
  500 CONTINUE
      CALL PUTDAT(INDEX,CID,TUPLE,NEWL)
      RDATE = DBDATE
      CALL RELPUT
C
C  CHANGE THE POINTERS FOR ANY KEY ATTRIBUTES.
C
      IF(NUMKEY.EQ.0) GO TO 9999
      I = 0
      IF(NUMKEY.LE.5) GO TO 520
      I = LOCATT(BLANK,NAME)
  520 CONTINUE
      IF(NUMKEY.GT.5) GO TO 530
      I = I + 1
      IF(I.GT.NUMKEY) GO TO 9999
      START = KEYDAT(1,I)
      KSTART = KEYDAT(1,I)
      IPOLD = KEYDAT(2,I)
      IPNEW = IPOLD
      ATTWDS = KEYDAT(3,I)
      ATTYPE = KEYDAT(4,I)
      GO TO 535
  530 CONTINUE
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 9999
      IF(ATTKEY.EQ.0) GO TO 520
      START = ATTKEY
      KSTART = ATTKEY
      IPOLD = ATTCOL
      IPNEW = ATTCOL
  535 CONTINUE
      IF(ATTWDS.NE.0) GO TO 540
C
C  VARIABLE LENGTH ATTRIBUTE.
C
      IPOLD = BUFFER(KQ1+IPOLD-1) + 2
      IPNEW = TUPLE(IPNEW) + 2
      IF((IPNEW.LT.1).OR.(IPNEW.GT.MAXCOL)) GO TO 800
  540 CONTINUE
      IF(BUFFER(KQ1+IPOLD-1).EQ.TUPLE(IPNEW)) GO TO 520
C
C  THE VALUE CHANGED.
C
      IF(BUFFER(KQ1+IPOLD-1).NE.NULL)
     +CALL BTREP(BUFFER(KQ1+IPOLD-1),0,CID,ATTYPE)
      IF(TUPLE(IPNEW).NE.NULL)
     +CALL BTADD(TUPLE(IPNEW),CID,ATTYPE)
      IF(START.EQ.KSTART) GO TO 520
      IF(NUMKEY.LE.5) GO TO 550
      ATTKEY = START
      CALL ATTPUT(ISTAT)
      GO TO 520
  550 CONTINUE
      ISTAT = LOCATT(KEYDAT(5,I),NAME)
      CALL ATTGET(ISTAT)
      ATTKEY = START
      CALL ATTPUT(ISTAT)
      GO TO 520
C
C  NEW TUPLE HAS VARIABLE LENGTH POINTERS WHICH ARE WIERD.
C
  800 CONTINUE
      RMSTAT = 100
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE RMRES(INDPTR)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   RESTORE THE INTERNAL POINTERS FOR THE NAVIGATION OF
C             MULTIPLE PROGRAM INTERFACE PATHS.
C
C  PARAMETERS:
C     INPUT:  INDPTR--INDEX TO SAVE BLOCK (RANGE OF 0 TO 9)
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:VARDAT.BLK
      INCLUDE rin:KEYDAT.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:RULCOM.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:RELTBL.BLK
      INCLUDE rin:PTRCOM.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:SRTCOM.BLK
      LOGICAL NE
      LOGICAL EQ
C
C  SEE IF THE INDEX IS WITHIN RANGE.
C
      IF(INDCUR.EQ.NULL) GO TO 400
      IF(INDPTR.EQ.NULL) GO TO 400
      IF((INDPTR.LT.0).OR.(INDPTR.GT.9)) GO TO 500
C
C  SEE IF THE CURRENT BLOCK IS ALREADY THERE.
C
      IF(INDPTR.EQ.INDCUR) GO TO 999
C
C  SAVE THE CURRENT BLOCKS.
C
      CALL RMSAV(INDCUR)
C
C  RESTORE THE BLOCKS.
C
      DO 100 I=1,INDMAX
      IF(INDNUM(I).EQ.INDPTR) GO TO 200
  100 CONTINUE
C
C  NUMBER HAS NOT BEEN SAVED.
C
      GO TO 400
  200 CONTINUE
C
C  GET THE START OF THE POINTERS IN THE BUFFER
C
      I = INDPTR + 1
      KQ1 = SAVBLK(1,I)
      IF(KQ1.EQ.0) RETURN
C
C  MOVE THE POINTER VALUES FROM THE BUFFER TO THE COMMON BLOCKS
C
C TUPLEA
      NW = 10
      CALL BLKMOV(ATTNAM,SAVBUF(KQ1),NW)
      KQ1 = KQ1 + NW
C TUPLER
      NW = 13
      CALL BLKMOV(NAME,SAVBUF(KQ1),NW)
      KQ1 = KQ1 + NW
      IF(EQ(NAME,CNAME)) GO TO 210
      J = LOCREL(NAME)
      LRROW = LRROW + 1
  210 CONTINUE
C  RIMPTR
      CALL BLKMOV(IVAL,SAVBUF(KQ1),6)
      KQ1 = KQ1 + 6
C  VARDAT
      NUMVAR = SAVBUF(KQ1)
      NW = 1 + (NUMVAR*2)
      IF(NW.GT.11) NW = 11
      CALL BLKMOV(NUMVAR,SAVBUF(KQ1),NW)
      KQ1 = KQ1 + NW
C  KEYDAT
      NUMKEY = SAVBUF(KQ1)
      NW = 1 + (NUMKEY*6)
      IF(NW.GT.31) NW = 31
      CALL BLKMOV(NUMKEY,SAVBUF(KQ1),NW)
      KQ1 = KQ1 + NW
C  SRTCOM
      NREAD = SAVBUF(KQ1)
      NSORT = SAVBUF(KQ1+1)
      CALL BLKMOV(FIXLT,SAVBUF(KQ1+2),1)
      KQ1 = KQ1 + 3
C  RULCOM
      NW = 1
      RULCNT = SAVBUF(KQ1)
      IF(RULCNT.NE.0) NW = 18
      CALL BLKMOV(RULCNT,SAVBUF(KQ1),NW)
      KQ1 = KQ1 + NW
C  WHCOM
      NBOO = SAVBUF(KQ1)
      KSTRT = SAVBUF(KQ1+1)
      MAXTU = SAVBUF(KQ1+2)
      LIMTU = SAVBUF(KQ1+3)
      NEXPOS = SAVBUF(KQ1+4)
      NEXPOT = SAVBUF(KQ1+5)
      KQ1 = KQ1 + 6
      IF(NBOO.EQ.0) GO TO 230
      CALL BLKMOV(BOO,SAVBUF(KQ1),NBOO)
      KQ1 = KQ1 + NBOO
      CALL BLKMOV(KATTP,SAVBUF(KQ1),NBOO)
      KQ1 = KQ1 + NBOO
      CALL BLKMOV(KATTL,SAVBUF(KQ1),NBOO)
      KQ1 = KQ1 + NBOO
      CALL BLKMOV(KATTY,SAVBUF(KQ1),NBOO)
      KQ1 = KQ1 + NBOO
      CALL BLKMOV(KOMTYP,SAVBUF(KQ1),NBOO)
      KQ1 = KQ1 + NBOO
      CALL BLKMOV(KOMPOS,SAVBUF(KQ1),NBOO)
      KQ1 = KQ1 + NBOO
      CALL BLKMOV(KOMLEN,SAVBUF(KQ1),NBOO)
      KQ1 = KQ1 + NBOO
      CALL BLKMOV(KOMPOT,SAVBUF(KQ1),NBOO)
      KQ1 = KQ1 + NBOO
      CALL BLKMOV(WHRVAL,SAVBUF(KQ1),NEXPOS)
      KQ1 = KQ1 + NEXPOS
      CALL BLKMOV(WHRLEN,SAVBUF(KQ1),NEXPOT)
      KQ1 = KQ1 + NEXPOT
  230 CONTINUE
      INDCUR = INDPTR
      GO TO 999
  400 CONTINUE
      RMSTAT = 50
      GO TO 999
  500 CONTINUE
      RMSTAT = 70
  999 CONTINUE
      RETURN
      END
      SUBROUTINE RMRULE(SWITCH)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   SET THE RULE CHECKING FLAG
C
C  PARAMETERS:
C         SWITCH--0 MEANS NOCHECK, NOT 0 MEANS CHECK
      INCLUDE rin:FLAGS.BLK
      INTEGER SWITCH
      RUCK = .TRUE.
      IF(SWITCH.EQ.0) RUCK = .FALSE.
      RETURN
      END
      SUBROUTINE RMSAV(INDPTR)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   SAVE THE INTERNAL POINTERS FOR THE NAVIGATION OF
C             MULTIPLE PROGRAM INTERFACE PATHS.
C
C  PARAMETERS:
C     INPUT:  INDPTR--INDEX TO SAVE BLOCK (RANGE OF 0 TO 9)
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:KEYDAT.BLK
      INCLUDE rin:SRTCOM.BLK
      INCLUDE rin:RULCOM.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:VARDAT.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:PTRCOM.BLK
      INCLUDE rin:DCLAR4.BLK
	integer inited
	save inited
	data inited/0/
c      DATA NEXPOS /0/
c      DATA NEXPOT /0/
c      DATA NBLK /1/
c      DATA SAVBLK /20*0/
	if(inited.ne.0)goto 100
	inited=1
	nexpos=0
	nexpot=0
	nblk=1
	do 30 i=1,20
	savblk(i,1)=0
30	continue
100	continue
C
C  SEE IF THE INDEX IS WITHIN RANGE.
C
      IF((INDPTR.LT.0).OR.(INDPTR.GT.9)) GO TO 500
      IF(INDMAX.EQ.0) GO TO 300
      DO 200 I=1,INDMAX
      IF(INDNUM(I).EQ.INDPTR) GO TO 400
  200 CONTINUE
C
C  NUMBER HAS NOT BEEN SAVED.
C
  300 CONTINUE
      INDMAX = INDMAX + 1
      INDNUM(INDMAX) = INDPTR
  400 CONTINUE
C
C  SAVE ALL BLOCKS.
C
C  SET THE NUMBER OF WORDS TO SAVE THE POINTERS
C
C  TUPLEA 8 (10 ON 32 BIT MACHINES)
C  TUPLER 9 (13 ON 32 BIT MACHINES)
C  RIMPTR 6
C  VARDAT 1+2*NVAR
C  KEYDAT 1+5*NKEY (1+16*NKEY ON 32 BIT MACHINES)
C  SRTCOM 3
C  RULCOM 1 OR 18
C  WHCOM  6+8*NBOO (+2 IN NBOO NE 0)
C
C  TOTALS - 35 + 2*NVAR + 5*NKEY + 8*NBOO + .... (60/64 BIT MACHINES)
C           41 + 2*NVAR + 16*NKEY + 8*NBOO + ... (32 BIT MACHINES)
C
      NVAR = NUMVAR
      IF(NVAR.GT.5) NVAR = 5
      NKEY = NUMKEY
      IF(NKEY.GT.5) NKEY = 5
      NW = 41
      NW = NW + 2*NVAR
      NW = NW + 6*NKEY
      NW = NW + 8*NBOO
      IF(RULCNT.NE.0) NW = NW + 17
      IF(NBOO.NE.0) NW = NW + NEXPOS
      IF(NBOO.NE.0) NW = NW + NEXPOT
C
C  ESTABLISH THE SPACE IN THE POINTER BUFFER
C
      I = INDPTR + 1
      KQ1 = SAVBLK(1,I)
      IF(KQ1.EQ.0) KQ1 = NBLK
      IF(NW.EQ.SAVBLK(2,I)) GO TO 420
      NWO = SAVBLK(2,I)
      NADD = NW - NWO
      IF((NBLK+NADD).GT.1000) GO TO 600
      MOVE = NBLK - (KQ1+NWO)
      IF(NADD.GT.0) MOVE = -MOVE
      IF((KQ1+NWO).LT.NBLK)
     X     CALL BLKMOV(SAVBUF(KQ1+NW),SAVBUF(KQ1+NWO),MOVE)
C
C  UPDATE THE INDICES
C
      SAVBLK(1,I) = KQ1
      SAVBLK(2,I) = NW
      DO 410 K=1,10
      IF(SAVBLK(1,K).LE.KQ1) GO TO 410
      SAVBLK(1,K) = SAVBLK(1,K) + NADD
  410 CONTINUE
      NBLK = NBLK + NADD
  420 CONTINUE
C
C  THE THE POINTER VALUES TO THE BUFFER
C
C TUPLEA
      NW = 10
      CALL BLKMOV(SAVBUF(KQ1),ATTNAM,NW)
      KQ1 = KQ1 + NW
C TUPLER
      NW = 13
      CALL BLKMOV(SAVBUF(KQ1),NAME,NW)
      KQ1 = KQ1 + NW
C RIMPTR
      NW = 6
      CALL BLKMOV(SAVBUF(KQ1),IVAL,NW)
      KQ1 = KQ1 + NW
C VARDAT
      NW = 1 + NVAR*2
      CALL BLKMOV(SAVBUF(KQ1),NUMVAR,NW)
      KQ1 = KQ1 + NW
C KEYDAT
      NW = 1 + NKEY*6
      CALL BLKMOV(SAVBUF(KQ1),NUMKEY,NW)
      KQ1 = KQ1 + NW
C SRTCOM
      SAVBUF(KQ1) = NREAD
      SAVBUF(KQ1+1) = NSORT
      CALL BLKMOV(SAVBUF(KQ1+2),FIXLT,1)
      KQ1 = KQ1 + 3
C RULCOM
      NW = 1
      IF(RULCNT.NE.0) NW = 18
      CALL BLKMOV(SAVBUF(KQ1),RULCNT,NW)
      KQ1 = KQ1 + NW
C  WHCOM
      SAVBUF(KQ1  ) = NBOO
      SAVBUF(KQ1+1) = KSTRT
      SAVBUF(KQ1+2) = MAXTU
      SAVBUF(KQ1+3) = LIMTU
      SAVBUF(KQ1+4) = NEXPOS
      SAVBUF(KQ1+5) = NEXPOT
      KQ1 = KQ1 + 6
      IF(NBOO.EQ.0) GO TO 430
      CALL BLKMOV(SAVBUF(KQ1),BOO,NBOO)
      KQ1 = KQ1 + NBOO
      CALL BLKMOV(SAVBUF(KQ1),KATTP,NBOO)
      KQ1 = KQ1 + NBOO
      CALL BLKMOV(SAVBUF(KQ1),KATTL,NBOO)
      KQ1 = KQ1 + NBOO
      CALL BLKMOV(SAVBUF(KQ1),KATTY,NBOO)
      KQ1 = KQ1 + NBOO
      CALL BLKMOV(SAVBUF(KQ1),KOMTYP,NBOO)
      KQ1 = KQ1 + NBOO
      CALL BLKMOV(SAVBUF(KQ1),KOMPOS,NBOO)
      KQ1 = KQ1 + NBOO
      CALL BLKMOV(SAVBUF(KQ1),KOMLEN,NBOO)
      KQ1 = KQ1 + NBOO
      CALL BLKMOV(SAVBUF(KQ1),KOMPOT,NBOO)
      KQ1 = KQ1 + NBOO
      CALL BLKMOV(SAVBUF(KQ1),WHRVAL,NEXPOS)
      KQ1 = KQ1 + NEXPOS
      CALL BLKMOV(SAVBUF(KQ1),WHRLEN,NEXPOT)
      KQ1 = KQ1 + NEXPOT
  430 CONTINUE
      INDCUR = INDPTR
      RETURN
  500 CONTINUE
      RMSTAT = 70
      RETURN
  600 CONTINUE
      RMSTAT = 71
      RETURN
      END
      SUBROUTINE RMSORT(INDPTR,ANAMES,NUMATT,SORTOR)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  FORTRAN INTERFACE ROUTINE TO CALL SOCON TO SORT RIM DATA
C
C  PARAMETERS:
C              INDPTR--MULTIPLE RELATION POSITION POINTER
C              ANAMES--ARRAY OF ATTRIBUTES TO SORT ON
C              NUMATT--NUMBER OF ATTRIBUTES TO SORT ON
C              SORTOR--ARRAY OF ASCENDING OR DESCENDING INDICATORS
C                      LT 0 - DESCENDING
C                      GE 0 - ASCENDING
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:VARDAT.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:SRTCOM.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:PTRCOM.BLK
      INCLUDE rin:INCORE.BLK
      INCLUDE rin:FLAGS.BLK
C
      INTEGER INFIL
      INTEGER OUTFIL
      LOGICAL SAORD
      INTEGER SORTOR(*)
      INCLUDE rin:DCLAR1.BLK
C
      RMSTAT = 0
C         MAKE SURE DB IS DEFINED
C
      IF(DFLAG) GOTO 10
      RMSTAT = 16
      GOTO 999
C
   10 CONTINUE
C
C  RESTORE THE NEEDED BLOCKS
C
      CALL RMRES(INDPTR)
      IF(RMSTAT.NE.0) GO TO 999
C
C  GET THE ATTRIBUTE DATA
C
      NSOVAR = 0
      DO 800 N=1,NUMATT
      K = LOCATT(ANAMES(N),NAME)
      CALL ATTGET(K)
      IF(K.EQ.0) GO TO 200
      RMSTAT = 30
      GO TO 999
C
C  SET UP THE ATTRIBUTE SORT DATA
C
  200 CONTINUE
      SAORD = .TRUE.
      IF(SORTOR(N).LT.0) SAORD = .FALSE.
      NUMCOL = ATTCOL
C
C  CHECK FOR VARIABLE LENGTH - SORTING ON VARIABLE LENGTH
C  ATTRIBUTES IS CURRENTLY NOT ALLOWED
C
      IF(ATTWDS.NE.0) GO TO 300
      RMSTAT = 80
      GO TO 999
  300 CONTINUE
C
C  IF TEXT ATTRIBUTE DETERMINE THE NUMBER OF WORDS TO SORT ON - THIS
C  IS BASED ON THE NUMBER OF CHARACTERS (CURRENTLY 20) AND THE WORD
C  SIZE.
C     32 BIT WORDS - 20 CHARACTERS (5 WORDS)
C     60 BIT WORDS - 20 CHARACTERS (2 WORDS)
C     64 BIT WORDS - 16 CHARACTERS (2 WORDS)
C
      LSL = 1
      IF(ATTYPE.NE.KZTEXT) GO TO 400
C
C  TEXT - DETERMINE SORT WORDS
C
      LSL = 20/CHPWD
      IF(ATTWDS.LT.LSL) LSL = ATTWDS
C
C  LOAD THE SORT ARRAYS
C
  400 CONTINUE
      DO 600 K=1,LSL
      NUMCOL = NUMCOL + 1
      NSOVAR = NSOVAR + 1
C
C  CHECK ON THE NUMBER OF SORT WORDS - CURRENTLY 10
C  THIS MAY WANT TO BE UPPER FOR THE SMALLER MACHINES
C
      IF(NSOVAR.LE.NSORTW) GO TO 500
      RMSTAT = 81
      GO TO 999
C
C  LOAD ARRAYS
C
  500 CONTINUE
      SORTYP(NSOVAR) = SAORD
      VARPOS(NSOVAR) = NUMCOL
      IF(ATTYPE.EQ.KZINT) L=1
      IF(ATTYPE.EQ.KZREAL) L=2
      IF(ATTYPE.EQ.KZDOUB) L=3
      IF(ATTYPE.EQ.KZTEXT) L=4
      IF(ATTYPE.EQ.KZIVEC) L=1
      IF(ATTYPE.EQ.KZRVEC) L=2
      IF(ATTYPE.EQ.KZDVEC) L=3
      IF(ATTYPE.EQ.KZIMAT) L=1
      IF(ATTYPE.EQ.KZRMAT) L=2
      IF(ATTYPE.EQ.KZDMAT) L=3
      VARTYP(NSOVAR) = L
  600 CONTINUE
  800 CONTINUE
C
C  DO THE SORT.
C  OPEN THE INPUT SORT FILE
C
      INFIL = 20
	open(infil,file='sortfil.dat',access='sequential',
     1  form='unformatted',status='unknown',iostat=ios)
	if(ios.ne.0)call warn(16)
	if(ios.ne.0)return
      REWIND INFIL
C
C  SET UP TUPLE LIMITS - SAVE USER SPECIFIED LIMIT
C
      LIMTUS = LIMTU
      LIMTU = ALL9S
C
C  WRITE THE COMPLETE TUPLE AND CID ON THE SORT FILE
C
C  CHECK FOR VARIABLE LENGTH TUPLES IN THE RELATION
C
      FIXLT = .TRUE.
      IF(NUMVAR.GT.0) FIXLT = .FALSE.
C
C  INITIALIZE THE REMAINING VARIABLES
C
      LTUMAX = 0
      LTUMIN = ALL9S
      NSORT = 0
      LTUPLE = 0
      IF(FIXLT) LTUPLE = NCOL + 1
C
C  READ IN THE TUPLES AND WRITE THE SORT FILE
C
 1200 CONTINUE
      CALL RMLOOK(IP,1,1,LEN)
      IF(RMSTAT.NE.0) GO TO 1400
      LENX = LEN + 1
      NSORT = NSORT + 1
      IP = IP - 1
      IF(FIXLT) GO TO 1300
C
C  VARIBLE LENGTH TUPLE
C
      LTUPLE = LTUPLE + LENX
      IF(LENX.GT.LTUMAX) LTUMAX = LENX
      IF(LENX.LT.LTUMIN) LTUMIN = LENX
      WRITE(INFIL) LENX,CID,(BUFFER(IP+K),K=1,LEN)
      GO TO 1200
C
C  FIXED LENGTH TUPLES
C
 1300 CONTINUE
      WRITE(INFIL) CID,(BUFFER(IP+K),K=1,LEN)
      GO TO 1200
C
C  CHECK THAT SOME TUPLES WERE WRITTIN ON INFIL
C  RESET THE TUPLE LIMIT
C
 1400 CONTINUE
      RMSTAT = 0
      LIMTU = LIMTUS
      IF(NSORT.GT.0) GO TO 1420
      RMSTAT = -1
      GO TO 998
C
C  OPEN THE OUTPUT FILES
C
 1420 CONTINUE
      OUTFIL = 20
      IF(INDPTR.EQ.0) GO TO 1430
      OUTFIL = INFIL + INDPTR
 1430 CONTINUE
C
C  CLEAR OUT ANY PAGE DATA LEFT IN BUFFER
C
      CALL BLKCLN
C
C  FIXUP THE LENGTHS FOR VARIABLE LENGTH STUFF
C
      IF(FIXLT) GO TO 1440
      LTUPLE = LTUPLE + NSORT
      LTUMAX = LTUMAX + 1
      LTUMIN = LTUMIN + 1
C
C  CALL SOCON TO DO THE ACTUAL SORT
C
 1440 CONTINUE
      IERR = 0
      CALL SWCON(BUFFER,LIMIT,INFIL,OUTFIL,IERR)
      IF(IERR.EQ.0) GO TO 1450
      RMSTAT = 89
      GO TO 998
C
 1450 CONTINUE
C
C  INITIALIZE THE BUFFER AND RESAVE THE POINTERS
C
      NS = 1
      CALL RMGTSO(IP,10,-1,LEN,INDPTR)
      CALL RMSAV(INDCUR)
C
  998 CONTINUE
      IF(INDPTR.EQ.0) GO TO 999
C
C  CLOSE THE SORT INPUT FILE
C
      CLOSE(UNIT=INFIL,STATUS='DELETE')
  999 CONTINUE
      RETURN
      END
      SUBROUTINE RMSTRT
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   INITIALIZE ALL NEEDED VARIABLES AND ARRAYS
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:RELTBL.BLK
      INCLUDE rin:ATTBLE.BLK
      INCLUDE rin:INCORE.BLK
      INCLUDE rin:F1COM.BLK
      INCLUDE rin:F2COM.BLK
      INCLUDE rin:F3COM.BLK
      INCLUDE rin:RULCOM.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:SRTCOM.BLK
C
C  CALL THE RMCONS ROUTINE TO INITIALIZE THE HOLLERITH CONSTANTS
C  THIS CALL IS MADE ONLY ONCE PER EXECUTION
C
      DATA KALTST /0/
      IF(KALTST.EQ.1) GO TO 100
      CALL RMCONS
      KALTST = 1
  100 CONTINUE
C
C  SET FLAGS AND VARIABLES.
C
C  /MISC/
      ALL9S = 999999999
      CHPWD = 4
      MAXCOL = 1021
C  /FLAGS/
      DFLAG = .FALSE.
      OWNER = NONE
      IFMOD = .FALSE.
      TOL = 0.
      PCENT = .FALSE.
      RUCK = .TRUE.
C  /RELTBL/
      CNAME = BLANK
      LRROW = 0
      NRROW = 74
      RELMOD = 0
      RPBUF = 73
C  /ATTBLE/
      CANAME = BLANK
      CRNAME = BLANK
      CRSTRT = 0
      CROW = 0
      LROW = 0
      NAROW = 227
      ATTMOD = 0
      APBUF = 113
C  /INCORE/
      CALL ZEROIT(BLOCKS(1,1),60)
      NEXT = 1
      LIMIT = 4608
      NUMBL = 0
C  /F1COM/
      FILE1 = 31
      LENBF1 = 1024
      LF1REC = 0
      CAREC = 0
      CRREC = 0
C  /F2COM/
      FILE2 = 32
      LENBF2 = 1024
      DO 200 I=1,3
      CURBLK(I) = 0
      MODFLG(I) = 0
  200 CONTINUE
C  /F3COM/
      FILE3 = 33
      LENBF3 = 126
      MAXIC = 20
C  /RIMPTR/
      IVAL = 0
      CID = 0
      NID = 0
      NS = 0
      MID = 0
      INDCUR = NULL
      INDMAX = 0
C  /SRTCOM/
      NSORTW = 10
      FIXLT = .TRUE.
      NSORT = 0
      NREAD = 0
C  /RULCOM/
      RIMRRC = K8RRC
      RIMRDT = K8RDT
      RULCNT = 0
      RETURN
      END
      SUBROUTINE RMTIME(IT)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   RETURN THE CURRENT TIME
C
C  PARAMETERS:
C         IT------THE CURRENT TIME IN HH.MM.SS FORMAT
C
      INCLUDE rin:MISC.BLK
      REAL*8 IT
c      character*24 ctime
c      external ctime
c      character*24 ctm
c      integer*4 ltm
c      character*1 ctm1(24),rt1(8)
c	equivalence(ctm1(1),ctm)
c	equivalence(ctm1(12),rt1(1))
c        character*8 rtt
c	equivalence(rtt,rt1(1))
	character*8 rt
	real*8 irt
	equivalence(irt,rt)
        integer itarr(3),ihr,imn,isc
	equivalence (ihr,itarr(1)),(imn,itarr(2)),(isc,itarr(3))
       call time(krt)
	ihr=krt/3600
	krt=krt-(ihr*3600)
	imn=krt/60
	krt=krt-(imn*60)
	isc=krt
       write(rt,1000)ihr,imn,isc
1000   format(i2.2,'.',i2.2,'.',i2.2)
       it=irt
c      ltm=TIME()
c      ctm=ctime(ltm)
c	rt=rtt
c       it=irt
cc      CALL PUTT(IT,3,1H.)
cc      CALL PUTT(IT,6,1H.)
      RETURN
      END
      SUBROUTINE RMTOL(VAL,PERC)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  SET THE TOLERANCE VARIABLES IN THE FORTRAN INTERFACE
C
C  PARAMETERS: VAL----TOLERANCE VALUE - ABSOLUTE VALUE OR PERCENT
C              PERC---PERC = 0 -- VAL IS ABSOLUTE VALUE
C                     PERC = 1 -- VAL IS PERCENT
C
      INCLUDE rin:FLAGS.BLK
      INTEGER PERC
C
      TOL = VAL
      PCENT = .FALSE.
      IF(PERC.EQ.0) GO TO 999
C
C  PERCENTAGE
C
      TOL = VAL/100.
      PCENT = .TRUE.
  999 CONTINUE
      RETURN
      END
      SUBROUTINE RMUSER(ID)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   SET THE CURRENT USERID TO THE USER SUPPLIED ID
C
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:MISC.BLK
      INTEGER ID(*)
C
C  SET THE USERID TO ID.
C
      USERID = BLANK
      CALL STRMOV(ID,1,8,USERID,1)
      RETURN
      END
      SUBROUTINE RMVARC(CTYP,TUPVAL)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE: THIS ROUTINE CHANGES THE VARIABLE LENGTH ATTRIBUTE
C           TUPLE HEADERS FROM INTERNAL TO USER REPRESENTATION
C           OR VISA VERSA.
C
C                             USER                    INTERNAL
C           TYPE        WORD1       WORD2       WORD1       WORD2
C           ----------  ----------  ----------  ----------  ----------
C           TEXT        CHARACTERS  0           WORDS       CHARACTERS
C           INT         ITEMS       0           WORDS       1
C           REAL        ITEMS       0           WORDS       1
C           DOUBLE      ITEMS       0           WORDS       1
C           VECTORS     ITEMS       0           WORDS       1
C           MATRICES    ROWS        COLS        WORDS       ROWS
C
C  PARAMETERS:
C           CTYP-----CONVERSION TYPE - -1 = INTERNAL TO USER
C                                      +1 = USER TO INTERNAL
C           TUPVAL---ARRAY CONTAINING THE TUPLE VALUES
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:VARDAT.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:MISC.BLK
C
      INTEGER CTYP
      INTEGER TUPVAL(*)
C
C  IF THE NUMBER OF VARIABLE ATTRIBUTES EXCEEDS 5 WE HAVE TO USE
C  ATTGET ETC TO DO THE CONVERSION ----
C
      LOOP = NUMVAR
      IF(NUMVAR.LE.5) GO TO 100
C
C  MORE THAN 5 VARIABLE LENGTH ATTRIBUTES
C
      I = LOCATT(BLANK,NAME)
      LOOP = NATT
C
C  GET THE VALUES FOR EACH VARIABLE LENGTH ATTRIBUTE
C
  100 CONTINUE
      DO 500 K=1,LOOP
      IF(NUMVAR.LE.5) GO TO 200
      CALL ATTGET(ISTATX)
      IF(ISTATX.NE.0) GO TO 999
      IF(ATTWDS.NE.0) GO TO 500
      IP = TUPVAL(ATTCOL)
      ITYPE = ATTYPE
      GO TO 300
  200 CONTINUE
      IP = TUPVAL(POSVAR(1,K))
      ITYPE = POSVAR(2,K)
  300 CONTINUE
      IF((IP.LT.1).OR.(IP.GT.MAXCOL)) GO TO 998
      IW1 = TUPVAL(IP)
      IW2 = TUPVAL(IP+1)
      IF(CTYP.LT.0) GO TO 400
C
C  USER TO INTERNAL - RMPUT,RMLOAD
C
      IF(ITYPE.EQ.KZINT ) TUPVAL(IP) = IW1
      IF(ITYPE.EQ.KZREAL) TUPVAL(IP) = IW1
      IF(ITYPE.EQ.KZDOUB) TUPVAL(IP) = 2*IW1
      IF(ITYPE.EQ.KZTEXT) TUPVAL(IP) = (IW1-1)/CHPWD + 1
      IF(ITYPE.EQ.KZIVEC) TUPVAL(IP) = IW1
      IF(ITYPE.EQ.KZRVEC) TUPVAL(IP) = IW1
      IF(ITYPE.EQ.KZDVEC) TUPVAL(IP) = 2*IW1
      IF(ITYPE.EQ.KZIMAT) TUPVAL(IP) = IW1*IW2
      IF(ITYPE.EQ.KZRMAT) TUPVAL(IP) = IW1*IW2
      IF(ITYPE.EQ.KZDMAT) TUPVAL(IP) = 2*IW1*IW2
      TUPVAL(IP+1) = 1
      IF(ITYPE.EQ.KZTEXT) TUPVAL(IP+1) = IW1
      IF(ITYPE.EQ.KZIMAT) TUPVAL(IP+1) = IW1
      IF(ITYPE.EQ.KZRMAT) TUPVAL(IP+1) = IW1
      IF(ITYPE.EQ.KZDMAT) TUPVAL(IP+1) = IW1
      IF((TUPVAL(IP).LT.1).OR.(TUPVAL(IP).GT.MAXCOL)) GO TO 998
      GO TO 500
C
C  INTERNAL TO USER - RMGET
C
  400 CONTINUE
      IF(ITYPE.EQ.KZINT ) TUPVAL(IP) = IW1
      IF(ITYPE.EQ.KZREAL) TUPVAL(IP) = IW1
      IF(ITYPE.EQ.KZDOUB) TUPVAL(IP) = IW1/2
      IF(ITYPE.EQ.KZTEXT) TUPVAL(IP) = IW2
      IF(ITYPE.EQ.KZIVEC) TUPVAL(IP) = IW1
      IF(ITYPE.EQ.KZRVEC) TUPVAL(IP) = IW1
      IF(ITYPE.EQ.KZDVEC) TUPVAL(IP) = IW1/2
      IF(ITYPE.EQ.KZIMAT) TUPVAL(IP) = IW2
      IF(ITYPE.EQ.KZRMAT) TUPVAL(IP) = IW2
      IF(ITYPE.EQ.KZDMAT) TUPVAL(IP) = IW2
      TUPVAL(IP+1) = 0
      IF(ITYPE.EQ.KZIMAT) TUPVAL(IP+1) = IW1/IW2
      IF(ITYPE.EQ.KZRMAT) TUPVAL(IP+1) = IW1/IW2
      IF(ITYPE.EQ.KZDMAT) TUPVAL(IP+1) = (IW1/2)/IW2
  500 CONTINUE
      GO TO 999
C
  998 RMSTAT = 100
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE RMWHER(INDPTR,ANAMES,OPERS,VALS,NUMVAL,NXTBOO,NUMBOO)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  PROCESS A RIM WHERE CLAUSE IN THE FORTRAN INTERFACE
C
C  PARAMETERS:
C        INDPTR---MULTIPLE RELATION POSITION INDICATOR
C        ANAMES---ARRAY OF ATTRIBUTE NAMES
C        OPERS----ARRAY OF OPERATORS
C        VALS-----ARRAY OF CONDITION VALUES
C                   FIXED LENGTH - VSET1,VSET2,.....
C                   VARIABLE LENGTH ------
C                     TEXT  (NCHAR1)(0)VSET1,(NCHAR2)(0)VSET2,....
C                     INT,REAL,DOUB, AND VECTORS (ITEMS1)(0)VSET1,...
C                     MATRICES (ROWS1)(COLS1)VSET1,(ROWS2)(COLS2)VSET2,.
C        NUMVAL---NUMBER OF VALUE SETS (VSETS) IN VALS
C        NXTBOO---ARRAY OF "AND" "OR" OPERATORS
C        NUMBOO---NUMBER OF WHERE CONDITIONS (ROW DIMENSION
C                 OF ALL ARRAYS)
C
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:PTRCOM.BLK
C
      LOGICAL IFVAR
      LOGICAL IFLIM
      LOGICAL IFTUP
      INTEGER OPERS(*)
      INTEGER VALS(NUMBOO,*)
      INTEGER NUMVAL(*)
      INTEGER NXTBOO(*)
      INTEGER IDUM(2)
      INCLUDE rin:DCLAR1.BLK
C
C
C  MAKE SURE DB IS OPEN
C
      IF(DFLAG) GO TO 10
      RMSTAT = 16
      GO TO 9999
C
   10 CONTINUE
C  CHECK THE NUMBER OF OPERATORS
C
      IF(NUMBOO.LE.10) GO TO 100
      RMSTAT = 40
      GO TO 9999
C
C  RESTORE THE REQUIRED BLOCKS
C
  100 CONTINUE
      RMSTAT = 0
      CALL RMRES(INDPTR)
      IF(RMSTAT.NE.0) GO TO 9999
C
C  INITIALIZE
C
      NS = 0
      NTUPC = 0
      KMM = 0
      KSTRT = 0
      MAXTU = 0
      LIMTU = ALL9S
C
C  BREAK UP EACH CONDITION.
C
      DO 600 I=1,10
      KOMPOS(I) = 0
      KOMPOT(I) = 0
      KOMLEN(I) = 0
      KATTP(I) = 0
      KATTL(I) = 0
      KATTY(I) = 0
  600 CONTINUE
      NBOO = 1
      BOO(1) = K4AND
      NEXPOT = 1
      NEXPOS = 1
      DO 2000 K=1,NUMBOO
C
C  GET THE ATTRIBUTE.
C
      IFLIM = .FALSE.
      IF(ANAMES(K).NE.K8LIM) GO TO 1150
C
C     LIMIT KEYWORD
C
      IF(OPERS(K).EQ.K4EQ) GO TO 700
      RMSTAT = 41
      GO TO 9999
  700 CONTINUE
      LIMTU = VALS(K,1)
      IF((LIMTU.GT.0).AND.(LIMTU.LT.ALL9S)) GO TO 800
      RMSTAT = 41
      GO TO 9999
  800 CONTINUE
      NBOO = NBOO - 1
      IFLIM = .TRUE.
      GO TO 1800
 1150 CONTINUE
      IFTUP = .FALSE.
      IF(ANAMES(K).EQ.K8ROWS) IFTUP = .TRUE.
      IF(.NOT.IFTUP) GO TO 1190
C
C  ROW WHERE CLAUSE - CHECK TYPE AND GET MAXIMUM ROW NUMBER
C
      NTUPC = NTUPC + 1
      MAXTUN = VALS(K,1)
      IF(MAXTUN.GT.MAXTU) MAXTU = MAXTUN
      KOMPAR = OPERS(K)
      KOMTYP(NBOO) = LOCBOO(KOMPAR)
      IF(KOMTYP(NBOO).NE.0) GO TO 1170
C
C  UNRECOGNIZED BOOLEAN COMPARISION.
C
      RMSTAT = 42
      GO TO 9999
 1170 CONTINUE
      IF((KOMTYP(NBOO).GE.3).AND.(KOMTYP(NBOO).LE.5)) MAXTU = NTUPLE
      GO TO 1500
 1190 CONTINUE
      I = LOCATT(ANAMES(K),NAME)
      IF(I.NE.0) GO TO 1200
      CALL ATTGET(I)
      IF(I.EQ.0) GO TO 1300
C
C  UNRECOGNIZED ATTRIBUTE.
C
 1200 CONTINUE
      RMSTAT = 30
      GO TO 9999
 1300 CONTINUE
      KATTP(NBOO) = ATTCOL
      KATTL(NBOO) = ATTLEN
      CALL TYPER(ATTYPE,MATVEC,KATTY(NBOO))
C
C  DETERMINE THE TYPE OF BOOLEAN EXPRESSION.
C
      KOMPAR = OPERS(K)
      KOMTYP(NBOO) = LOCBOO(KOMPAR)
      IF(KOMTYP(NBOO).NE.0) GO TO 1500
C
C  UNRECOGNIZED BOOLEAN COMPARISION.
C
      RMSTAT = 42
      GO TO 9999
 1500 CONTINUE
C
C  CHECK FOR FAILS OR EXISTS AND EQS ONLY ON TEXT ATTRIBUTES
C
      IF(KOMTYP(NBOO).LE.1) GO TO 1800
      IF(KOMTYP(NBOO).GE.10) GO TO 1600
      IF(KOMTYP(NBOO).NE.9) GO TO 1510
      IF(ATTYPE.EQ.KZTEXT) GO TO 1510
      RMSTAT = 43
      GO TO 9999
C
C     CHECK FOR "WHERE XXX EQ MIN OR MAX"
C
 1510 CONTINUE
      ITEMP = VALS(K,1)
      KMM = 0
      IF((ITEMP.EQ.K4MIN).OR.(ITEMP.EQ.K4MAX)) KMM = ITEMP
      IF(KMM.EQ.0) GO TO 1550
C
C  WE HAVE A MIN/MAX SPECIFICATION - CHECK SYNTAX
C
      IF((KOMTYP(NBOO).LT.2).OR.(KOMTYP(NBOO).GT.7)) GO TO 1550
      IF(ATTYPE.EQ.KZTEXT) GO TO 1550
      IF(ATTYPE.EQ.KZINT ) GO TO 1530
      IF(ATTYPE.EQ.KZREAL) GO TO 1530
      IF(ATTYPE.EQ.KZDOUB) GO TO 1530
C
C  ILLEGAL ATTRIBUTE FOR USE WITH MIN/MAX.
C
      RMSTAT = 44
      GO TO 9999
 1530 CONTINUE
      IF(ATTLEN.EQ.1) GO TO 1540
      IF((ATTLEN.EQ.2).AND.(ATTYPE.EQ.KZDOUB)) GO TO 1540
C
C  ILLEGAL USE OF MULTI-WORD ATTRIBUTE WITH MIN/MAX.
C
      RMSTAT = 44
      GO TO 9999
 1540 CONTINUE
C
C     SET NBOO AND LIMTU TO FOOL RMLOOK FOR MINMAX
C
      MNBOO = NBOO
      MLIMTU = LIMTU
      NBOO = 0
      LIMTU = ALL9S
      KOMPOS(MNBOO) = NEXPOS
      CALL MINMAX(WHRVAL(NEXPOS),KMM)
      IF(RMSTAT.NE.0) GO TO 9999
      NEXPOS = NEXPOS + ATTLEN
      KOMPOT(MNBOO) = NEXPOT
      WHRLEN(NEXPOT) = ATTLEN
      NEXPOT = NEXPOT + 1
      LIMTU = MLIMTU
      NBOO = MNBOO
C
C  RESET RELATION POINTERS
C
      I = LOCREL(NAME)
      IF(I.EQ.0) GO TO 1545
      RMSTAT = 20
      GO TO 9999
 1545 CONTINUE
      KOMLEN(NBOO) = 1
      IF(K.EQ.NUMBOO) GO TO 2100
      IF((NXTBOO(K).NE.K4AND).AND.(NXTBOO(K).NE.K4OR)) GO TO 8000
      NBOO = NBOO + 1
      BOO(NBOO) = NXTBOO(K)
      GO TO 2000
 1550 CONTINUE
C
C  VALUE COMPARISON. MAKE SURE THE VALUE LOOKS GOOD.
C
      IFVAR = .FALSE.
      CALL ITOH(NR,NW,KATTL(NBOO))
      IF((.NOT.IFTUP).AND.(NW.EQ.0)) IFVAR = .TRUE.
      IF(KATTY(NBOO).EQ.0) NW = 1
      ITYPE = ATTYPE
      IF(KATTY(NBOO).EQ.0) ITYPE = KZINT
      KOMPOS(NBOO) = NEXPOS
      KOMPOT(NBOO) = NEXPOT
C
C  TRANSFER VALUES FROM VALS TO WHRVAL
C
      II = 0
      LOOP = NUMVAL(K)
      IF(LOOP.EQ.1) GO TO 1551
      IF(KOMTYP(NBOO).EQ.2) GO TO 1551
      IF(KOMTYP(NBOO).EQ.3) GO TO 1551
      IF(KOMTYP(NBOO).EQ.9) GO TO 1551
      RMSTAT = 47
      GO TO 9999
 1551 CONTINUE
      DO 1560 KK=1,LOOP
      IF(.NOT.IFVAR) GO TO 1552
C
C  VARIABLE LENGTH TUPLES
C
      NW = 0
      II = II + 1
      IF(ITYPE.EQ.KZINT ) NW = VALS(K,II)
      IF(ITYPE.EQ.KZREAL) NW = VALS(K,II)
      IF(ITYPE.EQ.KZDOUB) NW = 2*VALS(K,II)
      IF(ITYPE.EQ.KZTEXT) NW = (VALS(K,II)-1)/CHPWD + 1
      IF(ITYPE.EQ.KZIVEC) NW = VALS(K,II)
      IF(ITYPE.EQ.KZRVEC) NW = VALS(K,II)
      IF(ITYPE.EQ.KZDVEC) NW = 2*VALS(K,II)
      IF(ITYPE.EQ.KZIMAT) NW = VALS(K,II)*VALS(K,II+1)
      IF(ITYPE.EQ.KZRMAT) NW = VALS(K,II)*VALS(K,II+1)
      IF(ITYPE.EQ.KZDMAT) NW = 2*VALS(K,II)*VALS(K,II+1)
      NR = 0
      IF(ITYPE.EQ.KZTEXT) NR = VALS(K,II)
      IF(ITYPE.EQ.KZIMAT) NR = VALS(K,II)
      IF(ITYPE.EQ.KZRMAT) NR = VALS(K,II)
      IF(ITYPE.EQ.KZDMAT) NR = VALS(K,II)
      II = II + 1
C
C  LOAD RTHE ARRAYS
C
 1552 CONTINUE
      DO 1554 I=1,NW
      II = II + 1
      WHRVAL(NEXPOS) = VALS(K,II)
      IF(.NOT.IFTUP) GO TO 1553
      IF(WHRVAL(NEXPOS).GT.MAXTU) MAXTU = WHRVAL(NEXPOS)
      IF((WHRVAL(NEXPOS).GT.0).AND.(WHRVAL(NEXPOS).LE.MAXCOL))
     X       GO TO 1553
      RMSTAT = 48
      GO TO 9999
 1553 CONTINUE
      NEXPOS = NEXPOS + 1
 1554 CONTINUE
      IF(KOMTYP(NBOO).NE.9) GO TO 1558
C
C  EQS - GET THE NUMBER OF CHARACTERS
C
      IK = II + 1
      DO 1556 I=1,NW
      IK = IK - 1
      IF(VALS(K,IK).EQ.IBLANK) GO TO 1556
      KPO = NSCAN(VALS(K,IK),CHPWD,-CHPWD,BLANK,1,1)
      NR = (NW-I)*CHPWD + KPO
      GO TO 1558
 1556 CONTINUE
 1558 CONTINUE
      CALL HTOI(NR,NW,WHRLEN(NEXPOT))
      NEXPOT = NEXPOT + 1
 1560 CONTINUE
      IF(K.EQ.NUMBOO) GO TO 2000
      KOMLEN(NBOO) = NUMVAL(K)
      IF((NXTBOO(K).NE.K4AND).AND.(NXTBOO(K).NE.K4OR)) GO TO 8000
      NBOO = NBOO + 1
      BOO(NBOO) = NXTBOO(K)
      GO TO 2000
C
C  ATTRIBUTE COMPARISON. CHECK FOR LEGAL ATTRIBUTE
C
 1600 CONTINUE
C
C  MESSY CODE SO THAT WE CAN MOVE 8 CHARACTERS ON ANY MACHINE
C
      IDUM(1) = VALS(K,1)
      IF(CHPWD.LT.8) IDUM(2) = VALS(K,2)
      ANAME = BLANK
      CALL STRMOV(IDUM(1),1,8,ANAME,1)
      I = LOCATT(ANAME,NAME)
      IF(I.NE.0) GO TO 1200
      CALL ATTGET(I)
      KOMPOS(NBOO) = ATTCOL
      IF((ATTLEN.EQ.KATTL(NBOO)).AND.(ATTYPE.EQ.KATTY(NBOO)))
     X     GO TO 1800
      RMSTAT = 46
      GO TO 9999
 1800 CONTINUE
C
C  LOOK FOR THE NEXT BOOLEAN JOIN.
C
      IF(K.EQ.NUMBOO) GO TO 2000
      IF((NXTBOO(K).NE.K4AND).AND.(NXTBOO(K).NE.K4OR)) GO TO 8000
      IF(.NOT.IFLIM) KOMLEN(NBOO) = 1
C
C  GET NEXT OPERATION
C
      NBOO = NBOO + 1
      BOO(NBOO) = NXTBOO(K)
 2000 CONTINUE
C
C  GET THE LENGTH OF THE LIST IN THE LAST CONDITION
C
      IF(IFLIM) GO TO 2100
      KOMLEN(NBOO) = NUMVAL(NUMBOO)
      IF(KOMTYP(NBOO).LE.1) KOMLEN(NBOO) = 1
      IF(KOMLEN(NBOO).LE.1) GO TO 2100
C
C  WE HAVE A LIST - VALID ONLY FOR EQ AND NE
C
      IF(KOMTYP(NBOO).EQ.2) GO TO 2005
      IF(KOMTYP(NBOO).EQ.3) GO TO 2005
      IF(KOMTYP(NBOO).EQ.9) GO TO 2005
      RMSTAT = 47
      GO TO 9999
C
C  ROW WHERE CLAUSE - CHECK TYPE AND GET MAXIMUM ROW NUMBER
C
 2005 CONTINUE
      IF(.NOT.IFTUP) GO TO 2100
      LOOP = KOMLEN(NBOO)
      DO 2010 I=2,LOOP
      MAXTUN = VALS(NUMBOO,I)
      IF(MAXTUN.GT.MAXTU) MAXTU = MAXTUN
 2010 CONTINUE
C
C  CHECK FOR KEY PROCESSING
C
 2100 CONTINUE
      BOO(1) = K4AND
      IF(NTUPC.NE.NBOO) MAXTU = 0
      IF(BOO(NBOO).NE.K4AND) GO TO 9998
      IF(KOMTYP(NBOO).NE.2) GO TO 9998
      IF(IFTUP) GO TO 9998
      IF(KOMLEN(NBOO).NE.1) GO TO 9998
C
C  USE KEY PROCESSING.
C
      KSTRT = ATTKEY
      IF(KSTRT.NE.0) NS = 2
      GO TO 9998
C
C  UNABLE TO PROCESS THE WHERE CLAUSE.
C
 8000 CONTINUE
      RMSTAT = 45
      GO TO 9999
C
C  EXIT.
C
 9998 CONTINUE
      IF(MAXTU.EQ.0) MAXTU = ALL9S
      CALL WHETOL
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE RMZIP
      RETURN
      END
      SUBROUTINE RNAMEA(IATT)
      INCLUDE rin:TEXT.BLK
C
C     IATT....=2 IF COMMAND IS "RENAME ATTRIBUTE....."
C             =1 IF KEYWORD ATTRIBUTE IS OMITTED
C
C     THIS ROUTINE PROCESSES RENAME ATTRIBUTE COMMAND
C     STEP 1. CHECK SYNTAX
C     STEP 2. SEE IF NEWATT ALREADY EXISTS.
C             IF SO, CHECK THAT IT IS NOT IN SAME RELATION WITH
C             OLDATT AND THAT TYPE AND LENGTH AGREE WITH OLDATT.
C     STEP 3. LOOP ON ATTGET FOR ALL RELATIONS
C               CHECK PERMISSION.
C               RENAME
C               COUNT RENAMES
C     STEP 4. RENAME ATTRIBUTES IN RULES RELATION
C             ATTRIBUTE IS CHANGING NAMES IN ALL RELATIONS.
C             LOOP THRU CSCRTBL AND CHANGE.
C
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:DCLAR1.BLK
      INCLUDE rin:DCLAR6.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:RIMPTR.BLK
      LOGICAL CHANGE
      LOGICAL NE,EQ,EQKEYW
      INTEGER STATUS
   10 CONTINUE
C
C     CHECK SYNTAX
C
      ITEMS = LXITEM(DUM)
      IF(.NOT.EQKEYW(IATT+2,KWTO,2)) GO TO 8100
      IF((ITEMS.GT.3+IATT).AND.(.NOT.EQKEYW(4+IATT,KWIN,2))) GO TO 8100
      IF((ITEMS.NE.3+IATT).AND.(ITEMS.NE.5+IATT)) GO TO 8100
      ANAME1 = BLANK
      ANAME2 = BLANK
      CALL LXSREC(1+IATT,1,8,ANAME1,1)
      CALL LXSREC(3+IATT,1,8,ANAME2,1)
      IF((LXLENC(3+IATT).GE.1).AND.(LXLENC(3+IATT).LE.8)) GO TO 20
C
C     WARNING - NEW ATTRIBUTE NAME IS LONGER THAN 8 CHARS.
C
      CALL WARN(7,KWATTR,K4E)
      GO TO 9999
   20 CONTINUE
C
C     SCAN FOR FROM OR IN
C
      RNAME1 = BLANK
      IFLAG = 0
      J = LFIND(1,ITEMS,KWIN,2)
      IF(J.EQ.0)J = LFIND(1,ITEMS,KWFROM,4)
      IF(J.EQ.0) GO TO 100
C
C     SPECIFIED RELATION
C
      IFLAG = 1
      CALL LXSREC(J+1,1,8,RNAME1,1)
C
C  CHECK THAT RELATION EXISTS
C
      I = LOCREL(RNAME1)
      IF(I.EQ.0) GO TO 100
      CALL WARN(1,RNAME1,BLANK)
      GO TO 9999
  100 CONTINUE
C
C     SEE IF ANAME1 EXISTS
C
      I = LOCATT(ANAME1,RNAME1)
      IF(I.NE.0) GO TO 8200
C
C     SEE IF ANAME2 ALREADY EXISTS
C
      I = LOCATT(ANAME2,BLANK )
      IF(I.NE.0) GO TO 200
C
C     EXISTS - CHECK TYPE AND LENGTH
C
      CALL ATTGET(STATUS)
      ILEN = ATTLEN
      ITYPE = ATTYPE
      I = LOCATT(ANAME1,RNAME1)
      CALL ATTGET(STATUS)
      IF(ILEN.NE.ATTLEN) GO TO 8300
      IF(ITYPE.NE.ATTYPE) GO TO 8300
C
C     NOW CHAECK THAT OLD AND NEW DON'T COHABITATE IN SAME RELATION
C
      NUM = 0
  120 CONTINUE
      NUM = NUM + 1
      I = LOCATT(ANAME1,RNAME1)
      DO 130 II=1,NUM
      CALL ATTGET(STATUS)
      IF(STATUS.NE.0) GO TO 200
  130 CONTINUE
      I = LOCATT(ANAME2,RELNAM)
      IF(I.NE.0) GO TO 120
	if(nout.eq.6)goto 3140
      WRITE (NOUT,140) ANAME2,RELNAM
  140 FORMAT(19H -ERROR- Attribute ,A8,
     X       28H Already Exists In Relation ,A8)
      GO TO 9999
3140	continue
	write(c128wk,140)aname2,relnam
	call atxto
	goto 9999
  200 CONTINUE
C
C     RENAME ATTRIBUTE
C
      I = LOCATT(ANAME1,RNAME1)
      NUMT = 0
  210 CONTINUE
      CALL ATTGET(STATUS)
      IF(STATUS.NE.0) GO TO 300
C
C     CHECK FOR PERMISSION
C
      I = LOCREL(RELNAM)
      I = LOCPRM(RELNAM,2)
      IF(I.EQ.0) GO TO 220
      IF(IFLAG.EQ.1) GO TO 8400
      GO TO 210
  220 CONTINUE
      NUMT = NUMT + 1
      IF(NUMT.LE.10) NAMES(NUMT) = RELNAM
      ATTNAM = ANAME2
      CALL ATTPUT(STATUS)
      IF(IFLAG.NE.1) GO TO 210
  300 CONTINUE
	if(nout.eq.6)goto 3141
      WRITE (NOUT,305)ANAME1,NUMT
	goto 3142
3141	continue
	write(c128wk,305)aname1,numt
	call atxto
3142	continue
  305 FORMAT(11H Attribute ,A8,12H Renamed In ,I4,10H Relations)
C
C     NOW FOR THE NASTY NASTY RULES
C
      I = LOCREL(K8RDT  )
      IF(I.NE.0) GO TO 9999
C
C     LOOP THRU RMRULRRC AND CHANGE
C
      NS = 0
      NBOO = 0
      LIMTU = ALL9S
      NUMR = 0
  310 CONTINUE
      CALL RMLOOK(LOC,1,1,LENGTH)
      IF(RMSTAT.NE.0) GO TO 9997
      CHANGE = .FALSE.
      IF(NE(BUFFER(LOC+3),ANAME1)) GO TO 320
      IF((IFLAG.EQ.1).AND.(NE(BUFFER(LOC+5),RNAME1))) GO TO 320
      IF(NUMT.GT.10) GO TO 318
      DO 315 I=1,NUMT
      IF(EQ(NAMES(I),BUFFER(LOC+5))) GO TO 318
  315 CONTINUE
      GO TO 320
  318 CONTINUE
      CHANGE = .TRUE.
      CALL STRMOV(ANAME2,1,8,BUFFER(LOC+3),1)
      NUMR = NUMR + 1
  320 CONTINUE
      IF(NE(BUFFER(LOC+10),ANAME1)) GO TO 330
      IF((IFLAG.EQ.1).AND.(NE(BUFFER(LOC+12),RNAME1))) GO TO 330
      IF(NUMT.GT.10) GO TO 328
      DO 325 I=1,NUMT
      IF(EQ(NAMES(I),BUFFER(LOC+12))) GO TO 328
  325 CONTINUE
      GO TO 330
  328 CONTINUE
      CHANGE = .TRUE.
      CALL STRMOV(ANAME2,1,8,BUFFER(LOC+10),1)
      NUMR = NUMR + 1
  330 CONTINUE
      IF(CHANGE)CALL PUTDAT(1,CID,BUFFER(LOC),LENGTH)
      GO TO 310
 8100 CONTINUE
C
C     BAD SYNTAX
C
      CALL WARN(4,0,0)
      GO TO 9999
 8200 CONTINUE
C
C     ANAME1 NOT THERE
C
	if(nout.eq.6)goto 3143
      WRITE (NOUT,9200)ANAME1
 9200 FORMAT(19H -ERROR- Attribute ,A8,
     X       29H Is Not An Existing Attribute )
      GO TO 9999
3143	continue
	write(c128wk,9200)aname1
	call atxto
	goto 9999
 8300 CONTINUE
C
C     TYPE/LENGTH DIFFERS
C
	if(nout.eq.6)goto 3144
      WRITE (NOUT,9300)ANAME2,ANAME1
 9300 FORMAT(19H -ERROR- Attribute ,A8,
     X       35H Exists - Type/Length Differs From ,A8)
      GO TO 9999
3144	continue
	write(c128wk,9300)aname2,aname1
	call atxto
	goto 9999
 8400 CONTINUE
	if(nout.eq.6)goto 3145
      WRITE (NOUT,9400)
 9400 FORMAT(39H -ERROR- Unauthorized Access For RENAME )
      GO TO 9999
3145	continue
	write(c128wk,9400)
	call atxto
	goto 9999
 9997 CONTINUE
	if(nout.eq.6)goto 3146
      WRITE(NOUT,9998) ANAME1,NUMR
 9998 FORMAT(11H Attribute ,A8,12H Renamed In ,I3,
     X       20H Places In The Rules)
      GO TO 9999
3146	continue
	write(c128wk,9998)aname1,numr
	call atxto
c	goto 9999
C
C     ALL DONE
C
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE RNAMER
      INCLUDE rin:TEXT.BLK
C
C     SUBROUTINE TO RENAME A RELATION INCLUDING SUCH
C     NASTIES AS CHANGING THE RULES.
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:ATTBLE.BLK
      INCLUDE rin:START.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:DCLAR1.BLK
      INCLUDE rin:DCLAR6.BLK
      INCLUDE rin:WHCOM.BLK
      LOGICAL EQKEYW
      LOGICAL NE,EQ
      ITEMS = LXITEM(IDUM)
      IF(ITEMS.NE.5) GO TO 4000
      IF(.NOT.EQKEYW(4,KWTO,2)) GO TO 4000
      IF((LXLENC(5).GE.1).AND.(LXLENC(5).LE.8)) GO TO 2000
      CALL WARN(7,KWRELA,BLANK)
      GO TO 9999
 2000 CONTINUE
      NAMNEW = BLANK
      CALL LXSREC(5,1,8,NAMNEW,1)
      I = LOCREL(NAMNEW)
      IF(I.NE.0) GO TO 4150
C
C  NEW NAME IS A DUPLICATE.
C
	if(nout.eq.6)goto 3140
      WRITE(NOUT,9008)
 9008 FORMAT(44H -ERROR- Duplicate Relation Name Encountered)
      GO TO 9999
3140	continue
	write(c128wk,9008)
	call atxto
	goto 9999
 4150 CONTINUE
      RNAME = BLANK
      CALL LXSREC(3,1,8,RNAME,1)
      I = LOCREL(RNAME)
      IF(I.EQ.0) GO TO 4200
      CALL WARN(1,RNAME,0)
      GO TO 9999
 4200 CONTINUE
      I = LOCPRM(NAME,2)
      IF(I.EQ.0) GO TO 4250
C
C     FAILS MODIFY PERMISSION
C
	if(nout.eq.6)goto 3141
      WRITE (NOUT,5)
    5 FORMAT(39H -ERROR- Unauthorized Access For RENAME )
      GO TO 9999
3141	write(c128wk,5)
	call atxto
	goto 9999
 4250 CONTINUE
C
C  CHANGE EVERYTHING NEEDED FOR THE RELATION.
C
      CALL RELGET(ISTAT)
      NAMNEW = BLANK
      CALL LXSREC(5,1,8,NAMNEW,1)
      NAME = NAMNEW
      CALL RELPUT
      I = LOCATT(BLANK,RNAME)
      IF(I.NE.0) GO TO 9999
 4300 CONTINUE
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 4400
      RELNAM = NAMNEW
      CALL ATTPUT(ISTAT)
      GO TO 4300
 4400 CONTINUE
	if(nout.eq.6)goto 3142
      WRITE(NOUT,9009) RNAME,NAMNEW
 9009 FORMAT(10H RELATION ,A8,12H RENAMED TO ,A8)
C
	goto 3143
3142	write(c128wk,9009)rname,namnew
	call atxto
3143	continue
C     CHECK FOR RULES AND RENAME THEM
C
      I = LOCREL(K8RRC  )
      IF(I.NE.0) GO TO 9999
      NS = 0
      NBOO = 0
      LIMTU = ALL9S
C
C     LOOP THRU RMRULRRC AND CHANGE
C
 5000 CONTINUE
      CALL RMLOOK(LOC,1,1,LENGTH)
      IF(RMSTAT.NE.0) GO TO 5500
      IF(NE(BUFFER(LOC),RNAME)) GO TO 5000
      CALL STRMOV(NAMNEW,1,8,BUFFER(LOC),1)
      CALL PUTDAT(1,CID,BUFFER(LOC),LENGTH)
      GO TO 5000
 5500 CONTINUE
C
C     LOOP THRU RMRULRDT AND CHANGE
C
      I = LOCREL(K8RDT  )
      IF(I.NE.0) GO TO 9999
      NS = 0
      NBOO = 0
      LIMTU = ALL9S
 5600 CONTINUE
      CALL RMLOOK(LOC,1,1,LENGTH)
      IF(RMSTAT.NE.0) GO TO 9999
      IFLAG = 0
      IF(NE(BUFFER(LOC+5),RNAME)) GO TO 5700
      IFLAG = 1
      CALL STRMOV(NAMNEW,1,8,BUFFER(LOC+5),1)
 5700 CONTINUE
      IF(NE(BUFFER(LOC+12),RNAME)) GO TO 5800
      IFLAG = 1
      CALL STRMOV(NAMNEW,1,8,BUFFER(LOC+12),1)
 5800 CONTINUE
      IF(IFLAG.EQ.0) GO TO 5600
      CALL PUTDAT(1,CID,BUFFER(LOC),LENGTH)
      GO TO 5600
C
C     SYNTAX ERRORS
C
 4000 CONTINUE
      CALL WARN(4,0,0)
      GO TO 9999
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION ROUN(REAL,NUMC,EF)
      INCLUDE rin:TEXT.BLK
C
C     RETURN A ROUNDED VERSION OF THE REAL NUMBER
C     TO FIT IN NUMC CHARACTERS.  IF REAL IS NEGATIVE
C     REDUCE NUMC BY ONE.
C
      LOGICAL EF
      NUM = NUMC
      IF(REAL.LT.0.)NUM = NUM - 1
      ROUN = REAL
      IF(REAL.EQ.0.) RETURN
      IE = IEXP(REAL)
      IF((.NOT.EF).AND.(IE.LT.0)) IE = 0
      V = .5
      IF(REAL.LT.0.) V = -.5
      ROUN = REAL + V*(10.**(IE-NUM))
      RETURN
      END
      SUBROUTINE RTOC(STRING,CHAR1,NUM,VEAL)
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE TRIES TO DETERMINE THE BEST F FORMAT FOR
C     A REAL NUMBER AND CALL RTOF TO CHARACTERIZE IT.
C
      INTEGER STRING(*)
      LOGICAL EF
      EF = .FALSE.
      REAL = ROUN(VEAL,NUM-1,EF)
      NUM1 = NUM
      NUM2 = NUM1 - 2
      IF(REAL.EQ.0.) GO TO 10
      NP = IEXP(REAL)
      N = NUM - 1
      IF(REAL.LT.0.) N = N - 1
      NUM2 = N - NP
      IF(NP.GE.0) GO TO 10
      NUM2 = N
      IF(IABS(NP).GT.NUM-2) NUM2 = 0
   10 CONTINUE
      CALL RTOF(STRING,CHAR1,NUM1,NUM2,VEAL)
      RETURN
      END
      SUBROUTINE RTOF(STRING,CHAR1,NUM1,NUM2,VEAL)
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE CONVERTS A REAL NUMBER TO CHARACTERS AND
C     PUTS THE RESULT IN STRING.  FIRST IT TRYS TO FIT THE
C     NUMBER INTO FX.Y FORMAT WHERE X IS NUM1 AND Y IS NUM2.
C     IF THE NUMBER WONT FIT (I.E. NO SIGNIFICANT DIGITS WILL
C     MAKE IT), IT TRYS TO MAKE AN E FORMAT IN THE SAME SPACE.
C     IF THAT FAILS THE FIELD IS FILLED WITH ASTERISKS.
C
C     STRING....REPOSITORY FOR CHARACTERS
C     CHAR1.....STARTING POINT IN STRING
C     NUM1......FIELD WIDTH
C     NUM2......SPACE AFTER DECIMAL POINT
C     VEAL......A REAL NUMBER
C
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:MISC.BLK
      INTEGER STRING(*),CHAR1,ZERO
      LOGICAL EF
      EF = .FALSE.
      REAL = ROUN(VEAL,NUM1-1,EF)
      IERR = 0
      R = ABS(REAL)
      IN1 = INT(REAL)
      POINT = R - FLOAT(INT(R))
      NUM = NUM1 - NUM2 - 1
      IF(REAL.EQ.0.) GO TO 20
      IF(NUM.LT.0) GO TO 1000
      IF(NUM2.LT.0) GO TO 1000
      IF(NUM2.GT.NUM1) GO TO 1000
      IF(REAL.LT.0.) NUM = NUM - 1
      NUMM = -((NUM2+1)/2)
      IF(R.GE.10.**NUM ) GO TO 1000
      IF(R.LT.10.**NUMM) GO TO 1000
      IF(REAL.LT.0.) NUM = NUM + 1
C
C     FITS IN F FORMAT
C
   20 CONTINUE
      IF(NUM.GT.0) CALL ITOC(STRING,CHAR1,NUM,IN1,IERR)
      IF((NUM.EQ.1).AND.(REAL.LT.0.))CALL PUTT(STRING,CHAR1,K4MNUS)
      IF(IERR.NE.0) GO TO 1000
      CALL PUTT(STRING,CHAR1+NUM,K4DOT)
      IF(NUM2.EQ.0) GO TO 200
      POINT = POINT * 10.**NUM2
      IN1 = INT(POINT)
      CALL ITOC(STRING,CHAR1+NUM+1,NUM2,IN1,IERR)
      IF(IERR.NE.0) GO TO 1000
C
C     MAKE BLANKS AFTER THE DECIMAL POINT INTO ZEROS
C
      IL = CHAR1 + NUM + 1
      MAX = CHAR1 + NUM1 - 1
   50 CONTINUE
      IF(IL.GT.MAX) GO TO 200
      CALL GETT(STRING,IL,IC)
      IF(IC.NE.IBLANK) GO TO 200
      CALL PUTT(STRING,IL,K40)
      IL = IL + 1
      GO TO 50
  200 CONTINUE
C
C     CHANGE TRAILING ZEROS TO BLANKS
C
      NUM = CHAR1 + NUM1
      DO 250 I=1,NUM1
      NUM = NUM - 1
      CALL GETT(STRING,NUM,IC)
      IF(IC.NE.K40) GO TO 9999
      CALL PUTT(STRING,NUM,IBLANK)
  250 CONTINUE
      GO TO 9999
 1000 CONTINUE
      N = 4
      IF(ABS(REAL).LE.1.E+10) N = 3
      EF = .TRUE.
      REAL = ROUN(VEAL,NUM1-N,EF)
C
C      E - FORMAT
C
      MIN = 5
      IF(REAL.LT.0.) MIN = MIN + 1
      IF(NUM1.LT.MIN) GO TO 2000
      NUM = NUM1
      IC = CHAR1
      IF(REAL.GE.0) GO TO 1020
      CALL PUTT(STRING,IC,K4MNUS)
      IC = IC + 1
      NUM = NUM - 1
 1020 CONTINUE
      CALL PUTT(STRING,IC,K4DOT)
      IC = IC + 1
      NUM = NUM - 1
C
C     FIND THE INTEGER AND THE EXPONENT
C
      IE = IEXP(REAL)
      RR = ABS(REAL)/(10.**IE)
      IE = IE - 1
 1200 CONTINUE
      NUME = 1
      IF(IABS(IE).GE.10) NUME = 2
      IF(IABS(IE).GE.100) NUME = 3
      NUMI = NUM - NUME - 1
      IN1 = INT(RR*(10.**NUMI))
      CALL ITOC(STRING,IC,NUMI,IN1,IERR)
      IF(IERR.NE.0) GO TO 2000
      IC = IC + NUMI
      CALL PUTT(STRING,IC,K4PLUS)
      IF(IE.LT.0)CALL PUTT(STRING,IC,K4MNUS)
      IC = IC + 1
      CALL ITOC(STRING,IC,NUME,IABS(IE),IERR)
      IF(IERR.NE.0) GO TO 2000
C
C     SWITCH THE FIRST TWO CHARACTERS
C     I.E. X.XXX+YY RATHER THAN .XXXX+ZZ
C
      NUM = CHAR1
      IF(REAL.LT.0.) NUM = NUM + 1
      CALL GETT(STRING,NUM,IC1)
      CALL GETT(STRING,NUM+1,IC2)
      CALL PUTT(STRING,NUM,IC2)
      CALL PUTT(STRING,NUM+1,IC1)
      GO TO 9999
 2000 CONTINUE
C
C     STAR FILL
C
      CALL FILCH(STRING,CHAR1,NUM1,K4STAR)
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE RULDEL(RNAME,NUMRUL)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE: THIS ROUTINE PROCESSES A DELETE RULE COMMAND
C
C  PARAMETERS
C         RNAME---RULE RELATION - RIMRRC OR RIMRDT
C         NUMREL--RULE NUMBER TO DELETE
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:DCLAR1.BLK
      LOGICAL EQ
C
      NDP = 0
      ND = 0
C
C  CHECK IF A RULE NUMBER WAS ENTERED
C
      IF(NUMRUL.GT.0) GO TO 40
      CALL WARN(4,0,0)
      RMSTAT = 110
      GO TO 9999
   40 CONTINUE
C
C  SET UP THE RELATION DATA
C
      I = LOCREL(RNAME)
      IF(I.EQ.0) GO TO 100
   50 Continue
	if(nout.eq.6)goto 3140
	WRITE(NOUT,9000)
 9000 FORMAT(29H -WARNING- Rules Do Not Exist  )
      RMSTAT = 110
      GO TO 9999
3140	continue
	write(c128wk,9000)
	call atxto
	rmstat=110
	goto 9999
C
C  SET UP THE WHERE CLAUSE.
C
  100 CONTINUE
      NBOO = 0
      I = LOCATT(K8NUM,RNAME)
      IF(I.NE.0) GO TO 50
      CALL ATTGET(I)
      IF(I.NE.0) GO TO 50
      NBOO = 1
      BOO(1) = K4AND
      KATTP(1) = ATTCOL
      KATTL(1) = ATTLEN
      KATTY(1) = ATTYPE
      KOMTYP(1) = 2
      KOMPOS(1) = 1
      KOMLEN(1) = 1
      KOMPOT(1) = 1
      KSTRT = 0
      MAXTU = ALL9S
      LIMTU = ALL9S
      WHRVAL(1) = NUMRUL
      WHRLEN(1) = 1
      NS = 0
C
C  SEQUENCE THROUGH THE DATA DELETING TUPLES.
C
      IF(NTUPLE.LE.0) GO TO 9999
      IID = CID
  200 CONTINUE
      CALL RMLOOK(MAT,1,1,LENGTH)
      IF(RMSTAT.NE.0) GO TO 700
C
C  DELINK THIS TUPLE.
C
      CALL DELDAT(1,CID)
      IF(CID.EQ.IID) IID = NID
      ND = ND + 1
      NDP = 1
      GO TO 200
C
C  CHANGE THE STARTING ID IF NEEDED.
C
  700 CONTINUE
      CALL RELGET(ISTAT)
      RSTART = IID
      NTUPLE = NTUPLE - ND
      CALL RELPUT
      RMSTAT = 0
      IF(ND.NE.0) GO TO 9999
	if(nout.eq.6)goto 3142
      WRITE(NOUT,8001) NUMRUL
	goto 3143
3142	write(c128wk,8001)numrul
	call atxto
3143   continue
 8001 FORMAT(15H -WARNING- Rule,I4,15H Does Not Exist)
      RMSTAT = 110
 9999 CONTINUE
	if(nout.eq.6)goto 3144
      IF(EQ(K8RDT,RNAME)) WRITE(NOUT,9001) NDP
 9001 FORMAT(2X,I6,14H RULES DELETED )
	return
3144	continue
	if(.not.EQ(k8rdt,rname))return
	write(c128wk,9001)ndp
	call atxto
c
C
C  DONE.
C
      RETURN
      END
      SUBROUTINE RULES
      INCLUDE rin:TEXT.BLK
C
C  THE PURPOSE OF THIS ROUTINE IS TO INVOKE A ROUTINE TO
C  PRINT OUT ALL RULES PERTAINING TO A RIM SCHEMA IF SUCH
C  RULES EXIST.
C
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:MISC.BLK
      LOGICAL EQ
      INTEGER RRC(3)
      INTEGER OLDNUM
      INTEGER RULENO
C
      IF(EQ(USERID,OWNER)) GO TO 100
	if(nout.eq.6)goto 3140
      WRITE(NOUT,9000)
 9000 FORMAT(20H -ERROR- YOU are NOT,
     X       33H authorized to look at the rules )
      GO TO 999
3140	write(c128wk,9000)
	call atxto
	goto 999
  100 CONTINUE
C
C  LOOK FOR THE RULE RELATION CORRESPONDENCE TABLE.
C
      I = LOCREL(K8RRC)
      IF(I.EQ.0) GO TO 200
	if(nout.eq.6)goto 3141
      WRITE(NOUT,9001)
 9001 FORMAT(45H -WARNING- No Rules Defined For This Database )
      GO TO 999
3141	write(C128wk,9001)
	call atxto
	goto 999
C
C  CYCLE THROUGH THE RULES.
C
  200 CONTINUE
      OLDNUM = 0
      NBOO = 0
      LIMTU = ALL9S
  300 CONTINUE
      CALL RMLOOK(RRC,2,0,LEN)
      IF(RMSTAT.NE.0) GO TO 999
      NUMRUL = RRC(3)
      IF(NUMRUL.EQ.OLDNUM) GO TO 300
C
C  CALL PRULE TO DUMP OUT THE RULES.
C
      CALL PRULE(NUMRUL)
      OLDNUM = NUMRUL
      GO TO 300
C
C  DONE.
C
  999 CONTINUE
      RETURN
      END
      FUNCTION RXREC(I)
      INCLUDE rin:TEXT.BLK
C
C     THIS FUNCTION RETURNS THE REAL VALUE OF A REAL ITEM.
C
      INCLUDE rin:LXCARD.BLK
      INCLUDE rin:LXCON.BLK
      RXREC = 0.
      IF(I.LT.1) RETURN
      IF(I.GT.NEWN) RETURN
      IF(TYPE(I).NE.REAL) RETURN
      RXREC = RVAL(I)
      RETURN
      END
      SUBROUTINE SELECT
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE HANDLES THE SELECT COMMAND.
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:PROM.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:BLNKFL.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:SELCOM.BLK
      LOGICAL DONE,ADONE
      LOGICAL ITALLY
C
C     SET LPP AND MCPL
C
      LPP = 10000000
      IF(.NOT.CONNO) LPP = 56
      MCPL = 78
      IF(.NOT.CONNO)MCPL = 132
      IF(ULPP.NE.0) LPP = ULPP
      IF(UMCPL.NE.0) MCPL = UMCPL
C
C     CALL SELPAR TO SET SELCOM BLOCK
C
      ITALLY = .FALSE.
      CALL SELPAR(ITALLY)
      IF(NUMATT.LE.0) GO TO 900
      NLINE = 3
      if(noutr.ne.6)WRITE (NOUTR,30)
      CALL SPOUT(TITLE,MCPL)
      CALL SPOUT(MINUS,MCPL)
   30 FORMAT(1H )
C
C  OPEN THE SORT FILE IF WE HAVE "SORTED BY ....... "
C
      LENGTH = NCOL
      IF(NS.EQ.1) CALL GTSORT(IP,1,-1,LENGTH)
C
C     LOOP ON RECORDS
C
   50 CONTINUE
      IF(NS.EQ.1) CALL GTSORT(IP,1,1,LENGTH)
      IF(NS.NE.1) CALL RMLOOK(IP,1,1,LENGTH)
      IF(RMSTAT.NE.0) GO TO 9999
      DO 55 II=1,NUMATT
      CURPOS(II) = 1
   55 CONTINUE
C
C     SET UP VARIABLE LENGTH ATTRIBUTES
C
      DO 60 I=1,NUMATT
      IF(.NOT.VAR(I)) GO TO 60
      JP = IP + FP(I) - 1
      JP = BUFFER(JP) + IP - 1
      LEN(I) = BUFFER(JP)
      IF(ATYPE(I).EQ.KZTEXT) LEN(I) = BUFFER(JP+1)
      IF(ATYPE(I).EQ.KZDOUB) LEN(I) = LEN(I)/2
      IF(ATYPE(I).EQ.KZDVEC) LEN(I) = LEN(I)/2
      IF(ATYPE(I).EQ.KZDMAT) LEN(I) = LEN(I)/2
      ROWD(I) = BUFFER(JP+1)
      IF(ATYPE(I).EQ.KZIMAT) COLD(I) = LEN(I)/ROWD(I)
      IF(ATYPE(I).EQ.KZRMAT) COLD(I) = LEN(I)/ROWD(I)
      IF(ATYPE(I).EQ.KZDMAT) COLD(I) = LEN(I)/ROWD(I)
   60 CONTINUE
C
C     LOOP ON LINES
C
      DONE = .FALSE.
   70 CONTINUE
      IF(DONE) GO TO 50
      DONE = .TRUE.
      CALL FILCH(LINE,1,MCPL,BLANK)
C
C     LOOP ON ATTRIBUTES
C
      DO 100 I=1,NUMATT
      JP = IP + FP(I) - 1
      IF(VAR(I)) JP = BUFFER(JP) + IP + 1
      CALL SELOUT(BUFFER(JP),I,ADONE)
      DONE = DONE.AND.ADONE
  100 CONTINUE
      IF(NLINE.LT.LPP) GO TO 120
      IF(.NOT.(CONNI.AND.CONNO)) GO TO 108
	if(noutr.eq.6)goto 3143
      WRITE(NOUTR,104)
  104 FORMAT(28H More Text Follows - Enter * ,
     X         28H To Continue Or QUIT To Stop )
	goto 3144
3143	continue
	write(C128wk,104)
	call atxto
3144	continue
      PROM = IBLANK
      CALL LXLREC(IDUM,0,IDUM)
      PROM = K4RP
      IF(LXWREC(1,1).EQ.K4QUIT) GO TO 9999
  108 CONTINUE
      NLINE = 3
      IF(.NOT.CONNO.and.(noutr.ne.6)) WRITE (NOUTR,110)
  110 FORMAT(1H1)
      if(noutr.ne.6)WRITE (NOUTR,30)
      CALL SPOUT(TITLE,MCPL)
      CALL SPOUT(MINUS,MCPL)
  120 CONTINUE
      CALL SPOUT(LINE,MCPL)
      IF(BLNKFL) NLINE = NLINE + 1
      GO TO 70
  900 CONTINUE
C
C     NO VALID ATTRIBUTES
C
C     WRITE (NOUT,910)
C 910 FORMAT(40H -WARNING- No Valid Attributes Specified )
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE SELOUT(MAT,IATT,ADONE)
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE STUFFS THE CHARACTER REPRESENTATION OF AN
C     ATTRIBUTE VALUE INTO LINE FOR LATER PRINTING.
C
C     MAT.......DATA FOR THIS ATTRIBUTE
C     IATT......ATTRIBUTE NUMBER IN SELCOM
C     ADONE.....SET TO .TRUE. IF NO PARAGRAPHING LEFT
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:SELCOM.BLK
      INCLUDE rin:MISC.BLK
      DIMENSION MAT(*)
      LOGICAL ADONE
      ADONE = .TRUE.
      IPOS = 1
      IF((CURPOS(IATT).NE.1).AND.(PGRAPH(IATT).EQ.0)) GO TO 9999
      IF(CURPOS(IATT).GT.LEN(IATT)) GO TO 9999
      IF(ATYPE(IATT).NE.KZTEXT) GO TO 100
C
C     TEXT
C
      IF(PGRAPH(IATT).NE.0) GO TO 50
C
C     NON-PARAGRAPHED TEXT
C
      NC = NUMCOL(IATT)
      IF(NC.GT.LEN(IATT)) NC = LEN(IATT)
      GO TO 70
   50 CONTINUE
C
C     PARAGRAPHED TEXT
C
      NC = NUMCOL(IATT)
      MAX = LEN(IATT) - CURPOS(IATT) + 1
      IF(NC.GT.MAX) NC = MAX
      IF(NC.EQ.MAX) GO TO 70
C
C     SEE IF WE NEED WORRY ABOUT BROKEN WORDS
C
      MC = 0
      M2 = ISCAN(MAT(1),CURPOS(IATT)+NC,-NC,IBLANK,1,1,IPOS)
      IF(IPOS.NE.0) MC = IPOS - CURPOS(IATT) + 1
      IF(MC.GT.4) NC = MC
      ADONE = .FALSE.
C
C     CHECK IF REMAINDER OF LINE IS BLANK
C
      N = LEN(IATT) - CURPOS(IATT) - NC
      IPOS = NSCAN(MAT(1),CURPOS(IATT)+NC,N,IBLANK,1,1)
      IF(IPOS.EQ.0) ADONE = .TRUE.
   70 CONTINUE
      CALL STRMOV(MAT(1),CURPOS(IATT),NC,LINE,COL1(IATT))
      CURPOS(IATT) = CURPOS(IATT) + NC
      IF(IPOS.EQ.0) CURPOS(IATT) = LEN(IATT) + 1
      GO TO 9999
  100 CONTINUE
C
C     NON-TEXT STUFF
C
      IF(ATYPE(IATT).EQ.KZIMAT) GO TO 1000
      IF(ATYPE(IATT).EQ.KZRMAT) GO TO 1000
      IF(ATYPE(IATT).EQ.KZDMAT) GO TO 1000
      IF(SINGLE(IATT).NE.0) GO TO 3000
C
C     WE HAVE NON-MATRIX STUFF
C
      NUMTOP = (NUMCOL(IATT)+2)/(ITEMW(IATT)+2)
      IF((PGRAPH(IATT).NE.0).AND.(PGRAPH(IATT).LT.NUMTOP))
     X             NUMTOP = PGRAPH(IATT)
      IP = CURPOS(IATT)
      IF(ATYPE(IATT).EQ.KZDOUB) IP = 2*IP - 1
      IF(ATYPE(IATT).EQ.KZDVEC) IP = 2*IP - 1
      IC = COL1(IATT)
      IF(.NOT.VAR(IATT)) GO TO 150
      IF(NUMCOL(IATT).LT.20) GO TO 150
      IF(ATYPE(IATT).EQ.KZIVEC) GO TO 120
      IF(ATYPE(IATT).EQ.KZRVEC) GO TO 120
      IF(ATYPE(IATT).EQ.KZDVEC) GO TO 120
      GO TO 150
  120 CONTINUE
C
C     PUT IN DIMENSION
C
      NUMTOP = NUMTOP - 1
      IF(CURPOS(IATT).EQ.1) CALL ITOC(LINE,IC,6,LEN(IATT),IERR)
      IC = IC + 10
  150 CONTINUE
      NUMT = LEN(IATT) - CURPOS(IATT) + 1
      IF(NUMTOP.GT.NUMT) NUMTOP = NUMT
      DO 200 I=1,NUMTOP
      CALL SELPUT(MAT(IP),ATYPE(IATT),ITEMW(IATT),IC,LINE)
      IP = IP + 1
      IF(ATYPE(IATT).EQ.KZDOUB) IP = IP + 1
      IF(ATYPE(IATT).EQ.KZDVEC) IP = IP + 1
      IC = IC + 2 + ITEMW(IATT)
  200 CONTINUE
      CURPOS(IATT) = CURPOS(IATT) + NUMTOP
      IF(PGRAPH(IATT).EQ.0) GO TO 9999
      IF(CURPOS(IATT).LE.LEN(IATT)) ADONE = .FALSE.
      GO TO 9999
 1000 CONTINUE
C
C     MATRICIES
C
      IF(SINGLE(IATT).NE.0) GO TO 3500
      NUMTOP = (NUMCOL(IATT)+2)/(ITEMW(IATT)+2)
      IF((PGRAPH(IATT).NE.0).AND.(PGRAPH(IATT).LT.NUMTOP))
     X             NUMTOP = PGRAPH(IATT)
      IP = CURPOS(IATT)
      JC = (IP-1)/ROWD(IATT)
      JR = IP - JC*ROWD(IATT)
      JC = JC + 1
      IC = COL1(IATT)
      IF(.NOT.VAR(IATT)) GO TO 1150
      IF(NUMCOL(IATT).LT.20) GO TO 1150
C
C     PUT IN ROW AND COLUMN
C
      NUMTOP = NUMTOP - 1
      IF(CURPOS(IATT).NE.1) GO TO 1125
      CALL ITOC(LINE,IC,4,ROWD(IATT),IERR)
      CALL ITOC(LINE,IC+4,4,COLD(IATT),IERR)
 1125 CONTINUE
      IC = IC + 10
 1150 CONTINUE
      NUMT = COLD(IATT)*(ROWD(IATT)-JR) + COLD(IATT) - JC + 1
      IF(NUMTOP.GT.NUMT) NUMTOP = NUMT
      DO 1200 I=1,NUMTOP
      IP = ROWD(IATT)*(JC-1) + JR
      IF(ATYPE(IATT).EQ.KZDMAT) IP = 2 * IP - 1
      CALL SELPUT(MAT(IP),ATYPE(IATT),ITEMW(IATT),IC,LINE)
      JC = JC + 1
      IF(JC.LE.COLD(IATT)) GO TO 1170
      JC = 1
      JR = JR + 1
      IF(PGRAPH(IATT).NE.0) GO TO 1220
 1170 CONTINUE
      IC = IC + 2 + ITEMW(IATT)
 1200 CONTINUE
 1220 CONTINUE
      IF(.NOT.TRUNC(IATT)) GO TO 1240
      IF(JC.EQ.1) GO TO 1240
      JR = JR + 1
      JC = 1
 1240 CONTINUE
      CURPOS(IATT) = ROWD(IATT)*(JC-1) + JR
      IF(PGRAPH(IATT).EQ.0) GO TO 9999
      IF(JR.LE.ROWD(IATT)) ADONE = .FALSE.
      IF(ADONE)CURPOS(IATT) = LEN(IATT) + 1
      GO TO 9999
 3000 CONTINUE
C
C     SINGLE ITEM FROM A VECTOR
C
      IP = SINGLE(IATT)
      CURPOS(IATT) = LEN(IATT) + 1
      IF(IP.GT.LEN(IATT)) GO TO 3800
      CALL SELPUT(MAT(IP),ATYPE(IATT),ITEMW(IATT),COL1(IATT),LINE)
      GO TO 9999
 3500 CONTINUE
C
C     SINGLE ITEM FROM A MATRIX
C
      CURPOS(IATT) = LEN(IATT) + 1
      CALL ITOH(JR,JC,SINGLE(IATT))
      IF(JR.GT.ROWD(IATT)) GO TO 3800
      IF(JC.GT.COLD(IATT)) GO TO 3800
      IP = ROWD(IATT)*(JC-1) + JR
      IF(ATYPE(IATT).EQ.KZDMAT) IP = 2 * IP - 1
      CALL SELPUT(MAT(IP),ATYPE(IATT),ITEMW(IATT),COL1(IATT),LINE)
      GO TO 9999
 3800 CONTINUE
C
C     OUT OF RANGE
C
      CALL SELPUT(NULL,ATYPE(IATT),ITEMW(IATT),COL1(IATT),LINE)
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE SELPAR(ITALLY)
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE GOES THRU ATTRIBUTES SPECIFIED ON THE SELECT
C     COMMAND THEN (OR ALL) AND
C     1. BUILDS THE TITLE LINE
C     2.BUILDS THE MINUS LINE
C     3.SET INFORMATION INTO COMMON BLOCK SELCOM
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:SELCOM.BLK
      LOGICAL EQKEYW,END,IFALL
      LOGICAL ITALLY
      INTEGER STATUS
      INCLUDE rin:DCLAR1.BLK
C
C     INITIALIZE
C
      NUMBAD = 0
      NUM = CHPWD*(1+((MCPL-1)/CHPWD))
      CALL FILCH(TITLE,1,NUM,BLANK)
      CALL FILCH(MINUS,1,NUM,BLANK)
      CALL FILCH(LINE,1,NUM,BLANK)
      NUMATT = 0
      IT = 2
      ITEMS = LXITEM(DUM)
      LAST = LFIND(1,ITEMS,KWFROM,4)
      LAST = LAST - 1
      IF(ITALLY) LAST = 2
      IFALL = .FALSE.
      IP = 0
      IF(LAST.NE.2) GO TO 10
      IF(.NOT.EQKEYW(IT,KWALL,3)) GO TO 10
C
C     ALL
C
      IFALL = .TRUE.
      CALL LOCATT(BLANK,NAME)
C
C     LOOP ON ATTRIBUTES
C
   10 CONTINUE
C
C     GET ATTRIBUTE INTO TUPLEA
C
      IF(IFALL) GO TO 50
C
C     LOOK AT NEXT ATTRIBUTE
C
      IF(IT.GT.LAST) GO TO 1000
      IF(LXID(IT).NE.KZINT) GO TO 15
C
C     INTEGER ATTRIBUTE NUMBER
C
      NUM = LXIREC(IT)
      IT = IT + 1
      IF(NUM.LE.0) GO TO 880
      IF(NUM.GT.NATT) GO TO 880
      CALL LOCATT(BLANK,NAME)
      DO 12 I=1,NUM
      CALL ATTGET(STATUS)
      IF(STATUS.NE.0) GO TO 880
   12 CONTINUE
      GO TO 20
   15 CONTINUE
      ANAME = BLANK
      CALL LXSREC(IT,1,8,ANAME,1)
      IT = IT + 1
      CALL LOCATT(ANAME,NAME)
      CALL ATTGET(STATUS)
      IF(STATUS.EQ.0) GO TO 20
      CALL WARN(3,ANAME,NAME)
      NUMBAD = NUMBAD + 1
      GO TO 10
   20 CONTINUE
      NUMATT = NUMATT + 1
      IF(NUMATT.GT.20) GO TO 8040
C
C     SEE IF MAT(I,J) OR VEC(I,J)
C
      SINGLE(NUMATT) = 0
      IF(LXID(IT).NE.KZTEXT) GO TO 40
      IF(LXLENC(IT).NE.1) GO TO 40
      IF(LXWREC(IT,1).NE.K4LPAR) GO TO 40
      NUM = 0
      IF(ATTYPE.EQ.KZIVEC) NUM = 1
      IF(ATTYPE.EQ.KZRVEC) NUM = 1
      IF(ATTYPE.EQ.KZDVEC) NUM = 1
      IF(ATTYPE.EQ.KZIMAT) NUM = 2
      IF(ATTYPE.EQ.KZRMAT) NUM = 2
      IF(ATTYPE.EQ.KZDMAT) NUM = 2
      NUMA = 0
      IF(LXWREC(IT+2,1).EQ.K4RPAR) NUMA = 1
      IF(LXWREC(IT+3,1).EQ.K4RPAR) NUMA = 2
      IF(NUM.EQ.0) GO TO 800
      IF(NUMA.EQ.0) GO TO 820
      IF(NUM.NE.NUMA) GO TO 840
      IF(LXID(IT+1).NE.KZINT) GO TO 860
      IF(LXID(IT+NUMA).NE.KZINT) GO TO 860
      I1 = LXIREC(IT+1)
      I2 = 1
      IF(NUM.EQ.2) I2 = LXIREC(IT+2)
      IF(I1.LE.0) GO TO 860
      IF(I2.LE.0) GO TO 860
      CALL ITOH(N1,N2,ATTLEN)
      IF(N2.EQ.0) GO TO 30
      IF(ATTYPE.EQ.KZDVEC) N2 = N2/2
      IF(ATTYPE.EQ.KZDMAT) N2 = N2/2
      IF(NUM.EQ.1) GO TO 25
      IF(N1.NE.0) N2 = N2/N1
      IF(I1.GT.N1) GO TO 8020
      IF(I2.GT.N2) GO TO 8020
      GO TO 30
   25 CONTINUE
      IF(I1.GT.N2) GO TO 8020
   30 CONTINUE
      SINGLE(NUMATT) = I1
      IF(NUM.EQ.2)CALL HTOI(I1,I2,SINGLE(NUMATT))
      IT = IT + 2 + NUMA
   40 CONTINUE
C
C     SEE IF NEXT IS PARAGRAPH
C
      PGRAPH(NUMATT) = 0
      IF(IT.GT.LAST) GO TO 100
      IF(LXWREC(IT,1).NE.K4EQS) GO TO 100
      IF(LXID(IT+1).NE.KZINT) GO TO 8000
      PGRAPH(NUMATT) = LXIREC(IT+1)
      IT = IT + 2
      GO TO 100
   50 CONTINUE
C
C     ALL
C
      CALL ATTGET(STATUS)
      IF(STATUS.NE.0) GO TO 1000
      NUMATT = NUMATT + 1
      IF(NUMATT.GT.20) GO TO 8040
      PGRAPH(NUMATT) = 0
      SINGLE(NUMATT) = 0
  100 CONTINUE
C
C     GOT ATTRIBUTE IN TUPLEA
C
      NC = 0
      IF(IP.GT.(MCPL-10)) NUMATT = NUMATT - 1
      IF(IP.GT.(MCPL-10)) GO TO 900
      IP = IP + 2
      ICOL = ATTCHA
      NWORDS = ATTWDS
      IF(ATTYPE.EQ.KZDOUB) NWORDS = NWORDS/2
      IF(ATTYPE.EQ.KZDVEC) NWORDS = NWORDS/2
      IF(ATTYPE.EQ.KZDMAT) NWORDS = NWORDS/2
      COL1(NUMATT) = IP
      ATYPE(NUMATT) = ATTYPE
      LEN(NUMATT) = NWORDS
      IF(ATTYPE.EQ.KZTEXT)LEN(NUMATT) = ICOL
      ROWD(NUMATT) = ICOL
      COLD(NUMATT) = 0
      IF(ICOL.NE.0) COLD(NUMATT) = NWORDS/ICOL
      VAR(NUMATT) = NWORDS.EQ.0
      FP(NUMATT) = ATTCOL
      IF(VAR(NUMATT)) GO TO 200
C
C     FIXED STUFF
C
      TRUNC(NUMATT) = .FALSE.
      GO TO 300
  200 CONTINUE
C
C     VARIABLE STUFF
C
      TRUNC(NUMATT) = .FALSE.
      IF(PGRAPH(NUMATT).NE.0) GO TO 300
      PGRAPH(NUMATT) = 4
      IF(ATTYPE.EQ.KZTEXT) PGRAPH(NUMATT) = 40
  300 CONTINUE
      ITEMW(NUMATT) = 8
      IF(ATTYPE.EQ.KZTEXT)ITEMW(NUMATT) = 1
      NC = LEN(NUMATT) * (2 + ITEMW(NUMATT)) - 2
      IF(PGRAPH(NUMATT).NE.0)NC = PGRAPH(NUMATT)*(2+ITEMW(NUMATT))-2
      IF(ATTYPE.NE.KZTEXT) GO TO 310
      NC = LEN(NUMATT)
      IF(PGRAPH(NUMATT).NE.0) NC = PGRAPH(NUMATT)
  310 CONTINUE
      IF(SINGLE(NUMATT).NE.0) NC = ITEMW(NUMATT) + 2
      IF(NC.LE.0) NC = 40
C
C     INSERT TITLE
C
      JP = IP
      IF(.NOT.VAR(NUMATT)) GO TO 315
      IF(NC.LT.20) GO TO 315
      IF(ATTYPE.EQ.KZTEXT) GO TO 315
      IF(ATTYPE.EQ.KZINT) GO TO 315
      IF(ATTYPE.EQ.KZREAL) GO TO 315
      IF(ATTYPE.EQ.KZDOUB) GO TO 315
      IF(ATTYPE.EQ.KZIVEC) CALL STRMOV(K4DIM,1,3,TITLE,IP+3)
      IF(ATTYPE.EQ.KZRVEC) CALL STRMOV(K4DIM,1,3,TITLE,IP+5)
      IF(ATTYPE.EQ.KZDVEC) CALL STRMOV(K4DIM,1,3,TITLE,IP+5)
      IF(ATTYPE.EQ.KZRMAT) CALL STRMOV(K8RC,1,8,TITLE,IP)
      IF(ATTYPE.EQ.KZDMAT) CALL STRMOV(K8RC,1,8,TITLE,IP)
      IF(ATTYPE.EQ.KZIMAT) CALL STRMOV(K8RC,1,8,TITLE,IP)
      JP = IP + 10
  315 CONTINUE
      CALL STRMOV(ATTNAM,1,MIN0(8,NC),TITLE,JP)
      END = .FALSE.
      IF((IP+NC-1).GT.MCPL) END = .TRUE.
      IF(END) NC = MCPL - IP + 1
      NUMCOL(NUMATT) = NC
C
C     MAKE DASHES
C
      CALL FILCH(MINUS,IP,NC,K4MNUS)
      IP = IP + NC
      IF(.NOT.END) GO TO 10
      GO TO 900
  800 CONTINUE
C
C     WRONG TYPE FOR FOLLOWING PARENS
C
	if(nout.eq.6)goto 3140
      WRITE (NOUT,810)
  810 FORMAT(58H -ERROR- Attribute Must Be VEC Or MAT For Following Pare
     Xns)
      GO TO 9000
3140	write(c128wk,810)
	call atxto
	goto 9000
  820 CONTINUE
C
C     TRAILING PAREN IMPROPERLY SPECIFIED
	if(nout.eq.6)goto 3141
C
      WRITE (NOUT,830)
  830 FORMAT(36H -ERROR- Couldn't Find Closing Paren)
      GO TO 9000
3141	continue
	write(c128wk,830)
	call atxto
	goto 9000
  840 CONTINUE
C
C     VEC/MAT MISMATCH
C
	if(nout.eq.6)goto 3142
      WRITE (NOUT,850)
  850 FORMAT(38H -ERROR- Number Of Dimensions Mismatch)
      GO TO 9000
3142	write(c128wk,850)
	call atxto
	goto 9000
  860 CONTINUE
C
C     ROW/COL MUST BE POSITIVE INTEGER
C
	if(nout.eq.6)goto 3143
      WRITE (NOUT,870)
  870 FORMAT(42H -ERROR- ROW/COL Must Be Positive Integers)
      GO TO 9000
3143	write(c128wk,870)
	call atxto
	goto 9000
  880 CONTINUE
C
C     BAD INTEGER ATTRIBUTE
C
	if(nout.eq.6)goto 3144
      WRITE (NOUT,890)
  890 FORMAT(49H -ERROR- Improper Integer Attribute Specification )
      GO TO 9000
3144	write(c128wk,890)
	call atxto
	goto 9000
  900 CONTINUE
C
C     OOPS - NOT ENOUGH ROOM
C
	if(nout.eq.6)goto 3145
      WRITE(NOUT,910)
  910 FORMAT(25H -WARNING- Line Truncated )
	goto 3146
3145	write(c128wk,910)
	call atxto
3146	continue
 1000 CONTINUE
      MCPL = IP - 1
      IF(NUMBAD.GT.0) GO TO 9000
      RETURN
 8000 CONTINUE
C
C     PARAGRAPH NOT INTEGER
C
	if(nout.eq.6)goto 3147
      WRITE (NOUT,8010)
 8010 FORMAT(41H -ERROR- Improper Paragraph Specification )
      GO TO 9000
3147	write(c128wk,8010)
	call atxto
	goto 9000
 8020 CONTINUE
C
C     SINGLE TOO BIG
C
	if(nout.eq.6)goto 3148
      WRITE (NOUT,8030)
 8030 FORMAT(39H -ERROR- Requested Element Out Of Range )
      GO TO 9000
3148	write(c128wk,8030)
	call atxto
	goto 9000
 8040 CONTINUE
C
C  TOO MAY ATTRIBUTES SPECIFIED
C
	if(nout.eq.6)goto 3149
      WRITE(NOUT,8050)
 8050 FORMAT(46H -ERROR- Illegal Number Of Attributes (MAX 20))
      GO TO 9000
3149	write(c128wk,8050)
	call atxto
 9000 CONTINUE
C
C     BLEW IT
C
      NUMATT = 0
      CALL WARN(4,0,0)
      RETURN
      END
      SUBROUTINE SELPUT(VAL,TYPE,WIDTH,START,STRING)
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE PUTS AN ACTUAL VALUE (NON-TEXT) INTO STRING.
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:MISC.BLK
C
      INTEGER VAL,TYPE,WIDTH,START,STRING(*)
      IF(VAL.EQ.IBLANK) RETURN
      IF(VAL.NE.NULL) GO TO 100
C
C     NULL
C
      N = 3
      IF(WIDTH.LT.N) N = WIDTH
      CALL STRMOV(NULL,1,N,STRING,START)
      GO TO 9999
  100 CONTINUE
      IF(TYPE.EQ.KZINT) GO TO 200
      IF(TYPE.EQ.KZIVEC) GO TO 200
      IF(TYPE.EQ.KZIMAT) GO TO 200
C
C     TREAT AS REAL
C
      CALL RTOC(STRING,START,WIDTH,VAL)
      GO TO 9999
  200 CONTINUE
C
C     INTEGER
C
      CALL ITOC(STRING,START,WIDTH,VAL,IERR)
      IF(IERR.EQ.0) GO TO 9999
      CALL FILCH(STRING,START,WIDTH,K4STAR)
 9999 CONTINUE
      RETURN
      END
      SUBROUTINE SETIN(HFILE)
      INCLUDE rin:TEXT.BLK
C
C     SET THE INPUT FILE TO IFILE
C
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:FILES.BLK
      LOGICAL EQ
      REAL*8 HFILE
      CHARACTER*8 IFILE
      WRITE(IFILE,10) HFILE
   10 FORMAT(A8)
      IF(NINT.EQ.10) CLOSE(NINT)
      IF(EQ(HFILE,K8IN)) GO TO 100
C
C     NOT INPUT FILE
C
      CONNI = .FALSE.
      NINT = 10
      OPEN(UNIT=NINT,FILE=IFILE,STATUS='UNKNOWN')
      GO TO 900
  100 CONTINUE
C
C     INPUT FILE - NEVER CLOSED
C
C
C  CHECK THAT INPUT IS INPUT
C
      CONNI = .TRUE.
      NINT = 5
  900 CONTINUE
      CALL LXSET(K4INPT,NINT)
      RETURN
      END
      SUBROUTINE SETOUT(HFILE)
      INCLUDE rin:TEXT.BLK
C
C     SET THE OUTPUT FILE TO IFILE
C
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:FILES.BLK
      LOGICAL EQ
      REAL*8 HFILE
      CHARACTER*8 IFILE
      WRITE(IFILE,10) HFILE
   10 FORMAT(A8)
      IF(NOUT.EQ.11) CLOSE(NOUT)
      IF(NOUTR.EQ.11) CLOSE(NOUTR)
      IF(EQ(HFILE,K8OUT)) GO TO 100
C
C     NOT OUTPUT FILE
C
      CONNO = .FALSE.
      NOUTR = 11
      OPEN(UNIT=NOUTR,FILE=IFILE,STATUS='UNKNOWN')
      NOUT = 11
      IF(CONNI) NOUT = 6
      GO TO 900
  100 CONTINUE
C
C     OUTPUT FILE - NEVER CLOSED
C
C
C  CHECK THAT OUTPUT IS OUTPUT
C
      CONNO = .TRUE.
      NOUT = 6
      NOUTR = 6
  900 CONTINUE
      CALL LXSET(K4OTPT,NOUTR)
      RETURN
      END
      SUBROUTINE SETRUL
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE SETS UP THE RELATIONS NECESSARY TO ALLOW THE USER
C  TO DEFINE RULES FOR PROCESSING A RIM SCHEMA.  THESE RELATIONS
C  ARE :
C
C         RIMRDT --- THE RIM SCHEMA COMPILER RULE DESCRIPTION TABLE.
C
C         RIMRRC  --- THE RIM SCHEMA COMPILER RULE RELATION
C                     CORRESPONDENCE TABLE.
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:MISC.BLK
C
C
C  SET UP RELATION TABLE FOR RIMRRC.
C
      NAME = K8RRC
      CALL RMDATE(RDATE)
      NCOL = 3
      NATT = 2
      NTUPLE = 0
      RSTART = 0
      REND = 0
      RPW = K8DBA
      MPW = K8DBA
      CALL RELADD
      CALL ATTNEW(NAME,2)
C
C  ADD ATTRIBUTES FOR RIMRRC
C
      RELNAM = NAME
      ATTKEY = 0
      NW = (8-1)/CHPWD + 1
C
C  RELATION NAME
C
      ATTNAM = K8NAM
      ATTCOL = 1
      CALL HTOI(8,NW,ATTLEN)
      ATTYPE = KZTEXT
      CALL ATTADD
C
C  RULE NUMBER
C
      ATTNAM = K8NUM
      ATTCOL = 3
      ATTLEN = 1
      ATTYPE = KZINT
      CALL ATTADD
C
C  SET UP RIMRDT RELATION
C
      NAME = K8RDT
      CALL RMDATE(RDATE)
      NCOL = 14 + ((40-1)/CHPWD + 1)
      NATT = 9
      NTUPLE = 0
      RSTART = 0
      REND = 0
      RPW = K8DBA
      MPW = K8DBA
      CALL RELADD
      CALL ATTNEW(NAME,9)
C
C  ADD ATTRIBUTES FOR RIMRDT
C
      ATTKEY = 0
      RELNAM = NAME
C
C  RULE NUMBER
C
      ATTNAM = K8NUM
      ATTCOL = 1
      ATTLEN = 1
      ATTYPE = KZINT
      CALL ATTADD
C
C  AND/OR SWITCH
C
      ATTNAM = K8AOR
      ATTCOL = 2
      CALL HTOI(8,NW,ATTLEN)
      ATTYPE = KZTEXT
      CALL ATTADD
C
C  1ST ATTRIBUTE NAME
C
      ATTNAM = K8AN1
      ATTCOL = 4
      CALL HTOI(8,NW,ATTLEN)
      ATTYPE = KZTEXT
      CALL ATTADD
C
C  RELATION OR BLANK
C
      ATTNAM = K8RN1
      ATTCOL = 6
      CALL HTOI(8,NW,ATTLEN)
      ATTYPE = KZTEXT
      CALL ATTADD
C
C  BOOLEAN OPERATOR
C
      ATTNAM = K8OPR
      ATTCOL = 8
      CALL HTOI(8,NW,ATTLEN)
      ATTYPE = KZTEXT
      CALL ATTADD
C
C  2ND ITEM DESCRIPTOR
C
      ATTNAM = K8TYP
      ATTCOL = 10
      ATTLEN = 1
      ATTYPE = KZINT
      CALL ATTADD
C
C  2ND ATTRIBUTE NAME
C
      ATTNAM = K8AN2
      ATTCOL = 11
      CALL HTOI(8,NW,ATTLEN)
      ATTYPE = KZTEXT
      CALL ATTADD
C
C  2ND RELATION OR BLANK
C
      ATTNAM = K8RN2
      ATTCOL = 13
      CALL HTOI(8,NW,ATTLEN)
      ATTYPE = KZTEXT
      CALL ATTADD
C
C  VALUE.
C
      ATTNAM = K8VAL
      ATTCOL = 15
      NW = (40-1)/CHPWD + 1
      CALL HTOI(40,NW,ATTLEN)
      ATTYPE = KZTEXT
      CALL ATTADD
C
C  DONE WITH SETRULE.
C
      RETURN
      END
      SUBROUTINE SORT(NKSORT,ios)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  INTERFACE WITH SOCON TO SORT RIM DATA
C
C  PARAMETERS:
C              NKSORT--INDICATOR FOR THE TYPE OF SORT
C                        1=TUPLE SORT (SELECT)
C                        2=ATTRIBUTE SORT (TALLY)
C                        3=ID (POINTER) + ATTRIBUTE SORT (BUILD)
C              INDPTR--MULTIPLE RMHUNT INDEX - USED TO ASSIGN FILES
C
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:SRTCOM.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:INCORE.BLK
C
      INTEGER INFIL
      INTEGER OUTFIL
C
C  OPEN THE INPUT SORT FILE
C
      INFIL = 20
	open(infil,file='sortfil.dat',access='sequential',
     1  form='unformatted',status='unknown',iostat=ios)
	if(ios.eq.0)goto 50
	nsort=0
	goto 999
50	continue
c      REWIND INFIL
C
C  SET UP TUPLE LIMITS - SAVE USER SPECIFIED LIMIT
C
      LIMTUS = LIMTU
      LIMTU = ALL9S
C
C  BRANCH DEPENDING ON THE TYPE OF SORT REQUESTED
C
      IF(NKSORT.EQ.2) GO TO 350
      IF(NKSORT.EQ.3) GO TO 370
C
C  TUPLE SORT - WRITE THE COMPLETE TUPLE ON THE SORT FILE
C
C  CHECK FOR VARIABLE LENGTH TUPLES IN THE RELATION
C
      FIXLT = .TRUE.
      I = LOCATT(BLANK,NAME)
      DO 100 J=1,NATT
      CALL ATTGET(ISTATX)
      IF(ISTATX.NE.0) GO TO 110
      IF(ATTWDS.EQ.0) FIXLT = .FALSE.
  100 CONTINUE
  110 CONTINUE
C
C  INITIALIZE THE REMAINING VARIABLES
C
      LTUMAX = 0
      LTUMIN = ALL9S
      NSORT = 0
      LTUPLE = 0
      IF(FIXLT) LTUPLE = NCOL
C
C  READ IN THE TUPLES AND WRITE THE SORT FILE
C
  200 CONTINUE
      CALL RMLOOK(IP,1,1,LEN)
      IF(RMSTAT.NE.0) GO TO 400
      NSORT = NSORT + 1
      IP = IP - 1
      IF(FIXLT) GO TO 300
C
C  VARIBLE LENGTH TUPLE
C
      LTUPLE = LTUPLE + LEN
      IF(LEN.GT.LTUMAX) LTUMAX = LEN
      IF(LEN.LT.LTUMIN) LTUMIN = LEN
      WRITE(INFIL) LEN,(BUFFER(IP+K),K=1,LEN)
      GO TO 200
C
C  FIXED LENGTH TUPLES
C
  300 CONTINUE
      WRITE(INFIL) (BUFFER(IP+K),K=1,LEN)
      GO TO 200
C
C  ATTRIBUTE SORT - WRITE ONLY THE REQUESTED ATTRIBUTE ON THE SORT FILE
C
  350 CONTINUE
      FIXLT = .TRUE.
      LTUMAX = 0
      LTUMIN = ALL9S
      NSORT = 0
      LTUPLE = ATTWDS
C
C  READ THE TUPLES AND WRITE THE ATTRIBUTE VALUES ON THE SORT FILE
C
  360 CONTINUE
      CALL RMLOOK(IP,1,1,LEN)
      IF(RMSTAT.NE.0) GO TO 400
      NSORT = NSORT + 1
      IP = IP - 2
      WRITE(INFIL) (BUFFER(IP+ATTCOL+K),K=1,LTUPLE)
      GO TO 360
C
C  ID + ATTRIBUTE SORT (BUILD)
C
  370 CONTINUE
      FIXLT = .TRUE.
      LTUMAX = 0
      LTUMIN = ALL9S
      NSORT = 0
      LTUPLE = 2
  380 CONTINUE
      IF(NID.EQ.0) GO TO 400
      CID = NID
      CALL GETDAT(1,NID,ITUP,LENGT)
      IF(NID.LT.0) GO TO 400
      IP = ITUP + ATTCOL - 1
      IF(ATTWDS.NE.0) GO TO 390
C
C  ATTRIBUTE IS A VARIABLE LENGTH ATTRIBUTE.
C
      IP = BUFFER(IP) + ITUP + 1
  390 CONTINUE
      IF(BUFFER(IP).EQ.NULL) GO TO 380
C
C WRITE THE SORT FILE
C
      NSORT = NSORT + 1
      WRITE(INFIL) BUFFER(IP),CID
      GO TO 380
C
C  CHECK THAT SOME TUPLES WERE WRITTIN ON INFIL
C  RESET THE TUPLE LIMIT
C
  400 CONTINUE
      LIMTU = LIMTUS
      IF(NSORT.GT.0) GO TO 420
	if(nout.eq.6)goto 3140
      WRITE(NOUT,410)
  410 FORMAT(36H -WARNING- No Rows Available To SORT)
      GO TO 999
3140	write(c128wk,410)
	call atxto
	goto 999
C
C  OPEN THE OUTPUT FILES
C
  420 CONTINUE
      OUTFIL = 20
C
C  CLEAR OUT ANY PAGE DATA LEFT IN BUFFER
C
      CALL BLKCLN
C
C  FIXUP THE LENGTHS FOR THE VARIABLE LENGTH STUFF
C
      IF(FIXLT) GO TO 440
      LTUPLE = LTUPLE + NSORT
      LTUMAX = LTUMAX + 1
      LTUMIN = LTUMIN + 1
C
C  CALL SOCON TO DO THE ACTUAL SORT
C
  440 CONTINUE
      IERR = 0
      CALL SWCON(BUFFER,LIMIT,INFIL,OUTFIL,IERR)
      IF(IERR.EQ.0) GO TO 450
	if(nout.eq.6)goto 3141
      WRITE(NOUT,445)
  445 FORMAT(17H -ERROR- SORT I/O)
      NSORT = 0
      GO TO 999
3141	write(c128wk,445)
	call atxto
	goto 999
C
  450 CONTINUE
      RMSTAT = 0
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE SPOUT(STRING,NUMC)
      INCLUDE rin:TEXT.BLK
C
C     WRITE A LINE TO OUTPUT IGNORING TRAILING BLANKS
C
      INCLUDE rin:FILES.BLK
      INCLUDE rin:BLNKFL.BLK
      INCLUDE rin:MISC.BLK
      INTEGER STRING(*)
      BLNKFL = .TRUE.
      NW = (NUMC-1)/CHPWD
      NW = NW + 1
      NEND = NW
      DO 10 I=1,NEND
      IF(STRING(NW).NE.IBLANK) GO TO 20
      NW = NW - 1
   10 CONTINUE
      BLNKFL = .FALSE.
      RETURN
   20 CONTINUE
	if(noutr.eq.6)goto 3140
      WRITE (NOUTR,30)(STRING(I),I=1,NW)
   30 FORMAT(33A4)
      RETURN
3140	write(c128wk,30)(string(i),i=1,nw)
	call atxto
	return
      END
      SUBROUTINE STATUS(FILE,LFS)
      INCLUDE rin:TEXT.BLK
      CHARACTER*7 FILE
      LOGICAL EX
      LFS = 0
      INQUIRE(FILE=FILE,EXIST=EX)
      IF(EX) LFS = 1
      RETURN
      END
      SUBROUTINE STRMOV(IST1,IPOS1,NCH,IST2,IPOS2)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   MOVE A STRING OF CHARACTERS FROM ONE ARRAY TO ANOTHER
C
C  PARAMETERS:
C     IST1----ORIGINAL STRING WITH THE CHARACTERS TO BE MOVED
C     IPOS1---STARTING POSITION WITHIN THAT STRING
C     NCH-----NUMBER OF CHARACTERS TO MOVE
C     IST2----STRING TO RECEIVE THE CHARACTERS
C     IPOS2---STARTING POSITION WITHIN THAT STRING
C
      Character*1 IST1(*),IST2(*)
      INTEGER C1,C2
C
C  MAKE SURE THAT THINGS LOOK OK.
C
      IF(NCH.LE.0) RETURN
      C1 = IPOS1
      C2 = IPOS2
C
C  MOVE THE CHARACTERS FROM THE FIRST STRING TO THE SECOND.
C
      DO 100 I=1,NCH
      IST2(C2) = IST1(C1)
      C1 = C1 + 1
      C2 = C2 + 1
  100 CONTINUE
      RETURN
      END
      SUBROUTINE SUBREL
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE FINDS THE DIFFERENCE OF TWO RELATIONS BASED UPON
C  ATTRIBUTES.  THE RESULT FROM THIS PROCESS IS A PHYSICAL
C  RELATION WHICH HAS ALL TUPLES FROM THE SECOND RELATION WHICH
C  DO NOT HAVE MATCHES IN THE FIRST.
C
C  THE SYNTAX FOR THE SUBTRACT COMMAND IS:
C
C   SUBTRACT REL1 FROM REL2 FORMING REL3 [USING ATTR1 ATTR2...ATTR-N]
C
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:MISC.BLK
C
      INTEGER PTABLE
      LOGICAL EQKEYW
      INCLUDE rin:DCLAR1.BLK
      INCLUDE rin:DCLAR3.BLK
C
C  CALL RMDBLK TO MAKE SURE DATABASE MAY BE MODIFIED
C
      CALL RMDBLK(DBNAME)
      IF(RMSTAT.EQ.0) GO TO 50
      CALL WARN(RMSTAT,DBNAME,0)
      GO TO 9999
C
C  LOCAL ARRAYS AND VARIABLES :
C
C  PTABLE (MATRIX 10) USED TO CONTROL POINTERS
C        ROWS1,2 -- ATTRIBUTE NAME
C        ROW3 -- ATTRIBUTE LOCATION IN RELATION 1
C        ROW4 -- ATTRIBUTE LOCATION IN RELATION 2
C        ROW5 -- ATTRIBUTE LOCATION IN RELATION 3
C        ROW6 -- LENGTH IN WORDS
C        ROW7 -- ATTRIBUTE TYPE
C
C  EDIT COMMAND SYNTAX
C
   50 CONTINUE
      CALL BLKCLN
      NS = 0
      IF(.NOT.EQKEYW(3,KWFROM,4)) GO TO 9900
      IF(.NOT.EQKEYW(5,KWFORM,7)) GO TO 9900
      ITEMS = LXITEM(IDUMMY)
      IF(ITEMS.GT.6 .AND. .NOT.EQKEYW(7,KWUSIN,5)) GO TO 9900
C
C  KEYWORD SYNTAX OKAY
C
      RNAME1 = BLANK
      CALL LXSREC(2,1,8,RNAME1,1)
      I = LOCREL(RNAME1)
      IF(I.EQ.0) GO TO 100
C
C  MISSING FIRST RELATION.
C
      CALL WARN(1,RNAME1,0)
      GO TO 9999
  100 CONTINUE
C
C  SAVE DATA ABOUT RELATION 1
C
      I1 = LOCPRM(RNAME1,1)
      IF(I1.EQ.0) GO TO 110
      CALL WARN(9,RNAME1,0)
      GO TO 9999
  110 CONTINUE
      NCOL1 = NCOL
      NATT1 = NATT
      RNAME2 = BLANK
      CALL LXSREC(4,1,8,RNAME2,1)
      I = LOCREL(RNAME2)
      IF(I.EQ.0) GO TO 200
C
C  MISSING SECOND RELATION.
C
      CALL WARN(1,RNAME2,0)
      GO TO 9999
  200 CONTINUE
C
C  SAVE DATA ABOUT RELATION 2
C
      I2 = LOCPRM(RNAME2,1)
      IF(I2.EQ.0) GO TO 210
      CALL WARN(9,RNAME2,0)
      GO TO 9999
  210 CONTINUE
      NCOL2 = NCOL
      NATT2 = NATT
      RPW2 = RPW
      MPW2 = MPW
C
C  CHECK FOR LEGAL RNAME3
C
      IF((LXLENC(6).GE.1).AND.(LXLENC(6).LE.8)) GO TO 250
      CALL WARN(7,KWRELA,BLANK)
      GO TO 9999
  250 CONTINUE
C
C  CHECK FOR DUPLICATE RELATION 3
C
      RNAME3 = BLANK
      CALL LXSREC(6,1,8,RNAME3,1)
      I = LOCREL(RNAME3)
      IF(I.NE.0) GO TO 300
C
C  ERROR
C
	if(nout.eq.6)goto 3141
      WRITE(NOUT,9000)
 9000 FORMAT(55H -ERROR- Resultant Relation Does Not Have A Unique Name)
      GO TO 9999
3141	write(c128wk,9000)
	call atxto
	goto 9999
C
C  CHECK USER READ SECURITY
C
  300 CONTINUE
      IF((I1.NE.0).OR.(I2.NE.0)) GO TO 9999
C
C  RELATION NAMES OKAY -- CHECK THE ATTRIBUTES
C
C  SET UP PTABLE IN MATRIX POSITION 10
C
      CALL BLKDEF(10,7,NATT2)
      PTABLE = BLKLOC(10)
      NATT3 = 0
      IF(ITEMS.EQ.6) GO TO 500
C
C  SUBTRACT ON SOME OF THE ATTRIBUTES
C
      IF(ITEMS-7.LE.NATT2) GO TO 350
	if(nout.eq.6)goto 3143
      WRITE(NOUT,9001)
 9001 FORMAT(38H -ERROR- Too Many Attributes Specified)
      GO TO 9999
3143	write(c128wk,9001)
	call atxto
	goto 9999
  350 CONTINUE
      IJ = 1
      DO 400 I=8,ITEMS
C
C  RETRIEVE ATTRIBUTE LENGTH FOR OLD ATTRIBUTE
C
C
C  SEE IF IT FROM RELATION 1.
C
      ANAME = BLANK
      CALL LXSREC(I,1,8,ANAME,1)
      ICHK1 = LOCATT(ANAME,RNAME1)
C
C  SEE IF IT IS FROM RELATION 2.
C
      ICHK2 = LOCATT(ANAME,RNAME2)
      IF(ICHK2.NE.0) GO TO 450
C
C  ATTRIBUTE IS OKAY -- SET UP PTABLE
C
      CALL ATTGET(ISTAT)
      NATT3 = NATT3 + 1
      BUFFER(PTABLE) = LXWREC(I,1)
      BUFFER(PTABLE+1) = LXWREC(I,2)
      BUFFER(PTABLE+3) = ATTCOL
      BUFFER(PTABLE+4) = IJ
      NWORDS = ATTWDS
      BUFFER(PTABLE+5) = ATTLEN
      IF(NWORDS.EQ.0) NWORDS = 1
      IJ = IJ + NWORDS
      BUFFER(PTABLE+6) = ATTYPE
      IF(ICHK1.NE.0) GO TO 360
      ICHK1 = LOCATT(ANAME,RNAME1)
      CALL ATTGET(ISTAT)
      BUFFER(PTABLE+2) = ATTCOL
  360 CONTINUE
      PTABLE = PTABLE + 7
C
  400 CONTINUE
      ICT = IJ - 1
      GO TO 555
C
C  ATTRIBUTE WAS NOT IN RELATION 2
C
  450 CONTINUE
      CALL WARN(3,ANAME,RNAME2)
      GO TO 9999
C
C  SUBTRACT IS ON ALL ATTRIBUTES
C
  500 CONTINUE
      ICT = 1
C
C  STORE DATA FROM RELATION 2 IN PTABLE
C
      I = LOCATT(BLANK,RNAME2)
      DO 525 I=1,NATT2
      CALL ATTGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 525
      NATT3 = NATT3 + 1
      BUFFER(PTABLE) = IBLANK
      CALL STRMOV(ATTNAM,1,8,BUFFER(PTABLE),1)
      BUFFER(PTABLE+3) = ATTCOL
      BUFFER(PTABLE+4) = ICT
      NWORDS = ATTWDS
      BUFFER(PTABLE+5) = ATTLEN
      IF(NWORDS.EQ.0) NWORDS = 1
      ICT = ICT + NWORDS
      BUFFER(PTABLE+6) = ATTYPE
      PTABLE = PTABLE + 7
  525 CONTINUE
C
C  MARK COMMON ATTRIBUTES FROM RELATION 1
C
C
C  FIRST CHECK TO SEE IF ATTRIBUTE IS ALREADY IN PTABLE
C
      KQ1 = BLKLOC(10) - 7
      DO 550 I=1,NATT2
      KQ1 = KQ1 + 7
      J = LOCATT(BUFFER(KQ1),RNAME1)
      IF(J.NE.0) GO TO 550
C
C  ALREADY THERE -- CHANGE THE 2ND POINTER
C
      CALL ATTGET(ISTAT)
      BUFFER(KQ1+2) = ATTCOL
  550 CONTINUE
      ICT = ICT - 1
C
C  DONE LOADING PTABLE
C
C  SEE IF THERE ARE ANY COMMON ATTRIBUTES.
C
  555 CONTINUE
      PTABLE = BLKLOC(10)
      DO 570 I = 1,NATT3
      IF((BUFFER(PTABLE+2).NE.0).AND.(BUFFER(PTABLE+3).NE.0)) GO TO 600
      PTABLE = PTABLE + 7
  570 CONTINUE
C
C  NO COMMON ATTRIBUTES
C
	if(nout.eq.6)goto 3144
      WRITE(NOUT,9002) RNAME1,RNAME2
 9002 FORMAT(19H -ERROR- RELATIONS ,A8,5H AND ,A8,
     X26H Have No Common Attributes)
      GO TO 9999
3144	write(c128wk,9002)rname1,rname2
	call atxto
	goto 9999
C
C  PTABLE IS CONSTRUCTED
C
C  NOW CREATE ATTRIBUTE AND RELATION TABLES AND THE RELATION
C
  600 CONTINUE
C
C  SET UP THE WHERE CLAUSE FOR THE SUBTRACT.
C  THIS IS A DUMMY WHERE CLAUSE USED ONLY BY THE KEY PROCESSING
C
      KEYCOL = BUFFER(PTABLE+3)
      KEYTYP = BUFFER(PTABLE+6)
      NBOO = -1
      KATTL(1) = BUFFER(PTABLE+5)
      KATTY(1) = KEYTYP
      IF(KEYTYP.EQ.KZIVEC) KATTY(1) = KZINT
      IF(KEYTYP.EQ.KZRVEC) KATTY(1) = KZREAL
      IF(KEYTYP.EQ.KZDVEC) KATTY(1) = KZDOUB
      IF(KEYTYP.EQ.KZIMAT) KATTY(1) = KZINT
      IF(KEYTYP.EQ.KZRMAT) KATTY(1) = KZREAL
      IF(KEYTYP.EQ.KZDMAT) KATTY(1) = KZDOUB
      KOMPOS(1) = 1
      KSTRT = 0
      MAXTU = ALL9S
      LIMTU = ALL9S
C
C  SET UP RELATION TABLE.
C
      NAME = RNAME3
      CALL RMDATE(RDATE)
      NCOL = ICT
      NCOL3 = ICT
      NATT = NATT3
      NTUPLE = 0
      RSTART = 0
      REND = 0
      RPW = RPW2
      MPW = MPW2
      CALL RELADD
C
      CALL ATTNEW(NAME,NATT)
      PTABLE = BLKLOC(10)
      DO 700 K=1,NATT3
      ATTNAM = BLANK
      CALL STRMOV(BUFFER(PTABLE),1,8,ATTNAM,1)
      RELNAM = NAME
      ATTCOL = BUFFER(PTABLE+4)
      ATTLEN = BUFFER(PTABLE+5)
      ATTYPE = BUFFER(PTABLE+6)
      ATTKEY = 0
      CALL ATTADD
      PTABLE = PTABLE + 7
  700 CONTINUE
C
C  SEE IF WE CAN DO KEY PROCESSING.
C
      PTABLE = BLKLOC(10) - 7
      DO 800 K=1,NATT3
      PTABLE = PTABLE + 7
      IF(BUFFER(PTABLE+2).EQ.0) GO TO 800
      IF(BUFFER(PTABLE+3).EQ.0) GO TO 800
      J = LOCATT(BUFFER(PTABLE),RNAME1)
      IF(J.NE.0) GO TO 800
      CALL ATTGET(ISTAT)
      IF(ATTKEY.EQ.0) GO TO 800
C
C  WE FOUND A KEY ELEMENT IN MATN1 WHICH IS COMMON.
C
      KSTRT = ATTKEY
      NS = 2
      KATTL(1) = BUFFER(PTABLE+5)
      KATTY(1) = BUFFER(PTABLE+6)
      KEYCOL = BUFFER(PTABLE+3)
      GO TO 900
  800 CONTINUE
  900 CONTINUE
C
C  CALL SUBTRC TO CONSTRUCT MATN3
C
      CALL BLKDEF(11,MAXCOL,1)
      KQ3 = BLKLOC(11)
      PTABLE = BLKLOC(10)
      I = LOCREL(RNAME2)
      CALL SUBTRC(RNAME1,RNAME3,BUFFER(KQ3),NCOL3,NATT3,BUFFER(PTABLE),
     XKEYCOL,KEYTYP)
      GO TO 9999
C
C  SYNTAX ERROR IN SUBTRACT COMMAND
C
 9900 CONTINUE
      CALL WARN(4,0,0)
C
C
C  DONE WITH SUBTRACT
C
 9999 CONTINUE
      CALL BLKCLR(10)
      CALL BLKCLR(11)
      RETURN
      END
      SUBROUTINE SUBTRC(RNAME1,RNAME3,MATN3,NCOL3,NATT3,PTABLE,
     XKEYCOL,KEYTYP)
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE PERFORMS THE ACTUAL SUBTRACT BETWEEN
C  RELATION 1 AND 2 FORMING 3
C
C  PARAMETERS:
C         NAME1---NAME OF THE FIRST RELATION
C         MATN3---DATA TUPLE FOR RELATION 3
C         NCOL3---NUMBER OF FIXED LENGTH COLUMNS IN MATN3
C         NATT3---NUMBER OF ATTRIBUTES IN MATN3
C         PTABLE--POINTER TABLE FOR THIS SUBTRACT
C         KEYCOL--COLUMN OF MATN2 USED FOR SUPPLYING KEY VALUES
C         KEYTYP--ATTRIBUTE TYPE OF MATN1 USED FOR KEY VALUES
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:RIMPTR.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:DCLAR1.BLK
      DIMENSION MATN3(*)
      INTEGER PTABLE(7,*)
      INTEGER ATTLEN
      INTEGER ENDCOL
C
C  INITIALIZE THE MATRIX POINTERS.
C
      IDST = 0
      IDNEW = 0
      IDCUR = NID
C
C  GET THE PARAMETERS FOR THE FIRST MATRIX.
C
      I = LOCREL(RNAME1)
      IDM1 = NID
      NSP = 0
      IF(KSTRT.NE.0) NSP = 2
      NTUP3 = 0
C
C  SEQUENCE THROUGH MATN2.
C
  100 CONTINUE
      IF(IDCUR.EQ.0) GO TO 1000
      CALL ITOH(N1,N2,IDCUR)
      IF(N2.EQ.0) GO TO 1000
      CALL GETDAT(2,IDCUR,MATN2,NCOL2)
      IF(IDCUR.LT.0) GO TO 1000
C
C  MOVE THE COMPARISON VALUE INTO THE WHCOM ARRAYS.
C
      CALL ITOH(NCHAR,NWORDS,KATTL(1))
      IP = MATN2 + KEYCOL - 1
      IF(NWORDS.NE.0) GO TO 110
C
C  SPECIAL GYRATIONS FOR VARIABLE LENGTH STUFF.
C
      IP2 = BUFFER(IP)
      IP = MATN2 + IP2 + 1
  110 CONTINUE
      WHRVAL(1) = BUFFER(IP)
      NID = IDM1
      NS = NSP
  200 CONTINUE
      CALL RMLOOK(MATN1,1,1,NCOL1)
      IF(RMSTAT.NE.0) GO TO 400
C
C  CHECK TO SEE IF THE ATTRIBUTES MATCH.
C
      K = 1
  300 CONTINUE
      CALL PTRS(IPT1,IPT2,K,NATT3,PTABLE,LEN,ITYPE)
C
C  IF K IS 0 WE HAVE LOOKED AT ALL THE COMMON ATTRIBUTES.
C
      IF(K.EQ.0) GO TO 100
      I1 = MATN1 + IPT1 - 1
      I2 = MATN2 + IPT2 - 1
      IF(LEN.EQ.0) GO TO 320
      DO 310 I=1,LEN
      IF(BUFFER(I1).NE.BUFFER(I2)) GO TO 200
      I1 = I1 + 1
      I2 = I2 + 1
  310 CONTINUE
C
C  A MATCH. LOOK AT MORE ATTRIBUTES.
C
      GO TO 300
C
C  VARIABLE LENGTH ATTRIBUTE PROCESSING.
C
  320 CONTINUE
      IPT1 = BUFFER(I1)
      IPT2 = BUFFER(I2)
      I1 = MATN1 + IPT1 - 1
      I2 = MATN2 + IPT2 - 1
      IF(BUFFER(I1).NE.BUFFER(I2)) GO TO 200
      LEN = BUFFER(I1)
      I1 = I1 + 2
      I2 = I2 + 2
      DO 340 I=1,LEN
      IF(BUFFER(I1).NE.BUFFER(I2)) GO TO 200
      I1 = I1 + 1
      I2 = I2 + 1
  340 CONTINUE
      GO TO 300
C
C  OKAY -- NOW LOAD THE DATA.
C
  400 CONTINUE
      ENDCOL = NCOL3
      DO 900 KLM=1,NATT3
      KOL2 = PTABLE(4,KLM)
      KOL3 = PTABLE(5,KLM)
      ATTLEN = PTABLE(6,KLM)
      CALL ITOH(NCHAR,NWORDS,ATTLEN)
      IF(NWORDS.EQ.0) GO TO 700
      DO 600 I=1,NWORDS
C
C  LOAD THE ATTRIBUTE FROM MATN2.
C
      I2 = MATN2 + KOL2 - 1
      MATN3(KOL3) = BUFFER(I2)
      KOL3 = KOL3 + 1
      KOL2 = KOL2 + 1
  600 CONTINUE
      GO TO 900
  700 CONTINUE
      ENDCOL = ENDCOL + 1
      MATN3(KOL3) = ENDCOL
      I2 = MATN2 + KOL2 - 1
      KOL2 = BUFFER(I2)
      I2 = MATN2 + KOL2 - 1
      NWORDS = BUFFER(I2)
      MATN3(ENDCOL) = NWORDS
      NWORDS = NWORDS + 1
      DO 800 I=1,NWORDS
      ENDCOL = ENDCOL + 1
      I2 = I2 + 1
      MATN3(ENDCOL) = BUFFER(I2)
  800 CONTINUE
  900 CONTINUE
      CALL ADDDAT(3,IDNEW,MATN3,ENDCOL)
      IF(IDST.EQ.0) IDST = IDNEW
      NTUP3 = NTUP3 + 1
C
C  LOOK FOR MORE IN MATN2.
C
      GO TO 100
C
C  ALL DONE.
C
 1000 CONTINUE
      I = LOCREL(RNAME3)
      CALL RELGET(ISTAT)
      RSTART = IDST
      REND = IDNEW
      NTUPLE = NTUP3
      CALL RELPUT
      NUM = NTUP3
	if(nout.eq.6)goto 3147
      WRITE(NOUT,9000) NUM
 9000 FORMAT(31H Successful SUBTRACT Operation ,
     XI6,15H Rows Generated)
C
C  RETURN
C
      RETURN
3147	write(c128wk,9000)num
	call atxto
	return
      END
      SUBROUTINE SWCON(BUFFER,LBUF,INFIL,OUTFIL,IERR)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE  CONTROLLING ROUTINE FOR SORT
C
C  METHOD   ROUTINE DETERMINES WHICH KIND
C           OF SORT IS REQUIRED AND CALLS
C           APPLICABLE ROUTINE TO CARRY OUT SORT
C           THE 4 TYPES OF SORT THAT ARE AVAILABLE ARE
C
C           INCORE,LINK LIST (HART)
C           INCORE,IN SITU POINTERS
C           OUT-OF-CORE,FIXED TUPLE SIZE
C           OUT-OF-CORE,VARIABLE TUPLE SIZE
C           INCORE SORT IS FIXED OR VARIABLE
C           LTUPLE TUPLES
C
C  TIMING   UNKNOWN
C
C  DEFINITION OF VARIABLES
C
C  INFIL   FILE NAME OF FILE (SEQ) WHICH    (INT,I)
C          CONTAINS INPUT TUPLES
C         INFIL IS UNFORMATTED (BINARY)
C         EACH TUPLE IS WRITTEN AS A
C         RECORD AS FOLLOWS
C         FOR FIXED LENGTH RECORDS
C           WRITE(INFIL) (TUP(I),I=1,LTUPLE)
C         FOR VARIABLE LENGTH RECORDS
C           WRITE(INFIL) L,(TUP(I),I=1,L)
C
C  OUTFIL  FILE NAME OF FILE (SEQ) WHICH    (INT,I)
C          CONTAINS OUTPUT (SORTED) TUPLES
C          OUTFIL MAY EQ INFIL
C          FORMAT OF OUTFIL IS THE
C          SAME AS THAT OF INFIL
C
C  IERR    ERROR CONDITION                  (INT,O)
C           0 NORMAL RETURN
C           1 ERROR IN FILE READ
C           2 ERROR IN FILE WRITE
C
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:SRTCOM.BLK
      INTEGER OUTFIL,INFIL
      REAL*8 SCFIL1,SCFIL2
C
C  THE FOLLOWING THREE EXEC STATEM TO BE REPL
C  WITH UPDATE *CALL
C
      INTEGER BUFFER(*)
      INTEGER DPRU
      INCLUDE rin:DATA4.BLK
C
C  ESTABLISH RANDOM SCRATCH FILE NAMES
C
      SCFIL1 = K8ZZ98
      SCFIL2 = K8ZZ99
      REWIND INFIL
      I1 = 2*NSORT + 12
      IF(NSORT .GT. 2000) I1 = I1 + 89
   20 CONTINUE
      I3 = LTUPLE
      IF(FIXLT) I3 = LTUPLE*NSORT
      IF(I1+I3 .GT. LBUF) GO TO 100
C
C  INCORE SORT,HART METHOD
C
      CALL SWHART(INFIL,OUTFIL,BUFFER,I1,IERR)
      GO TO 400
  100 CONTINUE
      IF(NSORT+I3 .GT. LBUF) GO TO 200
C
C  INCORE SORT,POINTERS IN SITU
C
      CALL SWINPO(INFIL,OUTFIL,BUFFER,IERR)
      GO TO 400
  200 CONTINUE
CC
C  OUT-OF-CORE SORT
C
      IF( FIXLT) GO TO 300
C
C  VARIABLE LENGTH OUT-OF-CORE SORT
C
      CALL SWVLFS(INFIL,OUTFIL,SCFIL1,SCFIL2,
     X                 BUFFER,LBUF,LPRU,DPRU,IERR)
      GO TO 400
  300 CONTINUE
C
C  FIXED TUPLE LENGTH,OUT-OF-CORE SORT
C
      CALL SWFLFS(INFIL,OUTFIL,SCFIL1,SCFIL2,
     X                 BUFFER,LBUF,LPRU,DPRU,IERR)
  400 CONTINUE
      REWIND OUTFIL
      RETURN
      END
      SUBROUTINE SWCOST(NOPASS,NREC,LREC,SORD,COST)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE  DETERMINE COST OF A SORTING STRATEGY
C
C  METHOD   COMPUTE COST FROM FORMULA
C           COST=NOPASS*(2*NREC*(IOPOSC+LREC*IOTRAC) +
C                 + NSORT*NSOVAR*.5*SORD*COCOST
C                 + NREC*LREC*MOCOFI
C                 + NREC*(LREC-1)*MOCOAD)
C
C  DEFINITION OF PARAMETERS
C
C  NOPASS  NUMBER OF SORT PASSES EXCLUDING SEQUENTIAL     (INT,I)
C          READ AND WRITE (FIRST AND LAST)
C          EACH PASS CONSISTS OF ONE READ AND ONE WRITE
C
C  NREC   NUMBER OF PAGES ON SORT SCRATCH FILE           (INT,I)
C
C  LREC    LENGTH OF A SORT PAGE                          (INT,I)
C
C  SORD     SORT ORDER,I.E. NUMBER OF INPUT SORT BLOCKS   (INT,I)
C           IN CORE DURING MERGE PHASE
C
C  COST FORMULA PARAMETERS
C
C  IOPOSC  = RELATIVE COST FOR I OR O POSITIONING
C
C  IOTRAC  = RELATIVE COST OF I OR O TRANSFER OF ONE WORD
C
C  COCOST  = RELATIVE COST OF COMPARING TWO SINGLE VARIABLES
C
C  MOCOFI  = RELATIVE COST OF MOVING FIRST WORD OF ONE
C            BLOCK IN CORE
C
C  MOCOAD  = RELATIVE COST OF MOVING ADDITIONAL WORDS
C            OF THE BLOCK IN CORE
C
      INCLUDE rin:SRTCOM.BLK
      INTEGER SORD
      REAL IOPOSC,IOTRAC,COCOST,MOCOFI,MOCOAD
      INCLUDE rin:DATA5.BLK
      COST = NOPASS*(2*NREC*(IOPOSC+LREC*IOTRAC)
     X      +NSORT*NSOVAR*.5*SORD*COCOST
     X      +NREC*MOCOFI+NREC*(LREC-1)*MOCOAD)
      RETURN
      END
      SUBROUTINE SWFILO(BUFFER,LTUP,LREC,NTUREC,NINTUP,
     X                  INFIL,OUTFIL)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE  LOADING PASS FOR OUT-OF-CORE SORT
C           OF FIXED LENGTH TUPLES
C
C  TIMING   UNKNOWN
C
C  DEFINITION OF VARIABLES
C
C  BUFFER   CORE SCRATCH AREA OF                  (SCRATCH)
C           SUFFICIENT LENGTH
C              GE NINTUP*(1+LREC)+NTUREC*LREC
C
C  LTUP     LENGTH, IN WORDS, OF INDIVIDUAL       (INT,I)
C           TUPLE
C
C  LREC     LENGTH, IN WORDS, OF OUTPUT RECORD    (INT,I)
C
C  NTUREC   NUMBER OF TUPLES PER OUTPUT           (INT,I)
C           RECORD
C
C  NINTUP     NUMBER OF TUPLES                      (INT,I)
C           IN ONE SORT CHAIN
C
C
C  INFIL   FILE NAME OF FILE (SEQ) WHICH    (INT,I)
C           CONTAINS INPUT TUPLES
C           INFIL IS UNFORMATTED (BINARY)
C           EACH TUPLE IS WRITTEN AS A
C           RECORD AS FOLLOWS
C           FOR FIXED LENGTH RECORDS
C             WRITE(INFIL) (TUP(I),I=1,LTUPLE)
C           FOR VARIABLE LENGTH RECORDS
C             WRITE(INFIL) L,(TUP(I),I=1,L)
C
C  OUTFIL   FET FOR FILE      (RANDOM) WHICH      (INT,I)
C           CONTAINS CHAINS OF SORTED TUPLES
C           EACH CHAIN CONTAINS ONE OR MORE BLOCKS
C           EACH BLOCK CONTAINS
C            WORD 1   = NO TUPLES IN BLOCK
C            WORD 2   = CHAIN NO,NEG FOR LAST BLOCK
C            WORD 3FF = TUPLES INSORTED ORDER
C
C
      INCLUDE rin:SRTCOM.BLK
      INTEGER BUFFER(*)
      REWIND INFIL
      I2 = 0
      J1 = NINTUP*(1+LTUP)
      I8 = 0
   10 CONTINUE
      I8 = I8 + 1
      I1 = NINTUP
      DO 20 I=1,NINTUP
      READ(INFIL) (BUFFER(I1+I3),I3=1,LTUP)
      I2 = I2 + 1
      BUFFER(I) = I1 + 1
      I1 = I1 + LTUP
      IF(I2 .EQ. NSORT) GO TO 21
   20 CONTINUE
      I = NINTUP
   21 CONTINUE
C
C     READ COMPLETE FOR ONE CHAIN - SORT
C
      CALL SWICST(BUFFER,BUFFER,I)
C
C     SORT COMPLETE - UNLOAD
C
      I3 = 0
   40 CONTINUE
      I4 = J1 + 2
      DO 50 I5=1,NTUREC
      I3 = I3 + 1
      I7 = BUFFER(I3) - 1
      DO 45 I6=1,LTUP
   45 BUFFER(I4+I6) = BUFFER(I7+I6)
      I4 = I4 + LTUP
      IF(I3 .EQ. I) GO TO 55
   50 CONTINUE
      I5 = NTUREC
   55 CONTINUE
C
C  WRITE ONE RECORD
C
      BUFFER(J1+1) = I5
      I7 = I8
      IF(I3 .EQ. I) I7 = -I7
   60 BUFFER(J1+2) = I7
C
C  ADD IN RANDOM I/O STUFF
C
      CALL RIOOUT(OUTFIL,0,BUFFER(J1+1),LREC,IOS)
      IF(I3 .LT. I) GO TO 40
      IF(I2 .LT. NSORT) GO TO 10
C
C     SORT PASS COMPLETE FOR ALL CHAINS
C
      RETURN
      END
      SUBROUTINE SWFLFS(INFIL,OUTFIL,SCFIL1,SCFIL2,
     X                 BUFFER,LBUF,LPRU,DPRU,IERR)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE  DRIVER FOR OUT-OF-CORE SORT
C           OF FIXED LENGTH TUPLES
C
C  METHOD   A LEAST COST SORT STRATEGY
C           IS ESTABLISHED BASED UPON
C           MACHINE DEPENDENT PARAMETERS
C           THE COST IS BASED UPON
C           COST FOR POSITIONING ON
C           MASS STORAGE,MASS STORAGE
C           TRANSFERS,IN-CORE MOVEMENT
C           OF DATA AND COMPARISON OF
C           DATA.
C           AN N-ARY SORT/MERGE STRATEGY
C           IS CHOOSEN WHERE 2 LE N LE 9
C           N IS THE NUMBER OF CHAINS
C           OF DATA THAT IS MERGED IN
C           ONE SINGLE MERGE. EACH SORT PASS
C           MAY REQUIRE SEVERAL SUCH MERGES.
C
C
C
C
C  DEFINITION OF VARIABLES
C
C  INFIL   FILE NAME OF FILE (SEQ) WHICH    (TEXT,I)
C          CONTAINS INPUT TUPLES
C         INFIL IS UNFORMATTED (BINARY)
C         EACH TUPLE IS WRITTEN AS A
C         RECORD AS FOLLOWS
C         FOR FIXED LENGTH RECORDS
C           WRITE(INFIL) (TUP(I),I=1,LTUPLE)
C         FOR VARIABLE LENGTH RECORDS
C           WRITE(INFIL) L,(TUP(I),I=1,L)
C
C  OUTFIL  FILE NAME OF FILE (SEQ) WHICH    (TEXT,I)
C          CONTAINS OUTPUT (SORTED) TUPLES
C          OUTFIL MAY EQ INFIL
C          FORMAT OF OUTFIL IS THE
C          SAME AS THAT OF INFIL
C
C  SCFIL1  FILE NAME OF (RAN) SCRATCH FILE  (TEXT,I)
C
C  SCFIL2  FILE NAME OF (RAN) SCRATCH FILE  (TEXT,I)
C          NOTE THAT SCFIL1 MUST NOT BE
C          EQUAL TO SCFIL2
C
C  BUFFER  INCORE SCRATCH AREA              (ANY,SCRATCH)
C
C  LBUF    LENGTH OF BUFFER                 (INT,I)
C
C  LPRU    QUANTUM LENGTH OF RANDOM         (INT,I)
C          FILE RECORDS
C
C  DPRU    DELTA QUANTUM LENGTH OF          (INT,I)
C          RANDOM FILE RECORDS.
C          THE LENGTH OF SUCH A RECORD
C          MUST EQUAL
C          I*LPRU+DPRU
C
C  IERR    ERROR CONDITION                  (INT,O)
C           0 NORMAL RETURN
C           1 ERROR IN FILE READ
C           2 ERROR IN FILE WRITE
C
C
C  DEFINITION OF LOCAL VARIABLES
C
C  I1     SCRATCH
C  I2     SCRATCH,NO OF PAGES IN INITIAL
C         OFLOADING
C  I3     SCRATCH,NO OF SORT PASSES,NOT COUNTING
C         ACTIONS ON SEQUENTIAL FILES
C         OF WHOLE RANDOM FILES
C  I4     SCRATCH
C  I5     SCRATCH
C  I6     LOW COST SORT ORDER
C  I7     NO OF INCORE PAGES IN INITIAL
C         PASS WHERE SEQUENTIAL FILE IS
C         OFFLOADED
C  I8     SCRATCH,NO OF TUPLES PER RAN FILE PAGE
C  I9     SCRATCH,NO OF PAGES ON RANDOM FILES
C  I10    SCRATCH,LENGTH OF RANDOM FILE PAGE
C  COST   COST OF OPTIMUM SORT STRATEGY
C  NTUREC NO OF TUPLES PER RANDOM FILE PAGE
C  NRECS  NO OF PAGES ON RANDOM SCRATCH FILE
C  LREC   LENGTH OF RANDOM FILE PAGE
C  NPASS  NO OF SORT PASSES,NOT COUNTING
C         ACTIONS ON SEQUENTIAL FILES
C         ONE PASS CONTAINS ONE COMPLETE
C         WRITE AND ONE COMPLETE READ
C         OF WHOLE RANDOM FILES
C
      INCLUDE rin:SRTCOM.BLK
      DIMENSION BUFFER(*)
      INTEGER DPRU
      INTEGER SCARR1,SCARR2
      REAL*8 SCFIL1,SCFIL2
      INTEGER CHAIN1,OUTREC
      LOGICAL SWITCH
      LTUP = LTUPLE
      I6 = 0
      I1 = 2*LPRU
      I11 = 2*DPRU
      DO 100 I=2,9
      I1 = I1 + LPRU
      I11 = I11 + DPRU
      I10 = LPRU*((LBUF-I11)/I1) + DPRU
      IF(I10 .LT. LTUP) GO TO 110
      I8 = (I10-2)/LTUP
      I2 = (LBUF-I10)/(I10+I8)
C
C  I2 IS NO OF INCORE BLOCKS IN
C     INITIAL PASS
C
      I9 =(NSORT+I8-1)/I8
      I3 = 1
      I4 = I2
   10 CONTINUE
      I5 = I4
      I4 = I4*I + I5
      IF (I4 .GE. I9) GO TO 20
      I4 = I4 - I5
      I3 = I3 + 1
      GO TO 10
   20 CONTINUE
C
      CALL SWCOST(I3,I9,I10,I,A1)
      IF(I6 .GT. 0) GO TO 30
      GO TO 35
   30 CONTINUE
      IF(A1 .GE. COST) GO TO 90
   35 COST = A1
      I7 = I2
      I6 = I
      NTUREC = I8
      NRECS = I9
      NPASS = I3
      LREC = I10
   90 CONTINUE
      IF(I3 .EQ. 1) GO TO 110
  100 CONTINUE
  110 CONTINUE
C
C  OPTIMUM SORT STRATEGY DETERMINED
C
C  OPEN SORT SCRATCH FILES
C
      SCARR1 = 35
      SCARR2 = 36
      CALL DROPF(SCFIL1)
      CALL DROPF(SCFIL2)
      CALL RIOOPN(SCFIL1,SCARR1,LREC,IOS)
      CALL RIOOPN(SCFIL2,SCARR2,LREC,IOS)
      CALL SWFILO(BUFFER,LTUP,LREC,NTUREC,I7*NTUREC,
     X            INFIL,SCARR1)
C
C     NPASS IS THE NUMBER OF RANDOM TO RANDOM MERGES
C     NI IS THE NUMBER OF CHAINS ON THE INPUT FILE
C     NO IS THE NUMBER OF CHAINS ON THE OUTPUT FILE
C     NCHAIN IS THE NUMBER OF CHAINS TO MERGE
C     LCHAIN IS THE NUMBER OF PAGES PER INPUT CHAIN
C
      LCHAIN = I7
      NCHAIN = I6
      NI = (NRECS-1)/LCHAIN
      NI = NI + 1
      NO = NI
      SWITCH = .TRUE.
C
C     OUTER LOOP ON THE NUMBER OF PASSES
C
      NPASS = NPASS - 1
      IF(NPASS.EQ.0) GO TO 250
      DO 200 I=1,NPASS
      NI = NO
      NO = (NI-1)/NCHAIN
      NO = NO + 1
      SWITCH = .NOT. SWITCH
      INC = LCHAIN*NCHAIN
C
C     INNER LOOP ON NUMBER OF OUTPUT CHAINS
C
      DO 150 J=1,NO
      CHAIN1 = (J-1)*INC + 1
      OUTREC = CHAIN1
      IF(I.EQ.1) OUTREC = 0
      NCH = NCHAIN
      IF(J.EQ.NO) NCH = NI - (NO-1)*NCHAIN
      IF(SWITCH) CALL SWSMFL(BUFFER,CHAIN1,NCH,LCHAIN,OUTREC,J,NTUREC,
     X       LTUP,LREC,SCARR2,SCARR1)
      IF(.NOT.SWITCH) CALL SWSMFL(BUFFER,CHAIN1,NCH,LCHAIN,OUTREC,J,
     X       NTUREC,LTUP,LREC,SCARR1,SCARR2)
  150 CONTINUE
      LCHAIN = LCHAIN * NCHAIN
  200 CONTINUE
  250 CONTINUE
C
C     CALL SWUNLO TO CREATE OUTPUT SEQUENTIAL FILE
C
      CHAIN1 = 1
      OUTREC = 1
      NCH = NO
      IF(SWITCH) CALL SWUNLO(BUFFER,CHAIN1,NCH,LCHAIN,
     X      LTUP,LREC,SCARR1,OUTFIL)
      IF(.NOT.SWITCH) CALL SWUNLO(BUFFER,CHAIN1,NCH,LCHAIN,
     X      LTUP,LREC,SCARR2,OUTFIL)
C
C     RETURN THE SCRATCH RANDOM FILES
C
      CALL DROPF(SCFIL1)
      CALL DROPF(SCFIL2)
      RETURN
      END
      SUBROUTINE SWHART(INFIL,OUTFIL,BUFFER,LLL,IERR)
      INCLUDE rin:TEXT.BLK
      INCLUDE rin:SRTCOM.BLK
      INTEGER BUFFER(*)
      INTEGER OUTFIL
C
C  PURPOSE  CONTROLLING ROUTINE FOR IN-CORE HART SORT
C
C  TIMING   UNKNOWN
C
C  DEFINITION OF VARIABLES
C
C  INFIL   FILE NAME OF FILE (SEQ) WHICH    (INT,I)
C          CONTAINS INPUT TUPLES
C         INFIL IS UNFORMATTED (BINARY)
C         EACH TUPLE IS WRITTEN AS A
C         RECORD AS FOLLOWS
C         FOR FIXED LENGTH RECORDS
C           WRITE(INFIL) (TUP(I),I=1,LTUPLE)
C         FOR VARIABLE LENGTH RECORDS
C           WRITE(INFIL) L,(TUP(I),I=1,L)
C
C  OUTFIL  FILE NAME OF FILE (SEQ) WHICH    (INT,I)
C          CONTAINS OUTPUT (SORTED) TUPLES
C          OUTFIL MAY EQ INFIL
C          FORMAT OF OUTFIL IS THE
C          SAME AS THAT OF INFIL
C
C  BUFFER  CORE BUFFER TO USE FOR SORT      (ANY,SCR)
C
C  LLL     LENGTH OF LINK LIST              (INT,I)
C
C  IERR    ERROR CONDITION                  (INT,O)
C           0 NORMAL RETURN
C           1 ERROR IN FILE READ
C           2 ERROR IN FILE WRITE
C
      IF(FIXLT) GO TO 10
C
C  INCORE,VAR LENGTH
C
      I1 = LLL + 1
      DO 5 I2=1,NSORT
      BUFFER(I2) = I1 + 1
c      READ(INFIL) I4,(BUFFER(I1+I5),I5=1,I4)
      READ(INFIL) I4
      READ(INFIL) (BUFFER(I1+I5),I5=1,I4)
      BUFFER(I1) = I4
    5 I1 = I1 + I4 + 1
      GO TO 20
   10 CONTINUE
C
C  INCORE,FIXED LENGTH TUPLES
C
      I1 = LLL
      DO 15 I2=1,NSORT
      BUFFER(I2)= I1 + 1
      READ(INFIL) (BUFFER(I1+I4),I4=1,LTUPLE)
   15 I1 = I1 + LTUPLE
   20 CONTINUE
C
C  READ COMPLETED,SORT
C
      KGOTO = VARTYP(1)
      GO TO(21,22,23,23),KGOTO
   21 CALL SWHRTI(BUFFER(1),BUFFER(NSORT+1),BUFFER)
      GO TO 24
   22 CALL SWHRTR(BUFFER(1),BUFFER(NSORT+1),BUFFER)
      GO TO 24
   23 CALL SWHRTD(BUFFER(1),BUFFER(NSORT+1),BUFFER)
   24 CONTINUE
C
C  SORT COMPLETE,UNLOAD
C
      REWIND OUTFIL
      I5 = 2*NSORT + 1
      IF(FIXLT) GO TO 40
C
C  VARIABLE LENGTH TUPLES
C
      DO 35 I2=1,NSORT
      I3 = BUFFER(I5)
      I5 = NSORT + I3
      I1 = BUFFER(I3) - 1
      I4 = BUFFER(I1)
      WRITE(OUTFIL) I4,(BUFFER(I3+I1),I3=1,I4)
   35 CONTINUE
      RETURN
   40 CONTINUE
C
C  WRITE FIXED LENGTH TUPLES
C
      DO 45 I2=1,NSORT
      I3 = BUFFER(I5)
      I5 = I3 + NSORT
      I4 = BUFFER(I3) - 1
      WRITE(OUTFIL) (BUFFER(I3+I4),I3=1,LTUPLE)
   45 CONTINUE
      RETURN
      END
      SUBROUTINE SWHRTD(NN,LL,BUFFER)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE   TO SORT FIXED OR VARIABLE LENGTH
C            TUPLES ON ONE OR MORE ATTRIBUTES
C            INCORE SORT
C            GENERAL PURPOSE SORT
C
C  METHOD    FAST SORTING ALGORITHM PUBLISHED
C            1978 BY HART
C            CREATIVE COMPUTING JAN/FEB 1978
C            P 96 FF
C
C  TIMING   .13 CP SEC CYBER 760
C          1000 TUPLES,1 ATTRIBUTE SORT (INT)
C
C  DEFINITION OF VARIABLES
C
C  NN       VECTOR OF POINTERS TO BUFFER    (INT,I)
C
C  LL       LINK LIST OF POINTERS TO NN     (INT,O)
C           THE LIST DEFINES THE SORTED ORDER
C           ORDER OF BUFFER
C
C  BUFFER    VECTOR CONTAINING TUPLES TO SORT    (ANY,I)
C            NN POINTER ARE RELATIVE TO BUFFER(1)
C
      INCLUDE rin:SRTCOM.BLK
      INTEGER SWIICP,SWIRCP,SWIDCP,SWITCP
      DIMENSION NN(*),LL(*)
      INTEGER BUFFER(*)
      INTEGER S1
      K1=0
      I=0
      M1=0
      T2=0.
      T4=0.
      J=NSORT+1
      LL(1)=1
      LL(J)=1
      K2=1
      IF(NSORT.LE.1) RETURN
      S1=NSORT
  250 CONTINUE
C  CLIMB THE TREE
      IF(S1.LT.4) GO TO 320
      K2=K2*2
      B2=S1
      B2=B2/2.
      S1=INT(B2)
      T4=T4+(B2-S1)*K2
      GO TO 250
  320 CONTINUE
C  INITIAL CALCULATIONS
      T4=K2-T4
      B2=K2/2
  350 CONTINUE
C  NEXT TWIG
      IF(K1.EQ.K2) RETURN
      K1=K1+1
      T1=K1
      B1=B2
      T3=T2
  400 CONTINUE
C  ADD 1 TO REFLECTED BINARY COUNTER AND CARRY
      T1=T1/2.
      IF(INT(T1).LT.T1) GO TO 470
      M1=M1+1
      T2=T2-B1
      B1=B1/2.
      GO TO 400
  470 CONTINUE
C  TWIG CALCULATIONS
      T2=T2+B1
      IF(S1.EQ.2) GO TO 550
C  3-TWIGS AND 4-TWIGS
      IF(T3.LT.T4) GO TO 560
C  4-TWIG
      M1=-M1
      GO TO 630
  550 IF(T3.LT.T4) GO TO 610
  560 CONTINUE
C  3-TWIG
      M1=M1+1
      I=I+1
      LL(I)=I
      LL(J)=I
      J=J+1
  610 CONTINUE
C  2-TWIG
      M1=M1+1
  630 I=I+1
      L1=I
      LL(I)=I
      LL(J)=I
      L0=J
      J=J+1
      I=I+1
      L2=I
      LL(I)=I
      LL(J)=I
      GO TO 750
  700 CONTINUE
C  MERGE TWIGS AND BRANCHES
      J=J-1
      L0=J-1
      L1=LL(L0)
      L2=LL(J)
  750 CONTINUE
      DO 760 J3=1,NSOVAR
      JJ3 = VARPOS(J3) - 1
      NNL1 = NN(L1) + JJ3
      NNL2 = NN(L2) + JJ3
      KGOTO = VARTYP(J3)
      GO TO (751,752,753,754),KGOTO
  751 J2 = BUFFER(NNL2) - BUFFER(NNL1)
      GO TO 755
  752 J2 = SWIRCP(BUFFER(NNL1),BUFFER(NNL2))
      GO TO 755
  753 J2 = SWIDCP(BUFFER(NNL1),BUFFER(NNL2))
      GO TO 755
  754 J2 = SWITCP(BUFFER(NNL1),BUFFER(NNL2))
  755 CONTINUE
      IF(J2 .EQ. 0) GO TO 760
      IF((J2 .GT. 0 .AND. SORTYP(J3)) .OR.
     X   (J2 .LT. 0 .AND. .NOT. SORTYP(J3)))
     XGO TO 820
      GO TO 765
  760 CONTINUE
      GO TO 820
  765 CONTINUE
      LL(L0)=L2
  770 L0=L2
      L2=LL(L0)
      IF(L2.EQ.L0) GO TO 870
      DO 790 J3=1,NSOVAR
      JJ3 = VARPOS(J3) - 1
      NNL1 = NN(L1) + JJ3
      NNL2 = NN(L2) + JJ3
      KGOTO = VARTYP(J3)
      GO TO (781,782,783,784),KGOTO
  781 J2 = BUFFER(NNL2) - BUFFER(NNL1)
      GO TO 785
  782 J2 = SWIRCP(BUFFER(NNL1),BUFFER(NNL2))
      GO TO 785
  783 J2 = SWIDCP(BUFFER(NNL1),BUFFER(NNL2))
      GO TO 785
  784 J2 = SWITCP(BUFFER(NNL1),BUFFER(NNL2))
  785 CONTINUE
      IF(J2 .EQ. 0) GO TO 790
      IF((J2 .GT. 0 .AND. SORTYP(J3)) .OR.
     X   (J2 .LT. 0 .AND. .NOT. SORTYP(J3)))
     XGO TO 795
      GO TO 770
  790 CONTINUE
  795 CONTINUE
      LL(L0)=L1
  820 L0=L1
      L1=LL(L0)
      IF(L1.NE.L0) GO TO 750
      LL(L0)=L2
      GO TO 880
  870 LL(L0)=L1
  880 M1=M1-1
      IF(M1.GT.0) GO TO 700
      IF(M1.EQ.0) GO TO 350
C  GENERATE 2ND HALF OF A 4-TWIG
      M1=1-M1
      GO TO 630
      END
      SUBROUTINE SWHRTI(NN,LL,BUFFER)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE   TO SORT FIXED OR VARIABLE LENGTH
C            TUPLES ON ONE OR MORE ATTRIBUTES
C            INCORE SORT
C            FIRST SORT ATTRIBUTE IS INTEGER
C
C  METHOD    FAST SORTING ALGORITHM PUBLISHED
C            1978 BY HART
C            CREATIVE COMPUTING JAN/FEB 1978
C            P 96 FF
C
C  TIMING   .05 CP SEC CYBER 760
C          1000 TUPLES,1 ATTRIBUTE SORT (INT)
C
C  DEFINITION OF VARIABLES
C
C  NN       VECTOR OF POINTERS TO BUFFER    (INT,I)
C
C  LL       LINK LIST OF POINTERS TO NN     (INT,O)
C           THE LIST DEFINES THE SORTED ORDER
C           ORDER OF BUFFER
C
C  BUFFER    VECTOR CONTAINING TUPLES TO SORT    (ANY,I)
C            NN POINTER ARE RELATIVE TO BUFFER(1)
C
      INCLUDE rin:SRTCOM.BLK
      INTEGER SWIICP,SWIRCP,SWIDCP,SWITCP
      DIMENSION NN(*),LL(*)
      INTEGER BUFFER(*)
      INTEGER S1
      K1=0
      I=0
      M1=0
      T2=0.
      T4=0.
      J=NSORT+1
      LL(1)=1
      LL(J)=1
      K2=1
      IF(NSORT.LE.1) RETURN
      S1=NSORT
  250 CONTINUE
C  CLIMB THE TREE
      IF(S1.LT.4) GO TO 320
      K2=K2*2
      B2=S1
      B2=B2/2.
      S1=INT(B2)
      T4=T4+(B2-S1)*K2
      GO TO 250
  320 CONTINUE
C  INITIAL CALCULATIONS
      T4=K2-T4
      B2=K2/2
  350 CONTINUE
C  NEXT TWIG
      IF(K1.EQ.K2) RETURN
      K1=K1+1
      T1=K1
      B1=B2
      T3=T2
  400 CONTINUE
C  ADD 1 TO REFLECTED BINARY COUNTER AND CARRY
      T1=T1/2.
      IF(INT(T1).LT.T1) GO TO 470
      M1=M1+1
      T2=T2-B1
      B1=B1/2.
      GO TO 400
  470 CONTINUE
C  TWIG CALCULATIONS
      T2=T2+B1
      IF(S1.EQ.2) GO TO 550
C  3-TWIGS AND 4-TWIGS
      IF(T3.LT.T4) GO TO 560
C  4-TWIG
      M1=-M1
      GO TO 630
  550 IF(T3.LT.T4) GO TO 610
  560 CONTINUE
C  3-TWIG
      M1=M1+1
      I=I+1
      LL(I)=I
      LL(J)=I
      J=J+1
  610 CONTINUE
C  2-TWIG
      M1=M1+1
  630 I=I+1
      L1=I
      LL(I)=I
      LL(J)=I
      L0=J
      J=J+1
      I=I+1
      L2=I
      LL(I)=I
      LL(J)=I
      GO TO 750
  700 CONTINUE
C  MERGE TWIGS AND BRANCHES
      J=J-1
      L0=J-1
      L1=LL(L0)
      L2=LL(J)
  750 CONTINUE
      NNL2 = NN(L2) + VARPOS(1) - 1
      NNL1 = NN(L1) + VARPOS(1) - 1
      J2 = BUFFER(NNL2) - BUFFER(NNL1)
      IF(J2 .GT. 0 .AND. SORTYP(1)) GO TO 820
      IF(J2 .LT. 0 .AND. .NOT. SORTYP(1)) GO TO 820
      IF(J2 .NE. 0) GO TO 765
      IF(NSOVAR .EQ. 1) GO TO 820
      DO 760 J3=2,NSOVAR
      JJ3 = VARPOS(J3) - 1
      NNL1 = NN(L1) + JJ3
      NNL2 = NN(L2) + JJ3
      KGOTO = VARTYP(J3)
      GO TO (752,753,754,755),KGOTO
  752 J2 = BUFFER(NNL2) - BUFFER(NNL1)
      GO TO 756
  753 J2 = SWIRCP(BUFFER(NNL1),BUFFER(NNL2))
      GO TO 756
  754 J2 = SWIDCP(BUFFER(NNL1),BUFFER(NNL2))
      GO TO 756
  755 J2 = SWITCP(BUFFER(NNL1),BUFFER(NNL2))
  756 CONTINUE
      IF(J2 .EQ. 0) GO TO 760
      IF((J2 .GT. 0 .AND. SORTYP(J3)) .OR.
     X   (J2 .LT. 0 .AND. .NOT. SORTYP(J3)))
     XGO TO 820
      GO TO 765
  760 CONTINUE
      GO TO 820
  765 CONTINUE
      LL(L0)=L2
  770 L0=L2
      L2=LL(L0)
      IF(L2.EQ.L0) GO TO 870
      NNL2 = NN(L2) + VARPOS(1) - 1
      NNL1 = NN(L1) + VARPOS(1) - 1
      J2 = BUFFER(NNL2) - BUFFER(NNL1)
      IF(J2 .GT. 0 .AND. SORTYP(1)) GO TO 795
      IF(J2 .LT. 0 .AND. .NOT. SORTYP(1)) GO TO 795
      IF(J2 .NE. 0) GO TO 770
      IF(NSOVAR .EQ. 1) GO TO 795
      DO 790 J3=2,NSOVAR
      JJ3 = VARPOS(J3) - 1
      NNL1 = NN(L1) + JJ3
      NNL2 = NN(L2) + JJ3
      KGOTO = VARTYP(J3)
      GO TO (781,782,783,784),KGOTO
  781 J2 = BUFFER(NNL2) - BUFFER(NNL1)
      GO TO 785
  782 J2 = SWIRCP(BUFFER(NNL1),BUFFER(NNL2))
      GO TO 785
  783 J2 = SWIDCP(BUFFER(NNL1),BUFFER(NNL2))
      GO TO 785
  784 J2 = SWITCP(BUFFER(NNL1),BUFFER(NNL2))
  785 CONTINUE
      IF(J2 .EQ. 0) GO TO 790
      IF((J2 .GT. 0 .AND. SORTYP(J3)) .OR.
     X   (J2 .LT. 0 .AND. .NOT. SORTYP(J3)))
     XGO TO 795
      GO TO 770
  790 CONTINUE
  795 CONTINUE
      LL(L0)=L1
  820 L0=L1
      L1=LL(L0)
      IF(L1.NE.L0) GO TO 750
      LL(L0)=L2
      GO TO 880
  870 LL(L0)=L1
  880 M1=M1-1
      IF(M1.GT.0) GO TO 700
      IF(M1.EQ.0) GO TO 350
C  GENERATE 2ND HALF OF A 4-TWIG
      M1=1-M1
      GO TO 630
      END
      SUBROUTINE SWHRTR(NN,LL,BUFFER)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE   TO SORT FIXED OR VARIABLE LENGTH
C            TUPLES ON ONE OR MORE ATTRIBUTES
C            INCORE SORT
C             FIRST SORT ATTRIBUTE IS REAL
C
C  METHOD    FAST SORTING ALGORITHM PUBLISHED
C            1978 BY HART
C            CREATIVE COMPUTING JAN/FEB 1978
C            P 96 FF
C
C  TIMING   .05 CP SEC CYBER 760
C          1000 TUPLES,1 ATTRIBUTE SORT (REAL)
C
C  DEFINITION OF VARIABLES
C
C  NN       VECTOR OF POINTERS TO BUFFER    (INT,I)
C
C  LL       LINK LIST OF POINTERS TO NN     (INT,O)
C           THE LIST DEFINES THE SORTED ORDER
C           ORDER OF BUFFER
C
C  BUFFER    VECTOR CONTAINING TUPLES TO SORT    (ANY,I)
C            NN POINTER ARE RELATIVE TO BUFFER(1)
C
      INCLUDE rin:SRTCOM.BLK
      INTEGER SWIICP,SWIRCP,SWIDCP,SWITCP
      DIMENSION NN(*),LL(*)
      DIMENSION BUFFER(*)
      REAL BUFFER
      INTEGER S1
      K1=0
      I=0
      M1=0
      T2=0.
      T4=0.
      J=NSORT+1
      LL(1)=1
      LL(J)=1
      K2=1
      IF(NSORT.LE.1) RETURN
      S1=NSORT
  250 CONTINUE
C  CLIMB THE TREE
      IF(S1.LT.4) GO TO 320
      K2=K2*2
      B2=S1
      B2=B2/2.
      S1=INT(B2)
      T4=T4+(B2-S1)*K2
      GO TO 250
  320 CONTINUE
C  INITIAL CALCULATIONS
      T4=K2-T4
      B2=K2/2
  350 CONTINUE
C  NEXT TWIG
      IF(K1.EQ.K2) RETURN
      K1=K1+1
      T1=K1
      B1=B2
      T3=T2
  400 CONTINUE
C  ADD 1 TO REFLECTED BINARY COUNTER AND CARRY
      T1=T1/2.
      IF(INT(T1).LT.T1) GO TO 470
      M1=M1+1
      T2=T2-B1
      B1=B1/2.
      GO TO 400
  470 CONTINUE
C  TWIG CALCULATIONS
      T2=T2+B1
      IF(S1.EQ.2) GO TO 550
C  3-TWIGS AND 4-TWIGS
      IF(T3.LT.T4) GO TO 560
C  4-TWIG
      M1=-M1
      GO TO 630
  550 IF(T3.LT.T4) GO TO 610
  560 CONTINUE
C  3-TWIG
      M1=M1+1
      I=I+1
      LL(I)=I
      LL(J)=I
      J=J+1
  610 CONTINUE
C  2-TWIG
      M1=M1+1
  630 I=I+1
      L1=I
      LL(I)=I
      LL(J)=I
      L0=J
      J=J+1
      I=I+1
      L2=I
      LL(I)=I
      LL(J)=I
      GO TO 750
  700 CONTINUE
C  MERGE TWIGS AND BRANCHES
      J=J-1
      L0=J-1
      L1=LL(L0)
      L2=LL(J)
  750 CONTINUE
      JJ3 = VARPOS(1) - 1
      R2 = BUFFER(NN(L2)+JJ3) - BUFFER(NN(L1)+JJ3)
      IF(R2 .GT. 0. .AND. SORTYP(1)) GO TO 820
      IF(R2 .LT. 0. .AND. .NOT. SORTYP(1)) GO TO 820
      IF(R2 .NE. 0.) GO TO 765
      IF(NSOVAR .EQ. 1) GO TO 820
      DO 760 J3=2,NSOVAR
      JJ3 = VARPOS(J3) - 1
      NNL1 = NN(L1) + JJ3
      NNL2 = NN(L2) + JJ3
      KGOTO = VARTYP(J3)
      GO TO (752,753,754,755),KGOTO
  752 J2 = SWIICP(BUFFER(NNL1),BUFFER(NNL2))
      GO TO 756
  753 J2 = SWIRCP(BUFFER(NNL1),BUFFER(NNL2))
      GO TO 756
  754 J2 = SWIDCP(BUFFER(NNL1),BUFFER(NNL2))
      GO TO 756
  755 J2 = SWITCP(BUFFER(NNL1),BUFFER(NNL2))
  756 CONTINUE
      IF(J2 .EQ. 0) GO TO 760
      IF((J2 .GT. 0 .AND. SORTYP(J3)) .OR.
     X   (J2 .LT. 0 .AND. .NOT. SORTYP(J3)))
     XGO TO 820
      GO TO 765
  760 CONTINUE
      GO TO 820
  765 CONTINUE
      LL(L0)=L2
  770 L0=L2
      L2=LL(L0)
      IF(L2.EQ.L0) GO TO 870
      JJ3 = VARPOS(1)-1
      R2 = BUFFER(NN(L2)+JJ3) - BUFFER(NN(L1)+JJ3)
      IF(R2 .GT. 0. .AND. SORTYP(1)) GO TO 795
      IF(R2 .LT. 0. .AND. .NOT. SORTYP(1)) GO TO 795
      IF(R2 .NE. 0.) GO TO 770
      IF(NSOVAR .EQ. 1) GO TO 795
      DO 790 J3=2,NSOVAR
      JJ3 = VARPOS(J3) - 1
      NNL1 = NN(L1) + JJ3
      NNL2 = NN(L2) + JJ3
      KGOTO = VARTYP(J3)
      GO TO (781,782,783,784),KGOTO
  781 J2 = SWIICP(BUFFER(NNL1),BUFFER(NNL2))
      GO TO 785
  782 J2 = SWIRCP(BUFFER(NNL1),BUFFER(NNL2))
      GO TO 785
  783 J2 = SWIDCP(BUFFER(NNL1),BUFFER(NNL2))
      GO TO 785
  784 J2 = SWITCP(BUFFER(NNL1),BUFFER(NNL2))
  785 CONTINUE
      IF(J2 .EQ. 0) GO TO 790
      IF((J2 .GT. 0 .AND. SORTYP(J3)) .OR.
     X   (J2 .LT. 0 .AND. .NOT. SORTYP(J3)))
     XGO TO 795
      GO TO 770
  790 CONTINUE
  795 CONTINUE
      LL(L0)=L1
  820 L0=L1
      L1=LL(L0)
      IF(L1.NE.L0) GO TO 750
      LL(L0)=L2
      GO TO 880
  870 LL(L0)=L1
  880 M1=M1-1
      IF(M1.GT.0) GO TO 700
      IF(M1.EQ.0) GO TO 350
C  GENERATE 2ND HALF OF A 4-TWIG
      M1=1-M1
      GO TO 630
      END
      SUBROUTINE SWICST(MM,M,N)
      INCLUDE rin:TEXT.BLK
      DIMENSION M(*),MM(*)
C
C
C  PURPOSE       TO SORT A SUBSET OF EQUIDISTANT
C                ELEMENTS OF A VECTOR
C
C  TIMING        .00015*N*LN(N) SEC
C
C  DEFINITION OF PARAMETERS
C
C  M         VECTOR OF POINTERS TO MM
C
C  MM        VECTOR OF DATA TO SORT
C
C  N         NUMBER OF ELEMENTS TO SORT
C
C
      INCLUDE rin:SRTCOM.BLK
      INTEGER SWIICP,SWIRCP,SWIDCP,SWITCP
      I = 1
      DO 10 J=1,30
      IF(I .GE. N) GO TO 20
   10 I = I * 2
   20 CONTINUE
      ID1 = I
      NN = N
   50 ID2 = ID1
      I = I/2
      IF(I .GT. 0) GO TO 60
      RETURN
   60 CONTINUE
      ID1 = I
      III = N - I
      IF(III .GT. I) III = I
      DO 500 J=1,III
      I1 = J
      I2 = I1 + ID1
      J1 = M(I1)
      J2 = M(I2)
  200 CONTINUE
      DO 220 JJ3=1,NSOVAR
      JJ4 = VARPOS(JJ3) - 1
      KGOTO = VARTYP(JJ3)
      GO TO (211,212,213,214),KGOTO
  211 JJJ = SWIICP(MM(J1+JJ4),MM(J2+JJ4))
      GO TO 215
  212 JJJ = SWIRCP(MM(J1+JJ4),MM(J2+JJ4))
      GO TO 215
  213 JJJ = SWIDCP(MM(J1+JJ4),MM(J2+JJ4))
      GO TO 215
  214 JJJ = SWITCP(MM(J1+JJ4),MM(J2+JJ4))
  215 CONTINUE
      IF(.NOT. SORTYP(JJ3)) JJJ = -JJJ
      IF(JJJ .GT. 0) GO TO 400
      IF(JJJ .LT. 0) GO TO 240
  220 CONTINUE
      GO TO 400
  240 CONTINUE
C
C  NOT IN SORT
C
      M(I1) = J2
      I1 = I1 + ID1
      IF(I1 .LT. I2) GO TO 250
C
C  JUST FLIP-FLOP
C
      M(I2) = J1
      I2 = I2 + ID2
      IF(I2 .GT. NN) GO TO 500
      J2 = M(I2)
      GO TO 200
C
C  MORE THAN ONE TO MOVE DOWN
C
  250 JJ = I2 - ID1
      DO 300 II=I1,JJ,ID1
      J2 = M(I2 - ID1)
      M(I2) = J2
  300 I2 = I2 - ID1
      I2 = JJ + ID1 + ID2
      M(I1) = J1
      IF(I2 .GT. NN) GO TO 500
      J2 = M(I2)
      GO TO 200
C
C  IN SORT
C
  400 I1 = I1 + ID1
      IF(I1 .LT. I2) GO TO 450
C
C  ONE ONLY
C
      I2 = I2 + ID1
      IF(I2 .GT. NN) GO TO 500
      J1 = J2
      J2 = M(I2)
      GO TO 200
C
C   MORE THAN ONE
C
  450 J1 = M(I1)
      GO TO 200
  500 CONTINUE
      GO TO 50
      END
      INTEGER FUNCTION SWIDCP(I1,I2)
      INCLUDE rin:TEXT.BLK
      DOUBLE PRECISION I1,I2
      SWIDCP = 1
      IF(I1 .LT. I2) RETURN
      IF(I1 .GT. I2) GO TO 10
      SWIDCP = 0
      RETURN
   10 SWIDCP = -1
      RETURN
      END
      INTEGER FUNCTION SWIICP(I1,I2)
      INCLUDE rin:TEXT.BLK
      SWIICP = 1
      IF(I1 .LT. I2) RETURN
      IF(I1 .GT. I2) GO TO 10
      SWIICP = 0
      RETURN
   10 SWIICP = -1
      RETURN
      END
      SUBROUTINE SWINPO(INFIL,OUTFIL,BUFFER,IERR)
      INCLUDE rin:TEXT.BLK
      INCLUDE rin:SRTCOM.BLK
      DIMENSION BUFFER(*)
      INTEGER BUFFER,OUTFIL
C
C  PURPOSE  CONTROLLING ROUTINE FOR IN-CORE SORT
C              USING IN-SITU POINTER METHOD
C
C
C  TIMING   UNKNOWN
C
C  DEFINITION OF VARIABLES
C
C  INFIL   FILE NAME OF FILE (SEQ) WHICH    (INT,I)
C          CONTAINS INPUT TUPLES
C         INFIL IS UNFORMATTED (BINARY)
C         EACH TUPLE IS WRITTEN AS A
C         RECORD AS FOLLOWS
C         FOR FIXED LENGTH RECORDS
C           WRITE(INFIL) (TUP(I),I=1,LTUPLE)
C         FOR VARIABLE LENGTH RECORDS
C           WRITE(INFIL) L,(TUP(I),I=1,L)
C
C  OUTFIL  FILE NAME OF FILE (SEQ) WHICH    (INT,I)
C          CONTAINS OUTPUT (SORTED) TUPLES
C          OUTFIL MAY EQ INFIL
C          FORMAT OF OUTFIL IS THE
C          SAME AS THAT OF INFIL
C
C  BUFFER  CORE BUFFER TO USE FOR SORT      (ANY,SCR)
C
C  IERR    ERROR CONDITION                  (INT,O)
C           0 NORMAL RETURN
C           1 ERROR IN FILE READ
C           2 ERROR IN FILE WRITE
C
      I1 = NSORT
      IF(FIXLT) GO TO 10
C
C  INCORE,VAR LENGTH
C
      I1 = I1 + 1
      DO 5 I2=1,NSORT
      BUFFER(I2) = I1 + 1
c      READ(INFIL) I4,(BUFFER(I1+I5),I5=1,I4)
      READ(INFIL) I4
      READ(INFIL) (BUFFER(I1+I5),I5=1,I4)
      BUFFER(I1) = I4
    5 I1 = I1 + I4 + 1
      GO TO 20
   10 CONTINUE
C
C  INCORE,FIXED LENGTH TUPLES
C
      DO 15 I2=1,NSORT
      BUFFER(I2)= I1 + 1
      READ(INFIL) (BUFFER(I1+I4),I4=1,LTUPLE)
   15 I1 = I1 + LTUPLE
   20 CONTINUE
C
C  READ COMPLETED,SORT
C
      CALL SWICST(BUFFER,BUFFER,NSORT)
C
C  SORT COMPLETE,UNLOAD
C
      REWIND OUTFIL
      IF(FIXLT) GO TO 40
C
C  VARIABLE LENGTH TUPLES
C
      DO 35 I2=1,NSORT
      I3 = BUFFER(I2) - 1
      I4 = BUFFER(I3)
      WRITE(OUTFIL) I4,(BUFFER(I3+I1),I1=1,I4)
   35 CONTINUE
      RETURN
   40 CONTINUE
C
C  WRITE FIXED LENGTH TUPLES
C
      DO 45 I2=1,NSORT
      I3 = BUFFER(I2) - 1
      WRITE(OUTFIL) (BUFFER(I3+I4),I4=1,LTUPLE)
   45 CONTINUE
      RETURN
      END
      INTEGER FUNCTION SWIRCP(I1,I2)
      INCLUDE rin:TEXT.BLK
      REAL I1,I2
      SWIRCP = 1
      IF(I1 .LT. I2) RETURN
      IF(I1 .GT. I2) GO TO 10
      SWIRCP = 0
      RETURN
   10 SWIRCP = -1
      RETURN
      END
      INTEGER FUNCTION SWITCP(I1,I2)
      INCLUDE rin:TEXT.BLK
      Character*1 W1(4),W2(4)
      INTEGER IT1,IT2
      EQUIVALENCE (IT1,W1)
      EQUIVALENCE (IT2,W2)
      IT1 = I1
      IT2 = I2
      DO 100 I=1,4
      IF(W1(I).NE.W2(I)) GO TO 200
  100 CONTINUE
      SWITCP = 0
      RETURN
  200 CONTINUE
      IF(W1(I).GT.W2(I)) GO TO 300
      SWITCP = 1
      RETURN
  300 CONTINUE
      SWITCP = -1
      RETURN
      END
      SUBROUTINE SWSHEL(M,N)
      INCLUDE rin:TEXT.BLK
C
C     SORT AN INTEGER ARRAY OF LENGTH N
C     USING SHELL SORT ALGORITHM
C
      DIMENSION M(N)
      INC = 1
  100 CONTINUE
      IF((9*INC+4).GE.N) GO TO 200
      INC = 3*INC + 1
      GO TO 100
  200 CONTINUE
      IF(INC.LT.1) GO TO 1000
      NMMINC = N-INC
C
C     START THE SORT LOOP
C
      DO 800 IS = 1,NMMINC
      K1 = IS
      K2 = IS + INC
      IF(M(K1).LE.M(K2)) GO TO 800
      MOVE = IS
      MT = M(K2)
  400 CONTINUE
      K1 = MOVE
      K2 = K1 + INC
      M(K2) = M(K1)
      MOVE = MOVE - INC
      IF(MOVE.LT.1) GO TO 600
      IF(MT.LT.M(MOVE)) GO TO 400
  600 CONTINUE
      M(K1) = MT
  800 CONTINUE
      INC = (INC-1)/3
      GO TO 200
 1000 CONTINUE
      RETURN
      END
      SUBROUTINE SWSINK(IP,IIP,NIP,BUFFER)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE   TO INSERT A TUPLE INTO A SEQUENCE
C            OF SORTED TUPLES USING A SINK
C            SORT.  THE TOP TUPLE IS MOVED DOWN
C            IN THE EXISTING SEQUENCE UNTIL IT
C            IS NOT LESS THAN THE NEXT TUPLE
C            (IF ASCENDING SORT) OR NOT GREATER
C            THAN THE NEXT TUPLE (DESCENDING SORT)
C
C  DEFININITION OF VARIABLES
C
C  IP        VECTOR OF INDIRECT POINTERS          (INT,I/O)
C            IP(I) POINTS TO IIP.
C            IP(2), ... , IP(NIP) ARE
C            IN SORT UPON ENTRY. UPON
C            EXIT IP(1), ... ,IP(NIP)
C            ARE IN SORT
C
C  IIP       VECTOR OF CURRENT POINTERS           (INT,I)
C            TO BUFFER
C
C  NIP       NUMBER OF CURRENT CHAINS             (INT,I)
C            ** NOTICE **   NIP MUST BE GT 1
C
C  BUFFER     VECTOR CONTAINING TUPLES TO SORT    (ANY,I)
C             IIP POINTERS ARE RELATIVE TO
C             BUFFER(1)
C
      INCLUDE rin:SRTCOM.BLK
      INTEGER SWIICP,SWIRCP,SWIDCP,SWITCP
      DIMENSION IP(*),IIP(*)
      DIMENSION BUFFER(*)
      J1 = IP(1)
      I1 = IIP(J1)
      DO 100 I=2,NIP
      J3 = IP(I)
      I2 = IIP(J3)
      DO 20 J4=1,NSOVAR
      JJ4 = VARPOS(J4) - 1
      KGOTO = VARTYP(J4)
      GO TO (11,12,13,14),KGOTO
   11 J2 = SWIICP(BUFFER(I1+JJ4),BUFFER(I2+JJ4))
      GO TO 15
   12 J2 = SWIRCP(BUFFER(I1+JJ4),BUFFER(I2+JJ4))
      GO TO 15
   13 J2 = SWIDCP(BUFFER(I1+JJ4),BUFFER(I2+JJ4))
      GO TO 15
   14 J2 = SWITCP(BUFFER(I1+JJ4),BUFFER(I2+JJ4))
   15 CONTINUE
      IF(J2 .EQ. 0) GO TO 20
      IF((J2 .GT. 0 .AND. SORTYP(J4)) .OR.
     X   (J2 .LT. 0 .AND. .NOT. SORTYP(J4)))
     X    GO TO 200
      GO TO 30
   20 CONTINUE
C
C    EQUAL,PRESERVE ORIGINAL ORDER
C
      IF(J1 .LT. J3) GO TO 200
   30 CONTINUE
C
C     NOT IN SORT, CONTINUE TO SINK
C
      IP(I-1) = J3
      IP(I) = J1
  100 CONTINUE
  200 CONTINUE
      RETURN
      END
      SUBROUTINE SWSMFL(BUFFER,CHAIN1,NCHAIN,LCHAIN,OUTREC,OUTCHN,
     X                   NTUREC,LTUP,LREC,INFIL,OUTFIL)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE   MERGE ONE SET OF CHAINS INTO
C            SINGLE CHAIN OF SORTED TUPLES
C
C  METHOD    A STACK IS ESTABLISHED WITH
C            CURRENT FIRST TUPLE IN EACH
C            CHAIN.THE STACK IS IN ORDER.
C            THE FIRST TUPLE IS REMOVED
C            FROM THE STACK AND MOVED TO
C            OUTPUT BUFFER.THE NEXT TUPLE
C            IN THE PARTICULAR CHAIN IS
C            (IF ONE EXISTS) PUT ON TOP
C            OF STACK AND ALLOWED TO
C            SINK UNTIL IT IS IN SORT.
C            IF ONE DOES NOT EXIST,THE
C            STACK IS SHORTENED.WHEN
C            ONLY ONE CHAIN EXISTS,
C            ITS TAIL IS MOVED DIRECTLY
C            TO OUTPUT FILE
C  DEFINITION OF PARAMETERS
C
C  CHAIN1    RECORD NO ON INFILE WHICH CONTAINS   (INT,I)
C            PAGE 1 OF FIRST CHAIN
C
C  NCHAIN   NUMBER OF CHAINS TO MERGE           (INT,I)
C
C  LCHAIN    NUMBER OF PAGES PER INPUT CHAIN     (INT,I)
C
C  OUTREC    RECORD NO ON OUTFIL OF NEXT RECORD  (INT,I/O)
C            POSITION - IF ZERO EMPTY OUTPUT FILE - WRITE AT EOI
C
C  OUTCHN    OUTPUT CHAIN NUMBER                 (INT,I)
C
C  NTUREC     NUMBER OF TUPLES PER FULL PAGE     (INT,I)
C
C  LTUP      LENGTH OF A TUPLE                   (INT,I)
C
C  INFIL     FET OF INPUT FILE                   (FET,I)
CC
C  OUTFILE   FET OF OUTLUT FILE                 (FET,I)
C
C  DEFINITION OF LOCAL VARIABLES
C
C  IP    IP(I)  CONTAINS POINTER TO IP1
C               FOR I:TH TUPLE IN STACK
C  IP1   IP1(I) CONTAINS POINTER TO CURRENT
C               TUPLE ON PAGE I
C  IP2   IP2(I) CONTAINS POINTER TO LAST
C               TUPLE ON PAGE I
C  IP3   IP3(I) CONTAINS RECORD NUMBER ON
C               INFILE FOR CURRENT PAGE IN
C               CHAIN I.NEG IF LAST PAGE IN CHAIN
C  IP4   IP4(I) CONTAINS POINTER TO FIRST
C               WORD ON PAGE I
C
C  DEFINITION OF LOCAL VARIABLES
C
C  I5     NO OF TUPLES ON OUTPUT PAGE
C  I6     ADDRESS-1 TO NEXT TUPLE ON OUTPUT PAGE
C  J1      POINTER TO FIRST WORD OF OUTPUT PAGE
C
      INTEGER BUFFER(*)
      INTEGER CHAIN1,OUTREC,OUTCHN,OUTFIL
      DIMENSION IP(10),IP1(10),IP2(10),IP3(10),IP4(10)
C
C  INITIALIZE,IE LOAD THE FIRST
C  BLOCKS OF THE INPUT CHAINS,SET
C  UP CONTROL ARRAYS IP,IP1,...,IP4
C
      J1 = NCHAIN*LREC + 1
      BUFFER(J1) = NTUREC
      BUFFER(J1+1) = OUTCHN
      I1 = CHAIN1
      I2 = 1
      DO 10 I=1,NCHAIN
C* READ RECORD I1 TO BUFFER I2,LENGTH= LREC
      CALL RIOIN(INFIL,I1,BUFFER(I2),LREC,IOS)
      IP1(I) = I2+2
      IP2(I) = I2+(BUFFER(I2)-1)*LTUP+2
      IP3(I) = I1
      IF(BUFFER(I2+1) .LT. 0) IP3(I) = -IP3(I)
      IP(I) = I
      IP4(I) = I2
      I1 = I1 + LCHAIN
      I2 = I2 + LREC
   10 CONTINUE
      IF(NCHAIN .GT. 1) GO TO 17
      I1 = 1
      J1 = 1
      GO TO 123
   17 CONTINUE
      DO 15 I=2,NCHAIN
      CALL SWSINK(IP(NCHAIN-I+1),IP1(1),I,BUFFER)
   15 CONTINUE
      NIP = NCHAIN
C
C  INITIAL SETUP COMPLETE,
C  PREPARE FOR MERGE CYCLE
C
   20 CONTINUE
      I5 = 0
      I6 = J1 + 1
C
C  I5 IS NO TUPLES IN OUTPUT PAGE
C  I6 IS ADDRESS-1 TO NEXT TUPLE
C        ON OUTPUT PAGE
C
   25 CONTINUE
      IF(I5 .LT. NTUREC) GO TO 27
C
C  OUTPUT PAGE FULL
C
C* WRITE OUTPUT BUFFER TO OUTFILE,RECORD OUTREC
      CALL RIOOUT(OUTFIL,OUTREC,BUFFER(J1),LREC,IOS)
      IF(OUTREC.NE.0) OUTREC = OUTREC + 1
      GO TO 20
   27 I1 = IP(1)
      I2 = IP1(I1) - 1
      DO 30 I=1,LTUP
   30 BUFFER(I6+I) = BUFFER(I2+I)
      I5 = I5+1
      I6 = I6 + LTUP
      IP1(I1) = IP1(I1) + LTUP
      IF(IP1(I1) .LE. IP2(I1)) GO TO 50
C
C  INPUT BLOCK EMPTY
C
      IF(IP3(I1) .LT. 0) GO TO 40
      I2 = IP4(I1)
C*  READ BLOCK IP3(I1) TO BUFFER(I2)
      IP3(I1) = IP3(I1) + 1
      CALL RIOIN(INFIL,IP3(I1),BUFFER(I2),LREC,IOS)
      IP1(I1) =I2+2
      IP2(I1) = I2 + (BUFFER(I2)-1)*LTUP + 2
      IF(BUFFER(I2+1) .LT. 0) IP3(I1) = -IP3(I1)
      GO TO 50
   40 CONTINUE
C
C  CURRENT PAGE IS LAST PAGE IN CHAIN
C
      DO 45 I=2,NIP
   45 IP(I-1) = IP(I)
      NIP = NIP - 1
      IF(NIP .EQ. 1) GO TO 100
      GO TO 25
   50 CONTINUE
C
C  CURRENT IP(1) TUPLE MOVED
C  PICK UP NEXT AND LET IT SINK
C
      CALL SWSINK(IP,IP1,NIP,BUFFER)
      GO TO 25
  100 CONTINUE
C
C  ONLY ONE INPUT CHAIN LEFT
C
      I1 = IP(1)
      IF(I5 .LT. NTUREC) GO TO 103
      CALL RIOOUT(OUTFIL,OUTREC,BUFFER(J1),LREC,IOS)
      IF(OUTREC .NE. 0) OUTREC = OUTREC + 1
      J1 = IP4(I1)
      GO TO 123
  103 CONTINUE
      I2 = IP1(I1) - 1
      GO TO 115
  105 CONTINUE
      DO 110 I=1,LTUP
  110 BUFFER(I6+I) = BUFFER(I2+I)
      I6 = I6 + LTUP
      I2 = I2 + LTUP
      I5 = I5 + 1
  115 IF(I2 .LT. IP2(I1)) GO TO 105
      BUFFER(J1) = I5
      IF(IP3(I1) .LT. 0) BUFFER(J1+1) = -BUFFER(J1+1)
C* WRITE OUTPUT BUFFER
      CALL RIOOUT(OUTFIL,OUTREC,BUFFER(J1),LREC,IOS)
      IF(OUTREC.NE.0) OUTREC = OUTREC + 1
      IF(IP3(I1) .LT. 0) RETURN
  120 CONTINUE
C* READ RECORD IP3(I1) TO OUTPUT RECORD
      IP3(I1) = IP3(I1) + 1
      CALL RIOIN(INFIL,IP3(I1),BUFFER(J1),LREC,IOS)
  123 CONTINUE
      IF(BUFFER(J1+1) .LT. 0) GO TO 125
      BUFFER(J1+1) = OUTCHN
C* WRITE OUTPUT BUFFER
      CALL RIOOUT(OUTFIL,OUTREC,BUFFER(J1),LREC,IOS)
      IF(OUTREC.NE.0) OUTREC = OUTREC + 1
      GO TO 120
  125 CONTINUE
      BUFFER(J1+1) = -OUTCHN
C* WRITE OUTPUT BUFFER
      CALL RIOOUT(OUTFIL,OUTREC,BUFFER(J1),LREC,IOS)
      IF(OUTREC.NE.0) OUTREC = OUTREC + 1
      RETURN
      END
      SUBROUTINE SWSMVL(BUFFER,CHAIN1,NCHAIN,LCHAIN,OUTREC,OUTCHN,
     X                   INCH1,LREC,INFIL,OUTFIL)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE   MERGE ONE SET OF CHAINS INTO
C            SINGLE CHAIN OF SORTED TUPLES
C
C  METHOD    A STACK IS ESTABLISHED WITH
C            CURRENT FIRST TUPLE IN EACH
C            CHAIN.THE STACK IS IN ORDER.
C            THE FIRST TUPLE IS REMOVED
C            FROM THE STACK AND MOVED TO
C            OUTPUT BUFFER.THE NEXT TUPLE
C            IN THE PARTICULAR CHAIN IS
C            (IF ONE EXISTS) PUT ON TOP
C            OF STACK AND ALLOWED TO
C            SINK UNTIL IT IS IN SORT.
C            IF ONE DOES NOT EXIST,THE
C            STACK IS SHORTENED.WHEN
C            ONLY ONE CHAIN EXISTS,
C            ITS TAIL IS MOVED DIRECTLY
C            TO OUTPUT FILE
C  DEFINITION OF PARAMETERS
C
C  CHAIN1    RECORD NO ON INFILE WHICH CONTAINS   (INT,I)
C            PAGE 1 OF FIRST CHAIN
C
C  NCHAIN   NUMBER OF CHAINS TO MERGE           (INT,I)
C
C  LCHAIN    NUMBER OF PAGES PER INPUT CHAIN     (INT,I)
C
C  OUTREC    RECORD NO ON OUTFIL OF NEXT RECORD  (INT,I/O)
C            POSITION - IF ZERO EMPTY OUTPUT FILE - WRITE AT EOI
C
C  OUTCHN    OUTPUT CHAIN NUMBER                 (INT,I)
C
C  INCH1     CHAIN NUMBER OF FIRST INPUT CHAIN   (INT,I)
C
C  INFIL     FET OF INPUT FILE                   (FET,I)
CC
C  OUTFILE   FET OF OUTLUT FILE                 (FET,I)
C
C  DEFINITION OF LOCAL VARIABLES
C
C  IP    IP(I)  CONTAINS POINTER TO IP1
C               FOR I:TH TUPLE IN STACK
C  IP1   IP1(I) CONTAINS POINTER TO CURRENT
C               TUPLE ON PAGE I
C  IP2   IP2(I) CONTAINS NUMBER OF TUPLES
C               ON PAGE I
C  IP3   IP3(I) CONTAINS RECORD NUMBER ON
C               INFILE FOR CURRENT PAGE IN
C               CHAIN I.NEG IF LAST PAGE IN CHAIN
C  IP4   IP4(I) CONTAINS POINTER TO FIRST
C               WORD ON PAGE I
C
C  IP5   IP5(I) CONTAINS SEQUENTIAL TUPLE NUMBER
C                OF CURRENT TUPLE PAGE I.
C
C  DEFINITION OF LOCAL VARIABLES
C
C  I5     NO OF TUPLES ON OUTPUT PAGE
C  I6     ADDRESS-1 TO NEXT TUPLE ON OUTPUT PAGE
C  J1      POINTER TO FIRST WORD OF OUTPUT PAGE
C  INCH    INPUT CHAIN NUMBER
C  OUCH    OUTPUT RECORD NUMBER IN CHAIN
C
      INTEGER BUFFER(*)
      INTEGER CHAIN1,OUTREC,OUTCHN,OUTFIL
      DIMENSION IP(10),IP1(10),IP2(10),IP3(10),IP4(10)
      DIMENSION IP5(10)
      INTEGER OUCH
C
C  INITIALIZE,IE LOAD THE FIRST
C  BLOCKS OF THE INPUT CHAINS,SET
C  UP CONTROL ARRAYS IP,IP1,...,IP4
C
      J1 = NCHAIN*LREC + 1
      J2 = J1 + LREC - 1
      BUFFER(J1+1) = OUTCHN
      I1 = CHAIN1
      I2 = 1
      OUCH = 1
      INCH = INCH1
      DO 10 I=1,NCHAIN
C* READ RECORD I1 TO BUFFER I2,LENGTH= LREC
    1 CONTINUE
C
C     LOOK FOR CORRECT RECORD
C
      CALL RIOIN(INFIL,I1,BUFFER(I2),LREC,IOS)
      NUMCH = IABS(BUFFER(I2+1))
      IF(NUMCH.LT.INCH) GO TO 5
      IF(NUMCH.GT.INCH) GO TO 7
C
C     WE ARE IN THE CORRECT CHAIN
C
      INT = BUFFER(I2+2)
      IF(INT.EQ.1) GO TO 8
      I1 = I1 - INT + 1
      GO TO 1
    5 CONTINUE
C
C     IN SOME PREVIOUS CHAIN
C
      I1 = I1 + 1
      IF(BUFFER(I2+1).GT.0) I1 = I1 + 1
      GO TO 1
    7 CONTINUE
C
C     GOOD LORD - IN SOME SUBSEQUENT CHAIN
C
      I1 = I1 - BUFFER(I2+2)
      GO TO 1
    8 CONTINUE
C
C     FOUND THE FIRST RECORD IN CHAIN INCH
C
      IP1(I) = I2+4
      IP2(I) = BUFFER(I2)
      IP5(I) = 1
      IP3(I) = I1
      IF(BUFFER(I2+1) .LT. 0) IP3(I) = -IP3(I)
      IP(I) = I
      IP4(I) = I2
      I1 = I1 + LCHAIN
      I2 = I2 + LREC
      INCH = INCH + 1
   10 CONTINUE
      IF(NCHAIN.EQ.1) GO TO 18
      DO 15 I=2,NCHAIN
      CALL SWSINK(IP(NCHAIN-I+1),IP1(1),I,BUFFER)
   15 CONTINUE
   18 CONTINUE
      NIP = NCHAIN
C
C  INITIAL SETUP COMPLETE,
C  PREPARE FOR MERGE CYCLE
C
   20 CONTINUE
      I5 = 0
      I6 = J1 + 2
C
C  I5 IS NO TUPLES IN OUTPUT PAGE
C  I6 IS ADDRESS-1 TO NEXT TUPLE
C        ON OUTPUT PAGE
C
   25 CONTINUE
      I1 = IP(1)
      I2 = IP1(I1) - 2
      LTUP = BUFFER(I2+1) + 1
      IF((I6+LTUP).LE.J2) GO TO 27
C
C  OUTPUT PAGE FULL
C
C* WRITE OUTPUT BUFFER TO OUTFILE,RECORD OUTREC
      BUFFER(J1) = I5
      BUFFER(J1+2) = OUCH
      CALL RIOOUT(OUTFIL,OUTREC,BUFFER(J1),LREC,IOS)
      OUCH = OUCH + 1
      IF(OUTREC.NE.0) OUTREC = OUTREC + 1
      GO TO 20
   27 CONTINUE
      DO 30 I=1,LTUP
   30 BUFFER(I6+I) = BUFFER(I2+I)
      I5 = I5+1
      I6 = I6 + LTUP
      IP1(I1) = IP1(I1) + LTUP
      IP5(I1) = IP5(I1) + 1
      IF(IP5(I1) .LE. IP2(I1)) GO TO 50
C
C  INPUT BLOCK EMPTY
C
      IF(IP3(I1) .LT. 0) GO TO 40
      I2 = IP4(I1)
C*  READ BLOCK IP3(I1) TO BUFFER(I2)
      IP3(I1) = IP3(I1) + 1
      CALL RIOIN(INFIL,IP3(I1),BUFFER(I2),LREC,IOS)
      IP1(I1) =I2 + 4
      IP2(I1) = BUFFER(I2)
      IP5(I1) = 1
      IF(BUFFER(I2+1) .LT. 0) IP3(I1) = -IP3(I1)
      GO TO 50
   40 CONTINUE
C
C  CURRENT PAGE IS LAST PAGE IN CHAIN
C
      IF(NIP.EQ.1) GO TO 100
      DO 45 I=2,NIP
   45 IP(I-1) = IP(I)
      NIP = NIP - 1
      GO TO 25
   50 CONTINUE
C
C  CURRENT IP(1) TUPLE MOVED
C  PICK UP NEXT AND LET IT SINK
C
      IF(NIP.GT.1) CALL SWSINK(IP,IP1,NIP,BUFFER)
      GO TO 25
  100 CONTINUE
C
C     ALL DONE
C
      IF(I5.EQ.0) RETURN
      BUFFER(J1) = I5
      BUFFER(J1+2) = OUCH
      BUFFER(J1+1) = -OUTCHN
C* WRITE OUTPUT BUFFER
      CALL RIOOUT(OUTFIL,OUTREC,BUFFER(J1),LREC,IOS)
      IF(OUTREC.NE.0) OUTREC = OUTREC + 1
      RETURN
      END
      SUBROUTINE SWUNLO(BUFFER,CHAIN1,NCHAIN,LCHAIN,
     X                   LTUP,LREC,INFIL,OUTFIL)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE   MERGE ONE SET OF CHAINS INTO
C            SINGLE CHAIN OF SORTED TUPLES
C
C  METHOD    A STACK IS ESTABLISHED WITH
C            CURRENT FIRST TUPLE IN EACH
C            CHAIN.THE STACK IS IN ORDER.
C            THE FIRST TUPLE IS REMOVED
C            FROM THE STACK AND MOVED TO
C            OUTPUT BUFFER.THE NEXT TUPLE
C            IN THE PARTICULAR CHAIN IS
C            (IF ONE EXISTS) PUT ON TOP
C            OF STACK AND ALLOWED TO
C            SINK UNTIL IT IS IN SORT.
C            IF ONE DOES NOT EXIST,THE
C            STACK IS SHORTENED.WHEN
C            ONLY ONE CHAIN EXISTS,
C            ITS TAIL IS MOVED DIRECTLY
C            TO OUTPUT FILE
C  DEFINITION OF PARAMETERS
C
C  CHAIN1    RECORD NO ON INFILE WHICH CONTAINS   (INT,I)
C            PAGE 1 OF FIRST CHAIN
C
C  NCHAIN   NUMBER OF CHAINS TO MERGE           (INT,I)
C
C  LCHAIN    NUMBER OF PAGES PER INPUT CHAIN     (INT,I)
C
C
C  LTUP      LENGTH OF A TUPLE                   (INT,I)
C
C  INFIL     FET OF INPUT FILE                   (FET,I)
CC
C  OUTFILE   FET OF OUTLUT FILE                 (FET,I)
C
C  DEFINITION OF LOCAL VARIABLES
C
C  IP    IP(I)  CONTAINS POINTER TO IP1
C               FOR I:TH TUPLE IN STACK
C  IP1   IP1(I) CONTAINS POINTER TO CURRENT
C               TUPLE ON PAGE I
C  IP2   IP2(I) CONTAINS POINTER TO LAST
C               TUPLE ON PAGE I
C  IP3   IP3(I) CONTAINS RECORD NUMBER ON
C               INFILE FOR CURRENT PAGE IN
C               CHAIN I.NEG IF LAST PAGE IN CHAIN
C  IP4   IP4(I) CONTAINS POINTER TO FIRST
C               WORD ON PAGE I
C
      INTEGER BUFFER(*)
      INTEGER CHAIN1
      INTEGER OUTFIL
      DIMENSION IP(10),IP1(10),IP2(10),IP3(10),IP4(10)
C
C  INITIALIZE,IE LOAD THE FIRST
C  BLOCKS OF THE INPUT CHAINS,SET
C  UP CONTROL ARRAYS IP,IP1,...,IP4
C
      REWIND OUTFIL
      I1 = CHAIN1
      I2 = 1
      DO 10 I=1,NCHAIN
C* READ RECORD I1 TO BUFFER I2,LENGTH= LREC
      CALL RIOIN(INFIL,I1,BUFFER(I2),LREC,IOS)
      IP1(I) = I2+2
      IP2(I) = I2+(BUFFER(I2)-1)*LTUP+2
      IP3(I) = I1
      IF(BUFFER(I2+1) .LT. 0) IP3(I) = -IP3(I)
      IP(I) = I
      IP4(I) = I2
      I1 = I1 + LCHAIN
      I2 = I2 + LREC
   10 CONTINUE
      IF(NCHAIN .GT. 1) GO TO 17
      IP3(1) = CHAIN1 - 1
      I1 = 1
      GO TO 120
   17 CONTINUE
      DO 15 I=2,NCHAIN
      CALL SWSINK(IP(NCHAIN-I+1),IP1(1),I,BUFFER)
   15 CONTINUE
      NIP = NCHAIN
C
C  INITIAL SETUP COMPLETE,
C  PREPARE FOR MERGE CYCLE
C
   20 CONTINUE
   25 CONTINUE
      I1 = IP(1)
      I2 = IP1(I1) - 1
      WRITE(OUTFIL) (BUFFER(I2+I),I=1,LTUP)
      IP1(I1) = IP1(I1) + LTUP
      IF(IP1(I1) .LE. IP2(I1)) GO TO 50
C
C  INPUT BLOCK EMPTY
C
      IF(IP3(I1) .LT. 0) GO TO 40
      I2 = IP4(I1)
C*  READ BLOCK IP3(I1) TO BUFFER(I2)
      IP3(I1) = IP3(I1) + 1
      CALL RIOIN(INFIL,IP3(I1),BUFFER(I2),LREC,IOS)
      IP1(I1) =I2+2
      IP2(I1) = I2 + (BUFFER(I2)-1)*LTUP + 2
      IF(BUFFER(I2+1) .LT. 0) IP3(I1) = -IP3(I1)
      GO TO 50
   40 CONTINUE
C
C  CURRENT PAGE IS LAST PAGE IN CHAIN
C
      DO 45 I=2,NIP
   45 IP(I-1) = IP(I)
      NIP = NIP - 1
      IF(NIP .EQ. 1) GO TO 100
      GO TO 25
   50 CONTINUE
C
C  CURRENT IP(1) TUPLE MOVED
C  PICK UP NEXT AND LET IT SINK
C
      CALL SWSINK(IP,IP1,NIP,BUFFER)
      GO TO 25
  100 CONTINUE
C
C  ONLY ONE INPUT CHAIN LEFT
C
      I1 = IP(1)
      I2 = IP1(I1) - 1
      GO TO 115
  105 CONTINUE
      WRITE(OUTFIL) (BUFFER(I2+I),I=1,LTUP)
      I2 = I2 + LTUP
  115 IF(I2 .LT. IP2(I1)) GO TO 105
      IF(IP3(I1) .LT. 0) RETURN
  120 CONTINUE
C* READ RECORD IP3(I1)
      I2 = IP4(I1)
      IP3(I1) = IP3(I1) + 1
      CALL RIOIN(INFIL,IP3(I1),BUFFER(I2),LREC,IOS)
      IP1(I1) = I2 + 2
      IP2(I1) = I2 + (BUFFER(I2)-1)*LTUP +2
      IF(BUFFER(I2+1) .LT. 0) IP3(I1) = -IP3(I1)
      GO TO 100
      END
      SUBROUTINE SWUNVL(BUFFER,CHAIN1,NCHAIN,LCHAIN,
     X                   INCH1,LREC,INFIL,OUTFIL)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE   MERGE ONE SET OF CHAINS INTO
C            SINGLE CHAIN OF SORTED TUPLES
C
C  METHOD    A STACK IS ESTABLISHED WITH
C            CURRENT FIRST TUPLE IN EACH
C            CHAIN.THE STACK IS IN ORDER.
C            THE FIRST TUPLE IS REMOVED
C            FROM THE STACK AND MOVED TO
C            OUTPUT BUFFER.THE NEXT TUPLE
C            IN THE PARTICULAR CHAIN IS
C            (IF ONE EXISTS) PUT ON TOP
C            OF STACK AND ALLOWED TO
C            SINK UNTIL IT IS IN SORT.
C            IF ONE DOES NOT EXIST,THE
C            STACK IS SHORTENED.WHEN
C            ONLY ONE CHAIN EXISTS,
C            ITS TAIL IS MOVED DIRECTLY
C            TO OUTPUT FILE
C  DEFINITION OF PARAMETERS
C
C  CHAIN1    RECORD NO ON INFILE WHICH CONTAINS   (INT,I)
C            PAGE 1 OF FIRST CHAIN
C
C  NCHAIN   NUMBER OF CHAINS TO MERGE           (INT,I)
C
C  LCHAIN    NUMBER OF PAGES PER INPUT CHAIN     (INT,I)
C
C  INCH1     CHAIN NUMBER OF FIRST INPUT CHAIN   (INT,I)
C
C  INFIL     FET OF INPUT FILE                   (FET,I)
CC
C  OUTFILE   FET OF OUTLUT FILE                 (FET,I)
C
C  DEFINITION OF LOCAL VARIABLES
C
C  IP    IP(I)  CONTAINS POINTER TO IP1
C               FOR I:TH TUPLE IN STACK
C  IP1   IP1(I) CONTAINS POINTER TO CURRENT
C               TUPLE ON PAGE I
C  IP2   IP2(I) CONTAINS NUMBER OF TUPLES
C               ON PAGE I
C  IP3   IP3(I) CONTAINS RECORD NUMBER ON
C               INFILE FOR CURRENT PAGE IN
C               CHAIN I.NEG IF LAST PAGE IN CHAIN
C  IP4   IP4(I) CONTAINS POINTER TO FIRST
C               WORD ON PAGE I
C
C  IP5   IP5(I) CONTAINS SEQUENTIAL TUPLE NUMBER
C                OF CURRENT TUPLE PAGE I.
C
C  DEFINITION OF LOCAL VARIABLES
C
C  INCH    INPUT CHAIN NUMBER
C
      INTEGER BUFFER(*)
      INTEGER CHAIN1
      INTEGER OUTFIL
      DIMENSION IP(10),IP1(10),IP2(10),IP3(10),IP4(10)
      DIMENSION IP5(10)
C
C  INITIALIZE,IE LOAD THE FIRST
C  BLOCKS OF THE INPUT CHAINS,SET
C  UP CONTROL ARRAYS IP,IP1,...,IP4
C
      REWIND OUTFIL
      I1 = CHAIN1
      I2 = 1
      INCH = INCH1
      DO 10 I=1,NCHAIN
C* READ RECORD I1 TO BUFFER I2,LENGTH= LREC
    1 CONTINUE
C
C     LOOK FOR CORRECT RECORD
C
      CALL RIOIN(INFIL,I1,BUFFER(I2),LREC,IOS)
      NUMCH = IABS(BUFFER(I2+1))
      IF(NUMCH.LT.INCH) GO TO 5
      IF(NUMCH.GT.INCH) GO TO 7
C
C     WE ARE IN THE CORRECT CHAIN
C
      INT = BUFFER(I2+2)
      IF(INT.EQ.1) GO TO 8
      I1 = I1 - INT + 1
      GO TO 1
    5 CONTINUE
C
C     IN SOME PREVIOUS CHAIN
C
      I1 = I1 + 1
      IF(BUFFER(I2+1).GT.0) I1 = I1 + 1
      GO TO 1
    7 CONTINUE
C
C     GOOD LORD - IN SOME SUBSEQUENT CHAIN
C
      I1 = I1 - BUFFER(I2+2)
      GO TO 1
    8 CONTINUE
C
C     FOUND THE FIRST RECORD IN CHAIN INCH
C
      IP1(I) = I2+4
      IP2(I) = BUFFER(I2)
      IP5(I) = 1
      IP3(I) = I1
      IF(BUFFER(I2+1) .LT. 0) IP3(I) = -IP3(I)
      IP(I) = I
      IP4(I) = I2
      I1 = I1 + LCHAIN
      I2 = I2 + LREC
      INCH = INCH + 1
   10 CONTINUE
      IF(NCHAIN.EQ.1) GO TO 18
      DO 15 I=2,NCHAIN
      CALL SWSINK(IP(NCHAIN-I+1),IP1(1),I,BUFFER)
   15 CONTINUE
   18 CONTINUE
      NIP = NCHAIN
C
C  INITIAL SETUP COMPLETE,
C  PREPARE FOR MERGE CYCLE
C
   25 CONTINUE
      I1 = IP(1)
      I2 = IP1(I1) - 2
      LTUP = BUFFER(I2+1) + 1
   27 CONTINUE
      WRITE(OUTFIL) (BUFFER(I+I2),I=1,LTUP)
      IP1(I1) = IP1(I1) + LTUP
      IP5(I1) = IP5(I1) + 1
      IF(IP5(I1) .LE. IP2(I1)) GO TO 50
C
C  INPUT BLOCK EMPTY
C
      IF(IP3(I1) .LT. 0) GO TO 40
      I2 = IP4(I1)
C*  READ BLOCK IP3(I1) TO BUFFER(I2)
      IP3(I1) = IP3(I1) + 1
      CALL RIOIN(INFIL,IP3(I1),BUFFER(I2),LREC,IOS)
      IP1(I1) =I2 + 4
      IP2(I1) = BUFFER(I2)
      IP5(I1) = 1
      IF(BUFFER(I2+1) .LT. 0) IP3(I1) = -IP3(I1)
      GO TO 50
   40 CONTINUE
C
C  CURRENT PAGE IS LAST PAGE IN CHAIN
C
      IF(NIP.EQ.1) GO TO 100
      DO 45 I=2,NIP
   45 IP(I-1) = IP(I)
      NIP = NIP - 1
      GO TO 25
   50 CONTINUE
C
C  CURRENT IP(1) TUPLE MOVED
C  PICK UP NEXT AND LET IT SINK
C
      IF(NIP.GT.1) CALL SWSINK(IP,IP1,NIP,BUFFER)
      GO TO 25
  100 CONTINUE
C
C     ALL DONE
C
      RETURN
      END
      SUBROUTINE SWVLFS(INFIL,OUTFIL,SCFIL1,SCFIL2,
     X                 BUFFER,LBUF,LPRU,DPRU,IERR)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE  DRIVER FOR OUT-OF-CORE SORT
C           OF VARIABLE LENGTH TUPLES
C
C  METHOD   A LEAST COST SORT STRATEGY
C           IS ESTABLISHED BASED UPON
C           MACHINE DEPENDENT PARAMETERS
C           THE COST IS BASED UPON
C           COST FOR POSITIONING ON
C           MASS STORAGE,MASS STORAGE
C           TRANSFERS,IN-CORE MOVEMENT
C           OF DATA AND COMPARISON OF
C           DATA.
C           AN N-ARY SORT/MERGE STRATEGY
C           IS CHOOSEN WHERE 2 LE N LE 9
C           N IS THE NUMBER OF CHAINS
C           OF DATA THAT IS MERGED IN
C           ONE SINGLE MERGE. EACH SORT PASS
C           MAY REQUIRE SEVERAL SUCH MERGES.
C
C
C  DEFINITION OF VARIABLES
C
C  INFIL   FILE NAME OF FILE (SEQ) WHICH    (INT,I)
C          CONTAINS INPUT TUPLES
C         INFIL IS UNFORMATTED (BINARY)
C         EACH TUPLE IS WRITTEN AS A
C         RECORD AS FOLLOWS
C         FOR FIXED LENGTH RECORDS
C           WRITE(INFIL) (TUP(I),I=1,LTUPLE)
C         FOR VARIABLE LENGTH RECORDS
C           WRITE(INFIL) L,(TUP(I),I=1,L)
C
C  OUTFIL  FILE NAME OF FILE (SEQ) WHICH    (INT,I)
C          CONTAINS OUTPUT (SORTED) TUPLES
C          OUTFIL MAY EQ INFIL
C          FORMAT OF OUTFIL IS THE
C          SAME AS THAT OF INFIL
C
C  SCFIL1  FILE NAME OF (RAN) SCRATCH FILE  (TEXT,I)
C
C  SCFIL2  FILE NAME OF (RAN) SCRATCH FILE  (TEXT,I)
C          NOTE THAT SCFIL1 MUST NOT BE
C          EQUAL TO SCFIL2
C
C  BUFFER  INCORE SCRATCH AREA              (ANY,SCRATCH)
C
C  LBUF    LENGTH OF BUFFER                 (INT,I)
C
C  LPRU    QUANTUM LENGTH OF RANDOM         (INT,I)
C          FILE RECORDS
C
C  DPRU    DELTA QUANTUM LENGTH OF          (INT,I)
C          RANDOM FILE RECORDS.
C          THE LENGTH OF SUCH A RECORD
C          MUST EQUAL
C          I*LPRU+DPRU
C
C  IERR    ERROR CONDITION                  (INT,O)
C           0 NORMAL RETURN
C           1 ERROR IN FILE READ
C           2 ERROR IN FILE WRITE
C
C
C  DEFINITION OF LOCAL VARIABLES
C
C  I1     SCRATCH
C  I2     SCRATCH,NO OF PAGES IN INITIAL
C         OFLOADING
C  I3     SCRATCH,NO OF SORT PASSES,NOT COUNTING
C         ACTIONS ON SEQUENTIAL FILES
C         OF WHOLE RANDOM FILES
C  I4     SCRATCH
C  I5     SCRATCH
C  I6     LOW COST SORT ORDER
C  I7     NO OF INCORE PAGES IN INITIAL
C         PASS WHERE SEQUENTIAL FILE IS
C         OFFLOADED
C  I8     SCRATCH,NO OF TUPLES PER RAN FILE PAGE
C  I9     SCRATCH,NO OF PAGES ON RANDOM FILES
C  I10    SCRATCH,LENGTH OF RANDOM FILE PAGE
C  COST   COST OF OPTIMUM SORT STRATEGY
C  NRECS  NO OF PAGES ON RANDOM SCRATCH FILE
C  LREC   LENGTH OF RANDOM FILE PAGE
C
      INCLUDE rin:SRTCOM.BLK
      DIMENSION BUFFER(*)
      INTEGER DPRU
      INTEGER SCARR1,SCARR2
      REAL*8 SCFIL1,SCFIL2
      INTEGER CHAIN1,OUTREC
      INTEGER TUPL
      LOGICAL SWITCH
      I6 = 0
      I1 = 2*LPRU
      I11 = 2*DPRU
      TUPL = LTUPLE/NSORT
      DO 100 I=2,9
      I1 = I1 + LPRU
      I11 = I11 + DPRU
      I10 = LPRU*((LBUF-I11)/I1) + DPRU
      IF(I10 .LT. LTUMAX+2) GO TO 110
      I8 = (I10 - 2 - TUPL/2) / TUPL
      IF(I8 .EQ. 0) I8 = 1
      I2 = (LTUMIN*(LBUF-LTUMAX-I10))/((LTUMIN+1)*(I10-2))
C
C  I2 IS NO OF INCORE BLOCKS IN
C     INITIAL PASS
C
      I9 =(NSORT+I8-1)/I8
      I3 = 1
      I4 = I2
   10 CONTINUE
      I5 = I4
      I4 = I4*I + I5
      IF (I4 .GE. I9) GO TO 20
      I4 = I4 - I5
      I3 = I3 + 1
      GO TO 10
   20 CONTINUE
C
      CALL SWCOST(I3,I9,I10,I,A1)
      IF(I6 .GT. 0) GO TO 30
      GO TO 35
   30 CONTINUE
      IF(A1 .GE. COST) GO TO 90
   35 COST = A1
      I7 = I2
      I6 = I
      LREC = I10
   90 CONTINUE
      IF(I3 .EQ. 1) GO TO 110
  100 CONTINUE
  110 CONTINUE
C
C  OPTIMUM SORT STRATEGY DETERMINED
C
C  OPEN SORT SCRATCH FILES
C
      SCARR1 = 35
      SCARR2 = 36
      CALL DROPF(SCFIL1)
      CALL DROPF(SCFIL2)
      CALL RIOOPN(SCFIL1,SCARR1,LREC,IOS)
      CALL RIOOPN(SCFIL2,SCARR2,LREC,IOS)
      CALL SWVLLO(BUFFER,LREC,I7,INFIL,SCARR1,NI)
C
C     NPASS IS THE NUMBER OF RANDOM TO RANDOM MERGES
C     NI IS THE NUMBER OF CHAINS ON THE INPUT FILE
C     NO IS THE NUMBER OF CHAINS ON THE OUTPUT FILE
C     NCHAIN IS THE NUMBER OF CHAINS TO MERGE
C     LCHAIN IS THE NUMBER OF PAGES PER INPUT CHAIN
C
      LCHAIN = I7
      NCHAIN = I6
      NO = NI
      SWITCH = .TRUE.
C
C     OUTER LOOP ON THE NUMBER OF PASSES
      IF(NI .LE. I6) GO TO 250
  130 CONTINUE
      NI = NO
      NO = (NI-1)/NCHAIN
      NO = NO + 1
      SWITCH = .NOT. SWITCH
      IF(SWITCH) CALL DROPF(SCFIL1)
      IF(SWITCH) CALL RIOOPN(SCFIL1,SCARR1,LREC,IOS)
      IF(.NOT.SWITCH) CALL DROPF(SCFIL2)
      IF(.NOT.SWITCH) CALL RIOOPN(SCFIL2,SCARR2,LREC,IOS)
      INC = LCHAIN*NCHAIN
C
C     INNER LOOP ON NUMBER OF OUTPUT CHAINS
C
      INCH = 1
      DO 150 J=1,NO
      CHAIN1 = (J-1)*INC + 1
      OUTREC = 0
      NCH = NCHAIN
      IF(J.EQ.NO) NCH = NI - (NO-1)*NCHAIN
      IF(SWITCH) CALL SWSMVL(BUFFER,CHAIN1,NCH,LCHAIN,OUTREC,J,
     X       INCH,LREC,SCARR2,SCARR1)
      IF(.NOT.SWITCH) CALL SWSMVL(BUFFER,CHAIN1,NCH,LCHAIN,OUTREC,J,
     X       INCH,LREC,SCARR1,SCARR2)
      INCH = INCH + NCH
  150 CONTINUE
      LCHAIN = LCHAIN * NCHAIN
      IF(NO .GT. I6+1) GO TO 130
  250 CONTINUE
C
C     CALL SWUNVL TO CREATE OUTPUT SEQUENTIAL FILE
C
      CHAIN1 = 1
      NCH = NO
      INCH = 1
      IF(SWITCH) CALL SWUNVL(BUFFER,CHAIN1,NCH,LCHAIN,
     X      INCH,LREC,SCARR1,OUTFIL)
      IF(.NOT.SWITCH) CALL SWUNVL(BUFFER,CHAIN1,NCH,LCHAIN,
     X      INCH,LREC,SCARR2,OUTFIL)
C
C     RETURN THE SCRATCH RANDOM FILES
C
      CALL DROPF(SCFIL1)
      CALL DROPF(SCFIL2)
      RETURN
      END
      SUBROUTINE SWVLLO(BUFFER,LREC,NREC,INFIL,OUTFIL,NI)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE  LOADING PASS FOR OUT-OF-CORE SORT
C           OF VARIABLE LENGTH TUPLES
C
C  TIMING   UNKNOWN
C
C  DEFINITION OF VARIABLES
C
C  BUFFER   CORE SCRATCH AREA OF                  (SCRATCH)
C           SUFFICIENT LENGTH
C
C  LBUF     LENGTH OF BUFFER                      (INT,I)
C
C  LREC     LENGTH, IN WORDS, OF OUTPUT RECORD    (INT,I)
C
C
C  INFIL   FILE NAME OF FILE (SEQ) WHICH    (INT,I)
C           CONTAINS INPUT TUPLES
C           INFIL IS UNFORMATTED (BINARY)
C           EACH TUPLE IS WRITTEN AS A
C           RECORD AS FOLLOWS
C           FOR FIXED LENGTH RECORDS
C             WRITE(INFIL) (TUP(I),I=1,LENGTH)
C           FOR VARIABLE LENGTH RECORDS
C             WRITE(INFIL) L,(TUP(I),I=1,L)
C
C  OUTFIL   FET FOR FILE      (RANDOM) WHICH      (INT,I)
C           CONTAINS CHAINS OF SORTED TUPLES
C           EACH CHAIN CONTAINS ONE OR MORE BLOCKS
C           EACH BLOCK CONTAINS
C            WORD 1   = NO TUPLES IN BLOCK
C            WORD 2   = CHAIN NO,NEG FOR LAST BLOCK
C            WORD 3   = RECORD NUMBER IN CHAIN
C            WORD 4FF = TUPLES IN SORTED ORDER
C
C  NI         NUMBER OF CHAINS GENERATED
C
      INTEGER BUFFER(*)
      INTEGER OUTFIL
C
C  DEFINITION OF LOCAL VARIABLES
C  FIRST AN EXPLANATION OF HOW BUFFER IS USED
C
C  ON TOP OF BUFFER IS TUPLE INPUT AREA,LENGTH LTUMAX-1
C  SECOND IS RECORD OUTPUT AREA,LENGTH LREC
C  THIRD IS TUPLE SORT AREA,LENGTH NREC*(LREC-2)
C  FOUTH AND LAST IS POINTER AREA,LENGTH (NREC*(LREC-2))/LTUMIN
C
C  I1  ADDRESS TO FIRST WORD IN TUPLE AREA
C  I2  ADDRESS TO NEXT TUPLE (LENGTH WORD)
C  I3  AVAILABLE ROOM IN TUPLE AREA
C  I4  ADDRESS TO FIRST WORD IN POINTER AREA
C  I5  ADDRESS TO CURRENT POINTER
C  I6  CURRENT TUPLE ON INPUT FILE
C  I8  ADDRESS TO CURRENT TUPLE IN OUTPUT BUFFER
C  I9  NUMBER OF TUPLES IN OUTPUT BUFFER
C  I10 NUMBER OF OUTPUT RECORDS CURRENTLY WRITTEN
C      IN CHAIN
C  I11 LENGTH OF TUPLE IN INPUT AREA
C
      INCLUDE rin:SRTCOM.BLK
      REWIND INFIL
      I1 = LTUMAX + LREC
      LTUM = LTUMAX - 1
      I2 = I1
      I33 = NREC*(LREC - 3)
      I3 = I33
      I4 = I1 + I3
      I5 = I4
      I6 = 0
      NI = 0
      ILAST = 0
   10 CONTINUE
C
C  FILL TUPLE AREA
C
      I6 = I6 + 1
      IF(I6 .GT. NSORT) GO TO 100
c      READ(INFIL) I11,(BUFFER(J2),J2=1,I11)
      READ(INFIL) I11
      READ(INFIL) (BUFFER(J2),J2=1,I11)
   12 CONTINUE
      IF(I11 .GE. I3) GO TO 20
      DO 15 J2=1,I11
   15 BUFFER(I2+J2) = BUFFER(J2)
      BUFFER(I2) = I11
      BUFFER(I5) = I2 + 1
      I2 = I2 + I11 + 1
      I5 = I5 + 1
      I3 = I3 - I11 - 1
      GO TO 10
   20 CONTINUE
C
C  TUPLE AREA FULL,OR NO
C  MORE TUPLES ON INPUT FILE
C  SORT,UNLOAD
C
      CALL SWICST(BUFFER,BUFFER(I4),I5-I4)
      NI = NI + 1
      BUFFER(LTUM+2) = NI
      J1 = I4
      I10 = 0
   25 I9 = 0
      I8 = LTUM + 4
   30 CONTINUE
      J2 = BUFFER(J1) - 1
      J3 = BUFFER(J2)
      IF(J3+I8 .GE. I1) GO TO 50
      DO 40 J4=1,J3
   40 BUFFER(I8+J4) = BUFFER(J2+J4)
      I9 = I9 + 1
      J1 = J1 + 1
      BUFFER(I8) = J3
      I8 = I8 + J3 + 1
      IF(J1 .LT. I5) GO TO 30
      BUFFER(LTUM+2) = -NI
   50 CONTINUE
C
C  WRITE OUTPUT BUFFER
C
      BUFFER(LTUM+1) = I9
      I10 = I10 + 1
      IF(I10 .EQ. NREC .AND. ILAST .EQ. 0) BUFFER(LTUM+2) = -NI
      BUFFER(LTUM+3) = I10
      CALL RIOOUT(OUTFIL,0,BUFFER(LTUM+1),LREC,IOS)
      IF(BUFFER(LTUM+2).GT.0) GO TO 25
C
C  SHUFFLE TUPLE AREA IF REQUIRED
C
      I2 = I1
      I3 = I33
      I55 = I5
      I5 = I4
      IF(J1 .LT. I55) GO TO 60
      IF(ILAST .EQ. 0) GO TO 12
      RETURN
   60 CONTINUE
      NUM = I55 - J1
      CALL SWSHEL(BUFFER(J1),NUM)
   65 CONTINUE
      J2 = BUFFER(J1) - 1
      J3 = BUFFER(J2)
      DO 70 J4=1,J3
   70 BUFFER(I2+J4) = BUFFER(J2+J4)
      BUFFER(I2) = J3
      BUFFER(I5) = I2 + 1
      I2 = I2 + J3 + 1
      I5 = I5 + 1
      I3 = I3 - J3 - 1
      J1 = J1 + 1
      IF(J1 .LT. I55) GO TO 65
      GO TO 12
  100 CONTINUE
C
C  ALL TUPLES READ FROM INFIL
C
      ILAST = 1
      GO TO 20
      END
      SUBROUTINE TALLY
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  THIS ROUTINE PROCESSES THE RIM TALLY COMMAND
C
C  PARAMETERS: NONE
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:SELCOM.BLK
      INCLUDE rin:TUPLEA.BLK
C
      LOGICAL DONE
      LOGICAL ITALLY
C
C  THE FOLLOWING FUNNY LOOKING STUFF IS TO MAKE THE TITLE
C  "NUMBER OF OCCURANCES" WORK. FTN5, PORTABLE, ETC. -----
C
      INTEGER HEADER(6)
      EQUIVALENCE (HEADER(1),K4HEAD(1))
C
C     SET LPP AND MCPL
C
      LPP = 10000000
      IF(.NOT.CONNO) LPP = 56
      MCPL = 50
      IF(.NOT.CONNO)MCPL = 100
      IF(ULPP.NE.0) LPP = ULPP
      IF(UMCPL.NE.0) MCPL = UMCPL - 25
      IF(MCPL.LT.10) MCPL = 10
C
C     CALL SELPAR TO SET SELCOM BLOCK
C
      ITALLY = .TRUE.
      CALL SELPAR(ITALLY)
      IF(NUMATT.LE.0) GO TO 900
      NLINE = 3
C
C  PUT "NUMBER OF OCCURANCES" INTO THE TITLE LINE
C
      NPOS1 = NUMCOL(1) + 2
      NPOS = NPOS1 + 3
      CALL FILCH(TITLE,NPOS1,3,BLANK)
      CALL FILCH(MINUS,NPOS1,3,BLANK)
      NPOSH = NPOS
      DO 20 K=1,6
      CALL STRMOV(HEADER(K),1,4,TITLE,NPOSH)
      NPOSH = NPOSH + 4
   20 CONTINUE
      CALL FILCH(MINUS,NPOS,21,K4MNUS)
      NUM = NPOS + 20
      if(noutr.ne.6)WRITE (NOUTR,30)
   30 FORMAT(1H )
      CALL SPOUT(TITLE,NUM)
      CALL SPOUT(MINUS,NUM)
C
C  GET THE ATTRIBUTE LENGTH
C
      N2 = ATTWDS
C
C  SET UP THE NUMBER OF WORDS THAT WERE SORTED ON
C
      LOOP = 1
      IF(ATTYPE.EQ.KZTEXT) LOOP = 20/CHPWD
      IF(ATTYPE.EQ.KZDOUB) LOOP = 2
      IF(ATTYPE.EQ.KZDVEC) LOOP = 2
      IF(ATTYPE.EQ.KZDMAT) LOOP = 2
      IF(LOOP.GT.N2) LOOP = N2
C
C  SET UP A SCRATCH AREA IN BUFFER TO HOLD TUPLES
C
C  ESTABLISH THE BUFFER POINTER
C
      CALL BLKCHG(10,MAXCOL,1)
      KQ1 = BLKLOC(10) - 1
C
C  RETRIVE THE SORTED ATTRIBUTE VALUES FROM THE SORT FILE
C
      CALL GTSORT(IP,1,-1,N2)
C
C  GET THE VERY FIRST VALUE.
C
      NPRT = 0
      LIMTUT = LIMTU
      LIMTU = ALL9S
      CALL GTSORT(IP,1,1,N2)
  100 CONTINUE
      NOCC = 1
C
C  USE BUFFER AS A SCRATCH ARRAY TO HOLD THE ATTRIBUTE VALUE
C
      DO 110 N=1,N2
      BUFFER(KQ1+N) = BUFFER(IP+N-1)
  110 CONTINUE
  200 CONTINUE
      CALL GTSORT(IP,1,1,N2)
      IF(RMSTAT.NE.0) GO TO 400
      DO 210 N=1,LOOP
      IF(BUFFER(IP+N-1).NE.BUFFER(KQ1+N)) GO TO 400
  210 CONTINUE
      NOCC = NOCC + 1
      GO TO 200
C
C  THERE HAS BEEN A VALUE CHANGE. PRINT THE VALUE AND COUNT.
C
  400 CONTINUE
      NPRT = NPRT + 1
      IF(NPRT.LE.LIMTUT) GO TO 405
C
C  ALL DONE - CLOSE THE SORT FILE
C
      LIMTU = 0
      CALL GTSORT(IP,1,1,N2)
      GO TO 999
  405 CONTINUE
      CURPOS(1) = 1
      CALL FILCH(LINE,1,NUM,BLANK)
      CALL SELOUT(BUFFER(KQ1+1),1,DONE)
      IF(NLINE.LT.LPP) GO TO 420
      NLINE = 3
      IF(.NOT.CONNO.and.noutr.ne.6) WRITE(NOUTR,410)
  410 FORMAT(1H1)
      if(noutr.ne.6)WRITE(NOUTR,30)
      CALL SPOUT(TITLE,NUM)
      CALL SPOUT(MINUS,NUM)
  420 CONTINUE
C
C  PUT THE COUNT INTO LINE AND PRINT
C
      CALL ITOC(LINE,NPOS1+5,8,NOCC,IERR)
      CALL SPOUT(LINE,NUM)
      NLINE = NLINE + 1
      IF(RMSTAT.EQ.0) GO TO 100
      GO TO 999
C
C     NO VALID ATTRIBUTES
C
  900 CONTINUE
	if(nout.eq.6)goto 3148
      WRITE (NOUT,910)
	goto 999
3148	write(c128wk,910)
	call atxto
  910 FORMAT(40H -WARNING- No Valid Attributes Specified )
  999 CONTINUE
      LIMTU = LIMTUT
      CALL BLKCLR(10)
      RETURN
      END
      SUBROUTINE TOLED(K,V,N)
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE APPLIES A TOLERANCE TO A DOUBLE ROUTINE
C
C     K IS LOCBOO VALUE
C     V(N) IS DOUBLE ARRAY
C
      INCLUDE rin:FLAGS.BLK
      DOUBLE PRECISION V(N)
      DOUBLE PRECISION X
      X = TOL
      IF(K.GT.5) X = -X
      IF(PCENT) GO TO 50
      DO 20 I=1,N
      V(I) = V(I) - X
   20 CONTINUE
      RETURN
   50 CONTINUE
      DO 70 I=1,N
      V(I) = V(I)*(1.-X)
   70 CONTINUE
      RETURN
      END
      SUBROUTINE TOLER(K,V,N)
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE APPLIES A TOLERANCE TO A REAL ROUTINE
C
C     K IS LOCBOO VALUE
C     V(N) IS REAL ARRAY
C
      INCLUDE rin:FLAGS.BLK
      DIMENSION V(N)
      X = TOL
      IF(K.GT.5) X = -TOL
      IF(PCENT) GO TO 50
      DO 20 I=1,N
      V(I) = V(I) - X
   20 CONTINUE
      RETURN
   50 CONTINUE
      DO 70 I=1,N
      V(I) = V(I)*(1.-X)
   70 CONTINUE
      RETURN
      END
      LOGICAL FUNCTION TTY(I)
C
C  DUMMY ROUTINE FOR TTY ON THE VAX -- ALWAYS TRUE
C
      TTY = .TRUE.
      RETURN
      END
      SUBROUTINE TYPER(ATYPE,VECMAT,TYPE)
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE TURNS RIM TYPES SUCH AS IVEC
C     INTO TWO USEFUL TYPES.
C
C     ATYPE...RIM TYPE
C     VECMAT..3HVEC,3HMAT OR BLANKS
C     TYPE....3HINT,4HREAL,4HDOUB,4HTEXT
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:CONST4.BLK
C
      INTEGER ATYPE,VECMAT,TYPE
      VECMAT = IBLANK
      TYPE = ATYPE
      IF(TYPE.EQ.KZTEXT) RETURN
      IF(TYPE.EQ.KZINT ) RETURN
      IF(TYPE.EQ.KZREAL) RETURN
      IF(TYPE.EQ.KZDOUB) RETURN
      VECMAT = KZVEC
      TYPE = K4NONE
      IF(ATYPE.EQ.KZIVEC) TYPE = KZINT
      IF(ATYPE.EQ.KZRVEC) TYPE = KZREAL
      IF(ATYPE.EQ.KZDVEC) TYPE = KZDOUB
      IF(TYPE.NE.K4NONE) RETURN
      VECMAT = KZMAT
      IF(ATYPE.EQ.KZIMAT) TYPE = KZINT
      IF(ATYPE.EQ.KZRMAT) TYPE = KZREAL
      IF(ATYPE.EQ.KZDMAT) TYPE = KZDOUB
      RETURN
      END
      SUBROUTINE UNDATA (ALL,IRCNTR,IDAY,WORD1,LHASH,NAMOWN)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  UNLOADS THE DATA OF A DATABASE.
C
C  INPUTS:
C          ALL---------TRUE IF ALL RELATIONS ARE SPECIFIED.
C          IRCNTR------NUMBER OF RELATIONS IF SPECIFIED (ALL IS FALSE).
C          IDAY--------DAY CODE FOR HASH
C          WORD1--------COMMAND SPECIFIED.
C          LHASH--------LOGICAL SWITCH FOR HASH
C          NAMOWN--------FOR CHECKING PERMISSION
C          NAMOWN-------NAMOWN TO PASS TO CHKREL
C          NAMDB--------NAMDB FOR DEFINE.
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:DCLAR6.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:DCLAR1.BLK
      INCLUDE rin:DCLAR2.BLK
      INCLUDE rin:DCLAR3.BLK
      INTEGER LINE (20),QUOTE,DONE,
     X                START,ATTSTR,ATTCNT,TUPLE,STEP
      REAL*8 IREL(100)
      INTEGER ATDATA(250,5),STAT
      EQUIVALENCE (BUFFER(1),IREL(1)),(BUFFER(201),ATDATA(1,1))
      LOGICAL ALL,PERM,LHASH
C
C
C
C
	if(noutr.eq.6)goto 3140
      WRITE (NOUTR,50)
	goto 3141
3140	write(c128wk,50)
	call atxto
3141	continue
   50 FORMAT (1X,7HNOCHECK)
      J = LOCREL (BLANK)
      I = 0
      CALL FILCH (LINE,1,80,IBLANK)
      MPW1 = BLANK
   75 CONTINUE
C
C  GET MODIFY PASSWORD
C
      IF (ALL) GO TO 80
C
C  SUBSET OF THE DATA
C
      I = I + 1
      IF (I .GT. IRCNTR) GO TO 800
      RNAME = IREL(I)
      J = LOCREL (RNAME)
      GO TO 85
   80 CONTINUE
      CALL CHKREL (PERM,WORD1,ISTAT,NAMOWN)
      IF (ISTAT .NE. 0) GO TO 800
      IF  (.NOT. PERM) GO TO 80
   85 CONTINUE
      IF ((MPW .EQ. K4NONE) .OR. (MPW .EQ. MPW1)) GO TO 100
      CALL STRMOV(KWUSER,1,4,LINE,2)
      CALL PUTT(LINE,7,K4QUOT)
      NUM = 16
      IF (LHASH) NUM = 24
      IF (LHASH) CALL HASHIN (MPW,IDAY,LINE,8)
      IF (.NOT. LHASH) CALL STRMOV (MPW,1,8,LINE,8)
      CALL PUTT (LINE,NUM,K4QUOT)
      CALL SPOUT (LINE,NUM)
      MPW1 = MPW
  100 CONTINUE
C
C  WRITE LOAD COMMAND
C
	if(noutr.eq.6)goto 3142
      WRITE (NOUTR,150) NAME
	goto 3143
3142	write(c128wk,150)name
	call atxto
3143	continue
  150 FORMAT (1X,4HLOAD,1X,A8)
      J = LOCATT (BLANK,NAME)
      IND = 1
      ATTCNT = 0
  160 CALL ATTGET (ISTAT)
      IF (ISTAT .NE. 0) GO TO 250
      ATTCNT = ATTCNT + 1
      ATDATA (ATTCNT,1) = ATTCOL
      ATDATA (ATTCNT,2) = ATTCHA
      ATDATA (ATTCNT,3) = ATTWDS
C
C  GET ATTRIBUTE TYPE AND STRUCTURE
C
      CALL TYPER (ATTYPE,ATDATA(ATTCNT,5),ATDATA(ATTCNT,4))
      GO TO 160
  250 CONTINUE
      NEXTID = RSTART
      STAT = 0
C
C  PROCESS THE TUPLES
C
      DO 600 NEXTUP = 1,NTUPLE
      NC = 2
      KK = 0
      DONE = 0
C
C  GET THE DATA -- NC IS THE NUMBER OF CHARACTERS
C
      CALL GETDAT(IND,NEXTID,ITUP,LEN)
      CALL FILCH (LINE,1,80,IBLANK)
C
C  PROCESS THE TUPLE ACCORDING TO THE NUMBER OF ATTRIBUTES
C
      DO 500 LL = 1,ATTCNT
      STEP = 1
      ICOUNT = ATDATA (LL,1)
      IF (LL .EQ. ATTCNT) DONE = 1
      LEN1 = ATDATA (LL,2)
      LEN2 = ATDATA (LL,3)
      ATTSTR = ATDATA (LL,5)
      TUPLE = ITUP + ICOUNT - 1
C
C  CHECK TO SEE IF VARYING LENGTH -- IF SO GET NEW LENGTHS
C
      IF (LEN2 .NE. 0) GO TO 265
C
C  VARYING ATTRIBUTE
C
C  CHECK TO SEE IF VARYING SCALAR--IF SO, CHANGE TO VECTOR
      IF (ATTSTR .EQ. IBLANK) ATTSTR = KZVEC
      TUPLE = BUFFER (TUPLE) + ITUP - 1
      LEN2 = BUFFER (TUPLE)
      LEN1 = BUFFER (TUPLE + 1)
      TUPLE = TUPLE + 2
  265 CONTINUE
      ATTYPE = ATDATA (LL,4)
      IF (ATTYPE .NE. KZDOUB) GO TO 270
      LEN2 = LEN2/2
      STEP = 2
  270 CONTINUE
      IF(BUFFER(TUPLE).NE.NULL) GO TO 272
C
C  NULL VALUE - UNLOAD -0- ONLY
C
      CALL STRMOV(NULL,1,3,LINE,NC)
      NC = NC + 4
      IF(DONE.EQ.1) STAT = 1
      IF(NC.GE.60) CALL WRLINE(NC,STAT,LINE)
      GO TO 500
  272 CONTINUE
      IF (ATTYPE .NE. KZTEXT) GO TO 300
C
C  TEXT ITEM -- LEN1 IS NUMBER OF CHARACTERS
C
      CALL PUTT (LINE,NC,K4QUOT)
C
C  TEXT PROCESSING SECTION
C
      START = 1
      NC = NC + 1
      NONBLK = NSCAN (BUFFER(TUPLE),LEN1,-LEN1,IBLANK,1,1)
C
C  CHECK FOR BLANK LINE
C
      IF (NONBLK .EQ. 0) NONBLK = 1
C
C  CHECK FOR DOUBLE QUOTES
C
  290 CONTINUE
      ICHAR = NONBLK
      QUOTE = LSTRNG (BUFFER(TUPLE),START,NONBLK,K4QUOT,1,1)
      IF (QUOTE .NE. 0) ICHAR = (QUOTE - START + 1)
C
C  CHECK TO SEE IF THE TEXT STRING CAN FIT ON THE LINE
C
      IF ((NC + ICHAR) .GT. 60) ICHAR = 60 - NC
      IF(ICHAR.EQ.0) ICHAR = 1
      CALL STRMOV (BUFFER (TUPLE),START,ICHAR,LINE,NC)
      NC = NC + ICHAR
C
C  CHECK TO SEE IF WE ARE DONE
C
      IF (ICHAR .NE. (QUOTE - START + 1)) GO TO 295
C
C  NOT DONE -- HAVE A DOUBLE QUOTE
C
      CALL PUTT (LINE,NC,K4QUOT)
      NC = NC + 1
  295 CONTINUE
      START = START + ICHAR
      NONBLK = NONBLK - ICHAR
C
C  CHECK FOR FULL LINE
C
      IF ((NONBLK .NE. 0) .AND. (NC .GE. 60))
     X             CALL WRLINE (NC,STAT,LINE)
C
C  CHECK TO MAKE SURE SPLIT TEXT BEGINS IN COL. 1
C
      IF ((NONBLK .NE. 0) .AND. (NC .EQ. 2)) NC = 1
C
C  SPLIT LINE TEXT ATTRIBUTE OR DOUBLE QUOTE
C
      IF (NONBLK .NE. 0) GO TO 290
C
C  DONE WITH PROCESSING TEXT ITEM -- ADD QUOTES
C
C
C  LENGTH OF TEXT ATTRIBUTE IS STORED IN LEN2
C
  298 CONTINUE
      IF (DONE .EQ. 1) STAT = 1
      CALL PUTT (LINE,NC,K4QUOT)
      NC = NC + 2
      IF (NC .GE. 60) CALL WRLINE (NC,STAT,LINE)
      GO TO 500
C
C  PROCESS REAL AND INTEGER STUFF
C
  300 CONTINUE
      MATLEN = 1
C
C  PROCESS REAL OR INTEGER ATTRIBUTE (MATRIX,VECTOR, OR SCALAR)
C
      IF (ATTSTR .NE. KZMAT) GO TO 315
C
C  MATRIX PROCESSING -- NEED TO SET MATLEN AND CHANGE LEN2
C  TO THE NUMBER OF COLUMNS
C
      MATLEN = LEN1
      IF (LEN1 .NE. 0) LEN2 = LEN2/LEN1
      CALL PUTT (LINE,NC,K4LPAR)
      NC = NC + 1
  315 CONTINUE
      DO 350 KK = 1,LEN2
      IF ((((LEN2 .EQ. 1) .AND. (ATTSTR .NE. KZVEC)) .OR. (KK .GT. 1))
     X        .AND. (ATTSTR .NE. KZMAT)) GO TO 320
      CALL PUTT (LINE,NC,K4LPAR)
      NC = NC + 1
  320 CONTINUE
      DO 330 J = 1,MATLEN
C
C  CHECK TO SEE IF LAST DATA IN TUPLE -- IF SO SET STAT TO 1
C
      IF ((KK .EQ. LEN2) .AND. (J .EQ. MATLEN)
     X      .AND. (DONE .EQ. 1)) STAT = 1
      CALL SELPUT (BUFFER(TUPLE),ATTYPE,10,NC,LINE)
      NC = NC + 11
C
C             MAKE SURE NO DANGLING PARENS WITHOUT PLUS SIGN
C
      IF ((STAT .EQ. 1) .AND. (NC .GE. 60) .AND.
     X ((ATTSTR .EQ. KZVEC) .OR. (ATTSTR .EQ. KZMAT)))  STAT = 0
      IF (NC .GE. 60) CALL WRLINE (NC,STAT,LINE)
      TUPLE = TUPLE + STEP
  330 CONTINUE
      IF (ATTSTR .NE. KZMAT) GO TO 350
      CALL STRMOV (K4RPAR,1,2,LINE,NC)
      NC = NC + 2
  350 CONTINUE
      IF ((ATTSTR .EQ. IBLANK) .AND. (LEN2 .EQ. 1)) GO TO 360
      IF (NC .NE. 2) NC = NC - 1
      CALL STRMOV (K4RPAR,1,2,LINE,NC)
      NC = NC + 2
  360 CONTINUE
      IF (NC .GE. 60) CALL WRLINE (NC,STAT,LINE)
  500 CONTINUE
      IF (NC .NE. 2) CALL WRLINE (NC,1,LINE)
      STAT = 0
  600 CONTINUE
C
C  WRITE END STATEMENT FOR RELATION
C
	if(noutr.eq.6)goto 3145
      WRITE (NOUTR,700)
  700 FORMAT (1X,3HEND)
      GO TO 75
3145	write(c128wk,700)
	call atxto
	goto 75
  800 CONTINUE
      RMSTAT = 0
      RETURN
      END
      SUBROUTINE UNDEF (ALL,IRCNTR,IDAY,WORD1,LHASH,NAMOWN,NAMDB)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  UNLOADS THE DEFINITION OF A DATABASE.
C
C  INPUTS:
C          ALL------------TRUE IF ALL RELATIONS ARE SPECIFIED.
C          IRCNTR---------NUMBER OF RELATIONS IF SPECIFIED (ALL IS FALSE
C          IDAY-----------DAY CODE FOR HASH.
C          WORD1-----------COMMAND SPECIFIED.
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:DCLAR2.BLK
      INCLUDE rin:DCLAR6.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:DCLAR1.BLK
      INCLUDE rin:DCLAR3.BLK
      LOGICAL ALL,PERM,LHASH
C
C
      REAL*8 IREL(100),ATREL(2000)
      INTEGER STRUC,TYPE,WITH
      EQUIVALENCE (BUFFER(1),IREL(1)),(BUFFER(201),ATREL(1))
      DIMENSION LINE(20)
      IACNTR = 0
      CALL FILCH (LINE,1,80,IBLANK)
	if(noutr.eq.6)goto 3140
      WRITE (NOUTR,3) NAMDB
	goto 3141
3140	write(c128wk,3)namdb
	call atxto
3141	continue
    3 FORMAT (1X,7HDEFINE ,A6)
      CALL STRMOV(KWOWNE,1,5,LINE,2)
      CALL PUTT(LINE,8,K4QUOT)
      NUM = 17
      IF (LHASH) NUM = 25
      IF (LHASH) CALL HASHIN (USERID,IDAY,LINE,9)
      IF (.NOT. LHASH) CALL STRMOV (USERID,1,8,LINE,9)
      CALL PUTT (LINE,NUM,K4QUOT)
      CALL SPOUT (LINE,NUM)
	if(noutr.eq.6)goto 3142
      WRITE (NOUTR,4)
    4 FORMAT (1X,10HATTRIBUTES)
	goto 3143
3142	write(c128wk,4)
	call atxto
3143	continue
C
C  PROCESS ATTRIBUTES
C
      I = 0
      IF (IRCNTR .EQ. ALL9S) IRCNTR = 0
      J = LOCREL(BLANK)
    5 CONTINUE
      IF (ALL) GO TO 7
      I = I + 1
      IF (I .GT. IRCNTR) GO TO 50
      K = LOCATT (BLANK,IREL(I))
      GO TO 10
    7 CONTINUE
      CALL CHKREL(PERM,WORD1,ISTAT,NAMOWN)
      IF (ISTAT .NE. 0) GO TO 50
      IF (.NOT. PERM)  GO TO 7
      IRCNTR = IRCNTR + 1
      K = LOCATT (BLANK,NAME)
   10 CONTINUE
      CALL ATTGET (ISTAT)
      IF (ISTAT .NE. 0) GO TO 5
      IF (IACNTR .EQ. 0) GO TO 20
      DO 15 L = 1,IACNTR
      IF (ATTNAM .EQ. ATREL(L)) GO TO 10
   15 CONTINUE
C
C  NEW ATTRIBUTE
C
   20 CONTINUE
      IACNTR = IACNTR + 1
      ATREL(IACNTR) = ATTNAM
      CALL TYPER (ATTYPE,STRUC,TYPE)
      DO 22 KK = 1,4
   22 LINE(KK) = IBLANK
      IF (ATTKEY .NE. 0) LINE (4) = K4KEY
      IF (ATTWDS .EQ. 0) LINE (3) = KZVAR
      IF ((TYPE .NE. KZTEXT) .OR. (ATTWDS .EQ. 0)) GO TO 25
      ATTWDS = ATTCHA
      IF(ATTCHA.EQ.1) CALL PUTT(LINE(3),4,K41)
   25 CONTINUE
      IF (TYPE .EQ. KZDOUB) ATTWDS = ATTWDS/2
      IF ((ATTWDS .NE. 0) .AND. (ATTWDS .NE. ATTCHA) .AND.
     X           (STRUC .NE. IBLANK)) ATTWDS = ATTWDS/ATTCHA
      IF ((STRUC .NE. IBLANK) .AND. (ATTWDS .NE. 0))
     X              CALL ITOC (LINE(3),1,4,ATTWDS,IERR)
      IF ((STRUC .EQ. IBLANK) .AND. (ATTWDS .GT. 1))
     X              CALL ITOC (LINE(3),1,4,ATTWDS,IERR)
      IF (STRUC .NE. KZMAT) GO TO 40
      IF (ATTCHA .NE. 0) CALL ITOC (LINE(1),1,4,ATTCHA,IERR)
      LINE(2) = K4COMA
      IF (ATTCHA .EQ. 0) LINE(1) = KZVAR
   40 CONTINUE
	if(noutr.eq.6)goto 3144
      WRITE (NOUTR,45) ATTNAM,ATTYPE,(LINE(IN),IN=1,4)
   45 FORMAT (1X,A8,2X,A4,2X,A4,A1,A4,2X,A3)
      GO TO 10
3144	write(c128wk,45)attnam,attype,(line(in),in=1,4)
	call atxto
	goto 10
C
C
   50 CONTINUE
      IF (IRCNTR .EQ. 0) GO TO 400
      J = LOCREL(BLANK)
	if(noutr.eq.6)goto 3145
      WRITE (NOUTR,80)
	goto 3146
3145	write(c128wk,80)
	call atxto
3146	continue
   80 FORMAT (1X,9HRELATIONS)
C
C  LOOP THROUGH AND PRINT THE RELATIONS WITH THEIR ATTRIBUTES
C
      DO 150 I = 1,IRCNTR
      IF (ALL) GO TO 90
      RNAME = IREL(I)
      J = LOCREL (RNAME)
      CALL RELGET (ISTAT)
      GO TO 95
   90 CONTINUE
      CALL CHKREL (PERM,WORD1,ISTAT,NAMOWN)
      IF (ISTAT .NE. 0) GO TO 150
      IF (.NOT. PERM) GO TO 90
      RNAME = NAME
   95 CONTINUE
      ICUM = 0
      ICOUNT = 1
      NAMES (1) = RNAME
      WITH = K4WITH
      IEND = K4PLUS
      J = LOCATT (BLANK,RNAME)
  100 CONTINUE
      CALL ATTGET (ISTAT)
      IF (ISTAT .NE. 0) GO TO 105
      ICOUNT = ICOUNT + 1
      ICUM = ICUM + 1
      NAMES (ICOUNT) = ATTNAM
      IF (ICOUNT .LT. 5) GO TO 100
  105 IF (ICUM .EQ. NATT) IEND = IBLANK
	if(noutr.eq.6)goto 3147
      IF (ICOUNT .NE. 1) WRITE (NOUTR,110) NAMES(1),WITH,
     X         (NAMES(KK),KK=2,ICOUNT),IEND
	goto 3148
3147	continue
      IF (ICOUNT .NE. 1) WRITE (c128wk,110) NAMES(1),WITH,
     X         (NAMES(KK),KK=2,ICOUNT),IEND
	if(icount.ne.q)call atxto
3148	continue
  110 FORMAT (1X,A8,1X,A4,1X,5(A8,1X))
      NAMES(1) = BLANK
      WITH = IBLANK
      ICOUNT = 1
      IF (ISTAT .EQ. 0) GO TO 100
  150 CONTINUE
C
C  PRINT PASSWORDS (HASHED)
C
	if(noutr.eq.6)goto 3149
      WRITE (NOUTR,175)
	goto 3150
3149	write(c128wk,175)
	call atxto
3150	continue
  175 FORMAT (1X,9HPASSWORDS)
      CALL FILCH (LINE,1,80,IBLANK)
      J = LOCREL (BLANK)
      DO 300 I = 1,IRCNTR
      IF (ALL) GO TO 225
      J = LOCREL (IREL(I))
      RNAME = IREL(I)
      GO TO 240
  225 CONTINUE
      CALL CHKREL (PERM,WORD1,ISTAT,NAMOWN)
      IF (.NOT. PERM) GO TO 225
      RNAME = NAME
  240 CONTINUE
      CALL STRMOV(KWRPW,1,3,LINE,2)
      CALL STRMOV(K4FOR,1,3,LINE,6)
      CALL STRMOV (RNAME,1,8,LINE,10)
      CALL STRMOV(K4IS,1,2,LINE,19)
      CALL PUTT(LINE,22,K4QUOT)
      NUM = 31
      IF (LHASH) NUM = 39
      CALL PUTT (LINE,NUM,K4QUOT)
      RPW1 = RPW
      DO 250 J = 1,2
      IF (RPW1 .EQ. K4NONE) GO TO 230
      IF (LHASH) CALL HASHIN (RPW1,IDAY,LINE,23)
      IF (.NOT. LHASH) CALL STRMOV (RPW1,1,8,LINE,23)
      CALL SPOUT (LINE,NUM)
  230 CONTINUE
      RPW1 = MPW
      CALL PUTT (LINE,2,K4M)
  250 CONTINUE
  300 CONTINUE
  400 CONTINUE
	if(noutr.eq.6)goto 3151
      WRITE (NOUTR,450)
  450 FORMAT (1X,3HEND)
      RETURN
3151	write(c128wk,450)
	call atxto
	return
      END
      SUBROUTINE UNLOAD
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  SUBROUTINE CHECKS SYNTAX ON UNLOAD COMMAND AND UNLOADS
C            ACCORDING TO WHAT THE USER SPECIFIED.  CALLS UNDATA AND
C            UNDEF TO ACCOMPLISH THIS PURPOSE.
C
C
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:BUFFER.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:DCLAR1.BLK
      INCLUDE rin:DCLAR2.BLK
      INCLUDE rin:DCLAR3.BLK
      INCLUDE rin:DCLAR6.BLK
      INCLUDE rin:MISC.BLK
      REAL*8 IREL(100)
      INTEGER CHAR1,CHAR2
      EQUIVALENCE (BUFFER(1),IREL(1))
      LOGICAL ALL,PERM,LHASH
      DIMENSION NUMBER(9)
      EQUIVALENCE (NUMBER(1),K41)
      DATA NAMES /10*0/
      DATA NWORDS /2500/
      NAMES(1) = K8SCH
      NAMES(2) = K8ALL
      NAMES(3) = K8DATA
      LHASH = .FALSE.
      NOGO = 0
C
C  CLEAR OUT ANY PAGE DATA LEFT IN BUFFER
C
      CALL BLKCLN
      RMSTAT = 0
      ALL = .TRUE.
      WORD1 = K8ALL
      NUM = 2
      NAMOWN = USERID
      NAMDB = DBNAME
      ITEMS = LXITEM (I)
C
C  CHECK TO SEE IF DEFAULTS
C
      IF (ITEMS .EQ. 1) GO TO 25
C
C  FIND OUT IF WANT ALL,SCHEMA, OR DATA
C
C  SAVE THE PARTICULAR UNLOAD COMMAND IN WORD1
C
      WORD2 = BLANK
      CALL LXSREC (2,1,8,WORD2,1)
      DO 5 I = 1,3
      IF (NAMES (I) .NE. WORD2) GO TO 5
      WORD1 = WORD2
      GO TO 20
    5 CONTINUE
C
C  CHECK FOR DATA BASE NAME
C
      NAMDB = WORD2
      IF (NAMDB .NE. DBNAME) GO TO 9000
C
C  CHECK TO SEE IF DEFAULTS TO ALL
C
      IF (ITEMS .EQ. 2) GO TO 20
      NUM = NUM + 1
C
C  CHECK TO SEE IF WANTS TO CHANGE THE DBNAME
C
C
      IF (LXWREC (3,1) .NE. K4EQS) GO TO 15
      IF (ITEMS .EQ. 3) GO TO 9000
C
C  CHANGE THE NAME
C
      NAMDB = BLANK
      CALL LXSREC (4,1,6,NAMDB,1)
      NUM = NUM + 2
C
C  CHECK TO SEE IF JUST DEFAULT TO ALL
C
      IF (ITEMS .LE. 4) GO TO 20
   15 CONTINUE
      WORD1 = BLANK
      CALL LXSREC (NUM,1,8,WORD1,1)
C
C  CHECK TO SEE IF VALID COMMAND
C
      IF ((WORD1 .NE. K8ALL) .AND. (WORD1 .NE. K8SCH) .AND.
     X      (WORD1 .NE. K8DATA)) GO TO 9000
C
C
  20  CONTINUE
C
C  CHECK FOR HASH
C
      IF (NUM .EQ. ITEMS) GO TO 25
      IF (LXWREC(NUM + 1,1) .NE. K4EQS) GO TO 25
      IF (NUM + 1 .EQ. ITEMS) GO TO 9000
      IF (LXWREC(NUM + 2,1) .NE. K4HASH) GO TO 9000
      LHASH = .TRUE.
      NUM = NUM + 2
   25 CONTINUE
      ICNTR = 0
      CALL BLKDEF (10,NWORDS,1)
      IPERM = 0
  100 CONTINUE
      IF (ITEMS .GT. NUM) GO TO 200
C
C  THE COMMAND IS ALL SO SET ICNTR TO MAX
C
      ICNTR = ALL9S
      GO TO 400
C
C  THE USER HAS SPECIFIED WHICH RELATIONS HE WANTS DUMPED
C
  200 CONTINUE
      J = NUM + 1
      ALL = .FALSE.
  210 CONTINUE
      RNAME = BLANK
      CALL LXSREC (J,1,8,RNAME,1)
      IERR = 0
      IN = LOCREL (RNAME)
      IF (IN .EQ. 0) GO TO 225
	if(nout.eq.6)goto 3140
      WRITE (NOUT,215) RNAME
	goto 3141
3140	write(c128wk,215)rname
	call atxto
3141	continue
  215 FORMAT (2X,34H--ERROR-- Incorrect Relation Name ,A8)
      RMSTAT = 2
      IERR = 1
  225 CONTINUE
      IF ((J + 1) .GT. ITEMS) GO TO 250
      RNAME1 = BLANK
      CALL LXSREC (J+1,1,8,RNAME1,1)
      IF (RNAME1 .NE. K4EQS) GO TO 250
C
C  CHECK FOR INCORRECT SYNTAX
C
      IF ((J + 2) .GT. ITEMS) GO TO 9000
      J = J + 2
      IF (IERR .EQ. 1) GO TO 350
C
C  CHECK FOR PASSWORD
C
      NAMOWN = BLANK
      CALL LXSREC (J,1,8,NAMOWN,1)
  250 CONTINUE
C
C
C  CALL CHKREL TO CHECK PASSWORD PERMISSION ON THE UNLOAD
C
      CALL CHKREL (PERM,WORD1,ISTAT,NAMOWN)
      IF (PERM) GO TO 300
	if(nout.eq.6)goto 3142
      WRITE (NOUT,275) RNAME
	goto 3143
3142	write(c128wk,275)rname
	call atxto
3143	continue
  275 FORMAT (2X,43H--ERROR-- YOU Are Not Authorized To UNLOAD ,A8)
      RMSTAT = 9
      IERR = 1
      GO TO 350
  300 CONTINUE
C
C  CHECK TO MAKE SURE THERE IS ONLY ONE OF THE RELATIONS LISTED
C
      IF (ICNTR .EQ. 0 ) GO TO 335
      DO 310 KK = 1,ICNTR
      IF (IREL(ICNTR) .EQ. RNAME) GO TO 325
  310 CONTINUE
      GO TO 335
  325 CONTINUE
	if(nout.eq.6)goto 3144
      WRITE (NOUT,330) RNAME
  330 FORMAT (2X,39H--WARNING-- You Have Already Specified ,
     X            14HRelation Name ,A8)
      GO TO 350
3144	write(c128wk,330)rname
	call atxto
	goto 350
C
C  EVERYTHING IS CORRECT -- SAVE CERTAIN DATA IN IREL(ICNTR)
C
  335 CONTINUE
      ICNTR = ICNTR + 1
      IREL(ICNTR) = NAME
  350 CONTINUE
      J = J + 1
      IF (IERR .EQ. 1) NOGO = 1
      IF ( J .LE. ITEMS) GO TO 210
C
C  DONE WITH PERMISSION AND CRACKING
C
  400 CONTINUE
      IF (NOGO .EQ. 1) GO TO 9999
	if(noutr.eq.6)goto 3145
      WRITE(NOUTR,425)
	goto 3146
3145	write(c128wk,3425)
	call atxto
3146	continue
425    FORMAT(16H*(SET SEMI=NULL),/,18H*(SET DOLLAR=NULL))
3425    FORMAT(16H*(SET SEMI=NULL),1x,18H*(SET DOLLAR=NULL))
      IF (.NOT. LHASH) GO TO 480
      CALL RMDATE (IDAY)
      CALL RMTIME (ITIME)
	if(noutr.eq.6)goto 3147
      WRITE (NOUTR,450) ITIME,IDAY
	goto 3148
3147	write(c128wk,450)itime,iday
	call atxto
3148	continue
  450 FORMAT (24H RIM Communication File ,2A10)
C
C  CHANGE DAY DATE TO INTEGER
C
      CALL GETT (IDAY,8,CHAR1)
      CALL GETT (IDAY,7,CHAR2)
      DO 475 KK=1,9
      IF (CHAR1 .EQ. NUMBER (KK)) CHAR1 = KK
      IF (CHAR2 .EQ. NUMBER (KK)) CHAR2 = KK
  475 CONTINUE
      IF(CHAR1.EQ.K40) CHAR1 = 0
      IF((CHAR2.EQ.K40).OR.(CHAR2.EQ.IBLANK)) CHAR2 = 0
      NUM = CHAR2 * 10 + CHAR1
      NUM = MOD (NUM,7)
C
C  IF DIRECTIVE ALL OR SCHEMA CALL UNDEF
C
  480 CONTINUE
      IF ((WORD1 .EQ. K8SCH) .OR. (WORD1 .EQ. K8ALL))
     X             CALL UNDEF (ALL,ICNTR,NUM,WORD1,LHASH,NAMOWN,NAMDB)
      IF (ICNTR .EQ. 0) GO TO 8000
      IF ((WORD1 .EQ. K8ALL) .OR. (WORD1 .EQ. K8DATA))
     X             CALL UNDATA (ALL,ICNTR,NUM,WORD1,LHASH,NAMOWN)
      IF (ICNTR .EQ. 0) GO TO 8000
	if(noutr.eq.6)goto 3149
      WRITE(NOUTR,490)
  490 FORMAT(13H*(SET SEMI=;),/,15H*(SET DOLLAR=$))
      GO TO 9999
3149	write(c128wk,3490)
 3490 FORMAT(13H*(SET SEMI=;),15H*(SET DOLLAR=$))
	call atxto
	goto 9999
 8000 CONTINUE
C
C  ERROR FOR UNLOADING ALL OF THE DATA
C
	if(nout.eq.6)goto 3150
      WRITE (NOUT,8001)
 8001 FORMAT (/,2X,39H--ERROR-- YOU Do Not Have Authorization,
     X        /,13X,26HTo UNLOAD All Of The Data.,/)
      RMSTAT = 9
      GO TO 9999
3150	write(c128wk,3801)
 3801 FORMAT (2X,39H--ERROR-- YOU Do Not Have Authorization,
     X        3X,26HTo UNLOAD All Of The Data.)
	call atxto
	rmstat=9
	goto 9999
C
C  INCORRECT SYNTAX ERROR MESSAGE
C
 9000 CONTINUE
	if(nout.eq.6)goto 3152
      WRITE (NOUT,9001)
 9001 FORMAT (2X,42H--ERROR-- Incorrect Syntax For The Command)
      RMSTAT = 4
	goto 9999
3152	write(c128wk,9001)
	call atxto
C
C  CLEAN UP AND END
C
 9999 CONTINUE
      CALL BLKCLR (10)
      RETURN
      END
      SUBROUTINE LOWER(I,LOW)
      Character*1 I,LOW
      Character*1 TABLE(2,26)
      DATA TABLE /1HA,1Ha,1HB,1Hb,1HC,1Hc,1HD,1Hd,1HE,1He
     x,1HF,1Hf,1HG,1Hg,1HH,1Hh,1HI,1Hi,1HJ,1Hj,1HK,1Hk,1HL,1Hl
     x,1HM,1Hm,1HN,1Hn,1HO,1Ho,1HP,1Hp,1HQ,1Hq,1HR,1Hr,1HS,1Hs
     x,1HT,1Ht,1HU,1Hu,1HV,1Hv,1HW,1Hw,1HX,1Hx,1HY,1Hy,1HZ,1Hz/
      DO 100 J=1,26
      IF(TABLE(1,J).EQ.I) LOW = TABLE(2,J)
  100 CONTINUE
      RETURN
      END
      SUBROUTINE WARN(NUM,WORD1,WORD2)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   GENERAL PURPOSE WARNING PRINT ROUTINE
C
C  PARAMETERS:
C     INPUT:  NUM-----WARNING NUMBER
C             WORD1----OPTIONAL NAME
C             WORD2----OPTIONAL NAME
C
      INCLUDE rin:CONST8.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:DCLAR6.BLK
C
	if(nout.eq.6)goto 3140
      IF(NUM.NE.1) GO TO 2
      WRITE (NOUT,100) WORD1
  100 FORMAT(9H -ERROR- ,A8,
     X      34H Is Not A Recognized Relation Name )
      GO TO 99
C
    2 IF(NUM.NE.2) GO TO 3
      WRITE (NOUT,200)
  200 FORMAT(27H -ERROR- Undefined Relation )
      GO TO 99
C
    3 IF(NUM.NE.3) GO TO 4
      WRITE (NOUT,300) WORD1,WORD2
  300 FORMAT(19H -ERROR- ATTRIBUTE ,A8,
     X       24H is not in the relation ,A8)
      GO TO 99
C
    4 IF(NUM.NE.4) GO TO 5
      WRITE (NOUT,400)
  400 FORMAT(45H -ERROR- Syntax Is Incorrect For The Command )
      GO TO 99
C
    5 IF(NUM.NE.5) GO TO 6
      WRITE (NOUT,500)
  500 FORMAT(49H -ERROR- Syntax Is Incorrect For The WHERE Clause )
      GO TO 99
C
    6 IF(NUM.NE.6) GO TO 7
      WRITE (NOUT,600)
  600 FORMAT(41H Command Terminated - Enter Next Command )
      CALL SETIN(K8IN)
      GO TO 99
C
    7 IF(NUM.NE.7) GO TO 8
      WRITE (NOUT,700) WORD1,WORD2
  700 FORMAT(9H -ERROR- ,A8,A1,
     X      34H Names May Not Exceed 8 Characters  )
      GO TO 99
C
    8 IF(NUM.NE.8) GO TO 9
      GO TO 99
C
    9 IF(NUM.NE.9) GO TO 10
      WRITE(NOUT,900) WORD1
  900 FORMAT(41H -ERROR- Unauthorized Access To Relation ,A8)
      GO TO 99
C
   10 IF(NUM.NE.10) GO TO 11
      WRITE (NOUT,1000)
 1000 FORMAT(50H -ERROR- DATA FILES Do Not Contain A RIM Data Base)
      GO TO 99
C
   11 IF(NUM.NE.11) GO TO 12
      WRITE (NOUT,1100)
 1100 FORMAT(52H -ERROR- DATA BASE NAME Does Not Match File Contents)
      GO TO 99
C
   12 IF(NUM.NE.12) GO TO 13
      WRITE(NOUT,1200) WORD1
 1200 FORMAT(13H -ERROR- The ,A7,32H DATABASE Files Are Incompatible)
      GO TO 99
C
   13 IF(NUM.NE.13) GO TO 14
      WRITE(NOUT,1300) WORD1
 1300 FORMAT(1X,12H-ERROR- THE ,A7,25H DATABASE Is Attached In ,
     1            14HRead Only Mode)
      GO TO 99
C
   14 IF(NUM.NE.14) GO TO 15
      WRITE(NOUT,1400) WORD1
 1400 FORMAT(1X, 4HTHE ,A7,29H DATABASE Is Being Updated - ,
     1            16HPlease Try Later)
      GO TO 99
C
   15 IF(NUM.NE.15) GO TO 16
      WRITE(NOUT,1500) WORD1
 1500 FORMAT(18H -ERROR- DATABASE ,A7,20H Is Not A Local File )
      GO TO 99
C
   16 CONTINUE
	if(num.ne.16) goto 17
	write(nout,1600)
	goto 99
17	continue
   99 RETURN
3140	continue
      IF(NUM.NE.1) GO TO 92
      WRITE (c128wk,100) WORD1
	call atxto
      GO TO 99
C
   92 IF(NUM.NE.2) GO TO 93
      WRITE (c128wk,200)
	call atxto
      GO TO 99
C
   93 IF(NUM.NE.3) GO TO 94
      WRITE (c128wk,300) WORD1,WORD2
	call atxto
      GO TO 99
C
   94 IF(NUM.NE.4) GO TO 95
      WRITE (c128wk,400)
	call atxto
      GO TO 99
C
   95 IF(NUM.NE.5) GO TO 96
      WRITE (c128wk,500)
	call atxto
      GO TO 99
C
   96 IF(NUM.NE.6) GO TO 107
      WRITE (c128wk,600)
	call atxto
      CALL SETIN(K8IN)
      GO TO 99
C
  107 IF(NUM.NE.7) GO TO 108
      WRITE (c128wk,700) WORD1,WORD2
	call atxto
      GO TO 99
C
  108 IF(NUM.NE.8) GO TO 109
      GO TO 99
C
  109 IF(NUM.NE.9) GO TO 1010
      WRITE(c128wk,900) WORD1
	call atxto
      GO TO 99
C
 1010 IF(NUM.NE.10) GO TO 1011
      WRITE (c128wk,1000)
	call atxto
      GO TO 99
C
 1011 IF(NUM.NE.11) GO TO 1012
      WRITE (c128wk,1100)
	call atxto
      GO TO 99
C
 1012 IF(NUM.NE.12) GO TO 1013
      WRITE(c128wk,1200) WORD1
	call atxto
      GO TO 99
C
 1013 IF(NUM.NE.13) GO TO 1014
      WRITE(c128wk,1300) WORD1
	call atxto
      GO TO 99
C
 1014 IF(NUM.NE.14) GO TO 1015
      WRITE(c128wk,1400) WORD1
	call atxto
      GO TO 99
C
 1015 IF(NUM.NE.15) GO TO 1016
      WRITE(c128wk,1500) WORD1
	call atxto
      GO TO 99
C
 1016 CONTINUE
	if(num.ne.16)goto 1017
	write(c128wk,1600)
1600	format(' Error in sort file I/O')
	call atxto
1017	continue
	return
      END
      SUBROUTINE WHERE(IS)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  PROCESS A RIM WHERE CLAUSE
C
C  PARAMETERS:
C         IS------POINTER TO WHERE IN IREC ARRAY
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:RMKEYW.BLK
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:RIMCOM.BLK
      INCLUDE rin:TUPLEA.BLK
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:RIMPTR.BLK
C
      LOGICAL EQKEYW
      LOGICAL IFLIM
      LOGICAL IFTUP
      INCLUDE rin:DCLAR1.BLK
      NS = 0
      NTUPC = 0
      KMM = 0
      KSTRT = 0
      MAXTU = 0
      LIMTU = ALL9S
      ITEMS = LXITEM(ITEMP)
      JE = ITEMS - IS
      IF(JE.LT.2) GO TO 7000
C
C  BREAK UP EACH CONDITION.
C
      DO 600 I=1,10
      KOMPOS(I) = 0
      KOMPOT(I) = 0
      KOMLEN(I) = 0
      KATTP(I) = 0
      KATTL(I) = 0
      KATTY(I) = 0
  600 CONTINUE
      RMSTAT = 0
      NBOO = 1
      BOO(1) = K4AND
      NEXPOT = 1
      NEXPOS = 1
 1000 CONTINUE
      IS = IS + 1
      IF(IS.GT.ITEMS) GO TO 2000
C
C  GET THE ATTRIBUTE.
C
      IFLIM = .FALSE.
      IF(.NOT.EQKEYW(IS,KWLIMI,5)) GO TO 1150
C
C     LIMIT KEYWORD
C
      IF(.NOT.EQKEYW(IS+1,KWEQ,2)) GO TO 7100
      IF(LXID(IS+2).NE.KZINT) GO TO 7200
      LIMTU = LXIREC(IS+2)
      IF(LIMTU.LE.0) GO TO 7200
      NBOO = NBOO - 1
      IFLIM = .TRUE.
      GO TO 1800
 1150 CONTINUE
      IF(NBOO.LE.10) GO TO 1160
C
C  TOO MANY CONDITIONS.
C
	if(nout.eq.6)goto 3140
      WRITE(NOUT,9002)
 9002 FORMAT(52H -ERROR- More Than 10 Conditions In The WHERE Clause)
      GO TO 8000
3140   write(c128wk,9002)
	call atxto
	goto 8000
 1160 CONTINUE
      IFTUP = EQKEYW(IS,KWROWS,4)
      IF(.NOT.IFTUP) GO TO 1190
C
C  ROW WHERE CLAUSE - CHECK TYPE AND GET MAXIMUM ROW NUMBER
C
      NTUPC = NTUPC + 1
      IF(LXID(IS+2).NE.KZINT) GO TO 7300
      MAXTUN = LXIREC(IS+2)
      IF(MAXTUN.LE.0) GO TO 7300
      IF(MAXTUN.GT.MAXTU) MAXTU = MAXTUN
      KOMPAR = IBLANK
      CALL LXSREC(IS+1,1,3,KOMPAR,1)
      KOMTYP(NBOO) = LOCBOO(KOMPAR)
      IF(KOMTYP(NBOO).NE.0) GO TO 1170
C
C  UNRECOGNIZED BOOLEAN COMPARISION.
C
	if(nout.eq.6)goto 3141
      WRITE(NOUT,9003) KOMPAR
      GO TO 8000
3141	write(c128wk,9003)kompar
	call atxto
	goto 8000
 1170 CONTINUE
      IF((KOMTYP(NBOO).GE.3).AND.(KOMTYP(NBOO).LE.5)) MAXTU = NTUPLE
      GO TO 1500
 1190 ANAME = BLANK
      CALL LXSREC(IS,1,8,ANAME,1)
      I = LOCATT(ANAME,NAME)
      IF(I.NE.0) GO TO 1200
      CALL ATTGET(I)
      IF(I.EQ.0) GO TO 1300
C
C  UNRECOGNIZED ATTRIBUTE.
C
 1200 CONTINUE
      CALL WARN(3,ANAME,NAME)
      GO TO 8000
 1300 CONTINUE
      KATTP(NBOO) = ATTCOL
      KATTL(NBOO) = ATTLEN
      CALL TYPER(ATTYPE,MATVEC,KATTY(NBOO))
C
C  DETERMINE THE TYPE OF BOOLEAN EXPRESSION.
C
      KOMPAR = IBLANK
      CALL LXSREC(IS+1,1,3,KOMPAR,1)
      KOMTYP(NBOO) = LOCBOO(KOMPAR)
      IF(KOMTYP(NBOO).NE.0) GO TO 1500
C
C  UNRECOGNIZED BOOLEAN COMPARISION.
C
	if(nout.eq.6)goto 3141
      WRITE(NOUT,9003) KOMPAR
 9003 FORMAT(9H -ERROR- ,A4,34H Is Not A Valid Boolean Comparison)
      GO TO 8000
 1500 CONTINUE
C
C  CHECK FOR FAILS OR EXISTS
C
      IF(KOMTYP(NBOO).LE.1) GO TO 1800
      IF(KOMTYP(NBOO).GE.10) GO TO 1600
C
C     CHECK FOR "WHERE XXX EQ MIN OR MAX"
C
      ITEMP = LXWREC(IS+2,1)
      KMM = 0
      IF((ITEMP.EQ.K4MIN).OR.(ITEMP.EQ.K4MAX)) KMM = ITEMP
      IF(KMM.EQ.0) GO TO 1550
C
C  WE HAVE A MIN/MAX SPECIFICATION - CHECK SYNTAX
C
      IF((KOMTYP(NBOO).LT.2).OR.(KOMTYP(NBOO).GT.7)) GO TO 1550
      IF(ATTYPE.EQ.KZTEXT) GO TO 1550
      IF(ATTYPE.EQ.KZINT ) GO TO 1530
      IF(ATTYPE.EQ.KZREAL) GO TO 1530
      IF(ATTYPE.EQ.KZDOUB) GO TO 1530
C
C  ILLEGAL ATTRIBUTE FOR USE WITH MIN/MAX.
C
	if(nout.eq.6)goto 3142
      WRITE(NOUT,9000) ATTYPE
 9000 FORMAT(9H -ERROR- ,A4,42H Attributes Cannot Be Used With MIN Or MA
     XX)
      GO TO 8000
3142	write(c128wk,9000)
	call atxto
	goto 8000
 1530 CONTINUE
      IF(ATTLEN.EQ.1) GO TO 1540
      IF((ATTLEN.EQ.2).AND.(ATTYPE.EQ.KZDOUB)) GO TO 1540
C
C  ILLEGAL USE OF MULTI-WORD ATTRIBUTE WITH MIN/MAX.
C
	if(nout.eq.6)goto 3143
      WRITE(NOUT,9001)
 9001 FORMAT(61H -ERROR- Multi-Word Attributes Cannot Be Used With MIN o
     Xr MAX)
      GO TO 8000
3143	write(c128wk,9001)
	call atxto
	goto 8000
 1540 CONTINUE
C
C     SET NBOO AND LIMTU TO FOOL RMLOOK FOR MINMAX
C
      MNBOO = NBOO
      MLIMTU = LIMTU
      NBOO = 0
      LIMTU = ALL9S
      KOMPOS(MNBOO) = NEXPOS
      CALL MINMAX(WHRVAL(NEXPOS),KMM)
      IF(RMSTAT.NE.0) GO TO 7700
      NEXPOS = NEXPOS + ATTLEN
      KOMPOT(MNBOO) = NEXPOT
      WHRLEN(NEXPOT) = ATTLEN
      NEXPOT = NEXPOT + 1
      LIMTU = MLIMTU
      NBOO = MNBOO
C
C  RESET RELATION POINTERS
C
      I = LOCREL(NAME)
      IS = IS + 3
      KOMLEN(NBOO) = 1
      IF(IS.GT.ITEMS) GO TO 2100
      IF((LXWREC(IS,1).NE.K4AND).AND.(LXWREC(IS,1).NE.K4OR)) GO TO 7400
      NBOO = NBOO + 1
      BOO(NBOO) = LXWREC(IS,1)
      GO TO 1000
 1550 CONTINUE
C
C  VALUE COMPARISON. MAKE SURE THE VALUE LOOKS GOOD.
C
      NLIST = 0
      IS = IS + 2
      CALL ITOH(NR,NW,KATTL(NBOO))
      IF(KATTY(NBOO).EQ.0) NW = 1
      ITYPE = ATTYPE
      IF(KATTY(NBOO).EQ.0) ITYPE = KZINT
      KOMPOS(NBOO) = NEXPOS
      KOMPOT(NBOO) = NEXPOT
      IF(KOMTYP(NBOO).EQ.9) GO TO 1580
 1560 CONTINUE
C
C     USE PARVAL TO EXTRACT NEXT VALUE
C
      NWORDS = NW
      NROW = NR
      CALL PARVAL(IS,WHRVAL(NEXPOS),ITYPE,NWORDS,NROW,0,IERR)
      IF(IERR.NE.0) GO TO 8000
      IF(.NOT.IFTUP) GO TO 1570
C
C  ROW WHERE CLAUSE - CHECK TYPE AND SET MAXIMUM ROW
C
      IF(WHRVAL(NEXPOS).LE.0) GO TO 7300
      IF(WHRVAL(NEXPOS).GT.ALL9S) GO TO 7300
      IF(WHRVAL(NEXPOS).GT.MAXTU) MAXTU = WHRVAL(NEXPOS)
 1570 CONTINUE
      NLIST = NLIST + 1
      NEXPOS = NEXPOS + NWORDS
      CALL HTOI(NROW,NWORDS,WHRLEN(NEXPOT))
      NEXPOT = NEXPOT + 1
      KOMLEN(NBOO) = NLIST
      IF(NLIST.EQ.1) GO TO 1575
C
C  WE HAVE A LIST - VALID ONLY FOR EQ, EQS, AND NE
C
      IF((KOMTYP(NBOO).NE.2).AND.(KOMTYP(NBOO).NE.3)) GO TO 7600
 1575 CONTINUE
      IF(IS.GT.ITEMS) GO TO 2100
      IF((LXWREC(IS,1).NE.K4AND).AND.(LXWREC(IS,1).NE.K4OR)) GO TO 1560
      NBOO = NBOO + 1
      BOO(NBOO) = LXWREC(IS,1)
      GO TO 1000
 1580 CONTINUE
C
C     EQS - ONLY SAVE WHATS INPUT
C
      IF(ATTYPE.EQ.KZTEXT) GO TO 1585
 1581 CONTINUE
	if(nout.eq.6)goto 3145
      WRITE (NOUT,1582)
 1582 FORMAT(46H -ERROR- EQS Requires TEXT Elements And Values )
      GO TO 8000
3145	write(c128wk,1582)
	call atxto
	goto 8000
 1585 CONTINUE
      IF(LXID(IS).NE.KZTEXT) GO TO 1581
      NW = LXLENW(IS)
      NR = LXLENC(IS)
      CALL LXSREC(IS,1,NR,WHRVAL(NEXPOS),1)
      NEXPOS = NEXPOS + NW
      IS = IS + 1
      CALL HTOI(NR,NW,WHRLEN(NEXPOT))
      NEXPOT = NEXPOT + 1
      NLIST = NLIST + 1
      KOMLEN(NBOO) = NLIST
      IF(IS.GT.ITEMS) GO TO 2100
      IF((LXWREC(IS,1).NE.K4AND).AND.(LXWREC(IS,1).NE.K4OR)) GO TO 1585
      NBOO = NBOO + 1
      BOO(NBOO) = LXWREC(IS,1)
      GO TO 1000
C
C  ATTRIBUTE COMPARISON. CHECK FOR LEGAL ATTRIBUTE
C
 1600 CONTINUE
      ISAVE = ATTYPE
      ANAME = BLANK
      CALL LXSREC(IS+2,1,8,ANAME,1)
      I = LOCATT(ANAME,NAME)
      IF(I.EQ.0) GO TO 1700
      CALL WARN(3,ANAME,NAME)
      GO TO 8000
 1700 CONTINUE
      CALL ATTGET(I)
      KOMPOS(NBOO) = ATTCOL
      IF(ATTLEN.NE.KATTL(NBOO)) GO TO 7500
      IF(ATTYPE.NE.ISAVE) GO TO 7500
 1800 CONTINUE
C
C  LOOK FOR THE NEXT BOOLEAN JOIN.
C
      JE = ITEMS - IS
      IF(JE.LE.1) GO TO 2000
      IF ( (JE.EQ.2) .AND. (KOMTYP(NBOO).GT.1) ) GO TO 2000
      ISOR = LFIND(IS,JE,K4OR,2)
      ISAND = LFIND(IS,JE,K4AND,3)
      ISA = ISOR
      IF((ISAND.NE.0).AND.(ISAND.LT.ISOR))ISA = ISAND
      IF(ISOR.EQ.0) ISA = ISAND
      IF(ISA.EQ.0) GO TO 2000
      IF(IFLIM) GO TO 1900
      KOMLEN(NBOO) = ISA - IS - 2
      IF( (KOMLEN(NBOO).NE.0) .AND. (KOMTYP(NBOO).LE.1) ) GO TO 7800
      IF(KOMTYP(NBOO).LE.1) KOMLEN(NBOO) = 1
      IF(KOMLEN(NBOO).LE.1) GO TO 1900
C
C  WE HAVE A LIST - VALID ONLY FOR EQ, EQS, AND NE
C
      GO TO 7600
C
C  CONVERT WORDS TO CHARACTERS FOR TEXT ATTRIBUTES
C
 1900 CONTINUE
      NBOO = NBOO + 1
      IS = ISA
      BOO(NBOO) = LXWREC(IS,1)
      GO TO 1000
C
C  GET THE LENGTH OF THE LIST IN THE LAST CONDITION
C
 2000 CONTINUE
      IF(IFLIM) GO TO 2100
      KOMLEN(NBOO) = ITEMS - IS - 1
      IF( (KOMLEN(NBOO).NE.0) .AND. (KOMTYP(NBOO).LE.1) ) GO TO 7800
      IF(KOMTYP(NBOO).LE.1) KOMLEN(NBOO) = 1
      IF(KOMLEN(NBOO).LE.1) GO TO 2100
C
C  WE HAVE A LIST - VALID ONLY FOR EQ, EQS, AND NE
C
      GO TO 7600
C
C  CHECK FOR KEY PROCESSING
C
 2100 CONTINUE
      BOO(1) = K4AND
      IF(NTUPC.NE.NBOO) MAXTU = 0
      IF(BOO(NBOO).NE.K4AND) GO TO 9999
      IF(KOMTYP(NBOO).NE.2) GO TO 9999
      IF(IFTUP) GO TO 9999
      IF(KOMLEN(NBOO).NE.1) GO TO 9999
C
C  USE KEY PROCESSING.
C
      KSTRT = ATTKEY
      IF(KSTRT.NE.0) NS = 2
      GO TO 9999
 7000 CONTINUE
	if(nout.eq.6)goto 3146
      WRITE (NOUT,7010)
 7010 FORMAT(31H -ERROR- WHERE Clause Too Short )
      GO TO 8000
3146	write(c128wk,7010)
	call atxto
	goto 8000
 7100 CONTINUE
	if(nout.eq.6)goto 3147
      WRITE (NOUT,7110)
 7110 FORMAT(34H -ERROR- LIMIT Keyword Requires EQ )
      GO TO 8000
3147	write(c128wk,7110)
	call atxto
	goto 8000
 7200 CONTINUE
	if(nout.eq.6)goto 3148
      WRITE (NOUT,7210)
 7210 FORMAT(50H -ERROR- LIMIT Keyword Requires A Positive Integer )
      GO TO 8000
3148	write(c128wk,7210)
	call atxto
	goto 8000
 7300 CONTINUE
	if(nout.eq.6)goto 3149
      WRITE (NOUT,7310)
 7310 FORMAT(47H -ERROR- ROW Keyword Requires Positive Integers )
      GO TO 8000
3149	write(c128wk,7310)
	call atxto
	goto 8000
 7400 CONTINUE
	if(nout.eq.6)goto 3150
      WRITE (NOUT,7410)
 7410 FORMAT(51H -ERROR- MIN/MAX Should Only Be Followed By AND/OR )
      GO TO 8000
3150	write(c128wk,7410)
	call atxto
	goto 8000
 7500 CONTINUE
	if(nout.eq.6)goto 3151
      WRITE (NOUT,7510)
 7510 FORMAT(28H -ERROR- Compared Attributes,
     X       36H Must Be The Same In Type And Length )
      GO TO 8000
3151	write(c128wk,7510)
	call atxto
	goto 8000
 7600 CONTINUE
	if(nout.eq.6)goto 3152
      WRITE (NOUT,7610)
 7610 FORMAT(47H -ERROR- Lists Are Only Valid For EQ EQS And NE)
      GO TO 8000
3152	write(c128wk,7610)
	call atxto
	goto 8000
 7700 CONTINUE
	if(nout.eq.6)goto 3153
      WRITE(NOUT,7710)
 7710 FORMAT(50H -ERROR- MIN/MAX Not Available For Null Attributes)
      GO TO 8000
3153	write(c128wk,7710)
	call atxto
	goto 8000
 7800 CONTINUE
	if(nout.eq.6)goto 3154
      WRITE (NOUT,7810)
 7810 FORMAT(55H -ERROR- FAILS/EXISTS Should Only Be Followed By AND/OR)
      GO TO 8000
3154	write(c128wk,7810)
	call atxto
	goto 8000
C
C  UNABLE TO PROCESS THE WHERE CLAUSE.
C
 8000 CONTINUE
	if(nout.eq.6)goto 3155
      IF(NBOO.NE.0) WRITE (NOUT,8010)NBOO
 8010 FORMAT(9X,36HError Detected On Boolean Condition ,I2)
	goto 3156
3155	write(c128wk,8010)nboo
	call atxto
3156	continue

      RMSTAT = 4
C
C  QUIT.
C
 9999 CONTINUE
      IF(MAXTU.EQ.0) MAXTU = ALL9S
      CALL WHETOL
      RETURN
      END
      SUBROUTINE WHETOL
      INCLUDE rin:TEXT.BLK
C
C     THIS ROUTINE CHANGES THE WHERE COMMON BLOCK TO REFLECT
C     TOLERANCES WHERE POSSIBLE.  LE,LT,GE,GT TOLERANCES ARE
C     CRANKED INTO WHCOM TO AVOID CALCULATING THEM FOR EVERY
C     ROW.  EQ AND NE WILL BE DONE IN KOMPAR.
C
      INCLUDE rin:RMATTS.BLK
      INCLUDE rin:WHCOM.BLK
      INCLUDE rin:FLAGS.BLK
      INCLUDE rin:RIMPTR.BLK
      IF(TOL.EQ.0.) RETURN
      IF(NBOO.EQ.0) RETURN
      IF(KATTY(NBOO).EQ.KZREAL) NS = 0
      IF(KATTY(NBOO).EQ.KZDOUB) NS = 0
      DO 1000 I=1,NBOO
      IF(KATTY(I).EQ.KZTEXT) GO TO 1000
      IF(KATTY(I).EQ.KZINT) GO TO 1000
      IF(KOMTYP(I).LT.4) GO TO 1000
      IF(KOMTYP(I).GT.7) GO TO 1000
C
C     CHANGE THEM VALUES
C
      NUM = KOMLEN(I)
      NPOS = KOMPOS(I)
      NPOT = KOMPOT(I)
      DO 100 J=1,NUM
      CALL ITOH(NR,NW,WHRLEN(NPOT))
      NPOT = NPOT + 1
      IF(KATTY(I).EQ.KZREAL) CALL TOLER(KOMTYP(I),WHRVAL(NPOS),NW)
      IF(KATTY(I).EQ.KZDOUB) CALL TOLED(KOMTYP(I),WHRVAL(NPOS),NW/2)
      NPOS = NPOS + NW
  100 CONTINUE
 1000 CONTINUE
      RETURN
      END
      SUBROUTINE WRLINE (NC,ISTAT,LINE)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:  WRITES LINE TO OUTPUT BY USING SPOUT,BLANKS IT OUT AND
C            RESETS NC (NUMBER OF CHARACTERS) TO 1.
C
C  INPUTS:
C            NC---------NUMBER OF CHARACTERS
C            ISTAT------ARE WE DONE?  EQUAL TO 1 IF WE ARE.
C            LINE-------OUTPUT LINE
C
      INCLUDE rin:CONST4.BLK
      INCLUDE rin:MISC.BLK
      INTEGER LINE(*)
      IEND = K4PLUS
      IF (ISTAT .EQ. 1) IEND = IBLANK
      CALL PUTT (LINE,NC,IEND)
      CALL SPOUT (LINE,NC)
      CALL FILCH (LINE,1,80,IBLANK)
      NC = 2
      RETURN
      END
      SUBROUTINE XHIBIT
      INCLUDE rin:TEXT.BLK
C
C  THIS ROUTINE IS PART OF THE RIM DATA DICTIONARY/DIRECTORY SYSTEM.
C  IT ENABLES THE USER TO LIST ALL RELATIONS HAVING CERTAIN ATTRIBUTES.
C
      INCLUDE rin:TUPLER.BLK
      INCLUDE rin:FILES.BLK
      INCLUDE rin:MISC.BLK
      INCLUDE rin:FLAGS.BLK
C
      LOGICAL EQ
      LOGICAL FLAG
      INCLUDE rin:DCLAR1.BLK
C
C  EDIT THE EXHIBIT COMMAND
C
      ITEMS = LXITEM(IDUMMY)
      IF(ITEMS.EQ.1) GO TO 9900
      IF(ITEMS.GT.11) GO TO 9900
      NUMBER = ITEMS - 1
C
C  COMMAND IS OKAY
C
      FLAG = .FALSE.
C
      DO 100 I=1,NUMBER
      NAMES(I) = BLANK
      CALL LXSREC(I+1,1,8,NAMES(I),1)
  100 CONTINUE
	if(nout.eq.6)goto 3140
      WRITE(NOUTR,9000) (NAMES(I),I=1,NUMBER)
 9000 FORMAT(22H Relations Containing ,A8,1X,A8,1X,A8,1X,A8,
     X A8,1X,A8,1X,A8,1X,A8,1X,A8,1X,A8)
	goto 3141
3140	write(c128wk,9000) (names(i),i=1,number)
	call atxto
3141	continue
C
C  GO THROUGH EACH REALTION.
C
      I = LOCREL(BLANK)
  200 CONTINUE
      CALL RELGET(ISTAT)
      IF(ISTAT.NE.0) GO TO 500
C
C  SEE IF ALL THE ATTRIBUTES LISTED APPEAR IN THIS RELATION
C
      DO 300 I=1,NUMBER
      K = LOCATT(NAMES(I),NAME)
      IF(K.NE.0) GO TO 200
  300 CONTINUE
C
C  CHECK USER READ SECURITY.
C
      IF(EQ(USERID,OWNER)) GO TO 400
      IF(EQ(RPW,NONE)) GO TO 400
      IF(EQ(RPW,USERID)) GO TO 400
      IF(EQ(MPW,USERID)) GO TO 400
C
C  RELATION IS NOT AVAILABLE TO THE USER.
C
      GO TO 200
C
  400 CONTINUE
C
C  ATTRIBUTES ARE IN THIS RELATION
C
	if(noutr.eq.6)goto 3142
      WRITE(NOUTR,9001) NAME
 9001 FORMAT(5X,A8)
3143      FLAG = .TRUE.
      GO TO 200
3142	write(c128wk,9001)name
	call atxto
	goto 3143
  500 CONTINUE
C
C  SEE IF ANY RELATIONS HAD THE ATTRIBUTES
C
      IF(FLAG) GO TO 9999
C
C  NONE OF THE RELATIONS HAD THE ATTRIBUTES
C
	if(nout.eq.6)goto 3144
      WRITE(NOUT,9002)
 9002 FORMAT(57H -WARNING- Attribute List Does Not Occur In Any Relation
     Xs)
      GO TO 9999
3144	write(c128wk,9002)
	call atxto
	goto 9999
C
C  INVALID SYNTAX FOR 'EXHIBIT'
C
 9900 CONTINUE
	if(nout.eq.6)goto 3145
      WRITE(NOUT,9003)
 9003 FORMAT(47H -ERROR- Illegal Number Of Attributes Specified )
	goto 9999
3145	write(c128wk,9003)
	call atxto
C
C  DONE WITH EXHIBIT
C
 9999 RETURN
      END
      SUBROUTINE ZEROIT(ARRAY,NWDS)
      INCLUDE rin:TEXT.BLK
C
C  PURPOSE:   ZERO OUT AN ARRAY
C
C  PARAMETERS:
C         ARRAY---ARRAY TO BE ZEROED OUT
C         NWDS----NUMBER OF WORDS IN THE ARRAY
C
      INTEGER ARRAY(*)
      DO 100 I=1,NWDS
      ARRAY(I) = 0
  100 CONTINUE
      RETURN
      END
