-h- aaareadme.1st Mon Dec 02 10:17:26 1985 DF1:[DBMS]AAAREADME.1ST;1 DISCLAIMER This is the IPAD RIM program, a highly powerful and general relational DBMS. It is a public domain package with full sources included, and with the usual proviso: if you don't like it, you don't have to use it. No liability WHATEVER is assumed by DECUS, Boeing, or anybody else for this program or anything having to do with it. Nevertheless, it appears to work well, and you can add to it. You are encouraged to do so and get the modifications out, so that the program might become more capable for all. We do NOT know any more than you do about the package. All documentation is included and all sources and build files are here. Do not call us. Do not call DECUS. If you MUST have advice, the program came from Boeing which has since stopped distributing it. They sell a later version. Do not, however, contact us. You have what we do. The program works; we've tried it. But we don't want to take a lot of calls to help others get it running. The manual is here and reasonably complete, in Runoff format, and the command files to build it are here also. For those needing support, Boeing Computer Services (PO Box 24346, Seattle, Washington 98124) sell BCS RIM V6.0 (maybe a later version by now) which has numerous improvements and integrates graphics, plus a new report writer. Among the enhancements are the following (check however; some may be in this version also): A "NES" (not equal string) operator Enhanced WHERE clause with AVErage, multiple conditions Wild card retrievals on partial fields MicroRIM compatibility DATE, TIME, and DOLLAR attributes FILL, NOFILL, and UNION commands for relational algebra and format control Enhanced COMPUTE, PROJECT, and SET verbs More powerful UNLOAD command Temporary computed attributes and values Report writer and graphics components EXPAND command Efficiency improvements Numerous math functions and logical functions are added. Please contact BCS if you need support, but be prepared to pay for it. This program is also the ancestor of micro RIM and the Rbase series for IBM PC. If you want a supported version for IBM PC, you can contact MicroRim and/or just buy Rbase 4000 or Rbase 5000, the current successors. You will note many useful pieces of code here. In particular the BT???? files are the code to handle B trees. This has value by itself. All restrictions on distribution of this program expired on October 15, 1985. There may be other subversions in the world which have later dates or restrictions, but this version was passed out with users gaining ownership of the code subject to a restriction on sending it out of the US prior to 10/15/1985 without Boeing's consent. After 10/15/1985, all restrictions lapsed, so it may be sent anywhere. Please feel free to do so. -h- adddat.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]ADDDAT.FOR;1 SUBROUTINE ADDDAT(INDEX,ID,ARRAY,LENGTH) INCLUDE '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 'F2COM.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'BUFFER.BLK' INCLUDE '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 -h- applpro.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]APPLPRO.FOR;1 PROGRAM FTNJOB C C **** THE FOLLOWING VARIABLES MUST BE REAL*8 FOR THE VAX C REAL*8 DBNAME REAL*8 USER REAL*8 RNAME REAL*8 ANAME REAL*8 DATE C C **** C LOGICAL RPW,MPW DIMENSION NVAL(25),VAL(25) EQUIVALENCE (NVAL,VAL) DIMENSION XVALS(2) COMMON /RIMCOM/ RMSTAT INTEGER RMSTAT C C OPEN THE PLANES DATABASE C DBNAME = 6HPLANES CALL RMOPEN(DBNAME) USER = 5HAGENT CALL RMUSER(USER) C C LOCATE AND LIST ALL RELAIONS IN THE DATABASE C CALL RMLREL WRITE(6,100) 100 FORMAT(2X,13HRELATION NAME,3X,3HRPW,3X,3HMPW,3X, X 11HMODIFY DATE,3X,13HNO ATTRIBUTES,3X,9HNO TUPLES,/, X 2X,13H-------------,3X,3H---,3X,3H---,3X,11H-----------, X 3X,13H-------------,3X,9H---------,/) 110 CONTINUE CALL RMGREL(RNAME,RPW,MPW,DATE,NUMATT,NTUPLE) IF(RMSTAT.NE.0) GO TO 200 IRPW = 2HNO IMPW = 2HNO IF(RPW) IRPW = 3HYES IF(MPW) IMPW = 3HYES WRITE(6,120) RNAME,IRPW,IMPW,DATE,NUMATT,NTUPLE 120 FORMAT(4X,A8,6X,A3,3X,A3,5X,A8,8X,I3,11X,I3) GO TO 110 C C LOCATE AND LIST THE ATTRIBUTES OF THE AIRPLANS RELATION C 200 CONTINUE RNAME = 8HAIRPLANS CALL RMLATT(RNAME) WRITE(6,210) 210 FORMAT(/,/,/,2X,42HLISTING OF THE ATTRIBUTES FOR THE AIRPLANS, X 9H RELATION,/,/,14X,14HATTRIBUTE NAME,6X,4HTYPE,/, X 14X,14H--------------,6X,4H----,/) 220 CONTINUE CALL RMGATT(ANAME,ITYPE,DUM1,DUM2,DUM3,DUM4,DUM5,DUM6) IF(RMSTAT.NE.0) GO TO 240 WRITE(6,230) ANAME,ITYPE 230 FORMAT(17X,A8,9X,A4) GO TO 220 240 CONTINUE WRITE(6,250) 250 FORMAT(1H1) C C OPEN THE FTNDB DATABASE C DBNAME = 5HFTNDB CALL RMOPEN(DBNAME ) C C LOAD SOME DATA INTO THE FTNDB DATABASE - RELATION COORDS WITH C ATTRIBUTES NODE X Y Z C NVAL(1) = 1 VAL(2) = 10.0 VAL(3) = 10.0 VAL(4) = 100.0 RNAME = 6HCOORDS CALL RMFIND(1,RNAME) WRITE(6,300) 300 FORMAT(/,2X,31HCONTENTS OF THE COORDS RELATION,/) WRITE(6,310) 310 FORMAT(4X,4HNODE,4X,12HX-COORDINATE,3X,12HY-COORDINATE, X 3X,12HZ-COORDINATE,/,4X,4H----,4X,12H------------, X 3X,12H------------,3X,12H------------,/) DO 330 K=1,20 NVAL(1) = NVAL(1) + 50 VAL(2) = VAL(2) + 100. VAL(3) = VAL(3) + 1.5 VAL(4) = VAL(4) - 2.0 WRITE(6,320) NVAL(1),VAL(2),VAL(3),VAL(4) 320 FORMAT(4X,I4,4X,F8.2,7X,F8.2,7X,F8.2) CALL RMLOAD(1,NVAL) 330 CONTINUE C C LIST THE DATA IN THE COORDS RELATION SORTED BY NODE NUMBER C WHERE THE NODE NUMBER IS GREATER THAN 100 C C SELECT ALL FROM COORDS SORTED BY NODE=D WHERE NODE GT 100 C WRITE(6,340) 340 FORMAT(1H1,/,2X,33HSELECT ALL FROM COORDS SORTED BY , X 24HNODE=D WHERE NODE GT 100,/) WRITE(6,310) RNAME = 6HCOORDS CALL RMFIND(1,RNAME) ANAME = 4HNODE BOO = 2HGT CALL RMWHER(1,ANAME,BOO,100,1,0,1) CALL RMSORT(1,ANAME,1,-1) 350 CONTINUE CALL RMGET(1,NVAL) IF(RMSTAT.NE.0) GO TO 400 WRITE(6,320) NVAL(1),VAL(2),VAL(3),VAL(4) GO TO 350 C C CHANGE THE X COORDINATES OF ALL NODES LT 300 TO NEGATIVE C 400 CONTINUE RNAME = 6HCOORDS CALL RMFIND(1,RNAME) ANAME = 4HNODE BOO = 2HLT CALL RMWHER(1,ANAME,BOO,300,1,0,1) 410 CONTINUE CALL RMGET(1,NVAL) IF(RMSTAT.NE.0) GO TO 500 VAL(2) = -VAL(2) CALL RMPUT(1,NVAL) GO TO 410 C C PRINT THE CHANGED DATA C 500 CONTINUE WRITE(6,510) 510 FORMAT(1H1,/,2X,43HCHANGE THE X COORDINATE OF ALL NODE NUMBERS, X 13H LT 300 TO -X,/) WRITE(6,310) RNAME = 6HCOORDS CALL RMFIND(1,RNAME) ANAME = 4HNODE BOO = 2HLT CALL RMWHER(1,ANAME,BOO,300,1,0,1) 520 CONTINUE CALL RMGET(1,NVAL) IF(RMSTAT.NE.0) GO TO 600 WRITE(6,320) NVAL(1),VAL(2),VAL(3),VAL(4) GO TO 520 C C DELETE ALL NODES WHERE THE X COORDINATE EQ 810. OR 910. C 600 CONTINUE RNAME = 6HCOORDS CALL RMFIND(1,RNAME) ANAME = 1HX XVALS(1) = 810. XVALS(2) = 910. BOO = 2HEQ CALL RMWHER(1,ANAME,BOO,XVALS,2,0,1) 610 CONTINUE CALL RMGET(1,NVAL) IF(RMSTAT.NE.0) GO TO 700 CALL RMDEL(1) GO TO 610 C C PRINT THE ENTIRE RELATION C 700 CONTINUE WRITE(6,710) 710 FORMAT(1H1,/,2X,35HDELETE NODES WHERE X=810. OR X=910.,/) WRITE(6,310) RNAME = 6HCOORDS CALL RMFIND(1,RNAME) 720 CONTINUE CALL RMGET(1,NVAL) IF(RMSTAT.NE.0) GO TO 800 WRITE(6,320) NVAL(1),VAL(2),VAL(3),VAL(4) GO TO 720 C C CLOSE THE DATA BASE C 800 CONTINUE CALL RMCLOS END -h- attadd.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]ATTADD.FOR;1 SUBROUTINE ATTADD INCLUDE 'TEXT.BLK' C C PURPOSE: ADD A NEW TUPLE TO THE ATTRIBUTE RELATION C INCLUDE 'TUPLEA.BLK' INCLUDE 'ATTBLE.BLK' INCLUDE 'F1COM.BLK' INCLUDE '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 -h- attble.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]ATTBLE.BLK;1 C C *** / A T T B L E / *** C C BUFFER TO HOLD ONE PAGE FROM THE ATTRIBUTE RELATION C COMMON /ATTBLE/ ATTBUF(1024), X CANAME,CRNAME,CRSTRT,CROW,LROW,NAROW,ATTMOD,APBUF INTEGER ATTBUF REAL*8 CANAME REAL*8 CRNAME INTEGER CRSTRT INTEGER CROW INTEGER ATTMOD INTEGER APBUF INTEGER ATTBLE(9,113) EQUIVALENCE (ATTBUF(2),ATTBLE(1,1)) C C VARIABLE DEFINITIONS: C ATTBUF--BUFFER FOR ONE PAGE FROM THE ATTRIBUTE RELATION C ATTBLE--EQUIVALENCE ARRAY FOR EASIER USE OF ATTBUF C CANAME--CURRENT ATTRIBUTE NAME C CRNAME--CURRENT RELATION NAME C CRSTRT--CURRENT START IN ATTBUF FOR CRNAME C CROW----NEXT ROW IN ATTBLE TO GET C LROW----LAST ROW SENT IN TUPLEA C NAROW---NEXT AVAILABLE ROW FOR ADDING A TUPLE C ATTMOD--MODIFICATION FLAG - O MEANS NO, 1 MEANS YES C APBUF---ATTRIBUTES PER ATTBUF PAGE C -h- attdel.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]ATTDEL.FOR;1 SUBROUTINE ATTDEL(STATUS) INCLUDE '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 'RMATTS.BLK' INCLUDE 'ATTBLE.BLK' INCLUDE '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 -h- attget.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]ATTGET.FOR;1 SUBROUTINE ATTGET(STATUS) INCLUDE '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 'TUPLEA.BLK' INCLUDE 'ATTBLE.BLK' INCLUDE '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 -h- attnew.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]ATTNEW.FOR;1 SUBROUTINE ATTNEW(RNAME,NATT) INCLUDE '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 'RMATTS.BLK' INCLUDE 'ATTBLE.BLK' INCLUDE 'F1COM.BLK' INCLUDE 'START.BLK' INCLUDE '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 -h- attpag.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]ATTPAG.FOR;1 SUBROUTINE ATTPAG(THEROW) INCLUDE '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 'ATTBLE.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE '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 -h- attput.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]ATTPUT.FOR;1 SUBROUTINE ATTPUT(STATUS) INCLUDE '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 'FLAGS.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE '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 -h- blkchg.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]BLKCHG.FOR;1 SUBROUTINE BLKCHG(IND,NROWS,NCOLS) INCLUDE '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 'INCORE.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE '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 -h- blkcln.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]BLKCLN.FOR;1 SUBROUTINE BLKCLN INCLUDE 'TEXT.BLK' C C PURPOSE: CLEAN OUT THE ENTIRE BUFFER AREA C C PARAMETERS -- NONE C INCLUDE 'INCORE.BLK' INCLUDE 'F2COM.BLK' INCLUDE 'BUFFER.BLK' INCLUDE '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 -h- blkclr.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]BLKCLR.FOR;1 SUBROUTINE BLKCLR(IND) INCLUDE 'TEXT.BLK' C C PURPOSE: CLEAR A BLOCK FROM THE INCORE BUFFER C C PARAMETERS C INPUT: IND-----BLOCK INDEX INCLUDE 'INCORE.BLK' INCLUDE '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 -h- blkdef.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]BLKDEF.FOR;1 SUBROUTINE BLKDEF(IND,NROWS,NCOLS) INCLUDE '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 'INCORE.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE '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 -h- blkext.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]BLKEXT.FOR;1 SUBROUTINE BLKEXT(IND,NROWS,NCOLS) INCLUDE '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 'INCORE.BLK' C C EXTRACT THE DATA FROM BLOCKS. C NROWS = BLOCKS(2,IND) NCOLS = BLOCKS(3,IND) RETURN END -h- blkloc.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]BLKLOC.FOR;1 INTEGER FUNCTION BLKLOC(IND) INCLUDE '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 'INCORE.BLK' INCLUDE '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 -h- blkmov.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]BLKMOV.FOR;1 SUBROUTINE BLKMOV(TO,FROM,NWORDS) INCLUDE '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 -h- blnkfl.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]BLNKFL.BLK;1 C C *** / B L N K F L / *** C C COMMON BLOCK TO COMMUNICATE BETWEEN SPOUT AND SELECT C COMMON /BLNKFL/ BLNKFL LOGICAL BLNKFL C C VARIABLE DEFINITIONS: C BLNKFL--FLAG TO INDICATE IF SPOUT PRINTED A LINE C .TRUE. SPOUT PRINTED A LINE OF DATA C .FALSE. BLANK LINE C -h- btadd.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]BTADD.FOR;1 SUBROUTINE BTADD(VALU,IPTR,TYPE) INCLUDE '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 'RMATTS.BLK' INCLUDE 'F3COM.BLK' INCLUDE 'MISC.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'BTBUF.BLK' INCLUDE 'START.BLK' INCLUDE '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 -h- btbuf.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]BTBUF.BLK;1 C C *** / B T B U F / *** C C INCORE BUFFER FOR BTREE PAGING BLOCKS C COMMON /BTBUF/ CORE(2560) INTEGER CORE INTEGER VALUE(3,1) EQUIVALENCE (CORE(1),VALUE(1,1)) REAL RVALUE(3,1) EQUIVALENCE (CORE(1),RVALUE(1,1)) C C VARIABLE DEFINITIONS: C BTREE NODES ARE ARRANGED IN THREE WORD GROUPS C VALUE---ROW 1 - ARRAY OF BTREE KEY VALUES C VALUE---ROW 2 - ARRAY OF BTREE NODE POINTERS AND TUPLE C POINTERS C VALUE---ROW 3 - ARRAY OF MOT TUPLE POINTERS C C MOT TABLES ARE ARRANGED IN TWO WORD PAIRS C ROW 1 - MOT POINTER TO NEXT LINK C ROW 2 - TUPLE POINTER C -h- btget.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]BTGET.FOR;1 SUBROUTINE BTGET(ID,NSTRT) INCLUDE '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 'BTBUF.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE '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 -h- btinit.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]BTINIT.FOR;1 SUBROUTINE BTINIT(START) INCLUDE 'TEXT.BLK' C C PURPOSE: INITIALIZE FOR A NEW BTREE C C PARAMETERS: C START---NEW RECORD USED FOR THIS BTREE C INCLUDE 'F3COM.BLK' INCLUDE 'MISC.BLK' INCLUDE '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 -h- btlki.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]BTLKI.FOR;1 SUBROUTINE BTLKI(VAL,IPTR,MOTID) INCLUDE '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 'F3COM.BLK' INCLUDE 'MISC.BLK' INCLUDE 'BTBUF.BLK' INCLUDE '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 -h- btlkr.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]BTLKR.FOR;1 SUBROUTINE BTLKR(VAL,IPTR,MOTID) INCLUDE '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 'F3COM.BLK' INCLUDE 'MISC.BLK' INCLUDE 'BTBUF.BLK' INCLUDE '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 -h- btlkt.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]BTLKT.FOR;1 SUBROUTINE BTLKT(VAL,IPTR,MOTID) INCLUDE '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 -h- btmove.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]BTMOVE.FOR;1 SUBROUTINE BTMOVE(NEW,OLD,NV) INCLUDE 'TEXT.BLK' C C PURPOSE: MOVE NV VALUES FROM OLD TO NEW. C INCLUDE '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 -h- btput.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]BTPUT.FOR;1 SUBROUTINE BTPUT(ID) INCLUDE 'TEXT.BLK' C C PURPOSE: TURN ON THE WRITE FLAG ON THE INDICATED BLOCK C C PARAMETERS C INPUT: ID------RECORD NUMBER INCLUDE 'F3COM.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE '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 -h- btrep.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]BTREP.FOR;1 SUBROUTINE BTREP(VALU,IPTR,IPTRO,TYPE) INCLUDE '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 'RMATTS.BLK' INCLUDE 'F3COM.BLK' INCLUDE 'MISC.BLK' INCLUDE 'BTBUF.BLK' INCLUDE 'START.BLK' INCLUDE '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 -h- btsert.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]BTSERT.FOR;1 SUBROUTINE BTSERT(VAL,IP,STACK,SP,LOC,IN) INCLUDE '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 'F3COM.BLK' INCLUDE 'BTBUF.BLK' INCLUDE '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 -h- buffer.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]BUFFER.BLK;1 C C *** / B U F F E R / *** C C INCORE BUFFER FOR TUPLES AND IO PAGES C COMMON /BUFFER/BUFFER(4608) INTEGER BUFFER INTEGER BLKLOC C C VARIABLE DEFINITIONS C BUFFER--ARRAY TO HOLD ALL BLOCKS C -h- build.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]BUILD.FOR;1 SUBROUTINE BUILD INCLUDE 'TEXT.BLK' C C PURPOSE: BUILD A KEY INDEX FOR AN ATTRIBUTE IN A RELATION C INCLUDE 'RMATTS.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'START.BLK' INCLUDE 'FILES.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'MISC.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'SRTCOM.BLK' INCLUDE '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 WRITE(NOUT,300) ANAME 300 FORMAT(19H -ERROR- ATTRIBUTE ,A8, X 17H IS ALREADY A KEY ) GO TO 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) 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 -h- cdcdbs.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]CDCDBS.BLK;1 C C *** / C D C D B S / *** C C CURRENT DATABASE PERMANENT FILE DATA - CDC CYBER (BOEING) C COMMON /CDCDBS/DBDATA(5,10),NUMOPN INTEGER DBDATA INTEGER NUMOPN C C VARIABLE DEFINITIONS: C DBDATA(1,J) -- DATABASE NAMES IN H FORMAT (6HDBNAME) C DBDATA(2,J) -- DATABASE PERMANENT FILE NAMES IN H FORMAT C DBDATA(3,J) -- PERMANENT FILE USER NUMBERS IN H FORMAT C DBDATA(4,J) -- PERMANENT FILE PASSWORDS IN H FORMAT C DBDATA(5,J) -- DATABASE MODIFICATION INDICATORS C 0 = USER CONTROLLED FILE HANDLING C 1 = INDIRECT ACCESS C 2 = DIRECT ACCESS (READ ONLY) C 3 = DIRECT ACCESS (WRITE) C 4 = "DEFINE" DATABASE C <0 = DATABASE HAS BEEN MODIFIED (IE -1) C NUMOPN - NUMBER OF DATABASES IN DBDATA C -h- change.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]CHANGE.FOR;1 SUBROUTINE CHANGE(MAT,NVAL) INCLUDE '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 'RMATTS.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'SORBUF.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'FILES.BLK' INCLUDE 'RULCOM.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'START.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'TUPLER.BLK' INCLUDE '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 '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 WRITE(NOUT,9001) 9001 FORMAT(48H -ERROR- WHERE CLAUSE REQUIRED ON CHANGE COMMAND) GO TO 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 WRITE (NOUT,120) 120 FORMAT(45H -ERROR- BAD VEC(I) OR MAT(I,J) SPECIFICATION ) GO TO 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(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 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 WRITE(NOUT,9005) IVAL ISNOUT = NOUTR NOUTR = NOUT CALL PRULE(ISTAT) NOUTR = ISNOUT GO TO 500 720 CONTINUE ISTAT = -ISTAT WRITE(NOUT,9006) ISTAT 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 WRITE(NOUT,9005) IVAL ISNOUT = NOUTR NOUTR = NOUT CALL PRULE(ISTAT) NOUTR = ISNOUT GO TO 500 2220 CONTINUE ISTAT = -ISTAT WRITE(NOUT,9006) ISTAT GO TO 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 WRITE(NOUT,9005) IVAL ISNOUT = NOUTR NOUTR = NOUT CALL PRULE(ISTAT) NOUTR = ISNOUT GO TO 500 3890 CONTINUE ISTAT = -ISTAT WRITE(NOUT,9006) ISTAT GO TO 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 WRITE(NOUT,8110) MAXCOL 8110 FORMAT(36H -ERROR- RELATION ROW LENGTH EXCEEDS,I5) GO TO 9999 C C DONE C 9999 CONTINUE 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 9005 FORMAT(12H -ERROR- ROW,I4,22H FAILS TO SATISFY THE , X 14HFOLLOWING RULE) 9006 FORMAT(32H -ERROR- UNABLE TO PROCESS RULE ,I3) END -h- chkatt.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]CHKATT.FOR;1 SUBROUTINE CHKATT(JUNK,NUMELE,ERROR) INCLUDE '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 'TUPLEA.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'FILES.BLK' INCLUDE 'MISC.BLK' C INTEGER ERROR LOGICAL EQ INTEGER IFLAG INTEGER CSTART INTEGER JUNK(5,*) INCLUDE '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 WRITE(NOUT,9000) ANAME 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 WRITE(NOUT,9001) MAXCOL 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 -h- chkrel.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]CHKREL.FOR;1 SUBROUTINE CHKREL (PERM,WORD1,ISTAT,NAMOWN) INCLUDE '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 'CONST4.BLK' INCLUDE 'CONST8.BLK' INCLUDE 'DCLAR2.BLK' INCLUDE 'DCLAR6.BLK' INCLUDE 'TUPLER.BLK' INCLUDE '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 -h- chkrul.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]CHKRUL.FOR;1 SUBROUTINE CHKRUL(RNAME) INCLUDE 'TEXT.BLK' C C PURPOSE: CHECK IF RULES APPLY TO THE CURRENT RELATION C C PARAMETERS: RNAME--RELATION NAME TO CHECK C INCLUDE 'CONST4.BLK' INCLUDE 'CONST8.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'RULCOM.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'MISC.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'WHCOM.BLK' INCLUDE '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 -h- chktup.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]CHKTUP.FOR;1 SUBROUTINE CHKTUP(TUPLE,ISTAT) INCLUDE '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 'RMATTS.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'MISC.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'RULCOM.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'RELTBL.BLK' C INCLUDE 'FLAGS.BLK' INCLUDE '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 -h- cmpfor.com Mon Dec 02 10:17:26 1985 DF1:[DBMS]CMPFOR.COM;1 $set noon $set verify $diff ADDDAT.FOR [vaxrim]ADDDAT.FOR $diff APPLPRO.FOR [vaxrim]APPLPRO.FOR $diff ATTADD.FOR [vaxrim]ATTADD.FOR $diff ATTDEL.FOR [vaxrim]ATTDEL.FOR $diff ATTGET.FOR [vaxrim]ATTGET.FOR $diff ATTNEW.FOR [vaxrim]ATTNEW.FOR $diff ATTPAG.FOR [vaxrim]ATTPAG.FOR $diff ATTPUT.FOR [vaxrim]ATTPUT.FOR $diff BLKCHG.FOR [vaxrim]BLKCHG.FOR $diff BLKCLN.FOR [vaxrim]BLKCLN.FOR $diff BLKCLR.FOR [vaxrim]BLKCLR.FOR $diff BLKDEF.FOR [vaxrim]BLKDEF.FOR $diff BLKEXT.FOR [vaxrim]BLKEXT.FOR $diff BLKLOC.FOR [vaxrim]BLKLOC.FOR $diff BLKMOV.FOR [vaxrim]BLKMOV.FOR $diff BTADD.FOR [vaxrim]BTADD.FOR $diff BTGET.FOR [vaxrim]BTGET.FOR $diff BTINIT.FOR [vaxrim]BTINIT.FOR $diff BTLKI.FOR [vaxrim]BTLKI.FOR $diff BTLKR.FOR [vaxrim]BTLKR.FOR $diff BTLKT.FOR [vaxrim]BTLKT.FOR $diff BTMOVE.FOR [vaxrim]BTMOVE.FOR $diff BTPUT.FOR [vaxrim]BTPUT.FOR $diff BTREP.FOR [vaxrim]BTREP.FOR $diff BTSERT.FOR [vaxrim]BTSERT.FOR $diff BUILD.FOR [vaxrim]BUILD.FOR $diff CHANGE.FOR [vaxrim]CHANGE.FOR $diff CHKATT.FOR [vaxrim]CHKATT.FOR $diff CHKREL.FOR [vaxrim]CHKREL.FOR $diff CHKRUL.FOR [vaxrim]CHKRUL.FOR $diff CHKTUP.FOR [vaxrim]CHKTUP.FOR $diff CMPUTE.FOR [vaxrim]CMPUTE.FOR $diff COMPARE.FOR [vaxrim]COMPARE.FOR $diff CSC.FOR [vaxrim]CSC.FOR $diff DBLOAD.FOR [vaxrim]DBLOAD.FOR $diff DELDAT.FOR [vaxrim]DELDAT.FOR $diff DELDUP.FOR [vaxrim]DELDUP.FOR $diff DELETE.FOR [vaxrim]DELETE.FOR $diff DROPF.FOR [vaxrim]DROPF.FOR $diff EQ.FOR [vaxrim]EQ.FOR $diff EQKEYW.FOR [vaxrim]EQKEYW.FOR $diff F1CLO.FOR [vaxrim]F1CLO.FOR $diff F1OPN.FOR [vaxrim]F1OPN.FOR $diff F2CLO.FOR [vaxrim]F2CLO.FOR $diff F2OPN.FOR [vaxrim]F2OPN.FOR $diff F3CLO.FOR [vaxrim]F3CLO.FOR $diff F3OPN.FOR [vaxrim]F3OPN.FOR $diff FILCH.FOR [vaxrim]FILCH.FOR $diff GETDAT.FOR [vaxrim]GETDAT.FOR $diff GETT.FOR [vaxrim]GETT.FOR $diff GTSORT.FOR [vaxrim]GTSORT.FOR $diff HASH.FOR [vaxrim]HASH.FOR $diff HASHIN.FOR [vaxrim]HASHIN.FOR $diff HELPGEN.FOR [vaxrim]HELPGEN.FOR $diff HTOI.FOR [vaxrim]HTOI.FOR $diff IEXP.FOR [vaxrim]IEXP.FOR $diff IFRT.FOR [vaxrim]IFRT.FOR $diff INTCON.FOR [vaxrim]INTCON.FOR $diff INTDEF.FOR [vaxrim]INTDEF.FOR $diff INTLOD.FOR [vaxrim]INTLOD.FOR $diff ISCAN.FOR [vaxrim]ISCAN.FOR $diff ISECT.FOR [vaxrim]ISECT.FOR $diff ISREL.FOR [vaxrim]ISREL.FOR $diff ITOC.FOR [vaxrim]ITOC.FOR $diff ITOH.FOR [vaxrim]ITOH.FOR $diff JOIN.FOR [vaxrim]JOIN.FOR $diff JOIREL.FOR [vaxrim]JOIREL.FOR $diff KMPARD.FOR [vaxrim]KMPARD.FOR $diff KMPARI.FOR [vaxrim]KMPARI.FOR $diff KMPARR.FOR [vaxrim]KMPARR.FOR $diff KMPART.FOR [vaxrim]KMPART.FOR $diff KOMPXX.FOR [vaxrim]KOMPXX.FOR $diff LFIND.FOR [vaxrim]LFIND.FOR $diff LOADIT.FOR [vaxrim]LOADIT.FOR $diff LOCATT.FOR [vaxrim]LOCATT.FOR $diff LOCBOO.FOR [vaxrim]LOCBOO.FOR $diff LOCPRM.FOR [vaxrim]LOCPRM.FOR $diff LOCREL.FOR [vaxrim]LOCREL.FOR $diff LODELE.FOR [vaxrim]LODELE.FOR $diff LODPAS.FOR [vaxrim]LODPAS.FOR $diff LODREC.FOR [vaxrim]LODREC.FOR $diff LODREL.FOR [vaxrim]LODREL.FOR $diff LODRUL.FOR [vaxrim]LODRUL.FOR $diff LSTREL.FOR [vaxrim]LSTREL.FOR $diff LSTRNG.FOR [vaxrim]LSTRNG.FOR $diff LXCONS.FOR [vaxrim]LXCONS.FOR $diff LXCREC.FOR [vaxrim]LXCREC.FOR $diff LXEND.FOR [vaxrim]LXEND.FOR $diff LXGENR.FOR [vaxrim]LXGENR.FOR $diff LXGENS.FOR [vaxrim]LXGENS.FOR $diff LXGETI.FOR [vaxrim]LXGETI.FOR $diff LXGETR.FOR [vaxrim]LXGETR.FOR $diff LXID.FOR [vaxrim]LXID.FOR $diff LXIREC.FOR [vaxrim]LXIREC.FOR $diff LXITEM.FOR [vaxrim]LXITEM.FOR $diff LXLENC.FOR [vaxrim]LXLENC.FOR $diff LXLENW.FOR [vaxrim]LXLENW.FOR $diff LXLINE.FOR [vaxrim]LXLINE.FOR $diff LXLREC.FOR [vaxrim]LXLREC.FOR $diff LXMASK.FOR [vaxrim]LXMASK.FOR $diff LXNEXI.FOR [vaxrim]LXNEXI.FOR $diff LXSET.FOR [vaxrim]LXSET.FOR $diff LXSREC.FOR [vaxrim]LXSREC.FOR $diff LXSTOR.FOR [vaxrim]LXSTOR.FOR $diff LXUSET.FOR [vaxrim]LXUSET.FOR $diff LXWREC.FOR [vaxrim]LXWREC.FOR $diff MINMAX.FOR [vaxrim]MINMAX.FOR $diff MODIFY.FOR [vaxrim]MODIFY.FOR $diff MOTSCN.FOR [vaxrim]MOTSCN.FOR $diff NE.FOR [vaxrim]NE.FOR $diff NSCAN.FOR [vaxrim]NSCAN.FOR $diff PARVAL.FOR [vaxrim]PARVAL.FOR $diff PJECT.FOR [vaxrim]PJECT.FOR $diff PRJTUP.FOR [vaxrim]PRJTUP.FOR $diff PRULE.FOR [vaxrim]PRULE.FOR $diff PTRS.FOR [vaxrim]PTRS.FOR $diff PUTDAT.FOR [vaxrim]PUTDAT.FOR $diff PUTT.FOR [vaxrim]PUTT.FOR $diff QUERY.FOR [vaxrim]QUERY.FOR $diff RELADD.FOR [vaxrim]RELADD.FOR $diff RELDEL.FOR [vaxrim]RELDEL.FOR $diff RELGET.FOR [vaxrim]RELGET.FOR $diff RELOAD.FOR [vaxrim]RELOAD.FOR $diff RELPAG.FOR [vaxrim]RELPAG.FOR $diff RELPUT.FOR [vaxrim]RELPUT.FOR $diff REUSE.FOR [vaxrim]REUSE.FOR $diff RIM.FOR [vaxrim]RIM.FOR $diff RIOIN.FOR [vaxrim]RIOIN.FOR $diff RIOOPN.FOR [vaxrim]RIOOPN.FOR $diff RIOOUT.FOR [vaxrim]RIOOUT.FOR $diff RMCLOS.FOR [vaxrim]RMCLOS.FOR $diff RMCONS.FOR [vaxrim]RMCONS.FOR $diff RMDATE.FOR [vaxrim]RMDATE.FOR $diff RMDBGT.FOR [vaxrim]RMDBGT.FOR $diff RMDBLK.FOR [vaxrim]RMDBLK.FOR $diff RMDBPT.FOR [vaxrim]RMDBPT.FOR $diff RMDEL.FOR [vaxrim]RMDEL.FOR $diff RMFIND.FOR [vaxrim]RMFIND.FOR $diff RMGATT.FOR [vaxrim]RMGATT.FOR $diff RMGET.FOR [vaxrim]RMGET.FOR $diff RMGREL.FOR [vaxrim]RMGREL.FOR $diff RMGTSO.FOR [vaxrim]RMGTSO.FOR $diff RMHELP.FOR [vaxrim]RMHELP.FOR $diff RMLATT.FOR [vaxrim]RMLATT.FOR $diff RMLOAD.FOR [vaxrim]RMLOAD.FOR $diff RMLOOK.FOR [vaxrim]RMLOOK.FOR $diff RMLREL.FOR [vaxrim]RMLREL.FOR $diff RMMAIN.FOR [vaxrim]RMMAIN.FOR $diff RMOPEN.FOR [vaxrim]RMOPEN.FOR $diff RMPUT.FOR [vaxrim]RMPUT.FOR $diff RMRES.FOR [vaxrim]RMRES.FOR $diff RMRULE.FOR [vaxrim]RMRULE.FOR $diff RMSAV.FOR [vaxrim]RMSAV.FOR $diff RMSORT.FOR [vaxrim]RMSORT.FOR $diff RMSTRT.FOR [vaxrim]RMSTRT.FOR $diff RMTIME.FOR [vaxrim]RMTIME.FOR $diff RMTOL.FOR [vaxrim]RMTOL.FOR $diff RMUSER.FOR [vaxrim]RMUSER.FOR $diff RMVARC.FOR [vaxrim]RMVARC.FOR $diff RMWHER.FOR [vaxrim]RMWHER.FOR $diff RMZIP.FOR [vaxrim]RMZIP.FOR $diff RNAMEA.FOR [vaxrim]RNAMEA.FOR $diff RNAMER.FOR [vaxrim]RNAMER.FOR $diff ROUN.FOR [vaxrim]ROUN.FOR $diff RTOC.FOR [vaxrim]RTOC.FOR $diff RTOF.FOR [vaxrim]RTOF.FOR $diff RULDEL.FOR [vaxrim]RULDEL.FOR $diff RULES.FOR [vaxrim]RULES.FOR $diff RXREC.FOR [vaxrim]RXREC.FOR $diff SELECT.FOR [vaxrim]SELECT.FOR $diff SELOUT.FOR [vaxrim]SELOUT.FOR $diff SELPAR.FOR [vaxrim]SELPAR.FOR $diff SELPUT.FOR [vaxrim]SELPUT.FOR $diff SETIN.FOR [vaxrim]SETIN.FOR $diff SETOUT.FOR [vaxrim]SETOUT.FOR $diff SETRUL.FOR [vaxrim]SETRUL.FOR $diff SORT.FOR [vaxrim]SORT.FOR $diff SPOUT.FOR [vaxrim]SPOUT.FOR $diff STATUS.FOR [vaxrim]STATUS.FOR $diff STRMOV.FOR [vaxrim]STRMOV.FOR $diff SUBREL.FOR [vaxrim]SUBREL.FOR $diff SUBTRC.FOR [vaxrim]SUBTRC.FOR $diff SWCON.FOR [vaxrim]SWCON.FOR $diff SWCOST.FOR [vaxrim]SWCOST.FOR $diff SWFILO.FOR [vaxrim]SWFILO.FOR $diff SWFLFS.FOR [vaxrim]SWFLFS.FOR $diff SWHART.FOR [vaxrim]SWHART.FOR $diff SWHRTD.FOR [vaxrim]SWHRTD.FOR $diff SWHRTI.FOR [vaxrim]SWHRTI.FOR $diff SWHRTR.FOR [vaxrim]SWHRTR.FOR $diff SWICST.FOR [vaxrim]SWICST.FOR $diff SWIDCP.FOR [vaxrim]SWIDCP.FOR $diff SWIICP.FOR [vaxrim]SWIICP.FOR $diff SWINPO.FOR [vaxrim]SWINPO.FOR $diff SWIRCP.FOR [vaxrim]SWIRCP.FOR $diff SWITCP.FOR [vaxrim]SWITCP.FOR $diff SWSHEL.FOR [vaxrim]SWSHEL.FOR $diff SWSINK.FOR [vaxrim]SWSINK.FOR $diff SWSMFL.FOR [vaxrim]SWSMFL.FOR $diff SWSMVL.FOR [vaxrim]SWSMVL.FOR $diff SWUNLO.FOR [vaxrim]SWUNLO.FOR $diff SWUNVL.FOR [vaxrim]SWUNVL.FOR $diff SWVLFS.FOR [vaxrim]SWVLFS.FOR $diff SWVLLO.FOR [vaxrim]SWVLLO.FOR $diff TALLY.FOR [vaxrim]TALLY.FOR $diff TOLED.FOR [vaxrim]TOLED.FOR $diff TOLER.FOR [vaxrim]TOLER.FOR $diff TTY.FOR [vaxrim]TTY.FOR $diff TYPER.FOR [vaxrim]TYPER.FOR $diff UNDATA.FOR [vaxrim]UNDATA.FOR $diff UNDEF.FOR [vaxrim]UNDEF.FOR $diff UNLOAD.FOR [vaxrim]UNLOAD.FOR $diff UTOL.FOR [vaxrim]UTOL.FOR $diff WARN.FOR [vaxrim]WARN.FOR $diff WHERE.FOR [vaxrim]WHERE.FOR $diff WHETOL.FOR [vaxrim]WHETOL.FOR $diff WRLINE.FOR [vaxrim]WRLINE.FOR $diff XHIBIT.FOR [vaxrim]XHIBIT.FOR $diff ZEROIT.FOR [vaxrim]ZEROIT.FOR $set noverify -h- cmpute.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]CMPUTE.FOR;1 SUBROUTINE CMPUTE INCLUDE 'TEXT.BLK' C C PURPOSE: PROCESS COMPUTE COMMANDS C C INCLUDE 'RMATTS.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'FILES.BLK' INCLUDE 'MISC.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'BUFFER.BLK' C DATA AND DIMENSION: INTEGER FTYPE INTEGER KVAL REAL RVAL EQUIVALENCE (KVAL,RVAL) INTEGER LINE(7) LOGICAL EQKEYW INCLUDE 'DCLAR1.BLK' INCLUDE '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 WRITE(NOUT,9000) 9000 FORMAT(35H -ERROR- UNRECOGNIZED FUNCTION TYPE ) GO TO 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 WRITE(NOUTR,9100) WHAT,ANAME 9100 FORMAT(3X,A6,A8) WRITE(NOUTR,9200) 9200 FORMAT(27H ------------------------) CALL SPOUT(LINE,28) GO TO 9999 C C ERROR MESSAGES. C C ATTRIBUTE LENGTH IS GREATER THAN 1. C 8000 CONTINUE WRITE(NOUT,9400) 9400 FORMAT(26H -ERROR- FUNCTION WILL NOT, X 42H WORK ON MULTI-WORD OR VARIABLE ATTRIBUTES) GO TO 9999 C C TYPE IMPROPER FOR THE FUNCTION. C 8100 CONTINUE WRITE(NOUT,9500) 9500 FORMAT(32H -ERROR- FUNCTION TYPE WILL ONLY, X 39H WORK ON REAL,DOUBLE AND INT ATTRIBUTES) 9999 CONTINUE RETURN END -h- compare.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]COMPARE.FOR;1 PROGRAM COMPARE DIMENSION IARR(28) INTEGER*2 HALF(2,28) EQUIVALENCE (IARR(1),HALF(1,1)) COMMON /RIMCOM/ RMSTAT INTEGER RMSTAT DIMENSION TESTDAT(4) EQUIVALENCE (J1,A1),(J2,A2) REAL*8 DBNAME,RELNAME CALL STRMOV(8HCOMPUTED,1,8,TESTDAT(3),1) I1 = 0 I2 = 0 1 FORMAT(32A4) COMP = 1H/ COMP1 = 4HECHO 20 CONTINUE READ(5,1,END=100) IARR J2 = ISCAN(IARR,1,128,COMP,1,1,J1) IF(J1 .EQ. 0) GO TO 50 30 JJ1 = J1 + 3 IF(JJ1 .GT. 128) GO TO 50 J2 = ISCAN(IARR,JJ1,128,COMP,1,1,J1) IF(J1 .EQ. JJ1) GO TO 20 IF(J1 .NE. 0) GO TO 30 50 CONTINUE DO 60 I=1,32 J1 = HALF(1,I) J2 = HALF(2,I) I1 = I1 - J1 - J2 60 I2 = I2 + J1 + J2 GO TO 20 100 CONTINUE CALL RIGHT(J2,I1) CALL LEFT(J1,I1) J2 = J2 + J1 CALL RIGHT(J2,I2) CALL LEFT(J1,I2) J2 = J2 + J1 TESTDAT(1) = A1 TESTDAT(2) = A2 WRITE(6,200) J1,J2 200 FORMAT(' COMPUTED CHECKSUMS ARE ',2I8) DBNAME = 6HVERIFY CALL RMOPEN(DBNAME) RELNAME = 7HCOMPARE CALL RMFIND(1,RELNAME ) CALL RMLOAD(1,TESTDAT) CALL RMCLOS 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 -h- compre.com Mon Dec 02 10:17:26 1985 DF1:[DBMS]COMPRE.COM;1 $! $! COMMAND PROCEDURE TO COMPARE THE RESULTS OF THE RIM TESTS $! $! BUILD THE COMPARE PROGRAM $! $ FOR COMPARE $ LINK COMPARE,RIMLIB/LIB $! $! CHECK TEST1 $! $ ASSIGN TEST1.DAT FOR005 $ RUN COMPARE $ DEASSIGN FOR005 $! $! CHECK TEST2 $! $ ASSIGN TEST2.DAT FOR005 $ RUN COMPARE $ DEASSIGN FOR005 $! $! CHECK TEST3 $! $ ASSIGN TEST3.DAT FOR005 $ RUN COMPARE $ DEASSIGN FOR005 $! $! CHECK TEST4 $! $ ASSIGN TEST4.DAT FOR005 $ RUN COMPARE $ DEASSIGN FOR005 $! $! NOW USE RIM TO LOOK AT THE RESULTS $! $ RUN RIM OPEN VERIFY TALLY CHKSUM1 FROM COMPARE TALLY CHKSUM2 FROM COMPARE EXIT $! $ DEASSIGN FOR005 $! END OF COMPARE PROCEDURE $! -h- const4.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]CONST4.BLK;1 C C *** / C O N S T 4 / *** C C MISCELLANEOUS CONSTANTS -- 1-4 CHARACTER WORDS C COMMON /CONST4/ K4DP,K4RP,K4LP,K4HP,K4IS,K4EQ,K4ON,K4OR, X K4OFF,K4AND,K4MIN,K4MAX,K4AVE,K4SUM,K4END,K4DIM,K4CRE,K4UPD, X K4EOF,K4LOD,K4QUE,K4COM,K4CON,K4KEY,K4YES,K4FOR,K4LOA, X K4QUIT,K4EXIT,K4ECHO,K4LOAD,K4DATA,K4NONE,K4PROM,K4PRES, X K4INPT,K4OTPT,K4WITH,K4HASH, X K4A,K4D,K4Y,K4N,K4E,K4M,K40,K41,K42,K43,K44,K45,K46,K47, X K48,K49,K4DOT,K4COL,K4EQS,K4STAR,K4QUOT,K4COMA,K4LPAR,K4RPAR, X K4PLUS,K4MNUS,K4KOM(6),K4BOOL(17),K4HEAD(6) C -h- const8.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]CONST8.BLK;1 C C *** / C O N S T 8 / *** C C MISCELLANEOUS CONSTANTS -- 1-8 CHARACTER WORDS (REAL*8 VARIABLES) C COMMON /CONST8/ K8RRC,K8RDT,K8NAM,K8NUM,K8AOR,K8AN1, X K8RN1,K8OPR,K8TYP,K8AN2,K8RN2,K8VAL,K8XXX,K8AND,K8OR, X K8ZFIL,K8HDB,K8COMM,K8SCH,K8RC,K8DBA,K8RMDT,K8RIM, X K8BEGI,K8READ,K8USE,K8LOAD,K8DEFI,K8MENU,K8EXIT,K8IN, X K8OUT,K8LIM,K8ROWS,K8DATA,K8ALL,K8ZZ98,K8ZZ99 C REAL*8 K8RRC,K8RDT,K8NAM,K8NUM,K8AOR,K8AN1, X K8RN1,K8OPR,K8TYP,K8AN2,K8RN2,K8VAL,K8XXX,K8AND,K8OR, X K8ZFIL,K8HDB,K8COMM,K8SCH,K8RC,K8DBA,K8RMDT,K8RIM, X K8BEGI,K8READ,K8USE,K8LOAD,K8DEFI,K8MENU,K8EXIT,K8IN, X K8OUT,K8LIM,K8ROWS,K8DATA,K8ALL,K8ZZ98,K8ZZ99 C -h- csc.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]CSC.FOR;1 SUBROUTINE CSC INCLUDE '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 'CONST4.BLK' INCLUDE 'CONST8.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'FILES.BLK' INCLUDE 'MISC.BLK' C LOGICAL EQKEYW LOGICAL EQ INTEGER ERROR INTEGER EFLAG,RFLAG INTEGER DBSTAT INCLUDE 'DCLAR2.BLK' INCLUDE '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 WRITE (NOUT,9000) 9000 FORMAT(/,29H BEGIN RIM SCHEMA COMPILATION,/) GO TO 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 WRITE (NOUT,9001) 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 WRITE (NOUT,9002) 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 WRITE (NOUT,9003) 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 WRITE (NOUT,9004) 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 WRITE (NOUT,9005) 9005 FORMAT(66H -ERROR- NO ATTRIBUTES DEFINED - RELATION DEFINITION IS XIMPOSSIBLE) ERROR = ERROR + 1 GO TO 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 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 C C 625 CONTINUE CALL LODRUL GO TO 350 C C PROCESS PASSWORDS. C 700 CONTINUE IF(RFLAG.EQ.1) GO TO 725 WRITE (NOUT,9007) 9007 FORMAT(63H -ERROR- RELATIONS MUST BE DEFINED IN ORDER TO ASSIGN PA XSSWORDS) ERROR = ERROR + 1 GO TO 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 WRITE (NOUT,9008) DBNAME 9008 FORMAT(/,28H RIM SCHEMA COMPILATION FOR ,A8,12H IS COMPLETE,/) 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 WRITE (NOUT,9009) 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 -h- data1.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]DATA1.BLK;1 C C START OF THE THIRD RECORD OF THE RELATION/ATTRIBUTE DATA C DATA MSTRTP /227/ -h- data2.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]DATA2.BLK;1 C C START OF THE SECOND RECORD OF THE RELATION/ATTRIBUTE DATA C DATA MSTRTP /74/ -h- data3.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]DATA3.BLK;1 C C LENGTH OF THE WHRCOM COMMON BLOCK -- RMSAV C DATA LENBF4 /484/ -h- data4.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]DATA4.BLK;1 C C DECLARATIVES FOR SORT - SEE SWCON C DATA LPRU /128/ DATA DPRU /-1/ -h- data5.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]DATA5.BLK;1 C C COST CONSTANTS FOR SWCOST C DATA IOPOSC /375000./ DATA IOTRAC /130./ DATA COCOST /12./ DATA MOCOFI /4./ DATA MOCOAD /4./ -h- dbload.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]DBLOAD.FOR;1 SUBROUTINE DBLOAD INCLUDE 'TEXT.BLK' C C THIS ROUTINE IS THE DRIVER FOR LOADING DATA VALUES IN THE C RIM DATA BASE. C INCLUDE 'CONST8.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'RULCOM.BLK' INCLUDE 'FILES.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'MISC.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'RIMCOM.BLK' C LOGICAL EQKEYW INCLUDE '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 WRITE(NOUT,9000) 9000 FORMAT(/,25H BEGIN -RIM- DATA LOADING ) GO TO 200 100 CONTINUE CALL LODREC 200 CONTINUE IF(EQKEYW(1,KWLOAD,4)) GO TO 300 IF(EQKEYW(1,KWEND,3)) GO TO 1000 WRITE(NOUT,9001) 9001 FORMAT(46H -ERROR- UNRECOGNIZED LOAD COMMAND - RETYPE IT) GO TO 100 C C RELATION NAME SPECIFIED. C 300 CONTINUE IF(LXITEM(IDUMMY).EQ.2) GO TO 400 WRITE(NOUT,9002) 9002 FORMAT(46H -ERROR- MISSING RELATION NAME ON LOAD COMMAND) GO TO 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(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 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 WRITE(NOUT,9003) 9003 FORMAT(23H END -RIM- DATA LOADING ) C C SET THE PROMPT CHARACTER BACK TO R (RIM) C CALL LXSET(K4PROM,K4RP) RETURN END -h- dclar1.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]DCLAR1.BLK;1 C C RELATION NAMES --- C REAL*8 RNAME REAL*8 RNAME1 REAL*8 RNAME2 REAL*8 RNAME3 C C ATTRIBUTE NAMES --- C REAL*8 ANAME REAL*8 ANAME1 REAL*8 ANAME2 REAL*8 ANAMES(1) REAL*8 NAMES(10) -h- dclar2.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]DCLAR2.BLK;1 C C DATABASE NAME --- C REAL*8 NAMDB C C DATABASE OWNER NAME --- C REAL*8 NAMOWN -h- dclar3.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]DCLAR3.BLK;1 C C PASSWORDS --- C REAL*8 RPW1 REAL*8 RPW2 REAL*8 MPW1 REAL*8 MPW2 -h- dclar4.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]DCLAR4.BLK;1 C C FILE NAMES --- C REAL*8 FILE REAL*8 IFILE REAL*8 RIMDB1 REAL*8 RIMDB2 REAL*8 RIMDB3 -h- dclar5.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]DCLAR5.BLK;1 C C MENU MODE ARRAYS FOR RELATIONS AND ATTRIBUTES --- C REAL*8 IREL REAL*8 IATT -h- dclar6.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]DCLAR6.BLK;1 C C MISCELLANEOUS VARIABLES --- C C VARIABLE TO STORE WHATS COMPUTED IN CMPUTE C REAL*8 WHAT C C DATE AND TIME C REAL*8 IDAY REAL*8 ITIME C C DUMMY WORDS USED BY EQ AND NE C REAL*8 WORD1 REAL*8 WORD2 C C OLD AND NEW NAMES USED BY MODIFY C REAL*8 NAMOLD REAL*8 NAMNEW C C DATE OF LAST DATABASE MODIFICATION USED BY RMGREL C REAL*8 LASTMD -h- defcom.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]DEFCOM.FOR;1 C DEFAULT COMMON AREA - BLOCK DATA C DUMMY DECLARATIONS TO ENSURE ALL COMMONS GET LOADED C (USED IN OVERLAY VERSIONS, NOT IN VAX VERSION) BLOCK DATA COMMON /ATTBLE/I1 COMMON /BLNKFL/I2 COMMON /BTBUF/I3 COMMON /CDCDBS/I4 COMMON /CONST4/I5 COMMON /BUFFER/I6 COMMON /CONST8/I7 COMMON /F1COM/I8 COMMON /F2COM/I9 COMMON /F3COM/IA COMMON /FILES/IB COMMON /FLAGS/IC COMMON /INCORE/ID COMMON /KEYDAT/IE COMMON /LXCARD/IF COMMON /LXCIT/IG COMMON /LXCON/IH COMMON /LXGEN/II COMMON /LXWRDS/IJ COMMON /MISC/IK COMMON /PTRCOM/IL COMMON /RELTBL/IM COMMON /RIMCOM/IN COMMON /RIMPTR/IO COMMON /RMATTS/IP COMMON /RMKEYW/IR COMMON /RMSBUF/IS COMMON /RULCOM/IT COMMON /SELCOM/IU COMMON /SRTCOM/IW COMMON /STACK/IX COMMON /START/IY COMMON /TUPLEA/IZ COMMON /TUPLER/I0 COMMON /VARDAT/I11 COMMON /WHCOM/I12 END -h- deldat.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]DELDAT.FOR;1 SUBROUTINE DELDAT(INDEX,ID) INCLUDE '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 'F2COM.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'BUFFER.BLK' INCLUDE '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 -h- deldup.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]DELDUP.FOR;1 SUBROUTINE DELDUP(MAT) INCLUDE '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 'F2COM.BLK' INCLUDE 'START.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'FILES.BLK' INCLUDE 'MISC.BLK' INCLUDE 'BUFFER.BLK' DIMENSION MAT(*) LOGICAL IFALL INTEGER COLUMN INCLUDE '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 WRITE (NOUT,9001) ND,NAME 9001 FORMAT(2X,I6,26H ROWS DELETED IN RELATION ,A8) 9999 CONTINUE RETURN END -h- delete.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]DELETE.FOR;1 SUBROUTINE DELETE(MAT) INCLUDE 'TEXT.BLK' C C THIS ROUTINE PROCESSES A DELETE IN RIM. C C PARAMETERS C MAT-----ARRAY TO HOLD ONE TUPLE INCLUDE 'START.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'FILES.BLK' INCLUDE '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 WRITE(NOUT,9000) 9000 FORMAT(55H -ERROR- A WHERE CLAUSE IS REQUIRED ON A DELETE COMMAND) GO TO 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 WRITE(NOUT,9001) ND,NAME 9001 FORMAT(2X,I6,26H ROWS DELETED IN RELATION ,A8) C C DONE. C RETURN END -h- dirmak.com Mon Dec 02 10:17:26 1985 DF1:[DBMS]DIRMAK.COM;1 ADDDAT.FOR;1 APPLPRO.FOR;1 ARODB1.DAT;1 ARODB3.DAT;1 ATTADD.FOR;1 ATTBLE.BLK;1 ATTDEL.FOR;1 ATTGET.FOR;1 ATTNEW.FOR;1 ATTPAG.FOR;1 ATTPUT.FOR;1 BLKCHG.FOR;1 BLKCLN.FOR;1 BLKCLR.FOR;1 BLKDEF.FOR;1 BLKEXT.FOR;1 BLKLOC.FOR;1 BLKMOV.FOR;1 BLNKFL.BLK;1 BTADD.FOR;1 BTBUF.BLK;1 BTGET.FOR;1 BTINIT.FOR;1 BTLKI.FOR;1 BTLKR.FOR;1 BTLKT.FOR;1 BTMOVE.FOR;1 BTPUT.FOR;1 BTREP.FOR;1 BTSERT.FOR;1 BUFFER.BLK;1 BUILD.FOR;1 CDCDBS.BLK;1 CHANGE.FOR;1 CHKATT.FOR;1 CHKREL.FOR;1 CHKRUL.FOR;1 CHKTUP.FOR;1 CMPUTE.FOR;1 COMPARE.FOR;1 COMPRE.COM;1 CONST4.BLK;1 CONST8.BLK;1 CSC.FOR;1 DATA1.BLK;1 DATA2.BLK;1 DATA3.BLK;1 DATA4.BLK;1 DATA5.BLK;2 DBLOAD.FOR;1 DCLAR1.BLK;1 DCLAR2.BLK;1 DCLAR3.BLK;1 DCLAR4.BLK;1 DCLAR5.BLK;1 DCLAR6.BLK;1 DELDAT.FOR;1 DELDUP.FOR;1 DELETE.FOR;1 DROPF.FOR;1 EQ.FOR;1 EQKEYW.FOR;1 F1CLO.FOR;1 F1COM.BLK;1 F1OPN.FOR;1 F2CLO.FOR;1 F2COM.BLK;1 F2OPN.FOR;1 F3CLO.FOR;1 F3COM.BLK;1 F3OPN.FOR;1 FILCH.FOR;1 FILES.BLK;1 FLAGS.BLK;1 FOR003.DAT;1 FOR008.DAT;1 FOR009.DAT;1 GETDAT.FOR;1 GETT.FOR;1 GTSORT.FOR;1 HASH.FOR;1 HASHIN.FOR;1 HELP.COM;1 HELPDEF.DAT;1 HELPGEN.FOR;1 HELPOUT.DAT;1 HELPTXT.DAT;1 HTOI.FOR;1 IEXP.FOR;1 IFRT.FOR;1 INCORE.BLK;1 INSTALL.COM;2 INTCON.FOR;2 INTDEF.FOR;1 INTLOD.FOR;2 ISCAN.FOR;1 ISECT.FOR;1 ISREL.FOR;1 ITEST1.DAT;1 ITEST2.DQT;1 ITEST3.DAT;1 ITEST4.DAT;1 ITOC.FOR;1 ITOH.FOR;1 JOIN.FOR;1 JOIREL.FOR;1 KEYDAT.BLK;1 KMPARD.FOR;1 KMPARI.FOR;1 KMPARR.FOR;1 KMPART.FOR;1 KOMPXX.FOR;1 LFIND.FOR;1 LOADIT.FOR;1 LOADT.COM;1 LOCATT.FOR;1 LOCBOO.FOR;1 LOCPRM.FOR;1 LOCREL.FOR;1 LODELE.FOR;1 LODPAS.FOR;1 LODREC.FOR;1 LODREL.FOR;1 LODRUL.FOR;1 LSTREL.FOR;1 LSTRNG.FOR;1 LXCARD.BLK;1 LXCIT.BLK;1 LXCON.BLK;1 LXCONS.FOR;1 LXCREC.FOR;1 LXEND.FOR;1 LXGEN.BLK;1 LXGENR.FOR;1 LXGENS.FOR;1 LXGETI.FOR;1 LXGETR.FOR;1 LXID.FOR;1 LXIREC.FOR;1 LXITEM.FOR;1 LXLENC.FOR;1 LXLENW.FOR;1 LXLINE.FOR;1 LXLREC.FOR;1 LXMASK.FOR;1 LXNEXI.FOR;1 LXSET.FOR;1 LXSREC.FOR;1 LXSTOR.FOR;1 LXUSET.FOR;1 LXWRDS.BLK;1 LXWREC.FOR;1 MAKERIM.COM;1 MAKRIM.CMD;1 MINMAX.FOR;1 MISC.BLK;1 MODIFY.FOR;1 MOTSCN.FOR;1 NE.FOR;1 NSCAN.FOR;1 PAGDAT.BLK;1 PARVAL.FOR;1 PJECT.FOR;1 PRJTUP.FOR;1 PROM.BLK;1 PRULE.FOR;2 PTRCOM.BLK;1 PTRS.FOR;1 PUTDAT.FOR;1 PUTT.FOR;1 QUERY.FOR;1 README.1ST;3 RELADD.FOR;1 RELDEL.FOR;1 RELGET.FOR;1 RELOAD.FOR;1 RELPAG.FOR;1 RELPUT.FOR;1 RELTBL.BLK;1 REUSE.FOR;1 RH.DIR;1 RIM.FOR;2 RIMABS.ABS;1 RIMCOM.BLK;1 RIMDOC.RNO;1 RIMHLP.HLP;1 RIMPTR.BLK;1 RIMTXT.TXT;1 RIO.BLK;1 RIOIN.FOR;1 RIOOPN.FOR;2 RIOOUT.FOR;1 RMATTS.BLK;1 RMCLOS.FOR;1 RMCONS.FOR;1 RMDATE.FOR;1 RMDBGT.FOR;1 RMDBLK.FOR;1 RMDBPT.FOR;1 RMDEL.FOR;1 RMFIND.FOR;1 RMGATT.FOR;1 RMGET.FOR;1 RMGREL.FOR;1 RMGTSO.FOR;1 RMHELP.FOR;2 RMKEYW.BLK;1 RMLATT.FOR;1 RMLOAD.FOR;1 RMLOOK.FOR;2 RMLREL.FOR;1 RMMAIN.FOR;2 RMOPEN.FOR;1 RMPUT.FOR;1 RMRES.FOR;1 RMRULE.FOR;1 RMSAV.FOR;1 RMSBUF.BLK;1 RMSORT.FOR;1 RMSTRT.FOR;1 RMTIME.FOR;1 RMTOL.FOR;1 RMUSER.FOR;1 RMVARC.FOR;1 RMWHER.FOR;2 RMZIP.FOR;1 RNAMEA.FOR;1 RNAMER.FOR;1 ROUN.FOR;1 RTOC.FOR;1 RTOF.FOR;1 RULCOM.BLK;1 RULDEL.FOR;1 RULES.FOR;1 RXREC.FOR;1 SELCOM.BLK;1 SELECT.FOR;2 SELOUT.FOR;1 SELPAR.FOR;1 SELPUT.FOR;1 SETIN.FOR;1 SETOUT.FOR;1 SETRUL.FOR;1 SORBUF.BLK;1 SORT.FOR;1 SPOUT.FOR;1 SRTCOM.BLK;1 STACK.BLK;1 START.BLK;1 STATUS.FOR;1 STRMOV.FOR;1 SUBREL.FOR;1 SUBTRC.FOR;1 SWCON.FOR;1 SWCOST.FOR;1 SWFILO.FOR;1 SWFLFS.FOR;2 SWHART.FOR;1 SWHRTD.FOR;1 SWHRTI.FOR;1 SWHRTR.FOR;1 SWICST.FOR;1 SWIDCP.FOR;1 SWIICP.FOR;1 SWINPO.FOR;1 SWIRCP.FOR;1 SWITCP.FOR;1 SWSHEL.FOR;1 SWSINK.FOR;1 SWSMFL.FOR;1 SWSMVL.FOR;1 SWUNLO.FOR;1 SWUNVL.FOR;1 SWVLFS.FOR;1 SWVLLO.FOR;1 TALLY.FOR;1 TECO.INI;13 TEST1.COM;1 TEST1.DAT;1 TEST2.COM;2 TEST2.DAT;1 TEST3.COM;1 TEST4.COM;1 TEXT.BLK;1 TOLED.FOR;1 TOLER.FOR;1 TTY.FOR;1 TUPLEA.BLK;1 TUPLER.BLK;1 TYPER.FOR;1 UNDATA.FOR;1 UNDEF.FOR;1 UNLOAD.FOR;1 UPDATE.COM;1 UPDATF.CMD;1 UTOL.FOR;1 VARDAT.BLK;1 VERIFY.COM;2 WARN.FOR;1 WHCOM.BLK;1 WHERE.FOR;1 WHETOL.FOR;1 WRLINE.FOR;1 XHIBIT.FOR;1 ZEROIT.FOR;1 -h- dropf.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]DROPF.FOR;1 SUBROUTINE DROPF(IFILE) INCLUDE 'TEXT.BLK' REAL*8 IFILE CHARACTER*8 NFILE WRITE(NFILE,100) IFILE 100 FORMAT(A8) OPEN(UNIT=30,FILE=NFILE,STATUS='OLD',IOSTAT=IOS) IF(IOS.NE.0) RETURN CLOSE(UNIT=30,STATUS='DELETE') RETURN END -h- eq.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]EQ.FOR;1 LOGICAL FUNCTION EQ(WORD1,WORD2) INCLUDE '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 'DCLAR6.BLK' C EQ = WORD1.EQ.WORD2 RETURN END -h- eqkeyw.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]EQKEYW.FOR;1 LOGICAL FUNCTION EQKEYW(I,KEYW,LEN) INCLUDE '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 '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 -h- f1clo.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]F1CLO.FOR;1 SUBROUTINE F1CLO INCLUDE 'TEXT.BLK' C C PURPOSE: CLOSE THE RIM DIRECTORY FILE - FILE 1 C INCLUDE 'CONST8.BLK' INCLUDE 'F1COM.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'ATTBLE.BLK' INCLUDE 'RELTBL.BLK' INCLUDE '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 -h- f1com.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]F1COM.BLK;1 C C *** / F 1 C O M / *** C C FILE 1 COMMON CONTROL VARIABLES C COMMON /F1COM/ FILE1,LENBF1,LF1REC,CAREC,CRREC INTEGER FILE1 INTEGER CAREC INTEGER CRREC C C VARIABLE DEFINITIONS: C FILE1---FILE NAME OR UNIT FOR FILE1 - THE DIRECTORY FILE C LENBF1--LENGTH OF BLOCKS ON FILE1 C LF1REC--LAST FILE1 RECORD USED C CAREC---CURRENT ATTRIBUTE RECORD C CRREC---CURRENT RELATION RECORD C -h- f1opn.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]F1OPN.FOR;1 SUBROUTINE F1OPN(FILE) INCLUDE '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 'CONST8.BLK' INCLUDE 'F1COM.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'ATTBLE.BLK' INCLUDE 'RELTBL.BLK' INCLUDE 'FLAGS.BLK' LOGICAL EQ INCLUDE '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 -h- f2clo.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]F2CLO.FOR;1 SUBROUTINE F2CLO INCLUDE 'TEXT.BLK' C C PURPOSE: CLOSE THE DATA RANDOM IO FILE - FILE 2 C INCLUDE 'CONST8.BLK' INCLUDE 'F2COM.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'BUFFER.BLK' INCLUDE '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 -h- f2com.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]F2COM.BLK;1 C C *** / F 2 C O M / *** C C FILE 2 COMMON CONTROL VARIABLES C COMMON /F2COM/ FILE2,LENBF2,LF2REC,LF2WRD,CURBLK(3),MODFLG(3) INTEGER FILE2 INTEGER CURBLK C C VARIABLE DEFINITIONS: C FILE2---FILE NAME OR UNIT FOR FILE2 - THE DATA FILE C LENBF2--LENGTH OF BLOCKS ON FILE2 C LF2REC--NEXT AVAILABLE RECORD ON FILE2 C LF2WRD--NEXT AVAILABLE WORD IN LF2REC C CURBLK--CURRENT RECORDS IN CORE C MODFLG--NON-ZERO FLAG INDICATES RECORD IN CORE HAS MODS C -h- f2opn.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]F2OPN.FOR;1 SUBROUTINE F2OPN(FILE) INCLUDE '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 'CONST8.BLK' INCLUDE 'F2COM.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'RIMCOM.BLK' LOGICAL EQ INCLUDE '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 -h- f3clo.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]F3CLO.FOR;1 SUBROUTINE F3CLO INCLUDE 'TEXT.BLK' C C PURPOSE: CLOSE THE B-TREE RANDOM IO FILE - FILE 3 C INCLUDE 'CONST8.BLK' INCLUDE 'F3COM.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'BTBUF.BLK' INCLUDE '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 -h- f3com.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]F3COM.BLK;1 C C *** / F 3 C O M / *** C C FILE 3 COMMON CONTROL VARIABLES C COMMON /F3COM/ FILE3,LENBF3,LF3REC,MOTREC,MOTADD,LAST,NUMIC, X MAXIC,ICORE(3,20) INTEGER FILE3 C C VARIABLE DEFINITIONS: C FILE3---FILE NAME OR UNIT FOR FILE3 - THE B-TREE FILE C LENBF3--LENGTH OF BLOCKS ON FILE3 C LF3REC--NEXT AVAILABLE RECORD ON FILE3 C MOTREC--LAST RECORD USED FOR MULTIPLE OCCURRENCE TABLE C MOTADD--LAST WORD USED IN THAT RECORD C LAST----LAST RECORD REQUESTED C NUMIC---CURRENT NUMBER OF INCORE BLOCKS C MAXIC---MAXIMUM NUMBER OF INCORE BLOCKS POSSIBLE C ICORE---ARRAY OF INCORE BLOCK DATA C ROW 1 - NUMBER OF USES C ROW 2 - WRITE FLAG (1=YES, 0=NO) C ROW 3 - CORRESPONDING RECORD NUMBER C -h- f3opn.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]F3OPN.FOR;1 SUBROUTINE F3OPN(FILE) INCLUDE '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 'CONST8.BLK' INCLUDE 'F3COM.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'BTBUF.BLK' INCLUDE 'START.BLK' INCLUDE 'RIMCOM.BLK' LOGICAL EQ INCLUDE '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 -h- fig351.txt Mon Dec 02 10:17:26 1985 DF1:[DBMS]FIG351.TXT;4 Figure 3.5-1 -- Organization of Array Fixed Variable Fixed Variable Length Variable Length=1 Length Length=2 Attribute Length Attribute Attribute Attribute Parameters Attribute /------^--------\ +--+---------+---------+---------+---------+-+---------+---------+---------+-+ | | | | | |X| | | | | > | 3 | 4 | 5 | 6 |X| N | N+1 | N+2 | > < | | | | |X| | | | < | | | | | |X| | | | | +--+---------+---------+---------+---------+-+---------+---------+---------+-+ VALUE POINTER \-------v--------/ /---^---\ VALUE VALUE * NO. Chars 0 +---+ (text) | N | * NO. Words 0 +-+-+ (Int, Real) | * NO. Items 0 | (DOUB, DVEC) | * NO. Items 0 | (Ivec, RVEC) | * Row Dimens. Col. Dimens. | (Matrix) (Matrix) | \--v--/ | ^ | | +-------------------------------+ -h- filch.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]FILCH.FOR;1 SUBROUTINE FILCH(STRING,CHAR1,NUM,CHAR) INCLUDE '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 -h- files.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]FILES.BLK;1 C C *** / F I L E S / *** C C IDENTFIERS FOR INPUT AND OUTPUT FILES C COMMON /FILES/ NINT,NOUT,NOUTR,ECHO,CONNI,CONNO,BATCH INTEGER NINT INTEGER NOUT INTEGER NOUTR LOGICAL ECHO,CONNI,CONNO,BATCH C C VARIABLE DEFINITIONS: C NINT----INPUT FILE IDENTIFIER C NOUT----OUTPUT FILE IDENTIFIER C NOUTR---OUTPUT FILE IDENTIFIER FOR REPORTS C ECHO----ECHO FLAG FOR INPUT COMMANDS C CONNI---.TRUE. IFF INPUT IS INPUT AND NOT BATCH C CONNO---.TRUE. IFF OUTPUT IS OUTPUT AND NOT BATCH C BATCH---.TRUE. IFF BATCH MODE C -h- flags.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]FLAGS.BLK;1 C C *** / F L A G S / *** C C FLAG VARIABLES AND CONTROL VARIABLES C COMMON /FLAGS/ DBNAME,USERID,NEXTOP,OWNER,DBDATE,DBTIME, X TOL,LSTCMD,DFLAG,IFMOD,PCENT,RUCK LOGICAL DFLAG REAL*8 DBNAME REAL*8 USERID REAL*8 NEXTOP REAL*8 OWNER REAL*8 DBDATE REAL*8 DBTIME LOGICAL IFMOD REAL TOL LOGICAL PCENT LOGICAL RUCK INTEGER LSTCMD C C VARIABLE DEFINITIONS: C DFLAG---DEFINED DATA BASE FLAG C DBNAME--DATA BASE NAME C USERID--CURRENT USER PASSWORD C NEXTOP--NEXT OPERATION C OWNER---PASSWORD FOR DATA BASE DEFINITION C DBDATE--DATE THE DATA BASE WAS LAST CLOSED C DBTIME--TIME THE DATA BASE WAS LAST CLOSED C IFMOD---SET TO TRUE IFF DATA BASE HAS BEEN MODIFIED C TOL-----TOLORANCE FOR REAL COMPARS C PCENT---.TRUE. IF TOL IS PERCENT: .FALSE. IF ACTUAL VALUE C RUCK----RULE CHECKING SWITCH - .TRUE. OR .FALSE. C LSTCMD--LAST COMMAND ENTERED (3 CHARACTERS) C MACH----MACHINE IDENTIFIER (8 CHARACTERS) C -h- getdat.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]GETDAT.FOR;1 SUBROUTINE GETDAT(INDEX,ID,LOCTUP,LENGTH) INCLUDE '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 'F2COM.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'BUFFER.BLK' INCLUDE '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 -h- gett.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]GETT.FOR;1 SUBROUTINE GETT(STR1,IC1,WORD) INCLUDE '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 BYTE STR1(*) INTEGER WORD INTEGER CHWORD BYTE CHAR(4) EQUIVALENCE (CHWORD,CHAR(1)) INTEGER BLANK DATA BLANK /4H / CHWORD = BLANK CHAR(1) = STR1(IC1) WORD = CHWORD RETURN END -h- gtsort.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]GTSORT.FOR;1 SUBROUTINE GTSORT(MAT,INDEX,IFLAG,LENGTH) INCLUDE '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 'SRTCOM.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'F2COM.BLK' INCLUDE '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 READ(INFIL) LENGTH,(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 -h- hash.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]HASH.FOR;1 SUBROUTINE HASH(TEMP,N) INCLUDE '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 -h- hashin.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]HASHIN.FOR;1 SUBROUTINE HASHIN(PASS,NUM,HASHP,ICHAR) INCLUDE '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 'CONST4.BLK' INCLUDE 'CONST8.BLK' INCLUDE '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 -h- help.com Mon Dec 02 10:17:26 1985 DF1:[DBMS]HELP.COM;1 $! $! CREATE A PROGRAM TO LOAD THE HELP DATABASE $! $ FOR HELPGEN $ LINK HELPGEN,RIMLIB/LIB $! $! DEFINE THE HELP DATABASE $! $ ASSIGN HELPDEF.DAT FOR005 $ ASSIGN HELPOUT.DAT FOR006 $ DELETE HELPDB1.DAT;* $ DELETE HELPDB2.DAT;* $ DELETE HELPDB3.DAT;* $ RUN RIM $ DEASSIGN FOR005 $ DEASSIGN FOR006 $ SET PROT=(W:REW,G:REW) HELPDB1.DAT $ SET PROT=(W:REW,G:REW) HELPDB2.DAT $ SET PROT=(W:REW,G:REW) HELPDB3.DAT $! $! NOW RUN HELPGEN $! $ ASSIGN HELPTXT.DAT FOR002 $ RUN HELPGEN $ DEASSIGN FOR002 $! $! HELP DATABASE IS CONSTRUCTED $! -h- helpdef.dat Mon Dec 02 10:17:26 1985 DF1:[DBMS]HELPDEF.DAT;1 DEFINE HELPDB OWNER NONE ATTRIBUTES KEY3 TEXT 3 VERBAGE TEXT VAR COMMAND TEXT 20 RELATIONS HELP WITH KEY3 VERBAGE COMMAND END EXIT -h- helpgen.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]HELPGEN.FOR;1 PROGRAM HELPIN INTEGER TUPLE(28) REAL*8 DBNAME REAL*8 RNAME DBNAME = 6HHELPDB RNAME = 4HHELP CALL RMOPEN(DBNAME) CALL RMFIND(1,RNAME) TUPLE(2) = 8 1 CONTINUE READ (2,10)TUPLE(1) 10 FORMAT(A4) READ (2,20)(TUPLE(I),I=3,7) 20 FORMAT(5A4) 50 CONTINUE TUPLE(9) = 0 CALL GETL(TUPLE(10),TUPLE(8)) IF(TUPLE(10).EQ.4HENDC) GO TO 1 IF(TUPLE(10).EQ.4HENDD) GO TO 1000 CALL RMLOAD(1,TUPLE) GO TO 50 1000 CONTINUE CALL RMCLOS STOP 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.4HENDD) ISHIFT = 1 IF(LINEX(1).EQ.4HENDC) ISHIFT = 1 IF(M1.NE.1) M1 = M1 + 1 CALL STRMOV(LINEX,1,79,LINE,ISHIFT) NUMC = M1 RETURN END -h- helpout.dat Mon Dec 02 10:17:26 1985 DF1:[DBMS]HELPOUT.DAT;1 BEGIN RIM ----- VAX VERSION 5.0 UD22 83/09/28 09.48.22 RIM COMMAND MODE ENTER "MENU" FOR MENU MODE $R> BEGIN RIM SCHEMA COMPILATION $D> $D> $D> $D> $D> $D> $D> $D> RIM SCHEMA COMPILATION FOR HELPDB IS COMPLETE $R> END RIM EXECUTION 83/09/28 09.48.25 -h- helptxt.dat Mon Dec 02 10:17:26 1985 DF1:[DBMS]HELPTXT.DAT;1 HEL HELP HELP Command ----- ------- The HELP command provides the capability to obtain a description of the available RIM commands, a discussion of the general command syntax, a summary of all available commands, and general news about the RIM system. HELP is available at any time during execution except when in the interactive dialog (menu) mode. To receive help when in the command mode enter: HELP [{command name}] RIM WHERE SORT SYNTAX INPUT FORMAT SUMMARY NEWS 1 HELP Command ----- ------- You will then enter the HELP submodule and receive explanation of the selected option as: OPTION EXPLANATION ------ ----------- HELP previous command and syntax or, if first command identical to HELP RIM HELP command name indicated command and syntax HELP RIM list of commands for which help is available HELP SYNTAX description of the RIM command input format, basic syntax and data genration facilities HELP INPUT FORMAT an in-depth description of free-field input format and data generation facilities available in RIM HELP WHERE the RIM where clauses HELP SORT the RIM sort clause HELP SUMMARY summary of all available RIM commands HELP NEWS general news about the RIM system 1 HELP Command ----- ------- You will remain in the HELP submodule until you enter an END command which will return you to the command mode. The commands available inside the HELP submodule are identical to the HELP commands except that the keyword HELP is omitted. The HELP submodule displays information one screen at a time. After each screen you will have the option to continue displaying the text or to return to the HELP submodule by entering QUIT. ENDC OPE OPEN OPEN Command ----- ------- The OPEN command is required whenever an existing data base is to be used. You specify the name of the data base. RIM uses the name of the data base to form the names of the three local files which contain the data base. OPEN dbname Only one RIM data base may be open at one time (if you don't CLOSE the present data base before opening a new one, RIM will automatically close the present data base). The OPEN command must be issued before any commands that require data from the data base can be processed. ENDC CLO CLOSE CLOSE Command ------ ------- The CLOSE command permits you to close a RIM data base without leaving RIM. The reason for doing this is to close one data base, then open or define a different one all within one RIM session. This command is not needed if only one RIM data base is accessed during a RIM session. This command results in data needed by the data base being copied from its incore working areas to the local data base files. CLOSE Note: the current data base will be closed for you when you leave RIM by issuing an EXIT command ENDC USE USER USER Command ----- ------- This command is used to identify your password to RIM. Your password is used to check against read and modify passwords specified for the relations. Each time this command is issued, the new password replaces the current password. The default password is the word NONE. USER password ENDC INP INPUT INPUT Command ------ ------- This command causes RIM to read subsequent commands and/or data from a specified file. When RIM detects an end-of-file mark on the indicated file, RIM will return to the terminal or batch input file, as apppropriate, and continue to read input and/or data. The use of this command allows the user to define command procedures on file and then have RIM execute a set of commands without user interaction. INPUT filename A more explicit way to control return of input to your ter- minal or batch input file is to use INPUT INPUT as the last com- mand which returns input, as appropriate, to the batch input file or user terminal. As an alternative, INPUT TERMINAL may be used. 1 INPUT Command ------ ------- A more general use of this command is possible by causing a second alternate input file to be used from the first alter- nate file by use of the INPUT command. This nesting of alter- nate input files can be done to any depth. It should be noted that you must provide explicit returns on these alternate files using the INPUT command since the default is to return to your input file (terminal if applicable). ENDC OUT OUTPUT OUTPUT Command ------- ------- This command is used to specify the name of the output file. Specifying a file other than OUTPUT will result in the output from the RIM commands to be placed on a local file with the specified file name. The output file name may be changed as often as desired. The use of this command allows the user to get offline hardcopy output from RIM. OUTPUT filename OUTPUT TERMINAL will return the output to the user's terminal. ENDC ECH ECHO ECHO Command ----- ------- This command is used to control printing of your input commands on the output file. The default is for echo to be off in interactive execution and on in batch. To activate echo print you enter: ECHO ENDC NOE NOECHO NOECHO Command ------- ------- The NOECHO command turns off the echo printing. NOECHO ENDC TOL TOLERANCE TOLERANCE Command ---------- ------- For real and double precision attributes and for real and double precision vectors and matrices as well as for individual elements of such vectors and matrices, you may want to use a tolerance in qualifying equality, non equality and order. The tolerance applies to any real or double precision number you use in a WHERE clause. If A is an attribute with value a and r is a user specified number used in a WHERE clause and t a tolerance (positive, zero or negative), the following are true conditions: A EQ r if and only if r-t le a le r+t A NE r if and only if a lt r-t or a gt r+t A GT r if and only if a gt r-t A GE r if and only if a ge r-t A LT r if and only if a lt r+t A LE r if and only if a le r+t For real and double precision attributes of length greater than 1 and for real and double precision vectors and matrices, the above formulas are applied to the comparison of each element. 1 TOLERANCE Command ---------- ------- If t is a percentage tolerance, t is to be replaced with t x r/100 in the above expressions to define true conditions for percentage tolerances. TOLERANCE tol [PERCENT] where tol is the tolerance and the presence or absence of the keyword PERCENT indicates whether tol is a percentage tolerance or or not. The TOLERANCE command can be used as many times as desired to reset the tolerance. A tolerance stays in effect for a session until a new tolerance is specified. The default value for tolerance is 0. ENDC NOC NOCHECK NOCHECK Command -------- ------- Rule checking applies to the CHANGE command and LOAD command to load or modify data. The default is that rules, if defined, are enforced. The NOCHECK command suppresses the rule checking. NOCHECK [RULES] ENDC CHE CHECK CHECK Command ------ ------- The CHECK command turns on rule checking. The CHECK and NOCHECK commands may be issued as many times as required anywhere in the input stream while in command mode. CHECK [RULES] ENDC EXI EXIT EXIT Command ----- ------- To leave the RIM system you issue the command: {EXIT} QUIT This command closes your current data base. Data needed by your data bases are copied from the incore working areas to the files whose names were determined by the OPEN command or by the schema name designated in the DEFINE submodule. ENDC QUI QUIT QUIT Command ----- ------- To leave the RIM system you issue the command: {QUIT} EXIT This command closes your current data base. Data needed by your data bases are copied from the incore working areas to the files whose names were determined by the OPEN command or by the schema name designated in the DEFINE submodule. ENDC REL RELOAD RELOAD Command ------- ------- The RELOAD command is used whenever you want to rebuild the data files of your data base to recover unused space created by row deletions, certain attribute changes and relation removals. When a row is deleted, one of its variable length attributes changed so that it length increases, or when a relation is removed, the vacated space is not reused until you issue this command. If your data base has any KEY attributes, then the access pointer files maintainted for those attributes are also rebuilt. The syntax for this command is: RELOAD ENDC DEF DEFINE DEFINE Command ------- ------- The define submodule commands are used for defining the structure of the data base. The definition of the data base is called the schema and the schema name is the name of the data base and forms the essential part of the names of the local files used for the data base. Attributes, relations, passwords, and constraints (rules) are defined using this submodule. To access this submodule you enter: DEFINE dbname You must identify the name of the data base whose definition you are going to create or expand by specifying the schema name. This name is used to form the name of the local files used to store the data base tables and must when augmented with a single number be a legal local filename. For an example, see help for DEFINE EXAMPLE. ENDC OWN OWNER OWNER Command ------ ------- The OWNER command specifies the owner of the data base. The OWNER has permision to read or modify all data and the schema. OWNER password If the data base already exists and you want to define additional attributes or relations, password is checked against the existing owner password. ENDC ATT ATTRIBUTES ATTRIBUTES Command ----------- ------- ATTRIBUTES attname type1 [{length}] [KEY] VAR attname type2 [{row, col}] [KEY] row, VAR VAR, VAR . . . The attribute definitions are ended when you specify one of the keywords RELATIONS, PASSWORDS or RULES which start the other sections in the DEFINE submodule. 1 ATTRIBUTES Command ----------- ------- Type1 attributes: RIM supports seven data types of type1: floating point (real), integer, text, double precision, real vectors, integer vectors and double precision vectors. You must enter REAL, INT, TEXT, DOUB, RVEC, IVEC or DVEC for type1. The default length is one value except for TEXT for which it is 8 characters. The length is specified in number of values and characters respectively. VAR indicates variable length. The optional KEY specification causes an index file to be built for the attribute which is used by RIM to find qualifying rows for retrievals and updates. Under certain conditions, such an index file will make retrievals and updates considerably faster than if no index file is used. See WHERE clause definitions for a specific discussion. The default is that such an index file is not built (non-key attribute). You should consider the cost of building and storing index file data versus the benefits you will obtain from quicker retrievals when deciding if a KEY declaration should be used or not. No specific rules can be given here, experience should be used to judge. An 1 ATTRIBUTES Command ----------- ------- attribute can be changed from KEY to non-key or vice-versa later using the BUILD KEY and DELETE KEY commands. For larger data bases (more than 1, 000 rows), experience has shown that it is most efficient not to specify a KEY in the define submodule but rather to load the data without keys and to later cause index files to be built using the BUILD KEY command. The greater the number of keys the more efficient this method is. Type2 attributes: RIM supports three data types of type2: real matrices, integer matrices or double precision matrices. You must enter RMAT, IMAT or DMAT for type2. The matrices can be of fixed size, have variable column dimension or variable row and column dimensions. You enter the row dimension first, followed by the column dimension. Default dimension is 1, 1 . The key-word KEY has the same meaning as for type1 attributes. ENDC REL RELATIONS RELATIONS Command ---------- ------- To define relations enter: RELATIONS relname WITH attname1 [attname2 ...] . . . The relation definitions are ended by specifying one of the keywords ATTRIBUTES, PASSWORDS, RULES, or END which start the other sections of the DEFINE submodule or finishes the schema definition. The attributes must be listed in the order in which they are to appear in the relation. No attributes can be used which have not been previously defined, either in the current DEFINE submodule execution or in previous definition of this data base. Attributes which are defined but not included in a relation will not become part of the RIM schema. A RIM data base must have attributes and relations defined. Passwords and constraint rules are optional. ENDC PAS PASSWORDS PASSWORDS Command ---------- ------- If read or modify passwords are desired, you enter: PASSWORDS {READ PASSWORD} FOR relname IS password RPW {MODIFY PASSWORD} FOR relname IS password MPW . . The password definitions are ended by specifying one of the keywords ATTRIBUTES, RELATIONS, RULES, or END which start the other sections of the DEFINE submodule or finishes the data base definition. Passwords can be any string of characters up to 8 characters long. When you are doing queries, loads, or modifications, the current password is specified by the USER command. If this password does not match one of the read, modify or owner passwords for a relation you cannot query that relation. If this password does not match one of the modify or owner passwords, you cannot load or modify the given relation. ENDC RUL RULES RULES Command ------ ------- Constraint rules are another optional section of the DEFINE submodule. If rules are specified, they are used during the loading process or during CHANGE commands to screen out rows which do not meet the constraint rules. Rules are specified by relation. At most 10 rules may be specified for a single relation. There are several options available in the rule definition section. To define constraint rules you enter: RULES attname [IN relname] {EQ} value [{AND} attname ... ] NE OR GT GE LT LE 1 RULES Command ------ ------- or attname1 IN relname {EQA} attname2 IN relname [{AND} ... ] NEA OR GTA GEA LTA LEA where: EQ = Equals NE = Not equal to GT = Greater than GE = Greater than or equal to LT = Less than LE = Less than or equal to EQA = Equals attribute NEA = Not equal to attribute GTA = Greater than attribute LTA = Less than attribute LEA = Less than or equal to attribute 1 RULES Command ------ ------- The rule definitions are ended by specifying one of the keywords ATTRIBUTES, RELATIONS, PASSWORDS, or END which start the other sections of the DEFINE submodule or finishes the schema definition. Attributes referenced in the rule definitions must have been previously defined. By specifying rules, you can restrict an attribute to a range of values or require that the value of an attribute in one relation have a specified relationship to the values of an attribute in the same or a different relation. The compare operators ending in A (EQA etc.) are used when the comparison is to existing attribute values rather than to a specified constant. A rule expression may contain no more than 10 compare operators (9 Boolean operators). The method used for constraint checking is that the first attribute mentioned in the rule is taken from the input (LOAD or CHANGE command) data and checked against the remainder of the rule expression using existing values in the database. ENDC END END END Command ---- ------- To finish the schema definition you enter the following keyword and leave the DEFINE submodule: END The END command also terminates the LOAD process. ENDC DEX DEFINE EXAMPLE DEFINE EXAMPLE ------- ------- Example of define submodule commands: DEFINE RIMDB OWNER ME ATTRIBUTES MODEL TEXT KEY WEIGHT REAL NUMPASS INT CARRIER TEXT 16 FLIGHTNO INT NAME TEXT KEY AGE INT RELATIONS AIRPLANE WITH MODEL WEIGHT NUMPASS FLIGHTS WITH CARRIER FLIGHTNO MODEL PEOPLE WITH NAME AGE 1 DEFINE EXAMPLE ------- ------- PASSWORDS MPW FOR AIRLINES IS AGENT RPW FOR PEOPLE IS BLUE RULES MODEL IN FLIGHTS EQA MODEL IN AIRPLANE AGE GT 21 AND AGE LT 65 NUMPASS IN AIRPLANE LE 350 END ENDC LOA LOAD LOAD Command ----- ------- The load submodule commands are used to add data to a newly defined relation or to add data to a relation which already contains data. To access this submodule enter: LOAD relname You may now load data in the relation, one row per command, by entering data values in a one to one correspondence with the attributes: value1 value2 ... valuen Valuei takes the form described in the following table: 1 LOAD Command ----- ------- Attribute Type Length or Valuei Remark Dimension REAL, INT n n.gt.1 (val1 ... valn) Parentheses optional DOUB, RVEC IVEC, DVEC REAL, INT VAR (val1 val2 ...) Parentheses required DOUB, RVEC IVEC, DVEC TEXT any "text string" In special cases " " is optional (see INPUT FORMAT) RMAT, IMAT m, n ((r1c1...rmc1)(r1c2...) + Columnwise DMAT ...rmcn)) Parentheses optional RMAT, IMAT m, VAR ((r1c1...)(r1c2...)...)) Columnwise DMAT or Parentheses required VAR, VAR 1 LOAD Command ----- ------- To finish data loading you enter: END Multiple relations may be loaded from within the load submodule by re-entering the LOAD command instead of the END command. For an example of data loading, see LOAD EXAMPLE. ENDC LOX LOAD EXAMPLE LOAD EXAMPLE ----- ------- Example of load submodule commands: LOAD AIRPLANE DC9 87000. 110 747SP 200000. 350 LOAD PEOPLE BOB 30 JOE 32 ALICE 29 END If the value for an attribute is missing, you enter the characters --0- for the missing value or use two successive commas. L1011 -0- 250 L1011, , 250 These two records have identical meaning. ENDC SEL SELECT SELECT Command ------- ------- The SELECT command is used for displaying or printing data from one relation. It has many options. To print all data from a relation: SELECT ALL FROM relname To print selected attribute values from all rows in a relation: SELECT attname1 [ attname2 ... attnamen ] FROM relname The above form will print up to 20 attributes in any order. However the number of attributes is limited by space available in the line. As a rule of thumb, 7 attributes may be selected when running at an interactive terminal and 11 when running in batch mode or at an 132 character terminal. For variable length attributes or for attributes of fixed length that would otherwise not fit on a line alone or together with other attributes, you may format the output using the optional field width control: 1 SELECT Command ------- ------- SELECT attname1 [ =fw1 ] [ attname2 [ =fw2 ] ... ] + FROM relname fwi is the output field width for attnamei. For a text type attribute, fwi is the width of the output paragraph in number of characters, for other attribute types it is the number of values. When the field width option is used, RIM will use for each row as many output lines as required by the most critical attribute. Defaults are rather complex. For a fixed length attribute, no paragraphing is attempted. The system will use the field width required to display the value(s) of the attribute. For a variable length attribute of type TEXT, the default is display of a maximum of 40 characters with truncation of remaining text, if any. For variable length attributes of types REAL, INT, DOUB, the default is 4 values with truncation. For variable length vector type attributes, the default is 4 values with paragraphing (no truncation). For variable length matrix attributes the default is 4 values with paragraphing (no truncation). A row starts on a new line. 1 SELECT Command ------- ------- Whether field width is specified or not, the system will display the dimension of variable length vectors and matrices using one of the output value positions. However, should the user specify a width of only one value for such an attribute, the row and column dimensions will not be displayed. Further information about line width, no of lines per page, defaults and user specification is given under the WIDTH and LINES commands. When paragraphing TEXT type attributes, RIM will identify con- sequtive substrings of text separated by blanks and place such a substring on the line, if there is space available, or if the current current line contains less than four characters in which case the number of characters that fit on the line are removed from (the front of) the substring and put on the line (without hyphen). If there is not room on a line filled with more than four characters, the (first part of the) substring will be placed on the next line. 1 SELECT Command ------- ------- Examples of SELECT command: SELECT ivecvar FROM rel1 DIM IVECVAR ---------------------------- 7 1 2 3 4 5 6 7 1 10 SELECT imatvv FROM rel1 ROW COL IMATVV ----------------------------- 2 5 11 12 13 14 15 21 22 23 24 25 1 1 11 1 SELECT Command ------- ------- SELECT textv=9 FROM rel1 TEXTV ---------- THIS IS AN EXAMPL E OF WRAPAROUN D OF TEXT THIS IS ANOTHER EXAMPLE OF TEXT 1 SELECT Command ------- ------- The attribute name (attnamei) may be replaced by an attribute number (attnumi). It may also be a specific element of a vector or a mtrix. Thus the general form of the unconditional SELECT command is: SELECT {attname1 [ =fw1 ] } [attname2 [=fw2] ... ] + attnum1 [ =fw1 ] attname1(i) attname1(i, j) ALL FROM relname To print all attributes from a relation where certain conditions are met: SELECT ALL FROM relname WHERE condition1 [{AND} condition2 ... ] OR For help for the where clause, see the WHERE entry. For help for the sorted by clause, see the SORT entry. For examples, see SELECT EXAMPLES. ENDC WHE WHERE WHERE Clause ------ ------ Up to ten conditions may be combined using the Boolean operators of AND and OR. The conditions are combined from left to right. Each condition may be one of the following forms: attname EXISTS attname FAILS attname EQ MAX attname EQ MIN attname EQ value attname EQS value attname NE value attname GT value attname GE value attname LT value attname LE value attname EQ list attname NE list attname1 EQA attname2 attname1 NEA attname2 attname1 GTA attname2 attname1 GEA attname2 attname1 LTA attname2 attname1 LEA attname2 1 WHERE Clause ------ ------ ROWS EQ rownumber ROWS NE rownumber ROWS LT rownumber ROWS LE rownumber ROWS GE rownumber ROWS GT rownumber ROWS EQ list ROWS NE list LIMIT EQ number where: EQ = Equals EQS = Contains the text string NE = Not equals GT = Greater than GE = Greater than or equal to LT = Less than LE = Less than or equal to 1 WHERE Clause ------ ------ EQA = Equals attribute NEA = Not equals attribute GTA = Greater than attribute GEA = Greater than or equal to attribute LTA = Less than attribute LEA = Less than or equal to attribute MAX = Maximum value MIN = Minimum value Attname, attname1, attname2 may refer to an element of a vector or a matrix. When an attribute has been assigned a value, then EXISTS will qualify those attributes. If an attribute has not been assigned a value, but was loaded with -0-, then FAILS will qualify those attributes. 1 WHERE Clause ------ ------ MAX and MIN comparison can only be made for integer, real and double precision attributes of fixed length equal to 1. Value in comparison statement must follow the rules of the LOAD command for vectors and matrices, i.e. if the attribute is of variable length or dimension, parentheses must be used to input a vector or a matrix value or a list of vector and matrix values. EQS applies to text strings only. In such a comparison, value is a text string and the comparison is true if value is found as a substring anywhere within the attribute for which comparison is requested. NE comparison when applied to matrices or vectors is true if the length or dimension is different from the length or dimension of the user specified comparison vector or matrix or if any vector or matrix elements differs. 1 WHERE Clause ------ ------ GT and LT comparisons for vector and matrix attributes are lexicographical, i.e. a comparison is made element by element (columnwise for matrices) and continued until a true or false condition is detected. If no such condition is detected after the last element is checked, a false condition is assumed. Comparison is made only for vectors and matrices of the same size as comparison data. GE and LE comparisons for vector and matrix attributes are similar to GT and LT comparisons except it continues if an equal condition is detected and if no condition is detected after the last element is checked, a true condition is assumed. Comparison rules for vector attributes apply also to real, integer and double precision attributes of fixed or variable length. A list is a simple list a1, a2, a3, ..., an of values where a value may be a vector or matrix. 1 WHERE Clause ------ ------ The comparison key words ending in A are used when comparing the value of one attribute to the value of another attribute in the same row of the relation. ROWS refer to row numbers in a relation. Note that a relation is loaded in input row order but that subsequent operations (changes) to the data base may cause the order of the rows to change. When the LIMIT clause is used, only the first LIMIT number of the rows that otherwise would qualify will actually qualify. Processing the WHERE condition can be speeded up greatly if index processing is used. Index processing involves using the indices created for KEY attributes rather than looking at each row of a relation to find the rows qualified by the WHERE conditions. Index processing will be used when the following are all true: 1) The last condition uses an attribute which is KEY 2) The last condition uses EQ 3) The last condition is not combined by OR with the other conditions. ENDC SOR SORT SORTED BY ------- -- The output can be sorted by specifying sorting attributes. The sorting order is user specified with default low to high. SELECT ... FROM relname + SORTED BY attname1 [{=A} ] [ attname2 [={A} ] ... ] + D D [ WHERE ... ] A and D stands for ascending and descending order respectively. If a sort on more than one attribute is requested, the output will first be ordered according to the first mentioned attribute. In case there are duplicates for the first sort attribute, these will be ordered by the second sort attribute, duplicates within this by the third and so on. A maximum of 5 sort attributes may be specified. When multiple attributes are used, ascending and descending order may be used in any combination. A maximum of five sort attributes may be specified. Variable length attributes may not be used as sort attributes. When fixed length attributes are used as sort attributes, only the first 20 characters and the first value is used for sort. ENDC TAL TALLY TALLY Command ------ ------- The TALLY command prints a tally for an attribute giving each unique value and the number of times it occurs in a relation. The tally is ordered ascending or descending per user input. Default is ascending. The WHERE clause is optional. For a description of the WHERE clause see HELP WHERE. TALLY attname [{=A}] FROM relname [ WHERE ... ] D For examples of SELECT and TALLY, see SELECT EXAMPLES. ENDC SEL SELECT EXAMPLES SELECT EXAMPLES ------- -------- Examples of SELECT and TALLY commands: SELECT ALL FROM AIRPLANE SELECT MODEL FROM AIRPLANE SELECT ALL FROM AIRPLANE WHERE WEIGHT GT 100000. *8 AND NUMPASS LT 200 SELECT AGE FROM PEOPLE WHERE NAME EQ BOB SELECT ALL FROM AIRPLANE SORTED BY MODEL=D TALLY MODEL FROM FLIGHTS TALLY MODEL FROM FLIGHTS WHERE CARRIER EQ UNITED SELECT ALL FROM DIMENS WHERE HEIGHT GTA WIDTH SELECT FILE TITLE=4 OWNER FROM PFDATA ENDC LIS LISTREL LISTREL Command -------- ------- The purpose of LISTREL is to provide you with information about the relations in your data base. There are three formats for the LISTREL command. The first consists of simply entering: LISTREL Using LISTREL in this fashion provides you with a list of all relations currently defined in your data base. If you wish to display the definition of a specific relation, then the syntax is: LISTREL relname The use of LISTREL in this manner also provides a count of the number of defined rows for the specified relation. LISTREL ALL This command will display the definitions of all relations in the data base, including counts of number of defined rows in each relation. ENDC EXH EXHIBIT EXHIBIT Command -------- ------- The purpose of the EXHIBIT command is to allow you to query the RIM dictionary to obtain the names of all relations having a specific set of attributes. For example, if you want to know which relations contain the attribute attname you would enter: EXHIBIT attname You would then obtain either a list of the relations having this attribute, or a message indicating that this attribute was not found in any relations in the data base. In other cases, you may wish to know which relations contain a list of attributes. This request is handled in a similar manner. Suppose that you wanted to know which relations contain both attname1 and attname2. The command would than be: EXHIBIT attname1 attname2 In general, the syntax of this command is: EXHIBIT attname1 [attname2 ... attnamen] ENDC PRI PRINT RULES PRINT RULES Command ------ ----- ------- This command can be used by the person whose current password matches the owner of the data base definition to obtain a complete list of all constraint rules. PRINT RULES ENDC COM COMPUTE COMPUTE Command -------- ------- The COMPUTE command is used to compute simple functional values for an attribute. A WHERE clause is optional and uses the same syntax as is used in the SELECT command. COMPUTE {COUNT} attname FROM relname [WHERE ... ] MIN MAX AVE SUM There are some restrictions as to the type and word length of the attribute when using these computed functions. All of these functions exclude any -0- values when making their computations. 1 COMPUTE Command -------- ------- The following table describes the attribute type and length restrictions for each function: FUNCTION ATTRIBUTE TYPE ATTRIBUTE LENGTH -------- -------------- ---------------- COUNT any any MIN any 1 (20 chars for text) MAX any 1 (20 chars for text) AVE any except TEXT 1 SUM any except TEXT 1 Examples of COMPUTE command: COMPUTE AVE NUMPASS FROM FLIGHTS COMPUTE MAX WEIGHT FROM FLIGHTS WHERE NUMPASS LT 100 COMPUTE COUNT NAME FROM PEOPLE WHERE AGE GT 30 ENDC CHA CHANGE CHANGE Command ------- ------- The CHANGE command is used to change the value of an attribute in a relation where certain conditions are met. CHANGE {attname1} TO attname2 [IN relname] WHERE ... attname(i) attname(i, j) Value has the same form as descried in the LOAD command. The WHERE clause is required and and is described in the WHERE entry. If the relation name is not specified, the attribute is changed in all relations where the attribute is found and the conditions are met. For relations in which the change attribute is is present but in which one or more of the attributes used in the where clause are missing, an error message will be issued. ENDC DEL DELETE DELETE Command ------- ------- The delete command removes data from the data base. For a more precise description see: DELETE DUPLICATES DELETE ROW DELETE KEY ENDC DER DELETE ROW DELETE ROW Command ------- --- ------- The DELETE ROW command is used to delete selected rows in a relation. DELETE ROW FROM relname WHERE ... The name of the relation must be specified as well as a WHERE clause. The syntax for the WHERE clause is described in the WHERE entry. ENDC DED DELETE DUPLICATES DELETE DUPLICATES Command ------- ---------- ------- This command is used to remove any duplicate rows from a relation. It is useful to use on new relations which have been created by any of the relational algebra commands (JOIN, INTERSECT, SUBTRACT, or PROJECT). The syntax for this command is: DELETE DUPLICATES [attname1, attname2, ...] from relname Duplicates are checked only for the specified (combination of) attribute(s). Default is to check for complete row (all attributes). ENDC REM REMOVE REMOVE Command ------- ------- The REMOVE command is used to remove a relation definition and its data from the data base. REMOVE relname ENDC CHA CHANGE OWNER CHANGE OWNER Command ------- ----- ------- The CHANGE OWNER command is used to change the name of the data base owner password. Only a person whose password matches the curent owner password may use this command. priviledge. CHANGE OWNER TO newowner ENDC REN RENAME RENAME Command ------- ------- For detailed information on the RENAME command see: RENAME ATTRIBUTE RENAME RELATIONS ENDC REA RENAME ATTRIBUTE RENAME ATTRIBUTE Command ------- --------- ------- The RENAME attribute command is used to change the name of an attribute in the definition (schema) of the data base. RENAME [ATTRIBUTE] attname1 TO attname2 [ IN relname ] The old name is attname1 and the new name is attname2. If the name of the relation is not specified, the name change takes place in every relation that contains the old name. If relname is specified and attname1 is duplicate (or more), the first occurance will be changed. RULES and KEY defined for attname1 will automatically be redefined to apply for attname2. Examples of RENAME command: RENAME MODEL TO VERSION IN AIRPLANES RENAME NUMPASS TO CAPACITY ENDC BUI BUILD KEY BUILD KEY Command ------ --- ------- This command is used to change an attribute from non-key to KEY. An index is built from existing data values by making a pass through current rows of the specified relation. This index is then used and maintained just as if the attribute had been declared to be KEY in the original data base definition. BUILD KEY FOR attname IN relname ENDC DEK DELETE KEY DELETE KEY Command ------- --- ------- This command is used to change an attribute from KEY to non-key. The index file for that attribute is inactivated and no longer maintained or used once the attribute has been changed to non-key with this command. DELETE KEY FOR attname IN relname ENDC CHP CHANGE PASSWORD CHANGE PASSWORD Command ------- -------- ------- If you are the data base owner, you may change the read or modify passwords by the following command CHANGE {RPW} TO newpass FOR relname MPW ENDC RER RENAME RELATION RENAME RELATION Command ------- -------- ------- You may change the name of a relation by the following command RENAME RELATION relname TO newname Note: RULES and KEYs applying to relname will aumatically apply to newname. ENDC INT INTERSECT INTERSECT Command ---------- ------- The INTERSECT command allows you to combine the rows of two rela- tions into a third relation based on equality of values within a common set of attributes identified from a set of specified attributes. The syntax of the INTERSECT command is: INTERSECT relname1 WITH relname2 FORMING relname3 + [USING attname1 [attname2 ... attnamen]] The USING clause identifies which attributes that are included in the resulting relation. Common attributes used in the intersect process are identified within these. As an example, assume that you have the following two relations defined: REL-1 REL-2 NAME DEPT JOB DEPT JOB PAY ---------------------- -------------------- BOB A ENGR A ENGR 800 JIM C SUPR B ENGR 450 BOB B ENGR C ENGR 750 RAY C ENGR 1 INTERSECT Command ---------- ------- You may INTERSECT two relations restricted to specific sets of attributes (the USING clause) or use all attributes of both relations. In either case RIM will identify the common attributes. In the first case, suppose you wish to INTERSECT the two relations using attributes DEPT, NAME and JOB. The command for this would be: INTERSECT REL-1 WITH REL-2 FORMING REL-3 USING DEPT NAME JOB The result would be the new relation REL-3 shown below: REL-3 DEPT NAME JOB ----------------------- A BOB ENGR B BOB ENGR C RAY ENGR 1 INTERSECT Command ---------- ------- In this example there are no duplicate rows in REL-3. It is possible that the INTERSECT command will create duplicate rows. In general duplicate rows are not desired in a relation. Duplicates are not removed by the INTERSECT command but can be removed with the DELETE DUPLICATES command. Note also that by specifying which attributes the INTERSECT is using, you restrict the number of attributes in the resulting relation to only those specified in the USING clause. In another case, you may want RIM to use all the attributes in the two relations. In this instance, you would enter: INTERSECT REL-1 WITH REL-2 FORMING REL-4 The result would be REL-4 consisting of the attributes NAME, DEPT, JOB, and PAY, shown below with the resulting rows: REL-4 NAME DEPT JOB PAY ---------------------------------- BOB A ENGR 800 BOB B ENGR 450 RAY C ENGR 750 ENDC JOI JOIN JOIN Command ----- ------- The JOIN command is a function operating on two relations to form a third relation. The purpose of the JOIN is to juxtapose two relations based on a specified attribute from each. The result is a third relation containing all the attributes from both relations. Rows are generated into the new relation based upon a specified comparison between the two JOIN attributes. In general a row from the first relation may generate zero, one or more rows depending upon how many rows in the second relation have the desired match. The syntax of the JOIN command is: JOIN relname1 USING attname1 WITH relname2 USING attname2 + FORMING relname3 [WHERE {EQ}] NE GT GE LT LE 1 JOIN Command ----- ------- The conditional clause is different from the WHERE clause of select. In JOIN it applies only to the comparison of the two attributes upon which JOIN is based. If the WHERE clause is omitted (default), EQ is used. The comparisons involving order (GT etc.) refer to attname1 GT attname2 etc.. The comparison of the two single attributes follow the (lexicographical) rules of the where clause of select. 1 JOIN Command ----- ------- As an example, consider the relations REL1 and REL2: REL1 REL2 A B C D E ------------------------------ ------------------------ 1 2 3 3 1 4 5 6 6 2 7 8 9 The following JOIN command JOIN REL1 USING B WITH REL2 USING D + FORMING REL3 WHERE B LT D would produce: REL3 A B C D E -------------------------------------------------------- 1 2 3 3 1 1 2 3 6 2 4 5 6 6 2 1 JOIN Command ----- ------- The JOIN will function correctly on any comparison providing that you compare attributes of the same data type. All attribute names in the resultant relation must be unique for you to obtain accurate results when using SELECT or CHANGE commands on the relation. Any duplicate attribute names should be changed using the RENAME command before doing queries or updates to the new relation. In the case of duplicate attribute names, RENAME when applied to a specific relation will change the first attribute name. Note that if the constituient relations have no duplicate rows, the relation formed with JOIN will also have no duplicate rows. ENDC PRO PROJECT PROJECT Command -------- ------- The function of a PROJECT command is to create a new relation as a subset of an existing relation. You may want to create the new relation from the old one by removing attributes, removing rows, or both. The syntax for the PROJECT command is: PROJECT relname1 FROM relname2 USING {attname1 ... attnamen} + ALL [WHERE ...] The WHERE clause is optional but if specified it has the same syntax as specified in the WHERE entry. You are required to specify which attributes are to be retained in the new relation. The old relation is relname2 and the new relation is relname1. As an example consider the following relation: 1 PROJECT Command -------- ------- PEOPLE EMPNUM EMPNAME BOSS POSITION GROUP -------------------------------------------------- 2181 JONES SMITH MANAGER AADE 3964 ERICKSON BUSS APPL-MGR ACC 6543 GRAY PARKER ASST-MGR PHOTO 2233 SCHMITZ BUSS APPL-MGR ACC -------------------------------------------------- To create a new relation with EMPNAME and GROUP as the only attributes where no rows contains PARKER as BOSS enter the command: PROJECT TEMP1 FROM PEOPLE USING EMPNAME GROUP + WHERE BOSS NE PARKER TEMP1 EMPNAME GROUP ------------------- JONES AADE ERICKSON ACC SCHMITZ ACC 1 PROJECT Command -------- ------- The PROJECT command is useful to reduce the size of a relation when only a subset of the data is needed. RIM will not eliminate any duplicate rows formed in the new relation. You must do that yourself with the DELETE DUPLICATES command. ENDC SUB SUBTRACT SUBTRACT Command --------- ------- The SUBTRACT command is similar to the PROJECT command in that a new relation is formed from an existing relation, but rows are selected based upon the data of two relations rather than a WHERE clause within a single relation. Where the INTERSECT command looked for rows of two relations which matched up, the SUBTRACT does just the opposite. It looks for rows on in relation which do not match with any rows in the other relation. The syntax for the SUBTRACT command is: SUBTRACT relname1 FROM relname2 FORMING relname3 + [USING attname1 [attname2 ... attnamen]] All rows in the new relation will come from relname2. If the USING clause is not specified, then all attributes of relname2 will be attributes of relname3. relname1 is the relation that rows of relname2 are checked against for matches. 1 SUBTRACT Command --------- ------- As an example consider these two example relations: EMPDATA BOSSDATA EMPNUM EMPNAME BOSS BOSS POSITION GROUP ------------------------------- ----------------------------- 2181 JONES SMITH SMITH MANGER AADE 3964 ERICKSON BUSS PARKER ASST-MGR PHOTO 6543 GRAY PARKER BUSS APPL-MGR ACC 8461 BROWN WHITE 2233 SCHMITZ BUSS The following command will produce a new relation from EMPDATA: SUBTRACT BOSSDATA FROM EMPDATA FORMING TEMP USING EMPNAME BOSS The resulting relation TEMP would contain only one row: TEMP EMPNAME BOSS -------------------- BROWN WHITE ENDC NEW NEWPAGE NEWPAGE Command -------- ------- This command causes a new page to be issued. It applies to batch output only. The command is: NEWPAGE ENDC BLA BLANK BLANK Command ------ ------- Blank lines can be output by using the command: BLANK n where n is the number of blank lines written. ENDC TIT TITLE TITLE Command ------ ------- The command: TITLE "titlestring" causes the text "titlestring" to be printed, centered on the line. If the length of "titlestring" is longer than current lines width, it will be truncated and a warning issued. ENDC DAT DATE DATE Command ----- ------- The command: DATE will cause the current date to be printed, centered on the line. ENDC LIN LINES LINES Command ------ ------- This command controls the number of lines per page (exclusive of title). The command: LINES n will establish page size to n lines. Default is 56. ENDC WID WIDTH WIDTH Command ------ ------- This command controls the width of a printed line. The command: WIDTH n will establish a line width of n characters. Default is 78 if output is to a terminal, 132 if output is to a batch printer. ENDC ENDC INF INPUT FORMAT INPUT FORMAT ------ ------ Entering input through LXLREC -------- ----- ------- ------ LXLREC is a free-field input routine which separates user input into items which are grouped into records. Terminology ----------- line - one line of information with a maximum of 80 characters. A line corresponds to a card (for those old enough to remember card input). item - one piece of information. An item may be a real number, an integer or text. Items are delimited by blanks or commas. Multiple blanks count as a single blank. Multiple commas generate null items (see section on multiple commas). record - a collection or list of up to 100 items which is in response to a single request for data by the calling program. 1 INPUT FORMAT ------ ------ integer- all characters must be numeric except the first one which may be + or -. For example: -1 23 +10000 real - an item of the form i1.i2ei3 where i1 and i3 may be signed integers and i2 is an unsigned integer. The entire form is not necessary but at least one digit and either the . Or the e must be present. for example: 1. E-3 -2.7E+4 .0 text - any single item which is not an integer or real. If a text item looks like an integer or real or if it contains blanks or commas, it must be enclosed in quotes ("). Composing records --------- ------- Ordinarily records consist of one line. However, multiple records may be put on one line by separating them with dollars or semi-colons. Alternatively, a record may span several lines by ending all but the last line with a plus. In general items must be wholly contained on one line with the exception of quoted text items and comments. 1 INPUT FORMAT ------ ------ Special items - =, (, ) ------- ----- ----- Equals and left and right parentheses are treated as single items unless enclosed in quoted text items. Thus a=3. Is 3 items (two text and one real) rather than one item. "a=3." is one text item. This allows more convenient parsing of many commands. Multiple commas -------- ------ If more than one comma separates two items, each additional comma will generate a text item with Three characters "-0-". Thus, , , abc, , 2.5 is equivalent to -0-, abc, -0-, 2.5. 1 INPUT FORMAT ------ ------ Rules for text items ----- --- ---- ----- A quoted text item is terminated by a record separator (dollar or semi-colon). Quoted text items may be continued on multiple lines. If the trailing quote is omitted on the last item in a record, the quoted item is terminated at either the record separator, if any, or the last non-blank character on the line. Quotes may be included in quoted text items by doubling the quotes (e.g. "a, ""b" yields a, "b as a text string). The total number of characters for all text items in a record is limited to 2000. Some examples ---- -------- 1, 2. ABC "2." This record has four items - integer, real and two text 1 $ 2 This line is two records - each one integer 1 + 2 This is one record on two lines with two integers 1 INPUT FORMAT ------ ------ Comments -------- Comments may be included anywhere in the input stream by enclosing them between *( and ). For example *( this is a comment). comments are completely ignored by LXLREC. Empty lines between records are also ignored and may be used to paragraph input. An alternative form of comment is */..../ where slashes replace the parentheses. This may be used if parentheses are needed in the comment. Short cuts - data generation ----- ---- ---- ---------- Activities such as entering large volumes of data, repeating similiar records and reentering mis-typed records can be eased by using the LXLREC data generation facilities. 1 INPUT FORMAT ------ ------ Repeating items on previous record - *n, **, * --------- ----- -- -------- ------ ------- A data item of the form *n where n is an unsigned integer indicates that the next n items in that record are identical to the corresponding n items in the preceeding record. An isolated * is treated as *1. Double asterisks (**) indicate that the remaining items in the previous record are to be copied into the current record. Repeating an item in the current record - *=n *=n+step --------- -- ---- -- --- ------- ------ --- -------- An item of the form *=n, where n is an unsigned integer, indicates that the next n items are identical to the immediately preceding item. An item of the form *=n+step or *=n-step where step is an unsigned real or integer, indicates that the next n items are to be generated by consecutively incrementing the immediately preceding item. 1 INPUT FORMAT ------ ------ Generating multiple records - *+n ---------- -------- ------- --- A record beginning with *+n where n is an unsigned integer indicates that the next n records are to be generated from the preceding record. Each item of the generated record is formed by adding an item of the *+n record to the corresponding item of the immediately preceding input or generated record. A zero (integer) item should be inserted in an *+n record for text items in the preceding record. The number of items after the *+n must match the number in the preceding record. 1 INPUT FORMAT ------ ------ Note on generating items ---- -- ---------- ----- When increments are specified, either on the *+n record or as step on an *=n+step item they must match the item they are incrementing in type. It should be noted that the *+n record generation option is based on the expanded representation of the previous record. The generation does not operate on the card image of the preceding record if it contains data generation items. Therefore, it is not possible to repeat or increment an asterisk-type item. 1 INPUT FORMAT ------ ------ Examples -------- Consider the following seven input records to illustrate the data generation features. 1 2 3 4 5 6 7 8 9 10 11 12 2 1 *2 4 *=2 1 *=2+2 ** *+1 0 *=3 0 *=5 ** *+1 0 *=11 *+1 *12 *+1 ** ** Twelve data items are defined by each of these records. Each of the last six records is translated into the same internal record which is: 2 1 3 4 4 4 4 1 3 5 11 12 Note - the last five records could be replaced by the single record: *+5 ** 1 INPUT FORMAT ------ ------ Changing special characters -------- ------- ---------- It is possible to change the special characters LXLREC uses to break apart records. These special characters may either be changed to another character or set to null so that they are ignored. This is useful for reading specially formatted files or to allow special characters to be input as text items. to change special characters enter the following special comment as the only entry on a line between records. *(set keyword=newvalue) where keyword can be DOLLAR SEMI QUOTES BLANK PLUS COMMA 1 INPUT FORMAT ------ ------ and newvalue is either the word null or the new special character. For example, if one wanted to use dollars to delimit items rather than records and to not have commas delimit items, the following two lines could be entered. *(SET DOLLAR=NULL) *(SET COMMA=$) Note that commas could now be used in unquoted text strings and dollars could now be included in quoted text strings. Also, note that it is really the function that is being altered, not the character. Changing plus only changes the line continuation character, not the representation of real numbers. To restore the original condition after the above example, the following could be entered. 1 INPUT FORMAT ------ ------ *(SET DOLLAR=$) *(SET COMMA=, ) Warning - using the same character for multiple functions will produce undefined results...(undefined means even the author wouldn't want to guess what will happen). Echo ---- LXLREC will echo the input line as the default. Either the user or the calling program can switch echo on or off. The user accomplishes this by entering *(SET ECHO=ON) or *(SET ECHO=OFF) in the same manner as setting special characters. ENDC SYN SYNTAX Input Format, Data Generation and Syntax ------ ------ ---- ---------- --- ------ RIM is used by entering commands in response to input prompts. The input prompts vary with RIM submodule used. The commands always begin with a RIM keyword and may contain adiitional keywords and other text and numerical items. Keywords are described using capital letters. Three of the commands (DEFINE, HELP and LOAD) are used to enter submodules which have their own set of commands and prompts for defining a data base, for providing on-line help to the interactive user and for loading a data base. In describing commands, the following conventions are used: 1 Input Format, Data Generation and Syntax ------ ------ ---- ---------- --- ------ relname or name of a relation(s) relname1, relname2, ... attname or name of an attribute(s) attname1, attname2, ... value actual value(s) or (value may be a text string, value1, value2, ... scalar, vector or matrix) All relation and attribute names must contain at least 1 and no more than 8 alphanumeric characters. 1 Input Format, Data Generation and Syntax ------ ------ ---- ---------- --- ------ Many of the RIM commands have optional parts. These optional parts are enclosed in square brackets. [THIS IS OPTIONAL] Sometimes, a keyword is selected from a list of acceptable keywords. In this case the acceptable keywords are listed vertically with the first choice enclosed in brackets. {CHOOSE} ONE OF THESE RIM command keywords may be abbreviated. At least the first 3 characters in a keyword are required. 1 Input Format, Data Generation and Syntax ------ ------ ---- ---------- --- ------ The following 3 set of keywords are equivalent: 1) SELECT, FROM, WHERE DELETE DUPLICATES 2) SELEC FRO WHER DELET DUPL 3) SEL, FRO WHE, DEL DUP Commands in RIM are entered in a free-field format with blanks and commas as separators. RIM also provides powerful data repetition and data generation facilities. The following provides a short and non complete description of RIM conventions and data generation facilities. A more extensive description, intended for the more experienced RIM user, is contained in section INPUT FORMAT. 1 Input Format, Data Generation and Syntax ------ ------ ---- ---------- --- ------ Keywords and data values are separated by blanks and commas. If a command is too long for one 80 character line, it may be continued on succeeding line(s) by entering "+" as the last character on the line(s). RIM remembers the previous command. This enables you to re-use all or part of the previous command. This is done by using an asterisk to indicate which items of the previous command are to be re-used. A single asterisk means re-use thee corrosponding single item of th previous record. An asterisk followed by a number n means re-use the next n corresponding items. Two asterisks mean re-use all remaining corresponding items. 1 Input Format, Data Generation and Syntax ------ ------ ---- ---------- --- ------ ------ ------ ---- ---------- --- ------ The following are all equivalent: 1) THIS IS A COMMOND 2) THIS + IS+ A + COMMAND 3) * IS, A COMMAND 4) THIS *2 COMMAND 5) THIS ** 1 Input Format, Data Generation and Syntax ------ ------ ---- ---------- --- ------ Multiple commands may be entered on one line separated by a semicolon or a dollar sign . THIS IS FIRST ; THIS IS SECOND $ THIS IS THIRD Comments may be placed anywhere within a command by enclosing the comment between the characters *( and ). *(THIS IS A COMMENT) THIS IS NOT When numeric data is to be interpreted as text (alphanumeric) data, the numerals must be enclosed by quotation marks. "1234" 1 Input Format, Data Generation and Syntax ------ ------ ---- ---------- --- ------ When entering text strings which contain embedded blanks or commas, the entire string must be enclosed by quotation marks. "THIS IS A TEXT STRING" A text string may require continuation on additional line(s). The + sign convention can then be used within the quotation marks. "THIS IS+ A TEXT + STRING" It recommended as good practice not to use leading blanks in text strings. (The precise number of leading blanks in a string must be used when it is referenced) "THIS IS GOOD PRACTICE" " THIS IS NOT" 1 Input Format, Data Generation and Syntax ------ ------ ---- ---------- --- ------ Integer data are input as a string of digits without a decimal point. A sign may precede the digits 123 , -63, +56, 0 Real (floating point) numbers must include a decimal point or E for exponent. If a decimal point is not precent the E must be preceded by an integer. 1.3, .005, 0., 6.E-1, 6E-1, 0.60, -23.45 The absolute value of real number is limited to the range 1.0E-38 to 1.0e+38 ENDC SUM SUMMARY SUMMARY -------- DEFINING A DATABASE SCHEMA DEFINE dbname OWNER password ATTRIBUTES attname {REAL} [{length}] [KEY] INT VAR TEXT DOUB RVEC IVEC DVEC attname {RMAT} {row, col} [KEY] IMAT row, VAR DMAT VAR, VAR 1 SUMMARY -------- RELATIONS relname WITH attname1 [attname2 ... attnameN] PASSWORDS {READ PASSWORD} FOR {relname} IS PASSWORD RPW ALL {MODIFY PASSWORD} FOR {relname} IS PASSWORD MPW ALL RULES attname [IN relname] {EQ} value [{AND} ...] NE OR GT GE LT LE attname IN relname {EQA} attname IN relname [{AND} ... NEA OR GTA GEA LTA LEA END 1 SUMMARY -------- LOADING A RELATION LOAD relname value1 value2 ... valueN END value : SCALARS val1 TEXT "text string" VECTOR (val1, val2, ...) MATRIX ((r1c1, r2c1, ...), (r1c2, r2c2, ...), ...) 1 SUMMARY -------- QUERYING A RELATION SELECT {attname1 [=fld1], attname2 [=fld2], ...} FROM relname + attnum1 [=fld1], ... attname1(i), ... attname1(i, j), ... ALL [SORTED BY attname1 [={A}], [attname2 [={A}], ...]] + D D [WHERE ...] TALLY attname [={A}] FROM relname [WHERE ...] D 1 SUMMARY -------- WHERE CLAUSE : WHERE attname {EXISTS} [{AND} ...] FAILS OR EQ {value} EQS MAX NE MIN GT LT LE WHERE attname {EQA} attname [{AND} ...] NEA OR GTA GEA LTA LEA WHERE ROWS {EQ} rownumber [{AND} ...] NE OR LT LE GE GT 1 SUMMARY -------- WHERE {attname} {EQ} list [{AND} ...] ROWS NE OR WHERE LIMIT EQ number [{AND} ...] COMPUTATION COMMANDS COMPUTE {COUNT} attname FROM relname [WHERE ...] MIN MAX AVE SUM 1 SUMMARY -------- MODIFICATION COMMANDS CHANGE {attname} TO value [IN relname] WHERE ... attname(i) attname(i, j) CHANGE {RPW} TO newpass FOR relname MPW CHANGE OWNER TO newowner DELETE ROWS FROM relname WHERE ... DELETE DUPLICATES [attname1, attname2, ...] FROM relname DELETE RULE rulenumber RENAME ATTRIBUTE attname TO newname [IN relname] RENAME RELATION relname TO newname REMOVE relname 1 SUMMARY -------- RELATIONAL ALGEBRA COMMANDS INTERSECT relname1 WITH relname2 FORMING relname3 + [USING attname1 [attname2, ...]] JOIN relname1 USING attname1 WITH relname2 USING attname2 + FORMING relname3 [WHERE {EQ}] NE GT GE LT LE SUBTRACT relname1 FROM relname2 FORMING relname3 + [USING attname1 [attname2, ...]] PROJECT relname1 FROM relname2 USING + {attname1, [attname2, ...]} [WHERE ...] ALL 1 SUMMARY -------- QUERYING THE SCHEMA LISTREL [relname] ALL EXHIBIT attname [attname ...] PRINT RULES REPORT COMMANDS NEWPAGE BLANK n TITLE "title" DATE LINES n WIDTH n KEY COMMANDS BUILD KEY FOR attname IN relname DELETE KEY FOR attname IN relname 1 SUMMARY -------- RIM-TO-RIM COMMANDS UNLOAD [dbname [=newdbname]] {SCHEMA} [relname1 [=mpw] + DATA ALL [relname2 [=mpw], ...] MISCELLANEOUS COMMANDS OPEN dbname CLOSE INPUT {filename} TERMINAL OUTPUT {filename} TERMINAL EXIT QUIT MENU 1 SUMMARY -------- HELP [command name] USER password ECHO NOECHO CHECK NOCHECK TOLERANCE xx.xx [PERCENT] RELOAD ENDC NWS NEWS NEWS ----- November 24,1981 -- UD20 -- was implemented. UD20 traps bad user data and corrects several errors as follows: 1 correct error message in data loading 2 print error message if zero length attribute 3 correct several errors in RELOAD 4 trap bad pointers for var length attributes in appl interface 5 correct bad pointer increment by RMDEL 6 correct sort problem with already sorted data 7 correct rules problem in UNLOAD 8 trap use of list for other than EQ,NE and EQS 9 correct problem with rules not recognizing keyword ATTR 10 trap rule checking for non-scalars and text 11 correct the trapping of more than 10 rules per relation 12 remove message DB FILES ARE LOCAL for a define 13 correct UNLOAD problem with vectors etc. 14 put trap in PROJECT to assure that only valid attributes are used UD20 makes the following enhancement: 1 add EQS list to SELECT WHERE clause 1 NEWS ----- December 3,1981 -- UD21 -- was implemented. UD21 corrects several errors as follows: 1 put blank line from ECHO on proper file 2 trap case when RULES section entered w/o defining constraints 3 trap error in RULES when attribute name is a RIM keyword 4 correct B-tree error during appl prog load when KEYs defined 5 deactivate UNLOAD of RULES until UNLOAD can be reworked UD21 makes the following code enhancement: 1 make code more portable by softcoding file unit numbers ENDC RIM RIM RIM ---- RIM is a relational data base management system. RIM commands allow you to define, load, query and modify a data base. RIM supports the following commands: BLANK BUILD KEY CHANGE CLOSE COMPUTE DATE DEFINE DELETE KEY DELETE ECHO EXHIBIT EXIT INPUT INTERSECT JOIN LISTREL LOAD NEWPAGE NOECHO OPEN OUTPUT PRINT PROJECT QUIT RELOAD REMOVE RENAME SELECT SUBTRACT TALLY TITLE USER The DEFINE command and the LOAD command are used to enter submodules where commands known only to those submodules are processed. 1 RIM ---- The DEFINE submodule supports the following commands: DEFINE ELEMENTS RELATIONS PASSWORDS RPW (READ PASSWORD) MPW (MODIFY PASSWORD) RULES END The LOAD submodule supports the following commands: LOAD CHECK NOCHECK END 1 RIM ---- For a description of the general command syntax used by RIM enter SYNTAX. For a summary of the syntax for the current RIM command enter SUMMARY. For a description of the RIM WHERE clauses enter WHERE. ENDC MEN MENU MENU Command ----- ------- The MENU command places the user in menu mode. It may be entered at any point when in command mode except when in the DEFINE or LOAD modules. Menu mode is particulary useful for schema definition and data loading. ENDC UNL UNLOAD UNLOAD Command ------- ------- The UNLOAD command permits you to off-load a portion or all of your dOata base onto a previously designated file (see OUTPUT command). The file will contain 80 character text records and will be readable by RIM on the same or on a different computer using the INPUT command. Default file name is OUTPUT. The syntax of this command is: UNLOAD [ dbname = newname ] (ALL ) + SCHEMA DATA [ relname1 [ = mpw1 ] relname2 [ = mpw2 ] ...] The mandatory part offers a choice between ALL, DATA and SCHEMA. Specifying SCHEMA will off-load the schema of your data base, DATA will off-load the data of your data base and ALL will off-load both schema and data. 1 UNLOAD Command ------- ------- Optionally you may rename your data base by entering dbname = newname where dbname is the name of the currently open data base. By specifying relation names, you will only off-load data and/or schemas for the specific relations. The password associated with a relation name must be specified if your current user password does not allow you modify access to the relation. There are implicit password restrictions to the unload command as follows: If you are the data base owner, you may off-load any data and/or schema. If you are not the owner, you may off-load data and or schema for the relations for which you have modify access permission. Your password becomes the owner of the off-loaded data base. Rules, if any, will only be off-loaded if you are the owner of the data base and you have used the option ALL. h ENDD -h- htoi.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]HTOI.FOR;1 SUBROUTINE HTOI(I,J,K) INCLUDE '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 -h- iexp.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]IEXP.FOR;1 INTEGER FUNCTION IEXP(REAL) INCLUDE '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 -h- ifrt.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]IFRT.FOR;1 FUNCTION IFRT(WORD) INCLUDE '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 BYTE 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 -h- incore.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]INCORE.BLK;1 C C *** / I N C O R E / *** C C CONTROL VARIABLES FOR INCORE BUFFER MANAGEMENT C COMMON /INCORE/ BLOCKS(3,20),NEXT,LIMIT,NUMBL INTEGER BLOCKS C C VARIABLE DEFINITIONS: C BLOCKS--ARRAY WITH POINTERS AND DIMENSIONS OF INCORE BLOCKS C ROW 1---STARTING POSITION C ROW 2---NUMBER OF ROWS C ROW 3---NUMBER OF COLUMNS C NEXT----NEXT AVAILABLE ADDRESS IN THE BUFFER C LIMIT---LAST WORD IN THE BUFFER C NUMBL---NUMBER OF BLOCKS DEFINED C -h- install.com Mon Dec 02 10:17:26 1985 DF1:[DBMS]INSTALL.COM;1 $ ! RIM INSTALLATION PROCEDURE FOR THE VAX $ ! $ ! THE VAX VERSION OF RIM WAS CONVERTED BY: $ ! WAYNE J. ERICKSON $ ! DATA MANAGEMENT CONSULTANT $ ! 2029 5TH ST SE $ ! PUYALLUP, WASH 98371 $ ! (206) 848-5619 OR 543-2081 $ ! $ SET VERIFY $ ! COMPILE ALL THE ROUTINES $ ! @MAKERIM $ ! $ ! NOW LOAD THE SYSTEM $ ! @LOADT $ ! $ ! NOW BUILD THE HELP DATABASE $ ! @HELP $ ! $ ! NOW RUN THE VERIFICATION TESTS $ ! @VERIFY $ ! $ ! THIS COMPLETES INSTALLATION OF RIM $ ! $ ! THIS INSTALLATION WILL INSTALL RIM AND THE $ ! RIM PROGRAM INTERFACE LIBRARY ON A DIRECTORY $ ! ON YOUR SYSTEM. TO MAKE RIM ACCESSIBLE TO ALL $ ! USERS ON YOUR SYSTEM YOU WILL PROBABLY WANT $ ! TO DEFINE "RIM" AS A SYMBOL IN YOUR SYSTEM $ ! LOGIN COMMAND PROCEDURE. HERE IS AN EXAMPLE $ ! OF WHAT YOU MIGHT WANT TO SET UP. $ ! $ ! RIM :== RUN DB1:[RIM]RIM.EXE $ ! ASSIGN DB1:[RIM]HELPDB1.DAT HELPDB1 $ ! ASSIGN DB1:[RIM]HELPDB2.DAT HELPDB2 $ ! ASSIGN DB1:[RIM]HELPDB3.DAT HELPDB3 $ ! $ ! FOR USERS WHO WANT TO USE THE PROGRAM INTERFACE $ ! LIBRARY YOU WILL WANT TO DEFINE THE SYMBOL "RIMLIB" $ ! IN A MANNER SIMILAR TO THE FOLLOWING: $ ! $ ! RIMLIB :== DB1:[RIM]RIMLIB.OLB $ ! $ ! FOR INSTALLATIONS WHICH HAVE BEEN USING VERSION 4 $ ! OF RIM THE PROGRAM RIM4TO5 CAN BE USED TO CONVERT $ ! A VERSION 4 DATABASE TO VERSION 5. THE RIM4TO5 $ ! PROGRAM MUST BE COMPILED AND LINKED WITH YOUR $ ! CURRENT VERSION 4 INTERFACE LIBRARY. WHEN YOU RUN $ ! RIM4TO5 IT WILL ASK YOU FOR THE NAME OF YOUR $ ! VERSION 4 DATABASE. IT WILL CREATE A FILE CALLED $ ! RIM4TO5.DAT WHICH CAN BE USED AS A COMMAND FILE $ ! IN VERSION 5 OF RIM TO RECREATE YOUR DATABASE. $ ! SINCE THE NAMES OF THE DATABASE FILES ARE THE $ ! SAME FOR BOTH VERSIONS BE SURE TO DELETE THE $ ! VERSION 4 DATABASES BEFORE YOU USE RIM4TO5.DAT $ ! TO CREATE THE VERSION 5 DATABASES. $ ! $ ! IF YOU HAVE ANY PROBLEMS WITH YOUR RIM INSTALLATION $ ! PLEASE CONTACT : $ ! $ ! EUGENE MCKENNA $ ! PHONE 206-237-9186 $ ! $ ! OR $ ! $ ! DON TAYLOR $ ! PHONE 206-237-2389 $ ! $ SET NOVERIFY -h- intcon.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]INTCON.FOR;1 SUBROUTINE INTCON(INTOPT) INCLUDE '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 'RMATTS.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'FILES.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'MISC.BLK' C INTEGER DBSTAT LOGICAL EQKEYW INCLUDE '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 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,/) 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 WRITE(NOUT,8001) GO TO 100 C C REQUEST THE DATABASE NAME - NAMDB C 120 WRITE(NOUT,130) 130 FORMAT(/,1X,30HENTER 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 WRITE(NOUT,8002) GO TO 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 WRITE(NOUT,170) 170 FORMAT(/,1X,41HDO 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 WRITE(NOUT,8004) GO TO 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 WRITE(NOUT,230) 230 FORMAT(/,1X,32HSELECT THE UPDATE OPTION DESIRED,/ 1 5X,30H1) DEFINE ADDITIONAL RELATIONS,/ 2 5X,23H2) LOAD ADDITIONAL DATA,/) 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 WRITE(NOUT,8003) GO TO 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 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,/) 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 WRITE(NOUT,8004) GO TO 270 C C QUERY C 300 CONTINUE WRITE(NOUT,310) 310 FORMAT(/,1X,16HRIM COMMAND MODE,/) INTOPT = K4QUE GO TO 999 C C COMMAND MODE C 400 CONTINUE INTOPT = K4COM WRITE(NOUT,310) GO TO 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, 1 /) 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 -h- intdef.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]INTDEF.FOR;1 SUBROUTINE INTDEF(NAMDB,INTOPT) INCLUDE '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 'RMATTS.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'FILES.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'RELTBL.BLK' INCLUDE '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 'DCLAR1.BLK' INCLUDE 'DCLAR2.BLK' INCLUDE 'DCLAR3.BLK' INCLUDE '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 = 2 C C REQUEST THE DATABASE OWNER - NAMOWN C 100 WRITE(NOUT,110) 110 FORMAT(/,1X,36HENTER 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 WRITE(NOUT,8002) GO TO 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 WRITE(NOUT,8028) GO TO 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 WRITE(NOUT,8020) IRCD = 25 GO TO 830 C C REQUEST THE RELATION NAME - IREL(IRCD,1) WHERE C IRCD IS THE COUNT OF RELATIONS C 320 WRITE(NOUT,330) 330 FORMAT(/,1X,40HENTER 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 WRITE(NOUT,8006) GO TO 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 WRITE(NOUT,8029) RNAME GO TO 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 WRITE(NOUT,8029) RNAME GO TO 320 370 CONTINUE 380 CONTINUE C C REQUEST THE RELATION PASSWORDS C 390 WRITE(NOUT,400) 400 FORMAT(/,1X,41HENTER THE READ PASSWORD FOR THIS RELATION,/) 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 WRITE(NOUT,8017) GO TO 390 410 RPW1 = BLANK CALL LXSREC(1,1,8,RPW1,1) 420 WRITE(NOUT,430) 430 FORMAT(/,1X,43HENTER THE MODIFY PASSWORD FOR THIS RELATION,/) 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 WRITE(NOUT,8017) GO TO 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 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),/) 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 WRITE(NOUT,8007) GO TO 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 WRITE(NOUT,8008) GO TO 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 WRITE(NOUT,8009) GO TO 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 WRITE(NOUT,8018) GO TO 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 WRITE(NOUT,8021) 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(LEN1.NE.ATTCHA) WRITE(NOUT,8015) ATTCHA IF(LEN2.NE.ATTWDS) WRITE(NOUT,8015) ATTWDS C C CHECK KEY C LEN = K4KEY IF(ATTKEY.EQ.0) LEN = IBLANK IF(KEY.NE.LEN) WRITE(NOUT,8019) IXREC1 GO TO 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(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 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 WRITE(NOUT,8022) IATC = 100 GO TO 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 WRITE(NOUT,8031) IREL(IRCD,1) 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 WRITE(NOUT,820) 820 FORMAT(/,1X,45HDO YOU HAVE ADDITIONAL RELATIONS TO DEFINE - , 1 6HY OR N,/) 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 WRITE(NOUT,8010) GO TO 810 C C DEFINE THE RIM SCHEMA SOURCE FILE C C WRITE THE DATABASE NAME AND OWNER C 830 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 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 WRITE(NOUT,8027) NAMDB GO TO 998 1120 IF(NAMOWN.EQ.OWNER) GO TO 999 WRITE(NOUT,8030) GO TO 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),/,9X,17HREENTER LAST LINE,/) 8008 FORMAT(/,1X,43H-ERROR- ATTRIBUTE TYPES MUST BE ONE OF THE , 1 12HFOLLOWING --,/,9X,21HINT,REAL,TEXT,DOUBLE,, 2 32HIVEC,RVEC,DVEC,IMAT,RMAT OR DMAT,/, 3 9X,17HREENTER LAST LINE,/) 8009 FORMAT(/,1X,44H-ERROR- THE NUMBER OF WORDS IN AN ATTRIBUTE , 1 41HMUST BE A POSITIVE INTEGER LESS THAN 1023,/, 2 9X,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,/,9X,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,35H-ERROR- UNAUTHORIZED ACCESS TO THE , 1 15HDATABASE SCHEMA,/,/,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 -h- intlod.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]INTLOD.FOR;1 SUBROUTINE INTLOD(INTOPT) INCLUDE 'TEXT.BLK' INCLUDE 'FILES.BLK' INCLUDE 'RMATTS.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'CONST8.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'MISC.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'DCLAR1.BLK' INCLUDE '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 WRITE(NOUT,20) 20 FORMAT(/,50H 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 WRITE(NOUT,8004) GO TO 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 WRITE(NOUT,100) 100 FORMAT(32H -WARNING- RELATION TABLES EMPTY ,/) INTOPT = K4EXIT GO TO 999 C C DISPLAY AVAILABLE RELATIONS C 200 CONTINUE WRITE(NOUT,210) 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 WRITE(NOUT,230) K,NAME 230 FORMAT(4X,I2,2H) ,A8) GO TO 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 WRITE(NOUT,8001) K GO TO 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 WRITE(NOUT,310) 310 FORMAT(/,44H ENTER THE MODIFY PASSWORD FOR THIS RELATION,/) 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 WRITE(NOUT,8002) GO TO 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 WRITE(NOUT,8003) NAME GO TO 10 C C GET THE ATTRIBUTES FOR THIS RELATION C 355 CONTINUE USERID = MPW1 360 CONTINUE I = LOCATT(BLANK,NAME) WRITE(NOUT,370) 370 FORMAT(/,44H ENTER THE ATTRIBUTE VALUES IN THE SPECIFIED, X 9H SEQUENCE,/,24H ENTER END WHEN COMPLETE,/) 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 WRITE(NOUT,410) (NAMES(J),J=1,7) 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 WRITE(NOUT,460) (NAMES(J),J=1,NUM) 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 -h- iscan.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]ISCAN.FOR;1 INTEGER FUNCTION ISCAN(STR1,IC1,LC1,STR2,IC2,LC2,J1) INCLUDE '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 BYTE STR1(*) BYTE 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 -h- isect.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]ISECT.FOR;1 SUBROUTINE ISECT(RNAME1,RNAME3,MATN3,NCOL3,NATT3,PTABLE, XKEYCOL,KEYTYP) INCLUDE '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 'MISC.BLK' INCLUDE 'RMATTS.BLK' INCLUDE 'FILES.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'WHCOM.BLK' INCLUDE '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 WRITE(NOUT,960) MAXCOL 960 FORMAT(36H -ERROR- RELATION ROW LENGTH EXCEEDS,I5) 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.EQ.0) WRITE(NOUT,9000) NUM 9000 FORMAT(32H SUCCESSFUL INTERSECT OPERATION , XI6,15H ROWS GENERATED) C C RETURN C RETURN END -h- isrel.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]ISREL.FOR;1 SUBROUTINE ISREL INCLUDE '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 'RMATTS.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'FILES.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'MISC.BLK' C INTEGER PTABLE LOGICAL EQ LOGICAL NE LOGICAL EQKEYW INCLUDE 'DCLAR1.BLK' INCLUDE '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 WRITE(NOUT,9000) 9000 FORMAT(55H -ERROR- RESULTANT RELATION DOES NOT HAVE A UNIQUE NAME) GO TO 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 WRITE(NOUT,9001) 9001 FORMAT(38H -ERROR- TOO MANY ATTRIBUTES SPECIFIED) GO TO 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 WRITE(NOUT,9002) ANAME 9002 FORMAT(9H -ERROR- ,A8,33H IS NOT COMMON TO EITHER RELATION) GO TO 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 WRITE(NOUT,9003) RNAME1,RNAME2 9003 FORMAT(19H -ERROR- RELATIONS ,A8,5H AND ,A8, X26H HAVE NO COMMON ATTRIBUTES) GO TO 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 WRITE(NOUT,9810) MAXCOL 9810 FORMAT(36H -ERROR- RELATION ROW LENGTH EXCEEDS,I5) GO TO 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 -h- itoc.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]ITOC.FOR;1 SUBROUTINE ITOC(STRING,CHAR1,NUMC,INT,IERR) INCLUDE '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 'CONST4.BLK' INCLUDE '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 -h- itoh.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]ITOH.FOR;1 SUBROUTINE ITOH(I,J,K) INCLUDE '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 -h- join.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]JOIN.FOR;1 SUBROUTINE JOIN(RNAME1,RNAME3,MATN3,NCOL3,NATT3,PTABLE, XKEYCOL,KEYTYP) INCLUDE '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 'MISC.BLK' INCLUDE 'FILES.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'WHCOM.BLK' INCLUDE '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.LT.100) WRITE (NOUT,103)ICROW 103 FORMAT(15H -WARNING- ROW ,I6, X 35H IGNORED BECAUSE ATTRIBUTE TOO LONG) GO TO 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 WRITE(NOUT,960) MAXCOL 960 FORMAT(36H -ERROR- RELATION ROW LENGTH EXCEEDS,I5) 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.EQ.0) WRITE(NOUT,9000) NUM 9000 FORMAT(27H SUCCESSFUL JOIN OPERATION , XI6,15H ROWS GENERATED) C C RETURN C RETURN END -h- joirel.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]JOIREL.FOR;1 SUBROUTINE JOIREL INCLUDE '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 'RMATTS.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'FILES.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'MISC.BLK' C INTEGER PTABLE LOGICAL EQ LOGICAL NE LOGICAL EQKEYW INCLUDE 'DCLAR1.BLK' INCLUDE '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 WRITE(NOUT,9000) 9000 FORMAT(55H -ERROR- RESULTANT RELATION DOES NOT HAVE A UNIQUE NAME) GO TO 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 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 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 WRITE(NOUT,9006) 9006 FORMAT(46H -ERROR- JOIN ATTRIBUTES ARE DIFFERENT LENGTHS ) GO TO 9999 9800 CONTINUE WRITE(NOUT,9005) 9005 FORMAT(44H -ERROR- JOIN ATTRIBUTES ARE DIFFERENT TYPES) GO TO 9999 C C TUPLE LENGTH EXCEEDS MAXCOL C 9850 CONTINUE WRITE(NOUT,9860) MAXCOL 9860 FORMAT(36H -ERROR- RELATION ROW LENGTH EXCEEDS,I5) GO TO 9999 9870 CONTINUE WRITE (NOUT,9880) 9880 FORMAT(32H -ERROR- JOIN ATTRIBUTE TOO LONG ) GO TO 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 -h- keydat.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]KEYDAT.BLK;1 C C *** / K E Y D A T / *** C C KEY ATTRIBUTE DATA FOR THE FORTRAN INTERFACE C COMMON /KEYDAT/ NUMKEY,KEYDAT(6,5) INTEGER NUMKEY INTEGER KEYDAT C C VARIABLE DEFINITIONS: C NUMKEY--NUMBER OF KEY ATTRIBUTES (CURRENT RELATION) C KEYDAT--ARRAY OF KEY ATTRIBUTE DATA C ROW 1 - ATTKEY VALUES C ROW 2 - ATTCOL VALUES C ROW 3 - ATTWDS VALUES C ROW 4 - ATTYPE VALUES C ROW 5 - ATTNAM VALUES C -h- kmpard.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]KMPARD.FOR;1 SUBROUTINE KMPARD(VALUE1,VALUE2,LEN,NK,OK) INCLUDE '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 '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 -h- kmpari.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]KMPARI.FOR;1 SUBROUTINE KMPARI(VALUE1,VALUE2,LEN,NK,OK) INCLUDE '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 -h- kmparr.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]KMPARR.FOR;1 SUBROUTINE KMPARR(VALUE1,VALUE2,LEN,NK,OK) INCLUDE '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 '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 -h- kmpart.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]KMPART.FOR;1 SUBROUTINE KMPART(VALUE1,VALUE2,LEN,NK,OK) INCLUDE '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 -h- kompxx.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]KOMPXX.FOR;1 SUBROUTINE KOMPXX(VALUE1,VALUE2,LEN,NK,OK,TYPE) INCLUDE '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 'RMATTS.BLK' INCLUDE '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 -h- lfind.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LFIND.FOR;1 INTEGER FUNCTION LFIND(ITEM1,NUM,KEY,NCHAR) INCLUDE '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 -h- loadit.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LOADIT.FOR;1 SUBROUTINE LOADIT(MAT) INCLUDE '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 'CONST4.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'FILES.BLK' INCLUDE 'RULCOM.BLK' INCLUDE 'START.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'MISC.BLK' INCLUDE '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 WRITE(NOUT,1010) 1010 FORMAT(53H -ERROR- THE DATA FAILS TO SATISFY THE FOLLOWING RULE,/) ISNOUT = NOUTR NOUTR = NOUT CALL PRULE(ISTAT) NOUTR = ISNOUT GO TO 100 1050 CONTINUE ISTAT = -ISTAT WRITE(NOUT,1060) ISTAT 1060 FORMAT(32H -ERROR- UNABLE TO PROCESS RULE ,I4) GO TO 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 WRITE(NOUT,9004) 9004 FORMAT(34H -ERROR- ATTRIBUTE TABLE TOO SHORT) GO TO 100 2400 CONTINUE C C TOO MANY ITEMS C WRITE (NOUT,2450) 2450 FORMAT(33H -ERROR- TOO MANY ITEMS ON RECORD ) GO TO 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 -h- loadt.com Mon Dec 02 10:17:26 1985 DF1:[DBMS]LOADT.COM;1 $ LINK RMMAIN,RIMLIB/LIB $ RENAME RMMAIN.EXE RIM.EXE $ SET PROT=(W:RE,G:RE) RIM.EXE -h- locatt.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LOCATT.FOR;1 FUNCTION LOCATT(ANAME,RNAME) INCLUDE '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 'ATTBLE.BLK' INCLUDE 'START.BLK' INCLUDE 'MISC.BLK' LOGICAL EQ LOGICAL NE INCLUDE 'DCLAR1.BLK' INCLUDE '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 -h- locboo.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LOCBOO.FOR;1 FUNCTION LOCBOO(KOMPAR) INCLUDE '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 'CONST4.BLK' INCLUDE '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 -h- locprm.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LOCPRM.FOR;1 FUNCTION LOCPRM(RNAME,JCODE) INCLUDE '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 'FLAGS.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'MISC.BLK' LOGICAL EQ INCLUDE '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 -h- locrel.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LOCREL.FOR;1 FUNCTION LOCREL(RNAME) INCLUDE '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 'RELTBL.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'MISC.BLK' INCLUDE 'RIMPTR.BLK' LOGICAL EQ INCLUDE 'DCLAR1.BLK' INCLUDE '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 -h- lodele.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LODELE.FOR;1 SUBROUTINE LODELE(NUMELE,ERROR) INCLUDE '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 'RMATTS.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'FILES.BLK' INCLUDE 'MISC.BLK' INCLUDE '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 WRITE(NOUT,9000) 9000 FORMAT(36H -ERROR- ILLEGAL DATA TYPE SPECIFIED) ERROR = ERROR + 1 GO TO 100 300 CONTINUE C C MAKE SURE THAT THE ATTRIBUTE NAME IS TEXT. C IF(LXID(1).EQ.KZTEXT) GO TO 400 WRITE(NOUT,9001) 9001 FORMAT(37H -ERROR- ATTRIBUTE NAMES MUST BE TEXT) ERROR = ERROR + 1 GO TO 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 WRITE(NOUT,9002) MAXCOL 9002 FORMAT(42H -ERROR- LENGTH MUST BE A POSITIVE INTEGER, X 18H IN THE RANGE 1 TO,I5) 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 WRITE(NOUT,9002) MAXCOL ERROR = ERROR + 1 GO TO 100 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 WRITE(NOUT,9003) 9003 FORMAT(56H -ERROR- MATRIX DATA TYPE REQUIRED WITH ROWS AND COLUMNS X) ERROR = ERROR + 1 GO TO 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 -h- lodpas.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LODPAS.FOR;1 SUBROUTINE LODPAS(ERROR) INCLUDE '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 'TUPLER.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'FILES.BLK' INCLUDE 'MISC.BLK' INTEGER ERROR LOGICAL EQKEYW INCLUDE 'DCLAR1.BLK' INCLUDE '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 WRITE(NOUT,550) 550 FORMAT(44H -ERROR- PASSWORDS MUST BE 1-8 ALPHANUMERIC , X 10HCHARACTERS) 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 -h- lodrec.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LODREC.FOR;1 SUBROUTINE LODREC INCLUDE 'TEXT.BLK' C C COVER ROUTINE FOR LXLREC WHICH HANDLES END-OF-FILES. C INCLUDE 'LXGEN.BLK' INCLUDE 'RMATTS.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'CONST8.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'FILES.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'MISC.BLK' LOGICAL EQKEYW INCLUDE 'DCLAR4.BLK' IF(RMSTAT.GT.1000) GO TO 800 NUMEOF = 0 IF(ECHO.AND.(NUMREP.EQ.0)) WRITE(NOUTR,10) 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 WRITE(NOUT,810) RMSTAT 810 FORMAT(/,13H SYSTEM ERROR,I5,/) GO TO 900 820 CONTINUE C C TOO MANY END-OF-FILES ENCOUNTERED C WRITE (NOUT,830) 830 FORMAT(45H -WARNING- END-OF-FILE ENCOUNTERED ON "INPUT",/, X 11X,28HTHE DATABASE FILES ARE LOCAL,/) GO TO 900 900 CONTINUE CALL RMCLOS 999 CONTINUE STOP 1000 CONTINUE RETURN END -h- lodrel.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LODREL.FOR;1 SUBROUTINE LODREL(NUMELE,ERROR) INCLUDE '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 'RMATTS.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'FILES.BLK' INCLUDE 'MISC.BLK' C LOGICAL EQKEYW INTEGER ERROR INCLUDE '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 WRITE(NOUT,9000) 9000 FORMAT(36H -ERROR- RELATION NAMES MUST BE TEXT) ERROR = ERROR + 1 GO TO 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 WRITE(NOUT,9001) 9001 FORMAT(44H -ERROR- DUPLICATE RELATION NAME ENCOUNTERED) ERROR = ERROR + 1 GO TO 100 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 -h- lodrul.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LODRUL.FOR;1 SUBROUTINE LODRUL INCLUDE '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 'RMATTS.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'CONST8.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'RULCOM.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'MISC.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'FILES.BLK' INCLUDE '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 WRITE(NOUT,520) 520 FORMAT(43H -ERROR- RULE COMPONENTS MUST APPLY TO THE , X 13HSAME RELATION ) 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 WRITE(NOUT,9000) 9000 FORMAT(41H -ERROR- UNRECOGNIZED BOOLEAN COMPARISION ) 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 WRITE (NOUT,710) 710 FORMAT(51H -ERROR- ATTRIBUTES MUST BE OF THE SAME TYPE/LENGTH) NERROR = 2 GO TO 100 720 CONTINUE WRITE(NOUT,730) 730 FORMAT(48H -ERROR- NON-TEXT ATTRIBUTES MUST BE OF LENGTH 1) 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 WRITE(NOUT,762) 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 WRITE(NOUT,792) 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 WRITE(NOUT,9001) 9001 FORMAT(55H -ERROR- RULES MUST BE JOINED WITH EITHER "AND" OR "OR") NERROR = 2 GO TO 100 900 CONTINUE J = J + 2 GO TO 500 C C SYNTAX ERRORS. C 1000 CONTINUE WRITE(NOUT,9002) 9002 FORMAT(48H -ERROR- RELATION MUST BE SPECIFIED IN THIS RULE) 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 -h- lstrel.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LSTREL.FOR;1 SUBROUTINE LSTREL INCLUDE 'TEXT.BLK' C C THIS ROUTINE SUMMARIZES THE USERS DEFINITION OF A RELATION C C INCLUDE 'RMATTS.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'CONST8.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'MISC.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'FILES.BLK' INTEGER STATUS LOGICAL EQ LOGICAL NE LOGICAL EQKEYW INTEGER IRPW INTEGER IMPW INCLUDE 'DCLAR1.BLK' INCLUDE 'DCLAR6.BLK' ITEMS = LXITEM(DUM) CALL RMDATE(IDAY) CALL RMTIME(ITIME) I = LOCREL(BLANK) NP = 0 IF(I.EQ.0) GO TO 100 WRITE(NOUT,20) 20 FORMAT(32H -WARNING- RELATION TABLES EMPTY ,/) GO TO 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 WRITE(NOUTR,160) IDAY,ITIME 160 FORMAT(10X,25HEXISTING RELATIONS AS OF ,A8,3X,A8/) NP = 1 200 CONTINUE WRITE(NOUTR,220) NAME 220 FORMAT(20X,A8) GO TO 100 900 CONTINUE IF(NP.EQ.0) WRITE(NOUT,1260) GO TO 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 WRITE(NOUT,1260) 1260 FORMAT(40H -ERROR- UNAUTHORIZED ACCESS TO RELATION , X 20H DATA NOT PERMITTED. ) GO TO 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 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,/) C C FIND AND PRINT ATTRIBUTE DESCRIPTIONS C I = LOCATT(BLANK,NAME) IF(I.EQ.0) GO TO 1500 WRITE(NOUT,1400) NAME 1400 FORMAT(20H -WARNING- RELATION ,A8, X 26H HAS NO ATTRIBUTES DEFINED ) GO TO 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(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 1510 CONTINUE IF(ATTYPE.EQ.KZIMAT) GO TO 1520 IF(ATTYPE.EQ.KZRMAT) GO TO 1520 IF(ATTYPE.EQ.KZDMAT) GO TO 1520 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 1520 CONTINUE IF(NWORDS.EQ.0) GO TO 1530 NC = NWORDS / NCHAR WRITE(NOUTR,1504) ATTNAM,ATTYPE,NCHAR,NC,KEY 1504 FORMAT(7X,A8,6X,A4,8X,I4,4H BY ,I4,6X,A3) GO TO 1500 1530 CONTINUE IF(NCHAR.EQ.0) GO TO 1540 WRITE(NOUTR,1505) ATTNAM,ATTYPE,NCHAR,KEY 1505 FORMAT(7X,A8,6X,A4,8X,I4,12H BY VARIABLE,2X,A3) GO TO 1500 1540 CONTINUE WRITE(NOUTR,1506) ATTNAM,ATTYPE,KEY 1506 FORMAT(7X,A8,6X,A4,4X,20HVARIABLE BY VARIABLE,2X,A3) GO TO 1500 C 1600 CONTINUE C C WRITE(NOUTR,1620) NTUPLE 1620 FORMAT(/,10X,25HCURRENT NUMBER OF ROWS = ,I8,/) IF(EQKEYW(2,KWALL,3)) GO TO 1100 GO TO 9999 8000 CONTINUE C C NO RELATIONS DEFINED - ALL SPECIFICATION C WRITE (NOUT,20) GO TO 9999 8100 CONTINUE C C NO RELATIONS PERMITTED - ALL SPECIFICATION C WRITE (NOUT,1260) GO TO 9999 8200 CONTINUE WRITE(NOUT,8210) 8210 FORMAT(35H -ERROR- TOO MANY ITEMS FOR LISTREL ) GO TO 9999 C C ALL DONE. C 9999 RETURN END -h- lstrng.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LSTRNG.FOR;1 INTEGER FUNCTION LSTRNG(STR1,IC1,LC1,STR2,IC2,LC2) INCLUDE '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 BYTE STR1(*) BYTE 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 -h- lxcard.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXCARD.BLK;1 C C THIS COMMON BLOCK CONTAINS INFORMATION NEEDED BY LXLREC FAMILY C OF ROUTINES. C C NEWN.....NUMBER OF ITEMS IN CURRENT RECORD C OLDN.....NUMBER OF ITEMS IN PREVIOUS RECORD C NEWREC...CURRENT TEXT ITEM CHARACTER IMAGE PACKED TOGETHER C OLDREC...SAME AS NEWREC BUT FOR PREVIOUS RECORD. C TYPE.....TYPE OF EACH ITEM 4HTEXT,3HINT,4HREAL C INTVAL...VALUE IF INTEGER TYPE, START POINTER IN NEWREC IF TEXT. C RVAL.....VALUE IF REAL TYPE, NUM. CHARS. IF TEXT TYPE. C NEXT.....NEXT AVAILABLE POITION IN NEWREC C NIN......INPUT FILE NAME C NOUT.....OUTPUT FILE NAME C ECHO.....LOGICAL .TRUE. IFF LXLREC SHOULD ECHO INPUT. C LXEOF....LOGICAL .TRUE. IFF EOF READ ON LAST READ C COMMON /LXCARD/NEWN,OLDN,NEWREC(290),OLDREC(290), X TYPE(100),INTVAL(100),RVAL(100),NEXT, X NIN,NOUT,ECHO,LXEOF INTEGER OLDN,OLDREC,TYPE LOGICAL ECHO,LXEOF -h- lxcit.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXCIT.BLK;1 C C THIS COMMON BLOCK CONTAINS INFORMATION ABOUT THE CURRENT ITEM. C C FIRST....FIRST CHARACTER OF ITEM. C LAST.....LAST CHARACTER OF ITEM. C TYP......TYP OF ITEM ONE OF THE FOLLOWING: C INTGER - IVAL SET TO VALUE C REAL - RVAL SET TO VALUE C TEXT - NO VALUE RETURNED C SAME (*N ITEMS) - IVAL=N C ALLSAM (** ITEMS) C REPEAT (*=N ITEMS) IVAL=N C GENRAT (*+N ITEMS) IVAL=N C COMMA - MAKE A -NULL- ITEM C IVALUE...INTEGER VALUE RETURN C RVALUE...REAL VALUE RETURN C NOEND....LOGICAL .TRUE. IFF END-OF-LINE ENCOUNTERED C WITHOUT END-OF-QUOTE OR END-OF-COMMENT. C C FOR REPEAT ITEMS OF THE FORM *=N?VALUE WHERE ? IS + OR - C IGEN.....INTEGER GENERATION VALUE C RGEN.....REAL GENERATION VALUE C TGEN.....TYPE OF GENERATION VALUE (REAL,TEXT OR NULL) C COMMON /LXCIT/FIRST,LAST,TYP,IVALUE,RVALUE,NOEND,IGEN,RGEN,TGEN INTEGER FIRST,LAST,TYP,TGEN LOGICAL NOEND -h- lxcon.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXCON.BLK;1 C C THIS COMMON CONTAINS CONSTANTS FOR THE LXLREC COLLECTION OF C ROUTINES. THESE ARE SET BY A DATA STATEMENT IN LXGENR. C NOTE THAT SOME CONSTANTS AREN'T. BLANK,CONT,DOLLAR,SEMI, C QUOTES,COMMA MAY BE CHANGED BY USER DIRECTIVES. THAT'S WHY C THERE IS BOTH BLANKS AND BLANK, AND PLUS AND CONT. C NWORD,MITEM,MCHAR AND NCPW CONTAIN MACHINE CONSTANTS. C NWORD....NUMBER OF WORDS TO HOLD MCHAR C MITEM....MAX NUMBER OF ITEMS C MCHAR....MAX TOTAL NUMBER OF TEXT CHARACTERS C NCPW.....NUMBER OF CHARACTERS PER WORD C ENDCOM...CHARACTER WHICH TERMINATES CURRENT COMMENT C C COMMON /LXCON/ DIGITS(10),MINUS,PLUS,POINT,DOLLAR,SEMI,CONT, X STAR,LPAREN,RPAREN,QUOTES,BLANK,TEXT,REAL,INTGER, X SAME,ALLSAM,REPEAT,GENRAT,EQUALS,COMMA,E,BLANKS, X NWORD,MITEM,MCHAR,NCPW,NULL,ENDCOM,SLASH INTEGER DIGITS,MINUS,PLUS,POINT,DOLLAR,SEMI,CONT INTEGER STAR,LPAREN,RPAREN,QUOTES,BLANK,TEXT,REAL,INTGER INTEGER SAME,ALLSAM,REPEAT,GENRAT,EQUALS,COMMA,E,BLANKS INTEGER NWORD,MITEM,MCHAR,NCPW,ENDCOM,SLASH -h- lxcons.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXCONS.FOR;1 SUBROUTINE LXCONS INCLUDE 'TEXT.BLK' C C PURPOSE: THIS ROUTINE INITIALIZES THE HOLLERITH CONSTANTS USED C BY THE LXLREC ROUTINES. THE CODE IS MACHINE DEPENDENT. C INCLUDE 'LXGEN.BLK' INCLUDE 'LXCON.BLK' INCLUDE 'LXCARD.BLK' INCLUDE '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 -h- lxcrec.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXCREC.FOR;1 FUNCTION LXCREC(I,J) INCLUDE '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 'LXCARD.BLK' INCLUDE '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 -h- lxend.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXEND.FOR;1 SUBROUTINE LXEND(LINE,LEN,LOC,MORE,NEWLEN) INCLUDE '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 '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 -h- lxgen.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXGEN.BLK;1 C C THIS COMMON CONTAINS GENERATION RECORD INFORMATION. C INTINC CONTAINS INTEGER INCREMENTS FOR INTEGER ITEMS C RINC CONTAINS REAL INCREMENTS FOR REAL ITEMS. C NUMREP IS THE REMAINING NUMBER OF RECORDS TO GENERATE. C COMMON /LXGEN/INTINC(100),RINC(100),NUMREP -h- lxgenr.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXGENR.FOR;1 SUBROUTINE LXGENR INCLUDE 'TEXT.BLK' C C THIS SUBROUTINE INCREMENTS REAL AND INTEGER VALUES BY THE C INCREMENTS STORED IN LXGEN FOR GENERATION RECORDS. C INCLUDE 'LXCARD.BLK' INCLUDE 'LXGEN.BLK' INCLUDE '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 -h- lxgens.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXGENS.FOR;1 SUBROUTINE LXGENS(RECORD,LENREC,NUML,LINE,LEN,NEWLEN, X MORE,LOC,IERR) INCLUDE '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 'LXCARD.BLK' INCLUDE 'LXCON.BLK' INCLUDE 'LXGEN.BLK' INCLUDE '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 WRITE (NOUT,8015) 8015 FORMAT(17H *** ERROR *** - , X 36HNUMBER OF ITEMS IN GENERATION RECORD, X /,17X,27HMUST MATCH PREVIOUS RECORD ) GO TO 1000 8020 CONTINUE C C TYPE DIFFERENCE C IERR = 22 IF(LENREC.NE.0) GO TO 1000 IF(NOUT.EQ.0) GO TO 1000 WRITE(NOUT,8025) 8025 FORMAT(17H *** ERROR *** - , X 34HTYPE MISMATCH ON GENERATION RECORD) GO TO 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 WRITE (NOUT,8055) 8055 FORMAT(17H *** ERROR *** - , X 45HILLEGAL TEXT OR *+N ITEM IN GENERATION RECORD ) GO TO 1000 END -h- lxgeti.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXGETI.FOR;1 SUBROUTINE LXGETI(STRING,LEN,IFINT,VALUE) INCLUDE '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 '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 -h- lxgetr.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXGETR.FOR;1 SUBROUTINE LXGETR(STRING,LEN,IFREAL,VALUE) INCLUDE '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 '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 -h- lxid.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXID.FOR;1 FUNCTION LXID(I) INCLUDE '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 'LXCARD.BLK' INCLUDE 'LXCON.BLK' LXID = BLANKS IF((I.GT.0) .AND. (I.LE.NEWN)) LXID = TYPE(I) RETURN END -h- lxirec.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXIREC.FOR;1 FUNCTION LXIREC(I) INCLUDE '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 'LXCARD.BLK' INCLUDE '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 -h- lxitem.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXITEM.FOR;1 FUNCTION LXITEM(NUM) INCLUDE 'TEXT.BLK' C C THIS FUNCTION RETURNS THE NUMBER OF ITEMS READ IN THE LAST C LXLREC RECORD. C INCLUDE 'LXCARD.BLK' NUM = NEWN LXITEM = NEWN RETURN END -h- lxlenc.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXLENC.FOR;1 FUNCTION LXLENC(I) INCLUDE '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 'LXCARD.BLK' INCLUDE '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 -h- lxlenw.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXLENW.FOR;1 FUNCTION LXLENW(I) INCLUDE '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 'LXCARD.BLK' INCLUDE '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 -h- lxline.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXLINE.FOR;1 SUBROUTINE LXLINE(RECORD,LENREC,NUML,LINE,LEN,LOC) INCLUDE '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 'LXCARD.BLK' INCLUDE 'PROM.BLK' INCLUDE 'LXCON.BLK' DIMENSION LINE(80) 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 IF(NIN.EQ.5) WRITE(6,5) PROM 5 FORMAT(1X,A2,$) READ (NIN,10,END=13) LINE 10 FORMAT(80A1) LXEOF = .FALSE. 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 WRITE(NOUT,20) LINE 20 FORMAT(16H INPUT LINE ... ,80A1) GO TO 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 -h- lxlrec.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXLREC.FOR;1 SUBROUTINE LXLREC(RECORD,LENREC,IERR) INCLUDE '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 'LXCARD.BLK' INCLUDE 'LXCON.BLK' INCLUDE 'LXCIT.BLK' INCLUDE 'LXGEN.BLK' INCLUDE '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 WRITE (NOUT,8015) 8015 FORMAT(17H *** ERROR *** - ,31H*N EXTENDS PAST PREVIOUS RECORD) GO TO 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 WRITE (NOUT,8025) 8025 FORMAT(17H *** ERROR *** - X ,43H*N OR ** OPTION REQUESTS LESS THAN ONE ITEM) GO TO 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 WRITE (NOUT,8035)MITEM 8035 FORMAT(17H *** ERROR *** - ,7HMAX OF ,I3,15H ITEMS EXCEEDED) GO TO 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 WRITE (NOUT,8045) 8045 FORMAT(17H *** ERROR *** - ,25H*=N MAY NOT BE FIRST ITEM) GO TO 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 WRITE (NOUT,8055) 8055 FORMAT(17H *** ERROR *** - ,32H*+N MUST BE FIRST ITEM IN RECORD) GO TO 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 WRITE (NOUT,8065) 8065 FORMAT(17H *** ERROR *** - ,28HFOR *=N ITEM N MUST POSITIVE) GO TO 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 WRITE (NOUT,8075)MCHAR 8075 FORMAT(17H *** ERROR *** - X ,40HTOTAL TEXT CHARACTERS FOR RECORD EXCEEDS ,I4) GO TO 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 WRITE (NOUT,8085) 8085 FORMAT(17H *** ERROR *** - X ,51H*=N VALUE DOES NOT AGREE IN TYPE WITH PREVIOUS ITEM) 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 -h- lxmask.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXMASK.FOR;1 FUNCTION LXMASK(NAMEIN) INCLUDE '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 -h- lxnexi.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXNEXI.FOR;1 SUBROUTINE LXNEXI(LINE,START,LEN) INCLUDE '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 'LXCIT.BLK' INCLUDE '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 -h- lxset.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXSET.FOR;1 SUBROUTINE LXSET(WHAT,NEWVAL) INCLUDE '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 'LXCON.BLK' INCLUDE 'PROM.BLK' INCLUDE 'LXCARD.BLK' INCLUDE '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 -h- lxsrec.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXSREC.FOR;1 SUBROUTINE LXSREC(I,CHAR1,NUMC,STRING,START) INCLUDE '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 'LXCON.BLK' INCLUDE '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 -h- lxstor.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXSTOR.FOR;1 SUBROUTINE LXSTOR(TYP,I,R,LINE,FIRST,LAST,STRING) INCLUDE '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 'LXCARD.BLK' INCLUDE '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 -h- lxuset.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXUSET.FOR;1 SUBROUTINE LXUSET(LINE,LEN,IFSET) INCLUDE '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 'LXCON.BLK' INCLUDE 'LXCARD.BLK' INCLUDE '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.NE.0)WRITE(NOUT,910) 910 FORMAT(46H *** WARNING *** DID NOT RECOGNIZE SET COMMAND) 1000 CONTINUE RETURN END -h- lxwrds.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXWRDS.BLK;1 C C *** / L X W R D S / *** C C HOLLERITH WORDS USED BY THE LXLREC ROUTINES C COMMON /LXWRDS/ KYA,KYB,KYC,KYD,KYE,KYF,KYH,KYI,KYK,KYL,KYM, X KYN,KYO,KYP,KYQ,KYR,KYS,KYT,KYU, X KYON,KYOFF,KYEOF,KYECHO,KYPROM,KYINPT,KYOTPT, X KYDOLL,KYSEMI,KYCOMM,KYBLAN,KYPLUS,KYQUOT, X KYPRES,KYBLNK C -h- lxwrec.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]LXWREC.FOR;1 FUNCTION LXWREC(I,J) INCLUDE '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 'LXCARD.BLK' INCLUDE '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 -h- makerim.com Mon Dec 02 10:17:26 1985 DF1:[DBMS]MAKERIM.COM;1 $ ! $ ! PROCEDURE TO INSTALL RIM VERSION 5 ON THE VAX $ ! $ ! CREATE THE RELOCATABLE LIBRARY $ ! $ LIBRARY RIMLIB/CREATE $ ! $ ! NOW COMPILE ALL ROUTINES $ ! @UPDATE ADDDAT @UPDATE ATTADD @UPDATE ATTDEL @UPDATE ATTGET @UPDATE ATTNEW @UPDATE ATTPAG @UPDATE ATTPUT @UPDATE BLKCHG @UPDATE BLKCLN @UPDATE BLKCLR @UPDATE BLKDEF @UPDATE BLKEXT @UPDATE BLKLOC @UPDATE BLKMOV @UPDATE BTADD @UPDATE BTGET @UPDATE BTINIT @UPDATE BTLKI @UPDATE BTLKR @UPDATE BTLKT @UPDATE BTMOVE @UPDATE BTPUT @UPDATE BTREP @UPDATE BTSERT @UPDATE BUILD @UPDATE CHANGE @UPDATE CHKATT @UPDATE CHKREL @UPDATE CHKRUL @UPDATE CHKTUP @UPDATE CMPUTE @UPDATE CSC @UPDATE DBLOAD @UPDATE DELDAT @UPDATE DELDUP @UPDATE DELETE @UPDATE DROPF @UPDATE EQ @UPDATE EQKEYW @UPDATE F1CLO @UPDATE F1OPN @UPDATE F2CLO @UPDATE F2OPN @UPDATE F3CLO @UPDATE F3OPN @UPDATE FILCH @UPDATE GETDAT @UPDATE GETT @UPDATE GTSORT @UPDATE HASH @UPDATE HASHIN @UPDATE HTOI @UPDATE IEXP @UPDATE IFRT @UPDATE INTCON @UPDATE INTDEF @UPDATE INTLOD @UPDATE ISCAN @UPDATE ISECT @UPDATE ISREL @UPDATE ITOC @UPDATE ITOH @UPDATE JOIN @UPDATE JOIREL @UPDATE KMPARD @UPDATE KMPARI @UPDATE KMPARR @UPDATE KMPART @UPDATE KOMPXX @UPDATE LFIND @UPDATE LOADIT @UPDATE LOCATT @UPDATE LOCBOO @UPDATE LOCPRM @UPDATE LOCREL @UPDATE LODELE @UPDATE LODPAS @UPDATE LODREC @UPDATE LODREL @UPDATE LODRUL @UPDATE LSTREL @UPDATE LSTRNG @UPDATE LXCONS @UPDATE LXCREC @UPDATE LXEND @UPDATE LXGENR @UPDATE LXGENS @UPDATE LXGETI @UPDATE LXGETR @UPDATE LXID @UPDATE LXIREC @UPDATE LXITEM @UPDATE LXLENC @UPDATE LXLENW @UPDATE LXLINE @UPDATE LXLREC @UPDATE LXMASK @UPDATE LXNEXI @UPDATE LXSET @UPDATE LXSREC @UPDATE LXSTOR @UPDATE LXUSET @UPDATE LXWREC @UPDATE MINMAX @UPDATE MODIFY @UPDATE MOTSCN @UPDATE NE @UPDATE NSCAN @UPDATE PARVAL @UPDATE PJECT @UPDATE PRJTUP @UPDATE PRULE @UPDATE PTRS @UPDATE PUTDAT @UPDATE PUTT @UPDATE QUERY @UPDATE RELADD @UPDATE RELDEL @UPDATE RELGET @UPDATE RELOAD @UPDATE RELPAG @UPDATE RELPUT @UPDATE REUSE @UPDATE RIM @UPDATE RIOIN @UPDATE RIOOPN @UPDATE RIOOUT @UPDATE RMCLOS @UPDATE RMCONS @UPDATE RMDATE @UPDATE RMDBGT @UPDATE RMDBLK @UPDATE RMDBPT @UPDATE RMDEL @UPDATE RMFIND @UPDATE RMGATT @UPDATE RMGET @UPDATE RMGREL @UPDATE RMGTSO @UPDATE RMHELP @UPDATE RMLATT @UPDATE RMLOAD @UPDATE RMLOOK @UPDATE RMLREL $ FOR RMMAIN $ ! @UPDATE RMOPEN @UPDATE RMPUT @UPDATE RMRES @UPDATE RMRULE @UPDATE RMSAV @UPDATE RMSORT @UPDATE RMSTRT @UPDATE RMTIME @UPDATE RMTOL @UPDATE RMUSER @UPDATE RMVARC @UPDATE RMWHER @UPDATE RMZIP @UPDATE RNAMEA @UPDATE RNAMER @UPDATE ROUN @UPDATE RTOC @UPDATE RTOF @UPDATE RULDEL @UPDATE RULES @UPDATE RXREC @UPDATE SELECT @UPDATE SELOUT @UPDATE SELPAR @UPDATE SELPUT @UPDATE SETIN @UPDATE SETOUT @UPDATE SETRUL @UPDATE SORT @UPDATE SPOUT @UPDATE STATUS @UPDATE STRMOV @UPDATE SUBREL @UPDATE SUBTRC @UPDATE SWCON @UPDATE SWCOST @UPDATE SWFILO @UPDATE SWFLFS @UPDATE SWHART @UPDATE SWHRTD @UPDATE SWHRTI @UPDATE SWHRTR @UPDATE SWICST @UPDATE SWIDCP @UPDATE SWIICP @UPDATE SWINPO @UPDATE SWIRCP @UPDATE SWITCP @UPDATE SWSHEL @UPDATE SWSINK @UPDATE SWSMFL @UPDATE SWSMVL @UPDATE SWUNLO @UPDATE SWUNVL @UPDATE SWVLFS @UPDATE SWVLLO @UPDATE TALLY @UPDATE TOLED @UPDATE TOLER @UPDATE TTY @UPDATE TYPER @UPDATE UNDATA @UPDATE UNDEF @UPDATE UNLOAD @UPDATE WARN @UPDATE WHERE @UPDATE WHETOL @UPDATE WRLINE @UPDATE XHIBIT @UPDATE ZEROIT -h- makrim.cmd Mon Dec 02 10:17:26 1985 DF1:[DBMS]MAKRIM.CMD;1 .ENABLE SUBSTITUTION .ENABLE QUIET .;$ ! .;$ ! PROCEDURE TO INSTALL RIM VERSION 5 ON THE VAX .;$ ! .;$ ! CREATE THE RELOCATABLE LIBRARY .;$ ! .;$ ! .;$ ! NOW COMPILE ALL ROUTINES .;$ ! @UPDATE ADDDAT @UPDATE ATTADD @UPDATE ATTDEL @UPDATE ATTGET @UPDATE ATTNEW @UPDATE ATTPAG @UPDATE ATTPUT @UPDATE BLKCHG @UPDATE BLKCLN @UPDATE BLKCLR @UPDATE BLKDEF @UPDATE BLKEXT @UPDATE BLKLOC @UPDATE BLKMOV @UPDATE BTADD @UPDATE BTGET @UPDATE BTINIT @UPDATE BTLKI @UPDATE BTLKR @UPDATE BTLKT @UPDATE BTMOVE @UPDATE BTPUT @UPDATE BTREP @UPDATE BTSERT @UPDATE BUILD @UPDATE CHANGE @UPDATE CHKATT @UPDATE CHKREL @UPDATE CHKRUL @UPDATE CHKTUP @UPDATE CMPUTE @UPDATE CSC @UPDATE DBLOAD @UPDATE DELDAT @UPDATE DELDUP @UPDATE DELETE @UPDATEF DROPF @UPDATE EQ @UPDATE EQKEYW @UPDATE F1CLO @UPDATE F1OPN @UPDATE F2CLO @UPDATE F2OPN @UPDATE F3CLO @UPDATE F3OPN @UPDATE FILCH @UPDATE GETDAT @UPDATE GETT @UPDATE GTSORT @UPDATE HASH @UPDATE HASHIN @UPDATE HTOI @UPDATE IEXP @UPDATE IFRT @UPDATE INTCON @UPDATE INTDEF @UPDATE INTLOD @UPDATE ISCAN @UPDATE ISECT @UPDATE ISREL @UPDATE ITOC @UPDATE ITOH @UPDATE JOIN @UPDATE JOIREL @UPDATE KMPARD @UPDATE KMPARI @UPDATE KMPARR @UPDATE KMPART @UPDATE KOMPXX @UPDATE LFIND @UPDATE LOADIT @UPDATE LOCATT @UPDATE LOCBOO @UPDATE LOCPRM @UPDATE LOCREL @UPDATE LODELE @UPDATE LODPAS @UPDATE LODREC @UPDATE LODREL @UPDATE LODRUL @UPDATE LSTREL @UPDATE LSTRNG @UPDATE LXCONS @UPDATE LXCREC @UPDATE LXEND @UPDATE LXGENR @UPDATE LXGENS @UPDATE LXGETI @UPDATE LXGETR @UPDATE LXID @UPDATE LXIREC @UPDATE LXITEM @UPDATE LXLENC @UPDATE LXLENW @UPDATE LXLINE @UPDATE LXLREC @UPDATE LXMASK @UPDATE LXNEXI @UPDATE LXSET @UPDATE LXSREC @UPDATE LXSTOR @UPDATE LXUSET @UPDATE LXWREC @UPDATE MINMAX @UPDATE MODIFY @UPDATE MOTSCN @UPDATE NE @UPDATE NSCAN @UPDATE PARVAL @UPDATE PJECT @UPDATE PRJTUP @UPDATE PRULE @UPDATE PTRS @UPDATE PUTDAT @UPDATE PUTT @UPDATE QUERY @UPDATE RELADD @UPDATE RELDEL @UPDATE RELGET @UPDATEF RELOAD @UPDATE RELPAG @UPDATE RELPUT @UPDATE REUSE @UPDATE RIM @UPDATEF RIOIN @UPDATEF RIOOPN @UPDATEF RIOOUT @UPDATE RMCLOS @UPDATE RMCONS @UPDATE RMDATE @UPDATE RMDBGT @UPDATE RMDBLK @UPDATE RMDBPT @UPDATE RMDEL @UPDATE RMFIND @UPDATE RMGATT @UPDATE RMGET @UPDATE RMGREL @UPDATE RMGTSO @UPDATE RMHELP @UPDATE RMLATT @UPDATE RMLOAD @UPDATE RMLOOK @UPDATE RMLREL F77 RMMAIN=RMMAIN.FOR/F77/I4/NOTR .;$ FOR RMMAIN .;$ ! @UPDATE RMOPEN @UPDATE RMPUT @UPDATE RMRES @UPDATE RMRULE @UPDATE RMSAV @UPDATE RMSORT @UPDATE RMSTRT @UPDATE RMTIME @UPDATE RMTOL @UPDATE RMUSER @UPDATE RMVARC @UPDATE RMWHER @UPDATE RMZIP @UPDATE RNAMEA @UPDATE RNAMER @UPDATE ROUN @UPDATE RTOC @UPDATE RTOF @UPDATE RULDEL @UPDATE RULES @UPDATE RXREC @UPDATE SELECT @UPDATE SELOUT @UPDATE SELPAR @UPDATE SELPUT @UPDATE SETIN @UPDATE SETOUT @UPDATE SETRUL @UPDATE SORT @UPDATE SPOUT @UPDATEF STATUS @UPDATE STRMOV @UPDATE SUBREL @UPDATE SUBTRC @UPDATE SWCON @UPDATE SWCOST @UPDATE SWFILO @UPDATEF SWFLFS @UPDATE SWHART @UPDATE SWHRTD @UPDATE SWHRTI @UPDATE SWHRTR @UPDATE SWICST @UPDATE SWIDCP @UPDATE SWIICP @UPDATE SWINPO @UPDATE SWIRCP @UPDATE SWITCP @UPDATE SWSHEL @UPDATE SWSINK @UPDATE SWSMFL @UPDATE SWSMVL @UPDATE SWUNLO @UPDATE SWUNVL @UPDATEF SWVLFS @UPDATEF SWVLLO @UPDATE TALLY @UPDATE TOLED @UPDATE TOLER @UPDATE TTY @UPDATE TYPER @UPDATE UNDATA @UPDATE UNDEF @UPDATE UNLOAD @UPDATE WARN @UPDATE WHERE @UPDATE WHETOL @UPDATE WRLINE @UPDATE XHIBIT @UPDATE ZEROIT -h- minmax.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]MINMAX.FOR;1 SUBROUTINE MINMAX(MMVAL,MMTYP) INCLUDE '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 'RMATTS.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'BTBUF.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'F3COM.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE '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 -h- misc.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]MISC.BLK;1 C C *** / M I S C / *** C C MISCELLANEOUS CONSTANTS USED LOTS OF PLACES C COMMON /MISC/ NONE,BLANK,IBLANK,ALL9S,NULL,CHPWD,MAXCOL,ENDWRD REAL*8 BLANK INTEGER ALL9S INTEGER NULL REAL*8 NONE INTEGER CHPWD INTEGER ENDWRD C C VARIABLE DEFINITIONS: C IBLANK--AN INTEGER BLANK WORD C BLANK---A BLANK WORD C ALL9S---THE VALUE 999999999 C NULL----THE RIM NULL VALUE: -0- C NONE----THE WORD 4HNONE C CHPWD---NUMBER OF CHARACTERS PER WORD C MAXCOL--MAXIMUM NUMBER OF COLUMNS ALLOWED IN A TUPLE C ENDWRD--RECORD END WORD -- 4H*END C -h- modify.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]MODIFY.FOR;1 SUBROUTINE MODIFY INCLUDE 'TEXT.BLK' C C THIS ROUTINE IS THE DRIVER FOR MODIFY OF THE RIM DATA BASE. C INCLUDE 'CONST8.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'ATTBLE.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'FILES.BLK' INCLUDE 'MISC.BLK' LOGICAL EQKEYW LOGICAL NE LOGICAL EQ INCLUDE 'DCLAR1.BLK' INCLUDE '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 WRITE(NOUT,422) 422 FORMAT(44H -ERROR- PASSWORDS MUST BE 1-8 ALPHANUMERIC , X 10HCHARACTERS) GO TO 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.EQ.0) WRITE(NOUT,9001) 9001 FORMAT(20H 0 ROWS CHANGED ) GO TO 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 WRITE(NOUT,9002) 9002 FORMAT(41H -ERROR- UNAUTHORIZED TO CHANGE THE OWNER) GO TO 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 WRITE(NOUT,3910) 3910 FORMAT(41H -ERROR- UNAUTHORIZED ACCESS TO THE RULES ) GO TO 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 -h- motscn.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]MOTSCN.FOR;1 SUBROUTINE MOTSCN(MOTID,IPTR) INCLUDE '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 '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 -h- ne.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]NE.FOR;1 LOGICAL FUNCTION NE(WORD1,WORD2) INCLUDE '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 'DCLAR6.BLK' C NE = WORD1.NE.WORD2 RETURN END -h- nscan.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]NSCAN.FOR;1 INTEGER FUNCTION NSCAN(STR1,IC1,LC1,STR2,IC2,LC2) INCLUDE '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 BYTE STR1(*) BYTE 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 -h- pagdat.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]PAGDAT.BLK;1 C C *** / P A G D A T / *** C COMMON /PAGDAT/ NEXTB,NEXTW,CURBLK(3),MODFLG(3),NWDS INTEGER CURBLK C C VARIABLE DEFINITIONS C NEXTB---NEXT BLOCK TO WRITE C NEXTW---NEXT WORD TO WRITE C CURBLK--CURRENT BLOCKS IN CORE C MODFLG--FLAG INDICATING MODS IN THE BLOCK C NWDS----NUMBER OF WORDS IN EACH BLOCK C -h- parval.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]PARVAL.FOR;1 SUBROUTINE PARVAL(ID,MAT,ATYPE,NWORDS,ROW,NCOLT,IERR) INCLUDE '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 'RMATTS.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'FILES.BLK' INCLUDE '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 WRITE (NOUT,8010) ID 8010 FORMAT(50H -ERROR- TYPE MISMATCH FOR VALUE STARTING AT ITEM ,I3) IERR = 1 GO TO 9999 8100 CONTINUE WRITE (NOUT,8110)ID 8110 FORMAT( X 53H -ERROR- INCORRECT LENGTH FOR VALUE STARTING AT ITEM ,I3) IERR = 2 GO TO 9999 8200 CONTINUE WRITE (NOUT,8210) ID 8210 FORMAT( X 51H -ERROR- PAREN MISMATCH FOR VALUE STARTING AT ITEM ,I3) IERR = 3 GO TO 9999 8300 CONTINUE WRITE(NOUT,8310) MAXCOL 8310 FORMAT(36H -ERROR- RELATION ROW LENGTH EXCEEDS,I5) IERR = 2 GO TO 9999 9990 CONTINUE C C RESET NWORDS C NWORDS = NWORD IF(JTYPE.EQ.KZDOUB) NWORDS = 2*NWORD 9999 CONTINUE RETURN END -h- pject.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]PJECT.FOR;1 SUBROUTINE PJECT INCLUDE '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 'RIMPTR.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'FILES.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'MISC.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'FLAGS.BLK' C C INTEGER STATUS LOGICAL EQKEYW INTEGER ATNCOL INCLUDE '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 WRITE (NOUT,1220) 1220 FORMAT( X 55H -ERROR- RESULTANT RELATION DOES NOT HAVE A UNIQUE NAME ) GO TO 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 WRITE (NOUT,2180) KNEW 2180 FORMAT(30H SUCCESSFUL PROJECT OPERATION ,I5, X 15H ROWS GENERATED ) GO TO 9999 C C 9900 CONTINUE CALL WARN(4,0,0) C 9999 CONTINUE CALL BLKCLR(10) CALL BLKCLR(11) RETURN END -h- prjtup.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]PRJTUP.FOR;1 SUBROUTINE PRJTUP(POINTS,LENP,LENNEW,OLDTUP,NEWTUP,LENT) INCLUDE '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 -h- prom.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]PROM.BLK;1 C C *** / P R O M / *** C C INTERACTIVE PROMPTING CHARACTERS C COMMON /PROM/ PROM INTEGER PROM C C VARIABLE DEFINITIONS C PROM----THE PROMPTING STRING OF CHARACTERS C -h- prule.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]PRULE.FOR;1 SUBROUTINE PRULE(NUMRUL) INCLUDE '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 'CONST4.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'CONST8.BLK' INCLUDE 'FILES.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'MISC.BLK' INCLUDE 'RELTBL.BLK' C DIMENSION MAT(24) DIMENSION LINE(18) INTEGER SAVSCR(21) INTEGER SAVTUR(13) INTEGER ANDOR LOGICAL EQ C C PRINT HEADING. C WRITE(NOUTR,9000) NUMRUL 9000 FORMAT(13H RULE NUMBER ,I5) 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 -h- ptrcom.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]PTRCOM.BLK;1 C C *** / P T R C O M / *** C C PROGRAM INTERFACE NAVIGATION POINTER SAVE BLOCK. C COMMON /PTRCOM/ INDNUM(10),MAXGET(10),NEXPOS,NEXPOT, X SAVBLK(2,10),SAVBUF(1000) INTEGER SAVBLK,SAVBUF C C VARIABLE DEFINITIONS: C INDNUM--ARRAY OF POINTER NUMBERS IN USE C MAXGET--ARRAY OF INTIAL "NTUPLE" VALUES C NEXPOS--NEXT AVAILABLE POSITION IN THE WHRVAL ARRAY (WHCOM) C NEXPOT--NEXT AVAILABLE POSITION IN THE WHRLEN ARRAY (WHCOM) C SAVBLK--SAVBUF POINTER ARRAY (SIMILAR TO THE INCORE ARRAY) C SAVBUF--BUFFER TO HOLD THE POINTER AND WHERE CLAUSE DATA C -h- ptrs.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]PTRS.FOR;1 SUBROUTINE PTRS(IP1,IP2,K,NATT3,PTABLE,LEN,ITYPE) INCLUDE '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 -h- putdat.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]PUTDAT.FOR;1 SUBROUTINE PUTDAT(INDEX,ID,ARRAY,LENGTH) INCLUDE '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 'F2COM.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'BUFFER.BLK' INCLUDE '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 -h- putt.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]PUTT.FOR;1 SUBROUTINE PUTT(STR1,IC1,WORD) INCLUDE '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 BYTE STR1(*) BYTE WORD(*) STR1(IC1) = WORD(1) RETURN END -h- query.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]QUERY.FOR;1 SUBROUTINE QUERY INCLUDE 'TEXT.BLK' C C THIS ROUTINE IS THE DRIVER FOR QUERY OF THE RIM DATA BASE. C INCLUDE 'RMATTS.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'CONST8.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'FILES.BLK' INCLUDE 'MISC.BLK' INCLUDE 'SRTCOM.BLK' LOGICAL EQKEYW LOGICAL SAORD INCLUDE '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 WRITE (NOUT,602) 602 FORMAT(43H -WARNING- NO DATA EXISTS FOR THIS RELATION ) GO TO 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 WRITE (NOUT,720) 720 FORMAT(43H -WARNING- NO ROWS SATISFY THE WHERE CLAUSE ) GO TO 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 WRITE(NOUT,1165) 1165 FORMAT(41H -WARNING- VARIABLE LENGTH ATTRIBUTES MAY, 1 25H NOT BE SORTED OR TALLIED) GO TO 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 WRITE(NOUT,1175) 1175 FORMAT(44H -ERROR- ILLEGAL NUMBER OF SORTED ATTRIBUTES) GO TO 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) 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 WRITE(NOUTR,1610) 1610 FORMAT(1H1) GO TO 100 2000 CONTINUE RETURN END -h- reladd.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RELADD.FOR;1 SUBROUTINE RELADD INCLUDE 'TEXT.BLK' C C PURPOSE: ADD A NEW TUPLE TO THE RELTBL RELATION C INCLUDE 'TUPLER.BLK' INCLUDE 'RELTBL.BLK' INCLUDE 'F1COM.BLK' INCLUDE '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 -h- reldel.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RELDEL.FOR;1 SUBROUTINE RELDEL INCLUDE 'TEXT.BLK' C C PURPOSE: DELETE THE CURRENT TUPLE FROM THE RELTBL RELATION C BASED ON CONDITIONS SET UP IN LOCREL C INCLUDE '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 -h- relget.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RELGET.FOR;1 SUBROUTINE RELGET(STATUS) INCLUDE '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 'RELTBL.BLK' INCLUDE 'TUPLER.BLK' INCLUDE '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 -h- reload.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RELOAD.FOR;1 SUBROUTINE RELOAD INCLUDE 'TEXT.BLK' C C PURPOSE: RELOAD THE DATA BASE TO RECOVER LOST SPACE FROM C DELETIONS. C INCLUDE 'RMATTS.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'CONST8.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'START.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'MISC.BLK' INCLUDE 'SRTCOM.BLK' INCLUDE 'F2COM.BLK' INCLUDE 'F3COM.BLK' INCLUDE 'DCLAR1.BLK' INCLUDE 'DCLAR4.BLK' C C DIMENSION AND DATA C INTEGER FILE4 LOGICAL EQ INTEGER COLUMN INTEGER OFFSET 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) OPEN(UNIT=FILE4, FILE=FNAME, ACCESS='DIRECT', X RECL=LENBF2, ORGANIZATION='SEQUENTIAL', 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 -h- relpag.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RELPAG.FOR;1 SUBROUTINE RELPAG(THEROW) INCLUDE '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 'RELTBL.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE '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 -h- relput.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RELPUT.FOR;1 SUBROUTINE RELPUT INCLUDE 'TEXT.BLK' C C PURPOSE: REPLACE THE CURRENT TUPLE FROM THE RELTBL RELATION C BASED ON CONDITIONS SET UP IN LOCREL C INCLUDE 'FLAGS.BLK' INCLUDE 'TUPLER.BLK' INCLUDE '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 -h- reltbl.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]RELTBL.BLK;1 C C *** / R E L T B L / *** C C BUFFER TO HOLD ONE PAGE FROM THE RELTBL RELATION C COMMON /RELTBL/ RELBUF(1024), X CNAME,LRROW,NRROW,RELMOD,RPBUF INTEGER RELBUF REAL*8 CNAME INTEGER RELMOD INTEGER RPBUF INTEGER RELTBL(14,73) EQUIVALENCE (RELBUF(2),RELTBL(1,1)) C C VARIABLE DEFINITIONS: C RELBUF--BUFFER FOR ONE PAGE FROM THE RELTBL RELATION C RELTBL--EQUIVALENCE ARRAY FOR EASIER USE OF RELBUF C CNAME---CURRENT RELATION NAME SPECIFIED IN LOCREL C LRROW---LAST ROW SENT IN TUPLER C NRROW---NEXT AVAILABLE ROW FOR ADDING A TUPLE C RELMOD--MODIFICATION FLAG - O MEANS NO, 1 MEANS YES C RPBUF---RELATIONS PER RELBUF PAGE C -h- reuse.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]REUSE.FOR;1 SUBROUTINE REUSE INCLUDE 'TEXT.BLK' C C PURPOSE: RESET THE USAGE FLAGS TO OFF IN THE ICORE FLAGS C INCLUDE 'F3COM.BLK' DO 100 NUMB=1,NUMIC ICORE(1,NUMB) = 0 100 CONTINUE RETURN END -h- rim.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RIM.FOR;1 SUBROUTINE RIM INCLUDE 'TEXT.BLK' C INCLUDE 'RMATTS.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'CONST8.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'FILES.BLK' INCLUDE 'MISC.BLK' INCLUDE 'SELCOM.BLK' C LOGICAL EQKEYW INTEGER IDT(2) INTEGER DBSTAT INCLUDE '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,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 WRITE (NOUT,1332) 1332 FORMAT(/39H -ERROR- THE DATABASE NAME MUST BE 1-6 , X 23HALPHANUMERIC CHARACTERS,/) GO TO 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 WRITE (NOUTR,1367) 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 WRITE(NOUT,1368) 1368 FORMAT(44H -ERROR- PASSWORDS MUST BE 1-8 ALPHANUMERIC , X 10HCHARACTERS) GO TO 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 WRITE(NOUT,1466) 1466 FORMAT(50H -WARNING- LINES ENTERED IS OUT OF RANGE, RESET TO, X 8H DEFAULT,/) GO TO 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 WRITE(NOUT,1472) UMCPL 1472 FORMAT(51H -WARNING- WIDTH ENTERED IS OUT OF RANGE, RESET TO , X I4,/) GO TO 1000 1475 CONTINUE C MENU IF(.NOT.EQKEYW(1,KWMENU,4)) GO TO 1480 NEXTOP = K8MENU IF(.NOT.BATCH) GO TO 3500 WRITE(NOUT,1476) 1476 FORMAT(39H -ERROR- MENU MODE NOT ALLOWED IN BATCH ) 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 WRITE (NOUT,1499) 1499 FORMAT(37H -ERROR- INVALID COMMAND - RETYPE IT ) 1500 CONTINUE GO TO 1000 1550 CONTINUE C C NO RELATIONS YET C WRITE (NOUT,1560) 1560 FORMAT(53H -ERROR- NO RELATIONS DEFINED YET FOR THIS DATA BASE ,/) GO TO 1000 C C PROCESS THE INPUT COMMAND C 1600 CONTINUE IF((LXLENC(2).GE.1).AND.(LXLENC(2).LE.7)) GO TO 1610 WRITE(NOUT,1800) GO TO 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 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 WRITE(NOUT,100) 100 FORMAT(53H -WARNING- TITLE ENTERED WAS TOO LONG AND WILL BE TRU, X 6HNCATED ) 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 WRITE(NOUT,2302) 2302 FORMAT(34H -ERROR- ITEM 2 MUST BE AN INTEGER) GO TO 1000 2303 CONTINUE KOL = 1 IF(LXITEM(ITEM).EQ.2) KOL = LXIREC(2) IF(KOL.LE.0) KOL = 1 DO 2310 K=1,KOL 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 -h- rimabs.abs Mon Dec 02 10:17:26 1985 DF1:[DBMS]RIMABS.ABS;1 VAX/VMS RIM This program is the public domain version of the RIM database manager. Full sources and documents are present (the program is in Fortran and build files are present), with most of the manual machine readable too. RIM compares favorably with DBMS or Datatrieve in its richness and power and has a built in HELP menu for ease of use. It was developed under a NASA contract and is therefore available to US users with the limitation that it be neither published nor released to foreign parties until after January 1, 1986. It is probably the best public domain DBMS currently available, however, and is therefore made available for US users of VMS. Most applications which use Datatrieve can be reprogrammed in RIM, though the command language is different. Revision 1: A slightly later update (UP23) level is supplied, and an experimental version which is configured to run on the PDP11 under IAS. Due to the similarity of IAS to RSX11M, it should be possible to build it under RSX11M or maybe RSX11M+ without too much work. Response time of the PDP11 version is said to be slow however. Note: Backup sets on the tape are VMS Backup for the first ones, then RMS Backup so that a PDP11 may read its version. -h- rimcom.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]RIMCOM.BLK;1 C C *** / R I M C O M / *** C C RIM FORTRAN INTERFACE STATUS COMMON C COMMON /RIMCOM/ RMSTAT INTEGER RMSTAT C C VARIABLE DEFINITIONS C RMSTAT--STATUS FLAG C -1 NO MORE DATA AVAIABLE FOR RETRIEVAL C 0 OK - OPERATION SUCCESSFULL C 10 DATABASE FILES DO NOT CONTAIN A RIM DATABASE C 11 DATABASE NAME DOES NOT MATCH FILE CONTENTS C 12 INCOMPATABLE DATABASE FILES (DATE,TIME,ETC) C 13 DATABASE IS ATTACHED IN READ ONLY MODE C 14 DATABASE IS BEING UPDATED C 15 DATABASE FILES ARE NOT LOCAL FILES C 20 UNDEFINED RELATION C 30 UNDEFINED ATTRIBUTE C 40 MORE THAN 10 AND/OR OPERATORS IN THE WHERE CLAUSE C 41 ILLEGAL "LIMIT EQ N" CONDITION C 42 UNRECOGNIZED BOOLEAN COMPARISON C 43 EQS ONLY AVAILABLE FOR TEXT ATTRIBUTES C 44 ILLEGAL USE OF MIN/MAX IN THE WHERE CLAUSE C 45 UNRECOGNIZED AND/OR OPERATOR C 46 COMPARED ATTRIBUTES MUST BE THE SAME TYPE/LENGTH C 47 LISTS ARE VALID ONLY FOR EQ EQS AND NE C 48 ILLEGAL ROW SPECIFICATION C 50 RMFIND NOT CALLED C 60 RMGET NOT CALLED C 70 RELATION REFERENCE NUMBER OUT OF RANGE C 71 REFERENCE NUMBER BUFFER FULL C 80 VARIABLE LENGTH ATTRIBUTES MAY NOT BE SORTED C 81 THE NUMBER OF SORTED ATTRIBUTES IS TOO LARGE C 89 SORT SYSTEM ERROR (SHOULD NEVER GET THIS) C 90 UNAUTHORIZED RELATION ACCESS C 100 ILLEGAL VARIABLE LENGTH TUPLE DEFINITION (LOAD/PUT) C 110 UNRECOGNIZED RULE RELATIONS C 111 MORE THAN 10 RULES PER RELATION C 112 UNABLE TO PROCESS RULES C 2XX TUPLE VIOLATES RULE XX C C THE FOLLOWING CODES SHOULD NOT BE ENCOUNTERED IN NORMAL USE C C 1001 BUFFER SIZE PROBLEM - BLKCHG,BLKDEF C 1002 UNDEFINED BLOCK - BLKLOC C 1003 CANNOT FIND A LARGER BTREE VALUE - BTADD,PUTDAT C 1004 CANNOT FIND BTREE BLOCK - BTPUT C 1005 SORT READ FAILED C C 21XX RANDOM FILE ERROR XX ON FILE1 C 22XX RANDOM FILE ERROR XX ON FILE2 C 23XX RANDOM FILE ERROR XX ON FILE3 C 24XX RANDOM FILE ERROR XX ON FILE4 C -h- rimcrd.doc Mon Dec 02 10:17:26 1985 DF1:[DBMS]RIMCRD.DOC;1 RIM Handy Reference Card DEFINING A DATABASE SCHEMA DEFINE dbname OWNER password ATTRIBUTES attname {REAL} [{length}][KEY] INT VAR TEXT DOUB RVEC IVEC DVEC attname {RMAT} {row,col} [KEY] IMAT row,VAR DMAT VAR,VAR RELATIONS relname WITH attname1 [attname2...] PASSWORDS {READ PASSWORD} FOR {relname} IS password RPW ALL {MODIFY PASSWORD} FOR {relname} IS password MPW ALL RULES attname [IN relname] {EQ} value [{AND}...] NE OR GT GE LT LE attname IN relname {EQA} attname IN relname [{AND}...] NEA OR GTA GEA LTA LEA END LOADING A RELATION LOAD relname value1 value2 ... valueN END value: SCALARS val1 TEXT "text string" VECTOR (val1, val2, ...) MATRIX(r1c1,r2c1,...),(r1c2,r2c2,...)...) QUERYING A RELATION SELECT {attname1 [=fid1],attname2[=fid2],...} FROM relname + attnum1 [=fid1],... attname1(i),... attname1(i,j)... ALL [SORTED BY attname1 [={A}],[attname2 [={A}]...]]+ D D [WHERE ...] TALLY attname [={A}] FROM relname [WHERE...] D WHERE CLAUSE: WHERE attname {EXISTS} [{AND}...] FAILS OR EQS value EQ {value} NE MAX GT MIN LT LE GE WHERE attname {EQA} attname [{AND}...] NEA OR GTA GEA LTA LEA WHERE ROWS {EQ} rownumber [{AND}...] NE OR LT LE GE GT WHERE {attname} {EQ} list [{AND}...] ROWS NE OR WHERE LIMIT EQ number [{AND}...] OR ... QUERYING THE SCHEMA LISTREL [relname] ALL EXHIBIT attname1 [attname2...] PRINT RULES COMPUTATION COMMAND COMPUTE {COUNT} attname FROM relname [WHERE...] MIN MAX AVE SUM MODIFICATION COMMANDS CHANGE {attname} TO value [IN relname] WHERE ... attname(i) attname(i,j) CHANGE {RPW} TO newpass FOR relname MPW CHANGE OWNER TO newowner DELETE ROWS FROM relname WHERE ... DELETE DUPLICATES [attname1,attname2,...] FROM relname DELETE RULE rulenumber RENAME ATTRIBUTE attname TO newname [IN relname] RENAME RELATION relname TO newname REMOVE relname RELATIONAL ALGEBRA COMMANDS INTERSECT relname1 WITH relname2 FORMING relname3 + [USING attname1 [attname2,...]] JOIN relname1 Using attname1 WITH relname2 USING attname2 + FORMING relname3 [WHERE {EQ}] NE GT GE LT LE SUBTRACT relname1 FROM relname2 FORMING relname3 + [USING attname1 [attname2,...]] PROJECT relname1 FROM relname2 USING + {attname1,[attname2,...]} [WHERE ...] ALL REPORT COMMANDS NEWPAGE BLANK n TITLE "title" DATE LINES n WIDTH n KEY COMMANDS BUILD KEY FOR attname IN relname DELETE KEY FOR attname IN relname RIM-TO-RIM COMMAND UNLOAD [dbname [=newdbname]] {SCHEMA} [relname1 [=mpw] + DATA ALL [relname2 [=mpw],...] GENERAL COMMANDS INPUT {filename} TERMINAL OUTPUT {filename} TERMINAL EXIT QUIT MENU HELP [command name] USER password ECHO NOECHO CHECK NOCHECK TOLERANCE xx.xx [PERCENT] RELOAD CLOSE HOST DEPENDENT COMMANDS (note: may be CDC syntax) OPEN dbname [=filename],[UN=account],[PW=password],+ [DIRECT={R}] W ZIP "jet statement" -h- rimdoc.rno Mon Dec 02 10:17:26 1985 DF1:[DBMS]RIMDOC.RNO;4 .LEFT MARGIN +7 .RIGHT MARGIN +22 .LAYOUT 1,2 .NO FILL .CENTER DEFINITIONS ATTRIBUTE: An attribute is a 1-8 character alphanumeric name used to identify a specific column of a relation. DOMAIN: A domain is the set of values which are permissible in a column of a two-dimensional table of data (relation). KEY: An attribute may be specified to be "KEY". This specification will cause RIM to build an index for the attribute. Under certain conditions, this index will greatly improve the system efficiency for queries and updates. RELATION: A relation is a two-dimensional table of data. The column headings are the attributes of the relation and the rows are the data occurences (tuples). ROW: A row is the set of values in a row of a two- dimensional table (relation). A row is sometimes referred to as a tuple. SCHEMA: The schema is the definition of the relations and their attributes that comprise the data base. The relation passwords and constraint rules also are part of the schema. .PG .CENTER SUMMARY This document is the user's guide (VAX/VMS) for the Relational Information Management System, Version 5 (RIM-5). The information presented consists of instructions for using RIM-5 as a standalone system and for using RIM-5 in conjunction with an application program. Section 1.0 presents the method of implementation and access for RIM-5, a discussion of the files used by RIM-5, and the general syntax of the RIM-5 command language. Section 2.0 presents instructions for the use of RIM-5 as a standalone system in both menu and command modes. In the menu mode, you are prompted for the inputs required to create, update, and/or query the data base. The command mode, as an alternative, requires the direct input of RIM-5 commands to create, update, and/or query the data base. A discussion of all the available RIM-5 command is presented in this section. Section 3.0 presents the instructions for the application program interface. Any programming language that can call FORTRAN subroutines can be used. The appendices present a summary of the RIM-5 commands, a summary of the application program interface, a sample RIM FORTRAN program, a list of the current limitations, and a discussion of the LXLREC free field input routine. .PG .CENTER 1.0 OVERVIEW The Relational Information Management (RIM) System was originally developed as a prototype data base management system by Dennis L. Comfort and Wayne J. Erickson at The Boeing Company under NASA Contract NAS1-14700 (IPAD). Mr. Erickson at the University of Washington, and Frederick P. Gray at The Boeing Company made en- hancements to the system which culminated in RIM Version 4 (RIM- 4) . RIM-5, which is the version of RIM described in this document, was developed by Mr. Erickson for NASA and Mr. Gray and Geofferey Von Limbach for Boeing. RIM is based upon the relational algebra model for data management and has been used for both en- gineering and business data. The system is available as a stand- alone system and through an application program interface. The standalone system may be executed in two modes: menu or command. The menu mode prompts the user for the input required to create, update, and/or query the data base. The command mode requires the direct input of RIM commands. RIM-5 includes several enhancements relative to RIM-4, including: . highly portable FORTAN code . additional scientific attribute types for vectors and matrices . variable length attributes . improved sort option . improved where clause . an initial set of report writing commands . introduction of tolerance for floating point numbers . additional schema modification commands . enhanced FORTAN interface . RIM-to-RIM communications file To the interactive/batch user the RIM-5 creation, update, and query are, for the most part, identical to RIM-4. Data bases form RIM-4 must be reloaded for RIM-5, however. In addition, the ap- plication program interface has been expanded and modified to ac- comodate increased capabilities. .PG 1.1 IMPLEMENTATION AND ACCESS RIM is written entirely in FORTRAN 77. It requires approximately 300000 (decimal) bytes of virtual memory when run as a standalone program. Access to RIM depends on the execution method desired. To execute the standalone system, the following control statement is needed: RUN [rimact ]RIM where rimact is the name of the user directory on which RIMABS and the RIM HELP data base files reside. To use the RIM application program interface you need to link RIMLIB to your application program. This can be done with the following instruction: LINK JOBA,[rimact]RIMLIB/LIB where rimact is the name of the user directory on which RIMLIB resides. JOBA is the name of the object file of your application program. 1.2 DATA BASE FILES Each data base consists of three RIM-generated files whose logical names are formed by suffixing the data base name with a 1,2, and 3. The first file contains directory data, the second file con- tains the actual data for each relation, and the third file con- tains key element pointers. The default type for these files are "DAT". RIM uses logical files FOR005 and FOR006 for input and output. If your data base files do not reside on your directory with names equal to the logical data base files names, you must use the as- sign control statements prior to the RIM execution to assign required names to your data base files. You may also assign your input and outout files to files other than FOR005 and FOR006 if desired. 1.3 GENERAL COMMAND SYNTAX RIM is used by entering commands, (which start with keywords) in response to input prompts (which vary according to the submodule in use). Three of the commands (DEFINE, HELP, and LOAD), are used to enter submodules which have their own sets of commands for defining and loading a data base. In describing commands, the following conventions are used: relname .PG or name of a relation(s) relname1,relname2,... attname or name of an attribute(s) attname1,attname2,... value or actual values(s) value1,value2,... (value may be a text string, scalar, vector, or matrix) All relation and attribute names must contain at least 1 and no more than 8 alphanumeric characters. Many of the commands in RIM have optional parts. These optional parts are enclosed in square brackets. [THIS IS OPTIONAL] Some keywords in the commands are selected from a list of accep- table keywords. These keywords are in a vertical list with the first choice enclosed in braces. {CHOOSE} ONE OF THESE RIM command keywords may be abbreviated. At least the first 3 characters in the keywords are required. The following are equivalent: 1) SELECT, FROM, WHERE, DELETE DUPLICATES 2) SELEC, FRO, WHER, DELETE DUP 3) SEL, FRO, WHE, DEL DUP All commands in RIM are entered in a free-field format with blanks and commas as separators. the following contains a short descrip- tion of RIM conventions and data generation facilities. An exten- sive description, intended for the experienced RIM user, can be found in Appendix E. Keywords and data values are separated by blanks or commas. If a command is too long for one 80 character line, it may be continued on succeeding lines by entering "+" as the last character of the preceding line. RIM remembers each previous command. This en- ables you to re-use all or part of the previous command. This is done by using an asterisk to indicate which items of the previous .PG command are to be re-used. A single asterisk means re-use the corresponding single item of the previous record. An asterisk followed by a number n means re-use the next n corresponding items. Two asterisks mean re-use all remaining corresponding items. The following are all equivalent: 1) THIS IS A COMMAND 2) THIS + IS + A + COMMAND 3) * IS,A COMMAND 4) THIS *2 COMMAND 5) THIS ** Multiple commands may be entered on one line separated by a semi- colon or $. THIS IS THE FIRST ; THIS IS THE SECOND $ THIS IS THE THIRD Comments may be placed anywhere within a command by enclosing the comment between the characters *( and ). *(THIS IS A COMMENT) THIS IS NOT When numeric data is to be interpreted as text (alphanumeric) data, the numerals must be enclosed by quotation marks. "1234" When entering text strings which contain embedded blanks or commas, the entire string must be enclosed by quotation marks. "THIS IS A TEXT STRING" A text string may require continuation on one or more lines. The + sign continuation can then be used within the quotation marks. It is not recommended that you use leading blanks in text strings. Text which does not have embedded blanks or commas does not require quotes. Integer data is input as a string of digits without a decimal point. A sign may precede the digits. 123, -63, +56, 0 .PG Real or floating point numbers must include a decimal point or E for the exponent. If a decimal point is not present, the E must be preceded by an integer. 1.3, .005, 0., 6.E-1, 6E-1, 0.60, -23.45 The size of real numbers is limited to the range between 1.0E-38 and 1.0E+38. .PG .CENTER 2.0 RIM EXECUTION Execution of RIM as a standalone program can be effective in two modes, command mode or menu mode. The command mode is used when RIM is executed in the batch environment or for interactive users who wish to bypass the menu dialogue. A detailed description of the commands are given in section 2.1. The menu mode offers as- sistance to inexperienced users. An overview of this mode is discussed in section 2.2 and a more detailed description of the menu mode dialogue is given in section 2.3. The interactive user may switch freely between menu mode and command mode. When executing RIM interactively, the first output to your display will be: BEGIN RIM ---- VAX VERSION 5.0 UDXX YY/MM/DD HH.MM.SS RIM COMMAND MODE ENTER "MENU" FOR MENU MODE UDXX identifies the update level of RIM. The date and time stamp indicate current date and time. At the start of execution you are in the command mode but you may switch immediately to the menu mode as indicated. .PG 2.1 RIM COMMANDS This section presents a summary of the RIM commands. You are restricted from using certain commands based on the knowledge of assigned passwords. If no passwords are assigned to the relations by the data base owner, there are no command restrictions (the DEFINE submodule excepted). See figure 2.1-1. 2.1.1 General Commands .INDEX HELP Command HELP Command The HELP command allows you to obtain: a description of the available RIM commands, a discussion of the general command syntax, a summary of all available commands, and general news about the RIM system. HELP is available at any time during execution except when in the menu mode. To receive help when in the command mode enter: HELP [{command name}] RIM SYNTAX WHERE SUMMARY NEWS SORT INPUT FORMAT .PG CURRENT PASSWORD SECTION NUMBER COMMAND OWNER MODIFY READ NONE . 2.4.1 . GENERAL X X X X . 2.4.2 . DEFINE X . 2.4.3 . LOAD X X . 2.4.4 . DATA BASE QUERY X X X . 2.4.5 . SCHEMA QUERY X X 2 X 2 . 2.4.6 . COMPUTATION X X X . 2.4.7 . DATA BASE MODIFICATION X X . 2.4.8 . SCHEMA MODIFICATION X X 1 . 2.4.9 . RELATIONAL ALGEBRA X X . 2.4.10 . REPORT GENERATION X X X . 2.4.11 . COMMUNICATION X X 1 EXCEPT CHANGE OWNER 2 EXCEPT PRINT RULES .PG The HELP submodule available inside the HELP submodule are identical to the HELP commands except that the keyword HELP is omitted. The HELP submodule displays information one screen at a time. After each screen you will have the option to continue displaying the text by entering * or to return to the HELP submodule by entering QUIT. You will remain in the submodule until you enter an END command which will return to the command mode. .INDEX MENU Command MENU Command The MENU command places you in the menu mode. It may be entered at any point when in command mode except when in the DEFINE, HELP, or LOAD submodules. The menu mode is particularly useful for schema definition and data loading. MENU .PG .INDEX OPEN Command OPEN Command The OPEN command is required whenever an existing data base is to be used. You specify the name of the data base. RIM uses the name of the data base to form the names of the three files which contain the data base. The data base files must either reside in your dictionary or you must make a logical file assignment prior to RIM execution. OPEN dbname Only one RIM data base may be open at a time (if you don't close the present data base before opening a new one, RIM will auto- matically close the present data base.) The OPEN command must be issued before any commands that require data from the data base can be processed. .INDEX CLOSE Command CLOSE Command The CLOSE command permits you to close a RIM data base without leaving RIM. This enables you to close one data base, then open or define a different one, all within one RIM session. This command is not needed if only one RIM data base is acces- sed during a RIM session. This command results in update of the data base files to reflect all changes you have made to the data base. CLOSE Note: the current data base will be closed for you when you leave RIM by issuing an EXIT command. .INDEX USER Command USER Command This command is used to specify your user password to RIM. Your user password is used to check against read and modify passwords specified for the relations. Each time this com- mand is issued, the new password replaces the current user password. The default password is the word NONE. USER password .INDEX INPUT Command INPUT Command This command is used to specify the name of a file which contains the RIM commands and/or input data. Alternate input file names may be assigned as often as required. The use of this command allows you to define command pro- cedures on a file and then have RIM execute the set of commands without user interaction. INPUT filename .PG The last command on the alternate input file should be INPUT INPUT which returns input to the batch input file or your terminal. INPUT TERMINAL will, for interactive jobs, do the same thing. .INDEX OUTPUT Command OUTPUT Command This command is used to specify the name of the output file. Specifying a file other than OUTPUT will result in the output from the RIM commands being placed on the specified file name. The output file name may be changed as often as desired. The use of this command allows the interactive user to get an offline hardcopy output from RIM. OUTPUT filename OUTPUT OUTPUT will return the output to the batch output file or your terminal. OUTPUT TERMINAL will, for interactive jobs, do the same thing. .INDEX ECHO Command ECHO Command This command is used to control the printing of your input commands on the output file. Default is for ECHO printing enter: ECHO .INDEX NOECHO Command NOECHO Command The NOECHO command turns off ECHO printing. NOECHO .INDEX TOLERANCE Command TOLERANCE Command For attributes which contain floating point numbers, a tolerance may be used to qualify equality, nonequality and order. The tol- erance applies to any real or double precision number you use in a WHERE clause. If A is an attribute with value a, and r is a user specified number used in a WHERE clause, and t a tolerance (posi- tive, zero, negative), the following are true conditions: A EQ r if and only if r-t <= a <= r+t A NE r if and only if a < r-t or a > r+t A GT r if and only if a > r-t A GE r if and only if a => r-t A LT r if and only if a < r+t .PG A LE r if and only if a <= r+t If t is a percentage tolerance, t is to be replaced with t x r/100 in the above expressions to define true conditions for percentage tolerances. TOLERANCE tol [PERCENT] where tol is the tolerance and the presence or absence of the keyword PERCENT indicates whether tol is a percentage tolerance or an absolute tolerance. The TOLERANCE command can be used as many times as desired to reset the tolerance. A tolerance stays in effect for a session until a new tolerance is speci- fied. The default value for tolerance is 0. . .INDEX NOCHECK Command NOCHECK Command Rule checking applies to the CHANGE and LOAD commands. Default is that rules, if defined, are enforced. The NOCHECK command suppresses the ruler checking. NOCHECK CHECK command The CHECK command turns on rule checking. The CHECK and NOCHECK commands may be issued as many times as required anywhere in the input stream. CHECK .INDEX EXIT Command EXIT Command To leave RIM without dropping your current data base enter: {EXIT} QUIT This command closes your current data base. Data needed by your data bases is copied from the incore working areas to the logical files whose names were determined by the OPEN command or by the data base name designated in the DEFINE submodule. .INDEX RELOAD Command RELOAD Command The RELOAD command is used whenever you want to rebuild the data files of your data base to recover unused space created by row deletions, relation removals, and certain attribute changes. When a row is deleted or a relation removed, its space is not reused until you issue this command. In addition, if a variable length .PG attribute is modified so that it increases in length, the row is deleted and replaced with a new one. the old row becomes unused space. If your data base has any KEY attributes, then the access pointer files maintained for those attributes are also rebuilt. The syntax for the command is: RELOAD 2.1.2 Define Submodule Commands .INDEX Define Submodule Commands Define Submodule Commands The Define submodule (prompt = D> ) commands are used to define the structure of the data base and are used in the sequence described below. The definition of the data base is called the schema. The schema name is the name of the data base and forms the essential part of the names of the files used for the data base. Attributes, relations, passwords, and constraints (rules) are defined using this submodule. The naming conventions for schema definition are described in section 2.3.3. To access this submodule enter: DEFINE dbname You must identify the name of the data base whose definition you are going to create or expand by specifying the schema name. This name is used to form the name of the files used to store the data base tables. The dbname, when augmented with a single number must be a legal filename. Once dbname is specified you must identify the owner password of the definition. .INDEX OWNER password OWNER password If the data base already exists and you want to define additional attributes or relations, "password" is checked against the existing owner password. .INDEX ATTRIBUTES ATTRIBUTES attname type1 [{length}] [KEY] VAR attname type2 [{row,col}] [KEY] row,VAR VAR,VAR -- -- -- .PG The attribute definitions are ended when you specify one of the keywords RELATIONS, PASSWORDS or RULES .INDEX Type1 Attributes Type1 Attributes: RIM supports seven data types of "type1": real (floating point), integer, text, double precision, real vectors, integer vectors and double precision vectors. You must enter REAL, INT, TEXT, DOUB, RVEC,IVEC or DVEC for type1. The default length is one number, except for TEXT for which it is 8 characters. The length is speci- fied in number of values and characters respectively. VAR indicates variable length. The optional KEY specification causes an index file to be built for the attributes which is used by RIM to quickly find qualifying rows for retrievals and updates. The default is that such an index file is not built (non-key attribute). You should consider the cost of building and storing index file data versus the benefits you will obtain from quicker retrievals when deciding if a KEY declara- tion should be used. No specific rules can be given here, experience should be used to judge. An attribute can be changed from KEY to NON- KEY or vice-versa by using the BUILD KEY and DELETE KEY commands des- cribed in section 2.1.8. For large data bases (more than 1,000 rows) , experience has shown that it is most efficient not to specify a KEY in the DEFINE submodule but rather to load the data without keys and to later cause index files to be built using the BUILD KEY command. The greater the number of keys, the more efficient this method is. .INDEX Type2 Attributes Type2 Attributes: RIM supports three data types of "type2": real matrices, integer matrices or double precision matrices. You must enter RMAT, IMAT or DMAT for type2. The matrices can be of fixed size, have variable column dimension or variable row and column dimensions. You enter the row dimension first, followed by the column dimension. Default dimension is 1x1. The key-word KEY has the same meaning as for "type1" attributes. .INDEX Define RELATIONS To define relations enter: RELATIONS relname WITH attname1 [attname2...] - - - The relation definitions are ended by specifying one of the key- words ATTRIBUTES, PASSWORDS, RULES, or END which start the other sections of the DEFINE submodule or finishes the schema definition. .PG The attributes must be listed in the order in which they are to appear in the relation. No attributes can be used which have not been previously defined, either in the current attributes definition subsection or in a previous definition of this data base. Attri- butes which are defined but not included in a relation will not be- come part of the RIM schema. A RIM data base must have attributes and relations defined, but passwords and constraint rules are optional. If read or modify passwords are desired enter: PASSWORDS {READ PASSWORD} FOR relname IS password RPW {MODIFY PASSWORD} FOR relname IS password MPW - - - The password definitions are ended by specifying one of the key- words ATTRIBUTES, RELATIONS, RULES, or END which start the other sections of the DEFINE submodule or finishes the data base defini- tion. Passwords can be any string of alphanumeric characters up to 8 characters long. When you are doing queries, loads, or modi- fications, the current password is specified by the USER command. If this password does not match the read, modify, or owner pass- word for a given relation, you can query that relation. If this password does not match the modify or owner password, you cannot load or modify the relation. Constraint rules are another optional section of the DEFINE sub- module. If rules are specified, they are used during the loading process or during CHANGE commands to screen out rows which do not meet the constraint rules. Rules are specified by relation. At most 10 rules may be specified for a single relation. There are several options available in the rule definition section. To define constraint rules enter: .INDEX Define RULES RULES attname [IN relname] {EQ} value [ {AND} attname ...] NE OR GT GE LT LE or .PG attname1 IN relname {EQA} attname [ {AND} ...] NEA OR GTA LTA LEA where: EQ = Equals NE = Not equal to GT = Greater than GE = Greater than or equal to LT = Less than LE = Less than or equal to EQA = Equals attribute NEA = Not equal to attribute LTA = Less than attribute LEA = Less than or equal to attribute The rule definitions are ended by specifying one of the key- words ATTRIBUTES, RELATIONS, PASSWORDS, or END which start the other sections of the DEFINE submodule or finishes the schema definition. Attributes referenced in the rule defini- tions must have been previously defined. By specifying rules, you can restrict an attribute to a range of values or require that the value of an attribute in one relation have a specified relationship to the values of an attribute in the same or different relation. The comparison operators ending in A are used when the comparison is to existing attribute values rather than to a specified constant. A rule expression may contain a maximum of 9 Boolean operators. The method used for constraint checking is that the first attribute mentioned in the rule is taken from the input (LOAD or CHANGE command) data and checked against the re- mainder of the rule expression using existing values in the data base. To finish the schema definition you enter the following keyword and leave the DEFINE submodule: END .INDEX Define Submodule Commands Example of DEFINE submodule commands: DEFINE RIMDS OWNER ME ATTRIBUTES MODEL TEXT KEY WEIGHT REAL NUMPASS INT CARRIER TEXT FLIGHTNO INT .PG NAME TEXT KEY AGE INT UPDATE IMAT 4,VAR RELATIONS AIRPLANE WITH MODEL WEIGHT NUMPASS FLIGHTS WITH CARRIER FLIGHTNO MODEL UPDATE PEOPLE WITH NAME AGE PASSWORDS MPW FOR FLIGHTS IS AGENT RPW FOR PEOPLE IS BLUE RULES MODEL IN FLIGHTS EQA MODEL IN AIRPLANE AGE GT 21 AND AGE LT 65 NUMPASS IN AIRPLANE LE 350 .INDEX Load Submodule Commands 2.1.3 Load Submodule Commands The LOAD submodule (prompt = L>) commands are used to add rows to a newly defined relation or to add rows to a relation which already contains data. To access this submodule enter: LOAD relname You may now load rows into the relation, one row at a time, by entering data values in an order corresponding to the attribute order: value1 value2 ... valuen .PG The method used to input values for the different attribute types is shown below: Attribute Length or Type Dimension Valuei Remark REAL,INT n n=>1 (val1 ... valn) Parentheses DOUB,RVEC optional IVEC,DVEC REAL,INT VAR (val1 val2 ...) Parentheses DOUB,RVEC required IVEC,DVEC TEXT any "text string" In many cases, (see section 1.3) " " is optional RMAT,IMAT m,n ((r1c1...rmc1)(r1c2...) + Columnwise DMAT ...rmcn)) Parentheses optional RMAT,IMAT m,VAR ((r1c1...) (r1c2...)...)) Columnwise DMAT or Parentheses VAR,VAR required ------------------------------------------------------------------------ To finish data loading you enter: END Multiple relations may be loaded from within the LOAD submodule by re-entering the LOAD command instead of the END command. Example of LOAD submodule commands: USER AGENT LOAD AIRPLANE DC9 87000. 110 747SP 200000. 350 LOAD PEOPLE BOB 30 JOE 32 ALICE 29 LOAD FLIGHTS UAL 16 "757" ((1,2,3,4) (4,5,6,7)) *3 ((2,4,5,8)(1,2,3,4) (4,5,6,7)) END .PG If the value for an attribute is unknown, you enter the characters --0- for the missing value or use two successive commas. L1011 -0- -0- 250 L1011,,,250 These two input entries have identical meaning. 2.1.4 Commands for Querying the Data Base .INDEX SELECT command SELECT Command The SELECT command is used for displaying or printing data from one relation. It has many options. To print all the data from a relation: SELECT ALL FROM relname To print selected attribute values from all rows in a relation: SELECT attname1 [ attname2 ... attnamen ] FROM relname The above command will print up to 20 attributes in any order. The number of attributes is limited by space available in a line. As a rule of thumb, 7 attributes may be selected when running at an 80 character interactive terminal and 11 when running in the batch mode or at an 132 character terminal. For variable length attributes or for attributes of fixed length that would otherwise not fit on aline alone or together with other attributes, you may format the output using the optional field width control: SELECT attname1 [ =fw1 ] [ attname2 [ =fw2 ] ... ] + FROM fwi is the output field width for attnamei. For a text type attribute, fwi is the width of the output paragraph in number of characters, for other attribute types it is the number of values. When the field width option is used, RIM will use as many output lines as required for each row. Defaults are rather complex. For a fixed length attribute, other than matrix, no paragraphing is attempted. For a fixed length matrix, the default paragraph width is a full row. The system will use the field width required to display the value(s) of the attribute. For a variable length attribute of type TEXT, the default is a display of a maximum of 40 characters with paragraphing. For variable length attributes of types REAL, INT, DOUB, the default is 4 elements with truncation. For variable .PG length vector type attributes, the default is 4 elements with paragraphing (no truncation). For variable length matrix at- tributes the default is 4 elements with paragraphing (no trun- cation). A row starts on a new line. Whether field width is specified or not, the system will display the dimension of variable length vectors and matrices using one of the output positions. However, should you specify a width of one for such an attribute, the row and column dimensions will not be displayed. Further information about line width, number of lines per page, defaults and user specifications is given in section 2.1.10 as part of the RIM report writing features. When paragraphing TEXT type attributes, RIM will identify sub- strings of text separated by blanks. The substring is placed on the current line if there is space available. If the current line contains less than four characters, the number of characters that fit on the line are removed from (the front of) the substring and put on the line (without hyphen) and continued on the next line. If the current line contains more than four characters, the substring will be placed on the next line. .INDEX SELECT command Examples of SELECT command: SELECT ivecvar FROM rel1 DIM IVECVAR ------------------------------------ 7 1 2 3 4 5 6 7 1 10 SELECT imatvv FROM rel1 ROW COL IMATVV ---------------------------------------- 2 5 11 12 13 14 15 21 22 23 24 25 1 1 11 .PG .INDEX SELECT command SELECT textv = 9 FROM rel 1 TEXTV ------------- THIS IS AN EXAMPL E OF WRAPAROUN D OF TEXT THIS IS ANOTHER EXAMPLE OF TEXT The attribute name attnamei may be replaced by its correspond- ing attribute number (attnum1). The attribute number is deter- mined by the position of the attribute in the relation. Specific elements of a vector or a matrix may also be designated. The general form of the unconditional SELECT command is: SELECT {attname1 [ = fw1 ]} [attname2 [= fw2] ...] + attnum1 [ = fw1 ] attname1(i) attname1(i,j) attnum1(i) attnum1(i,j) ALL FROM relname To print all attributes from a relation where certain conditions are met: SELECT ALL FROM relname WHERE condition1 [ {AND} condition2 ...] OR Up to ten conditions may be combined using the Boolean operators AND/OR. The conditions are combined from left to right. Each condition may be one of the following forms: attname EXISTS attname FAILS attname EQ MAX attname EQ MIN attname EQ value attname EQS value attname NE value attname GT value attname GE value attname LT value .PG attname LE value attname EQ list attname NE list attname1 EQA attname2 attname1 NEA attname2 attname1 GTA attname2 attname1 GEA attname2 attname1 LTA attname2 attname1 LEA attname2 ROWS EQ rownumber ROWS NE rownumber ROWS LT rownumber ROWS LE rownumber ROWS GE rownumber ROWS GT rownumber ROWS EQ list ROWS NE list LIMIT EQ number where: EQ = Equals EQS = Contains the text string NE = Not equals GT = Greater than GE = Greater than or equal to LT = Less than LE = Less than or equal to EQA = Equals attribute NEA = Not equals attribute GTA = Greater than attribute GEA = Greater than or equal to attribute LTA = Less than attribute LEA = Less than or equal to attribute MAX = Maximum value MIN = Minimum value Attname, attname1, attname2 may refer to an element of a vector or a matrix. When an attribute has been assigned a value, then EXISTS will qualify those attributes. If an attribute has not been assigned a value, but was loaded with -0-, then FAILS will qualify those attributes. MAX and MIN comparison can only be made for integer, real and double precision attributes of fixed length equal to 1. Value in a comparison statement must follow the rules of section 2.1.3 for vectors and matrices, i.e., if the attribute is of variable length or dimension, parentheses must be used to input a vector or a matrix value or a list of vector and matrix values. .PG EQS applies to text strings only. In such a comparison, value is a text string and the comparison is true if value is found as a substring anywhere within the attribute for which comparison is requested. NE comparison when applied to matrices or vectors is true if the length or dimension is different from the length or dimension of your specified comparison vector or matrix or if any vector or matrix elements differs. GT and LT comparisons for vector and matrix attributes are "lexicographical", i.e. a comparison is made element by element (columnwise for matrices) and continued until a true or false condition is detected. If no such condition is detected after the last element is checked, a false condition is assumed. Comparison is made only for vectors and matrices of the same sizes as comparison data. GE and LE comparisons for vector and matrix attributes are similar to GT and LT comparisons except it continues if an equal condi- tion is detected and if no condition is detected after the last element is checked, a true condition is assumed. Comparison rules for vector attributes apply also to real, integer and double precision attributes of fixed or variable length. A list is a simple list (a1, a2, a3,...,an) of values. The comparison key words ending in A are used when comparing the value of one attribute to the value of another attribute in the same row of the relation. ROWS refer to row numbers in a relation. Note that a relation is loaded in input row order but that subsequent operations (changes) to the data base may cause the order of the rows to change. When the LIMIT clause is used, only the first LIMIT number of the rows that otherwise would qualify will actually qualify. Processing the WHERE condition can be speeded up greatly if index processing is used. Index processing involves using the indices created for KEY attributes rather than looking at each row of a relation to find the rows qualified by the WHERE conditions. Index processing will be used when the following are all true: 1) The last condition uses an attribute which is KEY 2) The last condition uses EQ 3) The last condition is not combined by OR with the other conditions. .PG The output can be sorted by specifying sorting attributes. The sorting order is user specified with default low to high. SELECT ... FROM relname SORTED BY attname1 [ {=A} ] { attname2 [={A} ] ...] + D D [ WHERE ...] A and D stands for ascending and descending order respectively. If a sort on more than one attribute is requested, the output will first be ordered according to the first mentioned attribute. In case there are duplicates for the first sort attribute, these will be ordered by the second sort attribute, duplicates within this by the third and so on. A maximum of 5 sorts may be specified. When multiple attributes are used, ascending and descending order may be used in any combination. Variable length attributes may not be used as sort attributes. When fixed length attributes are used as sort attributes, only the first 20 characters and the first value is used for sort. All these options can be described using the following general syntax: SELECT {attname1 [ = fw1 ] [...attname [ = fwn ] ] } + attnum1... attname1(i)... attname1(i,j)... attnum1(i)... attnum1(i,j)... ALL FROM relname + [SORTED BY attname [{=A} ]... ] + D [WHERE condition1 [{AND} condition2 ... ]] OR If the sum of the lengths (or fwi) of the attributes requested exceeds the line capacity, the data line will be truncated. See section 2.1.10 for further expanation of line width control. .INDEX TALLY Command TALLY Command The TALLY command prints a tally for an attribute giving each unique value and the number of times it occurs in a relation. The tally is ordered ascending or descending per user input. Default is ascending. The WHERE clause is optional and uses the same syntax as in the SELECT command. TALLY attname [{=A}] FROM relname [ WHERE ... ] D .PG Examples of SELECT and TALLY commands: SELECT ALL FROM AIRPLANE SELECT MODEL FROM AIRPLANE SELECT ALL FROM AIRPLANE WHERE WEIGHT GT 100000. *8 AND NUMPASS LT 200 SELECT AGE FROM PEOPLE WHERE NAME EQ BOB SELECT ALL FROM AIRPLANE SORTED BY MODEL=D TALLY MODEL FROM FLIGHTS TALLY MODEL FROM FLIGHTS WHERE CARRIER EQ UNITED SELECT ALL FROM DIMENS WHERE HEIGHT GTA WIDTH SELECT FILE TITLE=4 OWNER FROM PFDATA 2.1.5 Commands for Querying the Schema When you use any of these commands, RIM will display only the data you are authorized to access according to your current user password. .INDEX LISTREL Command LISTREL Command The purpose of LISTREL is to provide you with information about the relations in the data base. There are three formats for the LISTREL command. The first consists of simply entering: LISTREL Using LISTREL in this fashion provides you with a list of all relations currently defined in your data base. If you wish to display the definition of a specific relation, then the syntax is: LISTREL relname The use of LISTREL in this manner also provides a count of the number of rows defined for the specified relation. LISTREL ALL This command (restricted by user password) will display the definitions of all relations in the data base, including counts of the number of defined rows in each relation. .INDEX EXHIBIT Command EXHIBIT Command The purpose of the EXHIBIT command is to allow you to query the RIM dictionary to obtain the names of all relations having a specific set of attributes. For example, if you want to know which relations contain the attribute attname you would enter: EXHIBIT attname .PG You would then obtain either a list of the relations having this attribute, or a message indicating that this attribute was not found in any relations in the data base. The EXHIBIT command also allows you to query fro a list of attributes(maximum of 10). Suppose that you wanted to know which relations contian both attname1 and attname2. The command would then be: EXHIBIT attname1 attname2 The general syntax of this command is: EXHIBIT attname1 [attname2 ... attnamen ] .INDEX PRINT RULES Command PRINT RULES Command This command can be used when the current user password matches the owner password of the data base definition. To obtain a complete list of all constraint rules enter: PRINT RULES 2.1.6 Computation Command .INDEX COMPUTE Command COMPUTE Command The COMPUTE command is used to compute simple functional values of an attribute. A WHERE clause is optional and uses the same syntax as is used in the SELECT command. COMPUTE {COUNT} attname FROM relname [WHERE... ] MAX MIN AVE SUM There are some restrictions as to the type and word length of the attribute when using these computed functions. All of these functions exclude any -0- values when making their computations. The following table describes the attribute type and length restrictions for each function: .PG FUNCTION ATTRIBUTE TYPE ATTRIBUTE LENGTH COUNT any any MIN any of fixed length 1 for non-text, <= for text MAX any of fixed length 1 for non-text, <= for text AVE int, real, double 1 SUM int, real, double 1 Examples of COMPUTE command: COMPUTE AVE NUMPASS FROM FLIGHTS COMPUTE MAX WEIGHT FROM FLIGHTS WHERE NUMPASS LT 100 COMPUTE COUNT NAME FROM PEOPLE WHERE AGE GT 30 2.1.7 Data Base Modification Commands These commands are used to change the contents of the data base. a modify or owner password correlation is required in order to use these commands. .INDEX CHANGE Command CHANGE Command The CHANGE command is used to change the value of an attribute in a relation where certain conditions are met. CHANGE {attname1} TO value [IN relname] WHERE ... attname(i) attname(i,j) Value has the same form as described in Section 2.1.3. The WHERE clause is required and uses the same syntax as in the SELECT command. If the relation name is not specified, the attribute is changed in all relations where the attribute is found and the conditions are met. .INDEX DELETE ROW Command DELETE ROW Command The DELETE ROW command is used to delete selected rows in a relation. DELETE ROW FROM relname WHERE ... The name of the relation must be specified as well as a WHERE clause. The syntax for the WHERE clause is the same as in the SELECT command. .INDEX DELETE DUPLICATES Command DELETE DUPLICATES Command This command is used to remove any duplicate rows from a relation. It is particularly useful on relations which have been created by any of the relational algebra commands (JOIN, INTERSECT, SUBTRACT, or PROJECT). The syntax for this command is: DELETE DUPLICATES [attname1, attname2,...] from relname Duplicates are checked only for the specified (combination of) attribute(s). Default is to check the complete row (all attributes). Examples of CHANGE, DELETE, and DELETE DUPLICATES commands: CHANGE NUMPASS TO 320 IN AIRPLANES WHERE MODEL EQ 747SP CHANGE NAME TO ROBERT WHERE NAME EQ BOB DELETE ROW FROM AIRPLANES WHERE MODEL EQ DC10 CHANGE STABILITY TO LOW IN DIMENSIONS WHERE HEIGHT GTA WIDTH DEL DUP NUMPASS FRO AIRPLANES 2.1.8 Schema Modification Commands These commands are used to change the data base schema definition. Except for the CHANGE OWNER command, a modify or owner password correlation is required in order to use these commands. .INDEX CHANGE OWNER Command CHANGE OWNER Command The CHANGE OWNER command is used to change the name of the data base password. Only the current owner is allowed to use this command. CHANGE OWNER TO newowner .INDEX RENAME Attribute Command RENAME Attribute Command The RENAME attribute command is used to change the name of an attribute in the data base definition (schema). RENAME attname1 TO attname2 [IN relname] THe old name is attname1 and the new name is attname2. if the name of the relation is not specified, then the name change takes place in every relation that contains the old name. If the relname is specified and attname1 occurs more than once, the first occurence will be changed. RULES and KEY(s) defined for attname1 will automatically be redefined to apply to attname2. Examples of RENAME command: RENAME MODEL TO VERSION IN AIRPLANES RENAME NUMPASS TO CAPACITY .PG .INDEX BUILD KEY Command BUILD KEY Command This command is used to change an attribute from non-key to KEY. An index is built from existing data values by amking a pass through current rows of the specified relation. This index is then used and maintained just as if the attribute had been declared to be KEY in the original data base definition. BUILD KEY FOR attname IN relname Keys are not transferred to relations created by relational algebra commands. .INDEX DELETE KEY Command DELETE KEY Command This command is used to change an attribute from KEY to non-key. The index file for that attribute is deactivated and no longer maintained or used once the attribute has been changed to non-key with this command. DELETE KEY FOR attname IN relname .INDEX CHANGE PASSWORD Command CHANGE PASSWORD Command The read or modify passwords may be changed by using the following command: CHANGE {RPW} TO newpass FOR relname MPW .INDEX RENAME RELATION Command RENAME RELATION Command You may change the name of a relation by using the following command: RENAME RELATION relname TO newname RULES applying to relname will automatically apply to newname. .INDEX REMOVE Command REMOVE Command The REMOVE command is used to remove a relation definition and its data from the data base. REMOVE relname .PG 2.1.9 Relational Algebra Command These commands allow you to create new relations from existing relations. All relational algebra commands require modify permission on the constituent relations. .INDEX INTERSECT Command INTERSECT Command The purpose of the INTERSECT command is to allow you to combine the rows of relations into a third relation based on common values within a set of specified attributes. The syntax of the INTERSECT command is: INTERSECT relname1 WITH relname2 FORMING relname3 + [USING attname1 [attname2 ... attnamen]] The USING clause identifies the attributes that form the resulting relation. The attributes used in the INTERSECT process are the subset of those identified by the USING clause which are present in both relations. For example, assume that you have the following two relations defined: REL-1 REL-2 NAME DEPT JOB DEPT JOB PAY ------ ----- ----- ----- ----- ---- BOB A ENGR A ENGR 800 JIM C SUPR B ENGR 450 BOB B ENGR C ENGR 750 RAY C ENGR You may INTERSECT two relations restricted to specific sets of attributes (the USING clause) or use all attributes of both relations. In either case RIM will identify the common attributes and use the common values within these attributes to identify the conditions for intersect generation. Suppose you want to INTERSECT the two relations using attributes DEPT, NAME, and JOB. The command for this would be: INTERSECT REL-1 WITH REL-2 FORMING REL-3 USING DEPT NAME JOB The result would be the new relation REL-3 shown on the next page. .PG REL-3 DEPT NAME JOB ---- ----- ----- A BOB ENGR B BOB ENGR C RAY ENGR In this example there are no duplicate rows in REL-3. However, it is possible that the intersect command will create duplicate rows. Since, in general, duplicate rows are not desired in a relation, they can be removed with the DELETE DUPLICATES command. Note also that by specifying which attributes the INTERSECT is using, you restrict the number of attributes in the resulting relation to only those specified in the USING clause. Suppose you want RIM to use all the attributes in the two relations. In this instance you would enter: INTERSECT REL-1 WITH REL-2 FORMING REL-4 The result would be REL-4 consisting of the attributes NAME, DEPT, JOB, and PAY, shown below in the resulting rows: REL-4 NAME DEPT JOB PAY ----- ----- ---- --- BOB A ENGR 800 BOB B ENGR 450 RAY C ENGR 750 There may be situations where an INTERSECT is impossible to perform. These include: 1) The name of the resulting relation already exists 2) The two relations have no common attributes 3) The attributes in the USING clause do not exist in the relation being intersected 4) The resulting relation exceeds 1021 words If any of the above situations is encountered, you are warned of the problem and the INTERSECT command processing is stopped. In the case where common attribute names exist but there are no matching values, the operation will be successful resulting in an empty relation (0 orws). .PG The INTERSECT command is a powerful tool and may be used as a step towards satisfying queries which require attributes from more than on relation. .INDEX JOIN Command JOIN Command The JOIN command is a function operating on two relations to form a third relation. The purpose of the JOIN is to juxtapose two relations based on a specified attribute from each. The result of the JOIN command is a third relation containing all of the attributes from both relations. Rows are generated in the new relation as a result of the comparison conditions between attributes being satisfied. The syntax of the JOIN command is: JOIN relname1 USING attname1 WITH relname 2 USING + attname2 FORMING relname3 [ WHERE {EQ} ] NE GT GE LT LE The WHERE clause of the JOIN command is different form the WHERE clause of the SELECT command. In JOIN it applies only to the comparison of the two attributes upon which JOIN is based. If the WHERE clause is omitted (default), EQ is used. The value of attname1 in the first row of relname11 is compared to all the values of attname2. Rows which qualify are generated in relname3. The value of attname1 in the second row of relname1 is compared to all the values of attname2, etc. Each row from relname1 may generate 0, 1, 2, or more rows in relname3. For example, consider the relations REL1 AND REL2: REL1 REL2 A B C D E ---- --- --- --- --- 1 2 3 3 1 4 5 6 6 2 7 8 9 The following JOIN command would produce the result shown. .PG JOIN REL1 USING B WITH REL2 USING D + FORMING REL3 WHERE LT REL3 A B C D E ---- --- --- --- --- 1 2 3 3 1 1 2 3 6 2 4 5 6 6 2 The JOIN will function correctly on any comparison providing that you compare attributes of the same data type. All attribute names in the resultant relation must be unique in order for you to obtain accurate results from subsequent commands using the relation. Any duplicate attribute names should be change using the RENAME command before doing queries or updates to the new relation. In the case of duplicate attribute names, RENAME when applied to a specific relation will change the first attribute name. There may be situations where a JOIN is impossible to perform. These may include: 1) The name of the resulting relation already exists 2) The attribute in the USING clause does not exist in the relation being joined 3) The attributes being compared are different data types or lengths 4) An attribute in either of the relations greater than 300 computer words 5) The resulting relation exceeds 1021 words If any of the above situations are encountered you are warned of the problem and the JOIN command processing is stopped. .INDEX PROJECT Command PROJECT Command The function of a PROJECT command is to create a new relation as a subset of an existing relation. You may want to create the new relation from the old one by removing attributes, removing rows, or both. The syntax for the PROJECT command is: PROJECT relname1 FROM relname2 USING {attname1...attnamen} + ALL [WHERE ...] The WHERE clause is optional but it is specified, it has the same syntax as in the SELECT command. You are required to specify which attributes are to be retained in the new relation. The old relation is relname2 and the new relation is relname1. .PG For example consider the following relation: PEOPLE EMPNUM EMPNAME BOSS POSITION GROUP ------- ------- ------ -------- ------ 2181 JONES SMITH MANAGER AADE 3964 ERICKSON BUSS APPL-MGR ACC 6543 GRAY PARKER ASST-MGR PHOTO 2233 SCHMITZ BUSS APPL-MGR ACC To create a new relation with EMPNAME and GROUP as the only attributes and where now rows contain PARKER as BOSS enter the command: PROJECT TEMP1 FROM PEOPLE USING EMPNAME GROUP + WHERE BOSS NE PARKER TEMP1 EMPNAME GROUP ------- ------ JONES AADE ERICKSON ACC SCHMITZ ACC The PROJECT command is useful to reduce the size of a relation when only a subset of the data is needed. RIM will not eliminate any duplicate rows formed in the new relation. You must do that yourself with the DELETE DUPLICATES command. There may be situations where a PROJECT is impossible to perform. These include: 1) The name of the resulting relation already exists 2) An attribute in the USING or WHERE clause is not in the relation .INDEX SUBTRACT Command SUBTRACT Command The SUBTRACT command is similar to the PROJECT command in that the new relation is a subset of an existing relation. The rows, however, are selected based on the data in another relation rather than on a WHERE clause within the same relation. Where the INTERSECT command looked for rows of two relations which matched up, the SUBTRACT command does just the opposite. It looks for rows in the relation which do not match any rows in the other relation. The syntax for the SUBTRACT command is: SUBTRACT relname1 FROM relname2 FORMING relname3 + [USING attname1 [attname2 ... attnamen]] .PG All rows in the new realtion will come from relname2. If the USING clause is not specified, then all attributes of relname2 will be attributes of relname3. Relname1 is the relation that rows of relname2 are checked against for matches. If a USING clause is specified at least one of the attributes in the clause must be common to both relations. As an example consider these two example relations: EMPDATA BOSSDATA EMPNUM EMPNAME BOSS BOSS POSITION GROUP ------- ------- ------ ------ -------- -------- 2181 JONES SMITH SMITH MANAGER AADE 3964 ERICKSON BUSS PARKER ASST-MGR PHOTO 6543 GRAY PARKER BUSS APPL-MGR ACC The following command will produce a new relation from EMPDATA: SUBTRACT BOSSDATA FROM EMPDATA FORMING TEMP USING + EMPNAME BOSS The resulting relation TEMP would contain only one row: TEMP EMPNAME BOSS ------- ----- BROWN WHITE There may be situations where a SUBTRACT is impossible to perform. These include: 1) The name of the resulting relation already exists 2) The relations have no common attributes 3) The number of attributes in the USING clause is greater than the number in relname1 4) An attribute in the USING clause is not in the relations 2.1.10 Report Generation Commands These commands establish a limited report generation capability. .PG .INDEX NEWPAGE Command NEWPAGE Command This command causes a new page to be issued. It applies to batch output only. The command is: NEWPAGE .INDEX BLANK Command BLANK Command Blank lines can be inserted into the output stream by using the command: BLANK n where n is the number of blank lines written. .INDEX TITLE Command TITLE Command The command: TITLE "titlestring" causes the text "titlestring" to be printed, centered on the line. If the length of "titlestring" is longer than current lines width it will be truncated and a warning issued. .INDEX DATE Command DATE Command The command: DATE will cause the current date to be printed, centered on the line. .INDEX LINES Command LINES Command This command controls the number of lines per page (exclusive of title.) The command is: LINES n will establish page size to n lines. Default is 56. .INDEX WIDTH Command WIDTH Command This command controls the width of a printed line. The command: WIDTH n will establish a line width of n characters. Default is 78 if output is to a terminal, 132 if output is to a batch printer. If n is specified to be less than 20, 20 will be used. .PG 2.1.11 Communication Command .INDEX UNLOAD Command UNLOAD Command The UNLOAD command permits you to off-load a portion or all of your data base onto a previously designated file (see OUTPUT command). The file will contain 80 characters text records and can be read by RIM as an input file on the same or on a different computer using the INPUT command. Default file name is for006. The syntax of this command is: UNLOAD [dbname = newname] {ALL } + SCHEMA DATA [relname1 [ mpw1 ] relname2 [ mpw2 ] ... ] Specifying SCHEMA will off-load the schema of your data base, DATA will off-load the data of your data base and ALL will off-load both schema and data. Optionally, you may rename your data base by entering dbname =newname where dbname is the name of the currently open data base. By specifying relation names, you will only off-load data and/or schemas for the specific relations. The modify password does not allow you to modify access to the relation. There are implicit password restrictions to the unload command as follows: If you are the data base owner, you may off-load any data and/or schema. If you are not the owner, you may off-load data and/or schema for the relations for which you have modify access permission. Your password becomes the owner of the off-loaded data base. Rules, if any, will only be off-loaded if you are the owner of the data base and you have used the option ALL. .PG 2.2 MENU MODE EXECUTION OVERVIEW The RIM menu mode provides you with the capability to build the schema for a new data base and to update an existing data base definition. The options (create, update, query, command, and exit) available in menu mode are shown in figure 2.2-1. Executions may be terminated at anytime by entering the word QUIT. EXIT, in response to an input prompt, will return you to the top menu. The data base will be purged following a QUIT command. .PG l----------------l l BEGIN RIM 5.0 l l----------------l l l RIM COMMAND MODE ENTER "MENU" FOR MENU MODE R>MENU l l l SELECT THE EXECUTION OPTION DESIRED 1) CREATE A NEW DATABASE 2) UPDATE AN EXISTING DATABASE 3) QUERY AN EXISTING DATABASE 4) ENTER COMMAND MODE 5) EXIT l l------------------------------------------------l l l l l l l l l l l CREATE OPTION l QUERY OPTION l EXIT SECTION 2.2.1 l SECTION 2.2.3 l SECTION 2.1.1 l l UPDATE OPTION COMMAND MODE SECTION 2.2.2 SECTION 2.1 Figure 2.2-1 Section References for the Menu Mode Options .PG .INDEX Data Base Creation Option 2.2.1 Data Base Creation Option The purpose of this option is to construct a schema by prompting you for the data base, owner, the names of the relations, their associated attributes and read/modify passwords. After compilation of the schema, you have the opportunity to interactively load the data base and/or query the data base. In the command mode, you have available the full set of RIM commands (section 2.1) allowing the direct definition of the schema using the DEFINE submodule commands and the loading of the data base using the LOAD submodule commands. .INDEX Data Base Update Option 2.2.2 Data Base Update Option With this option you may add/modify relations and/or load additional data into the data base. If additional relations are desired, you are prompted for the names of the relations, their associated attributes and read/modify passwords. If additional data is to be loaded, the list of relations in the data base is displayed and your enter the required data. Removal or modification of data in the data base is done using the RIM data base modification commands. In this command mode, you have available the full set of RIM commands (section 2.1) allowing the direct addition of relations using the DEFINE submodule commands and the loading of data using the LOAD submodule commands. The data base modification commands are used to update existing data. .INDEX Query Option 2.2.3 Query Option With this option you are prompted for the data base name. The full set of RIM commands (section 2.1) is available to you for data base query. In addition to query, all other data base activities are available through the RIM command mode. .PG 2.3 RIM MENU MODE INTERACTIVE DIALOGUE This section presents the questions and menus that appear in the menu mode. The response options are also discussed. The menu mode is accessed by entering MENU anytime in the command mode when a R> prompt is present. 2.3.1 General Option and Questions SELECT THE EXECUTION OPTIION DESIRED 1) CREATE A NEW DATA BASE 2) UPDATE AN EXISTING DATA BASE 3) QUERY AN EXISTING DATA BASE 4) ENTER COMMAND MODE 5) EXIT SELECT THE UPDATE OPTION DESIRED 1) DEFINE ADDITIONAL RELATIONS 2) LOAD ADDITIONAL DATA The desired update option is selected by entering either the integer 1, allowing the definition of additional relations, or 2, allowing the loading of additional data into the data base. DO YOU WANT TO QUERY THE DATA BASE AT THIS TIME--Y OR N You may switch to the command mode for query by entering "Y". If the query option is not desired "N". 2.3.2 Data Base Files ENTER THE NAME OF THE DATA BASE The 1-6 character alphanumeric name assigned to the data base is entered here. The name is used to create the names of the logical files that contain the data base. .PG 2.3.3 Schema Definitions ENTER THE NAME OF THE DATA BASE The 1-6 character alphanumeric name assigned to the data base is entered here. All future references to this data will be via the assigned data base name. ENTER THE NAME OF THE DATA BASE OWNER The 1-8 character alphanumeric name of the data base owner is entered here. This name is used as the schema password. Additional schema definitions will not be permitted unless the user password matches the owner password assigned here. ENTER THE NAME ASSIGNED TO THIS RELATION A 1-8 character alphanumeric name assigned to the relation being defined. ENTER THE READ PASSWORD FOR THIS RELATION A 1-8 character alphanumeric string assigned by the owner as the read password for the relation being defined. if the owner has assigned a read password the user password must match in order to query the relation. If no read password is desired enter NONE. ENTER THE MODIFY PASSWORD FOR THIS RELATION A 1-8 character alphanumeric string by the owner as the modify password for the relation being defined. if the owner has assigned a modify password the user password must match in order to load or modify the relation. if no read password is desired enter NONE. ENTER THE ATTRIBUTES OF THIS RELATION ENTER END WHEN COMPLETE attname type length (IF >) "KEY" (IF KEY) Attname = 1-8 character alphanumeric string identifying the attribute being defined. .PG Type = INT (Integer) REAL (Real) TEXT (Text) DOUB (Double Precision) RVEC (Real Vector) IVEC (Integer Vector) DVEC (Double Precision Vector) RMAT (Real Matrix) IMAT (Integer Matrix) DMAT (Double Precision Matrix) Length = number of characters (text) or number of values (all others) 1,2,3 ..., etc., or VAR INT TEXT REAL DOUB RVEC IVEC DVEC row, column or RMAT row, VAR or IMAT VAR, VAR DMAT A variable length (or length greater than one) INT, REAL, or DOUB can be considered to be functionally identical to IVEC, RVEC, or DVEC. KEY = the word key indicates the attribute is key. Example: To define a text string attribute (TEXTST) of 60 characters, a real attribute (TEXTST) of 60 characters, a real attribute (REAL1), an integer key attribute (INT-1), and a real matrix with dimensions 6x8 (MAT68), the following entries would be made: R> TEXTST TEXT 60 R> REAL1 REAL R> INT-1 INT KEY R> MAT68 RMAT 6,8 To end the definition of the attributes for this relation, the word "END" is entered. DO YOU HAVE ADDITIONAL RELATIONS TO DEFINE--Y OR N Additional relations may be defined by entering the character "Y". If no additional relations are to be defined at this time, enter "N". .PG 2.3.4 Data Base Loading DO YOU WANT TO LOAD THE DATA BASE--Y OR N The data base is available for data loading if desired. Enter "Y" if you want to load the data base at this time. Enter "N" if no data is to be loaded. SELECT THE RELATION TO BE LOADED The relations defined in the data base will be listed. You select the relation to be loaded by entering the integer corresponding to the desired relation. ENTER THE MODIFY PASSWORD FOR THIS RELATION No data loading will be allowed for the selected relation unless the proper modify password is entered here. ENTER THE ATTRIBUTE VALUES IN THE SPECIFIED SEQUENCE ENTER END WHEN COMPLETE Entering data values at this point loads the data base. The values are entered in the order indicated and the value entered must correspond to the attribute type. If a text string contains embedded blanks, or commas, or if entirely numeric text is entered, it must be enclosed in quotation marks . Unused trailing characters in fixed length text strings will be blank filled. It is recommended that leading blanks not be used in text strings. If vectors or matrices are loaded, all values must be specified. Enter "END" when data loading is complete. It is recommended that large data bases and data bases that have vectors and matrices use the application program interface for loading data. DO YOU HAVE ADDITIONAL RELATIONS TO LOAD--Y OR N If you want to load another relation, enter "Y". If all the data base to be loaded at this time has been loaded, enter "N". .PG 3.0 RIM EXECUTION THROUGH THE APPLICATION PROGRAM INTERFACE Any programming language which can call FORTRAN subroutines can access and modify a pre-defined RIM data base through FORTRAN-callable subroutines contained in the RIM application program interface library(RIMLIB). Data is accessed one row at a time. The RIM data access subroutines store data in and retrieve data from an array you provide in your program logic. In either case the array used must be large enough to hold one complete row for each relation accessed. Attributes which contain text data must be given particular care. In general, Hollerith format (left adjusted, blank filled) is used. Some textual parameters like those for data base, relation and attribute names must allow for eight characters (8H), others like key words such as INT, REAL etc. must allow room for four characters (4H). Values of textual attributes or text strings used in conditional expressions are passed in an array packed together with other kinds of information. Such text strings are left adjusted with unspecified fill. The number of words such text strings occupy depends upon the length of the text string. there are special instructions in appropriate sections on how to pass such attributes. The application program interface requires you to manage the data base files. The data base files must exist on three properly named logical files before your program can be executed. Password checks operate in the application program interface in much the same way as in the standalone system. No password permission is requird for RMOPEN, RMUSER, RMRULE, or RMTOL. Read permission is required for all other calls except RMLOAD and RMPUT for which modify permission is required. Modify permission implies read permission. 3.1 INITIALIZING THE DATA BASE CALL RMOPEN (abname) --------------------- Input parameter: Dbname-- the name of the data base in Hollerith format This routine initializes the internal tables used by RIM and opens the specified data base by reading the data base control information into the incore working areas. .PG CALL RMCLOS ----------- This routine closes the current data base and copies the incore working areas to the logical data base files. This routine is required (if you have modified the data base) before your program can access another data base. 3.2 STATUS OF DATA BASE ACTIVITY When an operation on the data base has been attempted, the status of the operation is returned to the application program via the RMSTAT variable in the RIMCOM common block. This common block must be declared in the calling program as follows: COMMON /RIMCOM/ RMSTAT INTEGER RMSTAT The value of RMSTAT should be checked after each operation. A non-zero value indicates the operation was not successful. as a result, subsequent operations may not function as expected. The RMSTAT values and meanings are as follows: -1 NO MORE DATA AVAILABLE FOR RETRIEVAL 0 OK - OPERATION SUCCESSFUL 10 DATA BASE FILES DO NOT CONTAIN A RIM DATA BASE 11 DATA BASE NAME DOES NOT MATCH FILE CONTENTS 12 INCOMPATIBLE DATA BASE FILES (DATE,TIME,ETC) 13 DATA BASE IS ATTACHED IN READ ONLY MODE 14 DATA BASE IS BEING UPDATED 15 DATA BASE FILES ARE NOT LOCAL FILES 16 DATA BASE HAS BEEN OPENED 20 UNDEFINED RELATION 30 UNDEFINED ATTRIBUTE 40 MORE THAN 10 AND/OR OPERATORS IN THE WHERE CLAUSE 41 ILLEGAL "LIMIT EQ N" CONDITION 42 UNRECOGNIZED COMPARISON OPERATOR 43 EQS ONLY AVAILABLE FOR TEXT ATTRIBUTES 44 ILLEGAL USE OF MIN/MAX IN THE WHERE CLAUSE 45 UNRECOGNIZED AN/OR OPERATOR 46 COMPARED ATTRIBUTES MUST BE THE SAME TYPE/LENGTH 47 LISTS ARE VALID ONLY FOR EQ AND NE 50 RMFIND NOT CALLED 60 RMGET NOT CALLED 70 RELATION REFERENCE NUMBER OUT OF RANGE 80 VARIABLE LENGTH ATTRIBUTES MAY NOT BE SORTED 81 THE NUMBER OF SORTED ATTRIBUTES IS TOO LARGE 89 SORT SYSTEM ERROR 90 UNAUTHORIZED RELATION ACCESS 100 ILLEGAL VARIABLE LENGTH ROW DEFINITION (LOAD/PUT) 110 UNRECOGNIZED RULE RELATIONS 111 MORE THAN 10 RULES PER RELATION .PG THE FOLLOWING CODES SHOULD NOT BE ENCOUNTERED IN NORMAL USE 1001 BUFFER SIZE PROBLEM - BLKCHG,BLKDEF 1002 UNDEFINED BLOCK - BLKLOC 1003 CANNOT FIND A LARGER B-TREE VALUE - BTADD,PUTDAT 1004 CANNOT FIND B-TREE BLOCK - BTPUT 21XX RANDOM FILE ERROR XX ON FILE1 22XX RANDOM FILE ERROR XX ON FILE2 23XX RANDOM FILE ERROR XX ON FILE3 24XX RANDOM FILE ERROR XX ON FILE4 3.3 GENERAL ROUTINES The following routines are used to set the internal switches for rule checking, to specify the data base passwords, and to set the tolerance for real numbers. These routines may be called any number of times with the new value overwriting the current value. CALL RMUSER (password) --------------------- Input Parameters: password--the password in Hollerith (8H). This routine is used to provide the password necessary for checking data base access, relation read permission and relation modify premission. CALL RMRULE (switch) ------------------- Input Parameters: switch--- 0 no rule checking (NOCHECK RULES) (int) 1 check rules (CHECK RULES) This routine turns rule checking on and off (default--on if rules are defined). CALL RMTOL (val,percent) ------------------------ Input Parameters: val------the value of the tolerance (real) percent--0 if "val" is the absolute tolerance value (int) 1 if "val" is the tolerance percent This routine sets the tolerance for floating point numbers, (default: 0.). .PG 3.4 ACCESSING THE SCHEMA The following routines are used to obtain information about the data base schema. CALL RMLREL ----------- This routine sets an implicit pointer (used by the routine RMGREL) to the first relation in the data base. it must be called before data about any relations may be obtained. If there are no relations defined for which the current user password has read permission, RMSTAT will return 90, otherwise 0. CALL RMGREL (rname,row,mpw,lastmod,numatt,numrows) Output Parameters: rname---relation name (8H) rpw-----read password (.TRUE. or .FALSE.) mpw-----modify password (.TRUE. or .FALSE.) lastmod-date of last modification of relation data (8H) numatt--number of attributes in the relation (int) numrows-number of rows of data in the relation (int) This routine returns the data about the current relation (the relation indicated by the current pointers) and the increments the implied pointer to point to the next relation for which read permission is available. A successful execution of this routine sets RMSTAT equal to 0. I f you change passwords between calls to RMLREL and RMGREL or between successive calls to RMGREL, unpredictable results may occur. When the last relation is accessed RMSTAT will be set to -1. The following example shows how to use RMLREL and RMGREL to obtain the data about all relations in the data base. . . . COMMON /RIMCOM/ RMSTAT INTEGER RMSTAT . . . CALL RMOPEN (dbname) CALL RMUSER (password) . . . CALL RMLREL IF (RMSTAT.EQ.0) GO TO 100 . . .PG . print message that no relations are available using the current password . . . GO TO 200 100 CONTINUE CALL RMGREL(rname,rpw,mpw,lastmod,numatt,numrows) . . . printout the data about the relation, etc.......... . . . GO TO 100 200 CONTINUE . . . CALL RMLATT (rname) ------------------ Input Parameters: rname --- relation name (8H) This routine sets an implied pointer to the first attribute of the specified relation. if the relation exists and the current password allows access to relational data, RMSTAT will return 0. CALL RMGATT(aname,type,matvec,var,len1,len2,column,key) ------------------------------------------------------- Output Parameters: aname---attribute name (8H) type----attribute type (INT,REAL,DOUB,TEXT) (4H) matvec--attribute type (VEC or MAT -otherwise blank)(4H) var-----variable length attribute (.TRUE. or .FALSE.) len1----attribute length data as follows (int): TEXT-number of characters INT,REAL,DOUB,VEC-number of items MAT-row dimension len2----column location in the relation (int) (otherwise 0) (int) column--attribute column location in the relation (int) key-----keyed attribute (.TRUE. or .FALSE.) .PG This routine returns the data about the current attribute (the attribute indicated by the implied pointer) and increments the implied pointer to point to the next attribute. When the last attribute is accessed, RMSTAT will return -1. The following example shows the use of RMLREL,RMGREL,RMLATT, and RMGATT to obtain the data about all attributes for all realtions. (the equivalent of LISTREL ALL) . . . COMMON /RIMCOM/ RMSTAT INTEGER RMSTAT . . . CALL RMOPEN(dbname) CALL RMUSER(password) . . . CALL RMLREL 100 CONTINUE CALL RMGREL(rname,rpw,mpw,lastmod,numatt,numrows) IF (RMSTAT.NE.0) GO TO 300 CALL RMLATT(rname) DO 200 K=1,numatt CALL RMGATT(aname,type,matvec,var,len1,len2,column,key) IF(RMSTAT.NE.0) GO TO 300 . . . printout the relation and attribute data, etc.......... . . . 200 CONTINUE GO TO 300 300 CONTINUE . . . .PG 3.5 ACCESSING THE DATA BASE The routines which access the data base allow the following operations: 1) GET an existing row of data from aspecified relation and store it in a local array (must be preceded by a RMFIND). 2) LOAD a new row of data from a local array to the bottom of a specified relation (must be preceded by a RMFIND). 3) PUT an existing row of data back into a specified relation after it has been modified (must be preceded by a RMFIND, RMGET). 4) DELETE an existing row of data from a specified relation (must be preceded by a RMFIND, RMGET). Each of the above operations works on one row of data at a time. RMGET increments the pointers to point to the next row. The initial pointers must be established before the required operation can be performed (RMFIND). The rows returned may be qualified with a WHERE clause (default - all rows) and the rows may also be returned in a sorted order (RMGET only). To support concurrent access to multiple relation, a parameter is provided to allow the assigning of a number to identify the set of pointers for a given relation. In this way the operations on the data base are related to a number which in turn corresponds to the pointers for a single relation. CALL RMFIND (number,relname) ---------------------------- Input Parameters: number---number (0-5) assigns a pointer for the relation (int) relname--relation name (8H) This routine establishes the initial pointer number for a relation. A call to RMFIND must be made before calls to RMGET, RMWHER, RMLOAD, and RMSORT. .PG CALL RMWHER (number,attname,operator,value,numval,nextboo,numboo) ----------------------------------------------------------------- Input Parameters: number--number (0-5) identifies the relation pointer for this operation (int) attname-array of attribute names (may also be attribute number, ROWS or LIMIT) where the nth attname corresponds to the nth WHERE clause (Hollerith) operator-array of operators (EQ,GT,EQA,EXIS,FAIL,etc.) where the nth operator corresponds to the nth WHERE clause (each 4H) value---2-dimensional array of (any type, fixed, or variable) where the nth row corresponds to the nth WHERE clause The organization of the array is dependent on the of the array is dependent on the attribute type and length. Let vset represent a list of values (in most cases the list has one in vset (see the SELECT command). The rows are organized as follows: Fixed length attributes-------------------------- vset(1),vset(2),......,vset(numval) where numval is equal to the number o f values in the list (note if the EQA condition is used there can only be one member in the vset, see the SELECT command) Variable length attributes------------------------ TEXT - c(1),0,vset(1),c(2),0,vset(2)............, c(numval),0,vset(numval) where c is the number of characters in the corresponding vset and numval is equal to the number of values in the list. INT,REAL,DOUB,VEC - items(1),0,vset(1),items(2),0, vset(2)....,items(numval),0,vset(numval) where items is the number of items in the corresponding vset and numval is equal to the number of values in the list MAT-rows(1),col(1),vset(1),rows(2),col(2),vset(2), ......,rows(numval),col(numval),vset(numval) where rows is the number of rows and cols is the number of columns in the matrix .PG numval-number of values in the list of values (vset) where the nth numval corresponds to the nth WHERE clause (int array) nextboo-array of "AND" "OR" operators (each 4H) numboo-number of WHERE conditions (int). This routine qualifies a set of rows for retrieval (this corresponds to the where clause). For example, if the following WHERE clause were required: WHERE ATT1 EQ 4 7 12 OR ATT2 EQS "TEXT STRING" AND ATT3 + GT 5. AND ATT3 EQA ATT4 (ATT1 -- integer length 1) (ATT2 -- text variable length) (ATT3 -- real length 1) (ATT4 -- real length 1) The arrays would contain: attname(1) = 8HATT1 attname(2) = 8HATT2 attname(3) = 8HATT3 attname(4) = 8HATT3 operator(1) = 4HEQ operator(2) = 4HEQS operator(3) = 4HGT operator(4) = 4HEQA value(1,1) = 4 value(1,2) = 7 value(1,3) = 12 value(1,4) = value(1,5) = 0 value(2,1) = 11 value(2,2) = 0 value(2,3) = 4HTEXT value(2,4) = 4 H STR value(3,1) = 5. value(3,2) = value(3,3) = value(3,4) = value(3,5)=0 value(4,1) = 4HATT4 value(4,2) = value(4,3) = value(4,4) = value(4,5)=0 numval(1) = 3 numval(2) = 1 numval(3) = 1 numval(4) = 1 nextboo(1) = 4HOR nextboo(2) = 4HAND nextboo(3) = 4HAND nextboo(4) = 0 numboo = 4 "Value" would be dimensioned (4,5) in the above example. .PG CALL RMSORT (number,attname,numsort,sortype) Input Parameters: number --- number (0-5) identifies the pointer for the relation sorted (int) attname -- array of "numsort" attribute names to sort on (each 8H) numsort -- number of attributes to sort (int) sortype -- sort control numbers, corresponding to attname LT 0 causes descending sort, GE 0 causes ascending sort (int array) This routine sorts the data prior to retrieval (this is equivalent to the SORTED BY clause). For example, if the following SORTED BY clause were required: SORTED BY ATT1=A ATT2=A ATT3=D The array would contain: attname(1) = 8HATT1 attname(2) = 8HATT2 attname(3) = 8HATT3 sortype(1) = 1 sortype(2) = 1 sortype(3) = -1 numsort = 3 CALL RMGET (number,array) ------------------------ Input Parameters: Number --- number (0-5) identifies the relation pointer for this operation (int). Output Parameters: Array --- array to receive the row of data (any type). Let "coli" be the column number in the relation for the ith attribute (see RMGATT). Fixed length attributes-------------------- Array (coli) contains the start of the value for the i-th attribute. Variable length attributes---------------- Array (coli) contains the pointer "N" which points to the start of the attribute data in array. Array(N) contains one of the following: TEXT - number of characters INT,REAL,DOUB,VEC - number of items MAT(N+2) ,.....contains attribute values This routine gets a row of data from the specified relation and advances the pointer to the next qualifying row (as determined by RMWHER and RMSORT conditions). .TEST page 40 .P The following figure illustrates the organization of fixed and variable length data in the array. The pointer word, array(p) contains values as shown. Word p+1 contains 0 or the column dimension for matrix attribute type. .LITERAL Figure 3.5-1 -- Organization of Array Fixed Variable Fixed Variable Length Variable Length=1 Length Length=2 Attribute Length Attribute Attribute Attribute Parameters Attribute /------^--------\ +--+---------+---------+---------+---------+-+---------+---------+---------+-+ | | | | | |X| | | | | > | 3 | 4 | 5 | 6 |X| N | N+1 | N+2 | > < | | | | |X| | | | < | | | | | |X| | | | | +--+---------+---------+---------+---------+-+---------+---------+---------+-+ VALUE POINTER \-------v--------/ /---^---\ VALUE VALUE * NO. Chars 0 +---+ (text) | N | * NO. Words 0 +-+-+ (Int, Real) | * NO. Items 0 | (DOUB, DVEC) | * NO. Items 0 | (Ivec, RVEC) | * Row Dimens. Col. Dimens. | (Matrix) (Matrix) | \--v--/ | ^ | | +-------------------------------+ .END LITERAL .PG CALL RMLOAD (number,array) ------------------------- Input Parameters: number --- number (0-5) identifies the relation to load (int). array ---- array containing the row of data to load (any type). (see RMGET for a description of array) This sequence of calls will modify a row of data in a specified relation. CALL RMGET (number,array) ------------------------ . . . CALL RMDEL (number) ------------------- Input Parameters: number --- number (0-5) identifies the relation from which rows are to be deleted (int). This sequence of calls will delete a row of data in a specified relation. Calls to RMPUT and RMDEL must be preceded by calls to RMGET since neither RMPUT or RMDEL advances the pointer they operate on to the next row. .page .TAB STOPS 9,17,25,33,41,49,57,65,73 .LITERAL RIM Handy Reference Card DEFINING A DATABASE SCHEMA DEFINE dbname OWNER password ATTRIBUTES attname {REAL} [{length}][KEY] INT VAR TEXT DOUB RVEC IVEC DVEC attname {RMAT} {row,col} [KEY] IMAT row,VAR DMAT VAR,VAR RELATIONS relname WITH attname1 [attname2...] PASSWORDS {READ PASSWORD} FOR {relname} IS password RPW ALL {MODIFY PASSWORD} FOR {relname} IS password MPW ALL RULES attname [IN relname] {EQ} value [{AND}...] NE OR GT GE LT LE attname IN relname {EQA} attname IN relname [{AND}...] NEA OR GTA GEA LTA LEA END LOADING A RELATION LOAD relname value1 value2 ... valueN END value: SCALARS val1 TEXT "text string" VECTOR (val1, val2, ...) MATRIX(r1c1,r2c1,...),(r1c2,r2c2,...)...) QUERYING A RELATION SELECT {attname1 [=fid1],attname2[=fid2],...} FROM relname + attnum1 [=fid1],... attname1(i),... attname1(i,j)... ALL [SORTED BY attname1 [={A}],[attname2 [={A}]...]]+ D D [WHERE ...] TALLY attname [={A}] FROM relname [WHERE...] D WHERE CLAUSE: WHERE attname {EXISTS} [{AND}...] FAILS OR EQS value EQ {value} NE MAX GT MIN LT LE GE WHERE attname {EQA} attname [{AND}...] NEA OR GTA GEA LTA LEA WHERE ROWS {EQ} rownumber [{AND}...] NE OR LT LE GE GT WHERE {attname} {EQ} list [{AND}...] ROWS NE OR WHERE LIMIT EQ number [{AND}...] OR ... QUERYING THE SCHEMA LISTREL [relname] ALL EXHIBIT attname1 [attname2...] PRINT RULES COMPUTATION COMMAND COMPUTE {COUNT} attname FROM relname [WHERE...] MIN MAX AVE SUM MODIFICATION COMMANDS CHANGE {attname} TO value [IN relname] WHERE ... attname(i) attname(i,j) CHANGE {RPW} TO newpass FOR relname MPW CHANGE OWNER TO newowner DELETE ROWS FROM relname WHERE ... DELETE DUPLICATES [attname1,attname2,...] FROM relname DELETE RULE rulenumber RENAME ATTRIBUTE attname TO newname [IN relname] RENAME RELATION relname TO newname REMOVE relname RELATIONAL ALGEBRA COMMANDS INTERSECT relname1 WITH relname2 FORMING relname3 + [USING attname1 [attname2,...]] JOIN relname1 Using attname1 WITH relname2 USING attname2 + FORMING relname3 [WHERE {EQ}] NE GT GE LT LE SUBTRACT relname1 FROM relname2 FORMING relname3 + [USING attname1 [attname2,...]] PROJECT relname1 FROM relname2 USING + {attname1,[attname2,...]} [WHERE ...] ALL REPORT COMMANDS NEWPAGE BLANK n TITLE "title" DATE LINES n WIDTH n KEY COMMANDS BUILD KEY FOR attname IN relname DELETE KEY FOR attname IN relname RIM-TO-RIM COMMAND UNLOAD [dbname [=newdbname]] {SCHEMA} [relname1 [=mpw] + DATA ALL [relname2 [=mpw],...] GENERAL COMMANDS INPUT {filename} TERMINAL OUTPUT {filename} TERMINAL EXIT QUIT MENU HELP [command name] USER password ECHO NOECHO CHECK NOCHECK TOLERANCE xx.xx [PERCENT] RELOAD CLOSE HOST DEPENDENT COMMANDS (note: may be CDC syntax) OPEN dbname [=filename],[UN=account],[PW=password],+ [DIRECT={R}] W ZIP "jet statement" .END LITERAL .PAGE .C Summary of the Application Program Interface .LITERAL INITIALIZING THE DATA BASE CALL RMOPEN (dbname) Input parameter: dbname -- the name of the data base in Hollerith format CALL RMCLOS GENERAL ROUTINES CALL RMUSER (password) Input parameters: password -- the password text CALL RMRULE (switch) Input parameters: switch -- 0 - no rule checking (Nocheck) 1 - check rules (CHECK) CALL RMTOL (value,switch) Input parameters: value -- the value of the tolerance (real) switch - 0 if "val" is tolerance value (int) 1 if "val" is tolerance percent ACCESSING THE SCHEMA CALL RMLREL CALL RMGREL(rname,rpw,mpw,lastmod,numatt,numrows) Output parameters: rname - relation name (text) rpw read password, .TRUE. or .FALSE. mpw modify password, .TRUE. or .FALSE. lastmod date of last modification in relation data in yy/mm/dd format numatt number of attributes in relation (int) numrows number rows of data in relation (int) CALL RMLATT(rname) Input parameters: rname - relation name in hollerith (text) format CALL RMGATT(aname,type,matvec,var,len1,len2,column,key) Output parameters: aname - attribute name type - attribute type (INT, REAL, DOUB, or TEXT) matvec- attribute type (VEC or MAT, else blank) var variable length attribute, .TRUE. or .FALSE. len1 - attribute length data as follows (int): TEXT - number of characters INT, REAL, DOUB, VEC - number of items MAT - row dimension len2 - Column dimension of MAT attributes, otherwise 0 (int) column- attribute column location in relation (int) key - keyed attribute (.TRUE. or .FALSE.) ACCESSING THE DATA BASE CALL RMFIND(number,relname) Input parameters: number - user assigned number (0-5) used to reference the pointer for the relation (int) relname- relation name (characters, H format) CALL RMWHER(number,attname,operator,value,numval,nextboo,numboo) Input parameters: number - number (0-5) which identifies the relation pointer for this operation (int) attname - array of attribute names, attribute numbers, the keyword ROWS, or LIMIT operator - array of operators (EQ, GT, EQS, EQA, etc.) value - 2 dimensional array of WHERE clause "values" numval - Number of "values" in list of values nextboo - array of "AND" "OR" operators numboo - Number of WHERE conditions (int) CALL RMSORT(number,attname,numsort,sortype) Input parameters: number - number (0-5) which identifies the relation pointer for this operation (int) attname - array of "numsort" attribute names to sort on numsort - number of attributes to sort on (int) sortype - sort control numbers: -1 = descending sort, +1 = ascending sort. CALL RMGET(number,array) Input parameters: number - number (0-5) which identifies the relation pointer for this operation (int) OUTPUT Parameters: array - array to receive the row of data CALL RMLOAD(number,array) Input parameters: number - number (0-5) which identifies the relation pointer for this operation (int) array- array containing the row of data to load CALL RMPUT(number,array) Input parameters: number - number (0-5) which identifies the relation pointer for this operation (int) array - array containing the modified row of data. CALL RMDEL (number) Input parameters: number - number (0-5) which identifies the relation pointer to be deleted. (int) .END LITERAL .SKIP 2 .P The following is a small sample program in VAX Fortran to show how RIM may access the AERODB data base. It prints the following: .SKIP 1 1. All information about the schema (LISTREL ALL) .SKIP 1 2. The data in the relation REL300 sorted for the airports in Brazil sorted by descending altitude. CITYNAME is variable length and the commands are SELECT ALL FROM REL300 SORTED BY ALTITUDE=D WHERE CITYNAME EQS "BRAZIL". .SKIP 1 .LITERAL LOGICAL RPW,MPW,VAR,KEY COMMON/RIMCOM/RMSTAT INTEGER RMSTAT REAL*8 NAME,LASTMD,NAMEA,NAMEC,IVAR,DB,NAME DIMENSION NVAL(20) DIMENSION NAMEQS(5) C OPEN THE DATA BASE DBNAME=6HAERODB CALL RMOPEN(DBNAME) C LISTREL ALL CALL RMLREL 100 CONTINUE CALL RMGREL(NAME,RPW,MPW,LASTMD,NUMATT,NUMROW) IF(RMSTAT.NE.0)GOTO 200 LRP=3HNO IF(RPW) LRP=3HYES MRP=3HNO IF(MPW)MRP=3HYES WRITE(6,110)NAME,LRP,MRP,LASTMD,NUMATT,NUMROW 110 FORMAT(1X,A8,2(1X,A4),1X,A8,2I8) CALL RMLATT(NAME) 120 CONTINUE CALL RMGATT(NAMEA,ITYPE,MAT,VAR,LEN1,LEN2,NCOL,KEY) IF(RMSTAT.NE.0)GOTO 100 IVAR=5HFIXED IF(VAR)IVAR=8HVARIABLE IKEY=2HNO IF(KEY)IKEY=3HYES WRITE(6,130)NAMEA,ITYPE,MAT,IVAR,LEN1,LEN2,NCOL,IKEY) 130 FORMAT(1X,A8,2(1X,A5),1X,A8,3I8,1X,A3) GOTO 120 200 CONTINUE C SELECT ALL FROM REL300 SORTED BY ALTITUDE=D+ C WHERE CITYNAME EQS "BRAZIL" NAME=6HREL300 CALL RMFIND(1,NAME) IF(RMSTAT.NE.0)GOTO 999 NAMEQS(1)=6 NAMEQS(2)=0 NAMEQS(3)=4HBRAZ NAMEQS(4)=2HIL NAMEC=8HCITYNAME IBOOOP=3HEQS CALL RMWHER(1,NAMEC,IBOOOP,NAMEQS,1,0,1) IF(RMSTAT.NE.0)GOTO 500 NAMEA=8HALTITUDE CALL RMSORT(1,NAMEA,1,-1) IF(RMSTAT.NE.0)GOTO 999 300 CONTINUE CALL RMGET(1,NVAL) IF(RMSTAT.NE.0)GOTO 500 NUMX=(NVAL(5)-1)/10+1 NUMP=6+NUMX WRITE(6,400)(NVAL(K),K=1,NUMP) 400 FORMAT(A4,5I6,2X,30A1) GOTO 300 500 CONTINUE IF(RMSTAT.LT.0)GOTO 1000 999 CONTINUE WRITE(6,9001)RMSTAT 9001 FORMAT(' RMSTAT:',I5) C CLOSE THE DATA BASE 1000 CONTINUE CALL RMCLOS STOP END .END LITERAL .PAGE .C LIMITATIONS .P There is no limit on the number of rows of a relation except disk size. .P A row in a relation must fit in 1021 words. If len(i) is the fixed length (in words) of the ith attribute and var(j) is the length (in words) of the jth variable length attribute, then SUM(len(i) for i=1 to max)+sum((var(j)+3) for j=1 to max) must be less than 1021. This can mean that relations that fit on 60 bit machines may not fit on 32 bit machines. .P A relation or attribute name must not begin with the character string "RMRUL". .P The following words may not be used in attribute or relation names: TO, FROM, BY, USING, WHERE, IN, FORMING, ROWS, LIMIT, DUPLICATE. Also, names must not be a substring of the above which is 3 characters or more long starting with the first character. Thus FOR and FORM are illegal, however FORT is OK. .P In loading data, the value of the first attribute, if it is text, is limited as follows: If the relation contains only 1 or 2 attributes, then the following text strings and their RIM substrings are not allowed as values for the first attribute: CHECK, NOCHECK, ECHO, NOECHO, END, HELP, INPUT, OUTPUT, QUIT. If the relation contains three attributes then the value for the first attribute may not be HELP or HEL. .P The number of items in one command may not exceed 100. .P The number of rules specified for one relation may not exceed 10. .P The number of conditions used in the SELECT WHERE clause may not exceed 10. .PAGE .C Entering Input with the RIM User Interface .P The following discusses the reading and parsing of commands and data in the standalone system. .P The RIM user interface is a free-field input routine used by the RIM standalone system which separates user input into items which are grouped into records. .SKIP 1 .C Terminology .LIST .LE; LINE - One line of information with a maximum of 80 characters including blanks. .LE; ITEM - One piece of information. An item may be a real number, an integer or text. Items are delimited by blanks or commas. Multiple blanks count as a single blank. Multiple commas generate null items. .LE; RECORD - A collection or list of up to 100 items entered in response to a single request for data by the calling program. .LE; INTEGER - all characters must be numeric except that the first may be a + or - sign. For example: -1 23 +10000 .LE; REAL - An item of the form I1.I2EI3 where I1 and I3 may be signed integers and I2 is an unsigned integer. The entire form is not necessary but at least one digit and the . or two digits separated by the E are required. .LE; TEXT - Any single item that is not integer or real. If a text item looks like an integer or real it must be enclosed in quotes ("). .END LIST .C Composing Records .P Ordinarily records consist of one line. However multiple records may be put on a line by separating them with dollars or semicolons. Alternatively, a record may span several lines by ending all but the last line with a plus. Items must be wholly contained on one line with the exception of quoted text items and comments. .C Special Items - +,(, ) .P Equals and left and right parentheses are treated as single items unless enclosed in quoted text items. Thus a=3. is 3 items, two text and one real rather than one. "a=3." is one item. .C Multiple Commas .P If more than one comma separates 2 items, each additional comma will generate a text item with 3 characters, "-0-". .C Rules for Text Items .P A quoted text item is terminated by a record separator (dollar or semicolon). Quoted text items may be continued on multiple lines. If the trailing quote is omitted on the last item in a record, the quoted item is terminated at the record separator, if any, or the last nonblank character on the line. Quotes may be included in quoted text strings by doubling the quotes (e.g., "a,""b" yields a,"b as a text string). The total number of characters for all text strings in a record is limited to 2000. .C Comments .P Comments may be included anywhere in the input stream by enclosing them between *( and ). For example *( this is a comment). Comments are completely ignored by the user interface. Empty lines between records are ignored and may be used to paragraph input. An alternative form of comment is */ ... / which may be used if you need to have parentheses inside the comment. .C DATA GENERATION .P Activities such as entering large volumes of data can be eased by using the data generation facilities. .p REPEATING ITEMS ON PREVIOUS RECORD .P A data item of the form *n where n is an unsigned integer, indicates that the next n items are identical to the corresponding n items in the previous record. An isolated * is taken as *1. Double asterisks (**) indicate that the remaining items in the previous record are to be copied to the current record. .P REPEATING AN ITEM IN THE CURRENT RECORD - *=N, *=N+STEP .P An item of the form *=n, where n is an unsigned integer, indicates that the next n items are identical to the immediately preceding item. An item of the form *=n+step or *=n-step, where step is an unsigned real or integer, indicates that the next n items are to be generated by consecutively incrementing the immediately preceding item. .P GENERATING MULTIPLE RECORDS *+N .P A record beginning with *+n where n is an unsigned integer indicates that the next n records are to be generated from the preceding record. Each item of the generated record is formed by adding an item of the *+n record to the corresponding item of the immediately preceding record. A zero (integer) item should be inserted in an *+n record for text items in the preceding record. The number of items after the *+n must match the number in the preceding record. .skip 1 .C Notes on Generating Items .P When increments are specified, either on the *+n record or as step on an *=n+step item they must match the item thye are incrementing in type. It should be noted that the *+n record generation optuion is based on the expanded representation of the previous record. The generation does not operate on the card image of the preceding record if it contains data generation items. Therefore it is not possible to repeat or increment an asterisk-type item. .skip 1 .C Examples .p Consider the following 7 input records to illustrate data generation features: .Literal 1 2 3 4 5 6 7 8 9 10 11 12 2 1 *2 4 *=2 1 *=2+2 ** *+1 0 *=3 0 *=5 ** *+1 0 *=11 *+1 *12 *+1 ** ** .end literal .P Twelve data items are defined by each of these records. Each of the last six records is translated into the same internal record which is: 2#1#3#4#4#4#4#1#3#5#11#12 .break Note - the last 5 records could be replaced by the single record *+5 ** instead. .skip 2 .C Changing Special Characters .P It is possible to change the special characters the user interface uses to break apart records. These special characters may either be changed to others or set to null so they are ignored. This is useful for reading specially formatted files or to allow special characters to appear as input in text items. To change special characters enter the following special comment as the only entry on a line between records: .SKIP 1 *(SET KEYWORD=newvalue) .SKIP 1 where KEYWORD can be DOLLAR, SEMI, QUOTES, BLANK, PLUS, or COMMA and newvalue is either the word NULL or the new special character. For example if one wanted to use dollar to delimit items rather than records and not to have commas delimit items one would enter: .SKIP 1 *(SET DOLLAR=NULL) .BREAK *(SET COMMA=$) .SKIP 1 and commas could now be used in unquoted text strings. Note the function is altered, so for example the + sign still has its usual function in real numbers. To restore the original delimiters one could say: .skip 1 *(SET DOLLAR=$) .BREAK *(SET COMMA=,) .SKIP 1 .PG .DO INDEX .PRINT INDEX -h- rimhlp.hlp Mon Dec 02 10:17:26 1985 DF1:[DBMS]RIMHLP.HLP;1 1 RIM RIM is a relational data base management system. RIM commands allow you to define, load, query and modify a data base. To run RIM at LMRC just type RIM. 2 CONCEPTS RELATIONAL DATA BASE CONCEPTS ---------- ---- ---- -------- A RIM relational data base contains a SCHEMA and DATA. The DATA is organized as RELATIONS. A data base may contain several RELATIONS. Each RELATION consists of ATTRIBUTES. You can select, format and display data from a RELATION with one of the QUARY commands. You can select data from RELATIONs and combine it into new RELATIONs using the RELATIONAL ALGEBRA commands. 3 SCHEMA The SCHEMA is a definition of everything in the data base. It contains the details of all the ATTRIBUTES and RELATIONS as well as rules for entering data, passwords, and so on. 3 RELATION A RELATION is a table of data. It is made up of ATTRIBUTES or columns and ROWS. Each ROW represents the information for one item or entry in that RELATION. 3 ATTRIBUTE An ATTRIBUTE is a column in a table (RELATION). It has a name which is used as a heading for the column when the ATTRIBUTE is displayed. It also defines the type of data that goes in the column (integer, text, etc). 2 OVERVIEW RIM --- RIM is a relational data base management system. RIM commands allow you to define, load, query and modify a data base. RIM supports the following commands: BLANK BUILD KEY CHANGE CLOSE COMPUTE DATE DEFINE DELETE KEY DELETE ECHO EXHIBIT EXIT INPUT INTERSECT JOIN LISTREL LOAD NEWPAGE NOECHO OPEN OUTPUT PRINT PROJECT QUIT RELOAD REMOVE RENAME SELECT SUBTRACT TALLY TITLE USER The DEFINE command and the LOAD command are used to enter submodules where commands known only to those submodules are processed. The DEFINE submodule supports the following commands: DEFINE ELEMENTS RELATIONS PASSWORDS RPW (READ PASSWORD) MPW (MODIFY PASSWORD) RULES END The LOAD submodule supports the following commands: LOAD CHECK NOCHECK END For a description of the general command syntax used by RIM enter SYNTAX. For a summary of the syntax for the current RIM command enter SUMMARY. For a description of the RIM WHERE clauses enter WHERE. 2 COMMANDS RIM COMMANDS --- -------- 3 DEFINE DEFINE Command ------ ------- The define submodule commands are used for defining the structure of the data base. The definition of the data base is called the schema and the schema name is the name of the data base and forms the essential part of the names of the local files used for the data base. Attributes, relations, passwords, and constraints (rules) are defined using this submodule. To access this submodule you enter: DEFINE dbname You must identify the name of the data base whose definition you are going to create or expand by specifying the schema name. This name is used to form the name of the local files used to store the data base tables and must when augmented with a single number be a legal local filename. For an example, see help for DEFINE EXAMPLE. 4 EXAMPLE DEFINE EXAMPLE ------ ------- Example of define submodule commands: DEFINE RIMDB OWNER ME ATTRIBUTES MODEL TEXT KEY WEIGHT REAL NUMPASS INT CARRIER TEXT 16 FLIGHTNO INT NAME TEXT KEY AGE INT RELATIONS AIRPLANE WITH MODEL WEIGHT NUMPASS FLIGHTS WITH CARRIER FLIGHTNO MODEL PEOPLE WITH NAME AGE PASSWORDS MPW FOR AIRLINES IS AGENT RPW FOR PEOPLE IS BLUE RULES MODEL IN FLIGHTS EQA MODEL IN AIRPLANE AGE GT 21 AND AGE LT 65 NUMPASS IN AIRPLANE LE 350 END 4 OWNER OWNER Command ----- ------- The OWNER command specifies the owner of the data base. The OWNER has permision to read or modify all data and the schema. OWNER password If the data base already exists and you want to define additional attributes or relations, password is checked against the existing owner password. 4 ATTRIBUTES ATTRIBUTES Command ---------- ------- ATTRIBUTES attname type1 [{length}] [KEY] VAR attname type2 [{row, col}] [KEY] row, VAR VAR, VAR . . . The attribute definitions are ended when you specify one of the keywords RELATIONS, PASSWORDS or RULES which start the other sections in the DEFINE submodule. Type1 attributes: RIM supports seven data types of type1: floating point (real), integer, text, double precision, real vectors, integer vectors and double precision vectors. You must enter REAL, INT, TEXT, DOUB, RVEC, IVEC or DVEC for type1. The default length is one value except for TEXT for which it is 8 characters. The length is specified in number of values and characters respectively. VAR indicates variable length. The optional KEY specification causes an index file to be built for the attribute which is used by RIM to find qualifying rows for retrievals and updates. Under certain conditions, such an index file will make retrievals and updates considerably faster than if no index file is used. See WHERE clause definitions for a specific discussion. The default is that such an index file is not built (non-key attribute). You should consider the cost of building and storing index file data versus the benefits you will obtain from quicker retrievals when deciding if a KEY declaration should be used or not. No specific rules can be given here, experience should be used to judge. An attribute can be changed from KEY to non-key or vice-versa later using the BUILD KEY and DELETE KEY commands. For larger data bases (more than 1, 000 rows), experience has shown that it is most efficient not to specify a KEY in the define submodule but rather to load the data without keys and to later cause index files to be built using the BUILD KEY command. The greater the number of keys the more efficient this method is. Type2 attributes: RIM supports three data types of type2: real matrices, integer matrices or double precision matrices. You must enter RMAT, IMAT or DMAT for type2. The matrices can be of fixed size, have variable column dimension or variable row and column dimensions. You enter the row dimension first, followed by the column dimension. Default dimension is 1, 1. The key-word KEY has the same meaning as for type1 attributes. 4 RELATIONS RELATIONS Command --------- ------- To define relations enter: RELATIONS relname WITH attname1 [attname2 ...] . . . The relation definitions are ended by specifying one of the keywords ATTRIBUTES, PASSWORDS, RULES, or END which start the other sections of the DEFINE submodule or finishes the schema definition. The attributes must be listed in the order in which they are to appear in the relation. No attributes can be used which have not been previously defined, either in the current DEFINE submodule execution or in previous definition of this data base. Attributes which are defined but not included in a relation will not become part of the RIM schema. A RIM data base must have attributes and relations defined. Passwords and constraint rules are optional. 4 PASSWORDS PASSWORDS Command --------- ------- If read or modify passwords are desired, you enter: PASSWORDS {READ PASSWORD} FOR relname IS password RPW {MODIFY PASSWORD} FOR relname IS password MPW . . The password definitions are ended by specifying one of the keywords ATTRIBUTES, RELATIONS, RULES, or END which start the other sections of the DEFINE submodule or finishes the data base definition. Passwords can be any string of characters up to 8 characters long. When you are doing queries, loads, or modifications, the current password is specified by the USER command. If this password does not match one of the read, modify or owner passwords for a relation you cannot query that relation. If this password does not match one of the modify or owner passwords, you cannot load or modify the given relation. 4 RULES RULES Command ----- ------- Constraint rules are another optional section of the DEFINE submodule. If rules are specified, they are used during the loading process or during CHANGE commands to screen out rows which do not meet the constraint rules. Rules are specified by relation. At most 10 rules may be specified for a single relation. There are several options available in the rule definition section. To define constraint rules you enter: RULES attname [IN relname] {EQ} value [{AND} attname ... ] NE OR GT GE LT LE or: attname1 IN relname {EQA} attname2 IN relname [{AND} ... ] NEA OR GTA GEA LTA LEA where: EQ = Equals NE = Not equal to GT = Greater than GE = Greater than or equal to LT = Less than LE = Less than or equal to EQA = Equals attribute NEA = Not equal to attribute GTA = Greater than attribute LTA = Less than attribute LEA = Less than or equal to attribute The rule definitions are ended by specifying one of the keywords ATTRIBUTES, RELATIONS, PASSWORDS, or END which start the other sections of the DEFINE submodule or finishes the schema definition. Attributes referenced in the rule definitions must have been previously defined. By specifying rules, you can restrict an attribute to a range of values or require that the value of an attribute in one relation have a specified relationship to the values of an attribute in the same or a different relation. The compare operators ending in A (EQA etc.) are used when the comparison is to existing attribute values rather than to a specified constant. A rule expression may contain no more than 10 compare operators (9 Boolean operators). The method used for constraint checking is that the first attribute mentioned in the rule is taken from the input (LOAD or CHANGE command) data and checked against the remainder of the rule expression using existing values in the database. 4 END END Command --- ------- To finish the schema definition you enter the following keyword and leave the DEFINE submodule: END The END command also terminates the LOAD process. 3 LOAD LOAD Command ---- ------- The load submodule commands are used to add data to a newly defined relation or to add data to a relation which already contains data. To access this submodule enter: LOAD relname You may now load data in the relation, one row per command, by entering data values in a one to one correspondence with the attributes: value1 value2 ... valuen Valuei takes the form described in the following table: Attribute Type Length or Valuei Remark Dimension REAL, INT n n.gt.1 (val1 ... valn) Parentheses optional DOUB, RVEC IVEC, DVEC REAL, INT VAR (val1 val2 ...) Parentheses required DOUB, RVEC IVEC, DVEC TEXT any "text string" In special cases " " is optional (see INPUT FORMAT) RMAT, IMAT m, n ((r1c1...rmc1)(r1c2...) + Columnwise DMAT ...rmcn)) Parentheses optional RMAT, IMAT m, VAR ((r1c1...)(r1c2...)...)) Columnwise DMAT or Parentheses required VAR, VAR To finish data loading you enter: END Multiple relations may be loaded from within the load submodule by re-entering the LOAD command instead of the END command. For an example of data loading, see LOAD EXAMPLE. 4 EXAMPLE LOAD EXAMPLE ---- ------- Example of load submodule commands: LOAD AIRPLANE DC9 87000. 110 747SP 200000. 350 LOAD PEOPLE BOB 30 JOE 32 ALICE 29 END If the value for an attribute is missing, you enter the characters -0- for the missing value or use two successive commas. L1011 -0- 250 L1011, , 250 These two records have identical meaning. 3 QUERY COMMANDS FOR QUERYING A RELATION -------- --- -------- - -------- 4 TALLY TALLY Command ----- ------- The TALLY command prints a tally for an attribute giving each unique value and the number of times it occurs in a relation. The tally is ordered ascending or descending per user input. Default is ascending. The WHERE clause is optional. For a description of the WHERE clause see HELP WHERE. TALLY attname [{=A}] FROM relname [ WHERE ... ] D For examples of SELECT and TALLY, see SELECT EXAMPLES. 4 SELECT SELECT Command ------ ------- The SELECT command is used for displaying or printing data from one relation. It has many options. To print all data from a relation: SELECT ALL FROM relname To print selected attribute values from all rows in a relation: SELECT attname1 [ attname2 ... attnamen ] FROM relname The above form will print up to 20 attributes in any order. However the number of attributes is limited by space available in the line. As a rule of thumb, 7 attributes may be selected when running at an interactive terminal and 11 when running in batch mode or at an 132 character terminal. For variable length attributes or for attributes of fixed length that would otherwise not fit on a line alone or together with other attributes, you may format the output using the optional field width control: SELECT attname1 [ =fw1 ] [ attname2 [ =fw2 ] ... ] + FROM relname fwi is the output field width for attnamei. For a text type attribute, fwi is the width of the output paragraph in number of characters, for other attribute types it is the number of values. When the field width option is used, RIM will use for each row as many output lines as required by the most critical attribute. Defaults are rather complex. For a fixed length attribute, no paragraphing is attempted. The system will use the field width required to display the value(s) of the attribute. For a variable length attribute of type TEXT, the default is display of a maximum of 40 characters with truncation of remaining text, if any. For variable length attributes of types REAL, INT, DOUB, the default is 4 values with truncation. For variable length vector type attributes, the default is 4 values with paragraphing (no truncation). For variable length matrix attributes the default is 4 values with paragraphing (no truncation). A row starts on a new line. Whether field width is specified or not, the system will display the dimension of variable length vectors and matrices using one of the output value positions. However, should the user specify a width of only one value for such an attribute, the row and column dimensions will not be displayed. Further information about line width, no of lines per page, defaults and user specification is given under the WIDTH and LINES commands. When paragraphing TEXT type attributes, RIM will identify consequtive substrings of text separated by blanks and place such a substring on the line, if there is space available, or if the current current line contains less than four characters in which case the number of characters that fit on the line are removed from (the front of) the substring and put on the line (without hyphen). If there is not room on a line filled with more than four characters, the (first part of the) substring will be placed on the next line. Examples of SELECT command: SELECT ivecvar FROM rel1 DIM IVECVAR ---------------------------- 7 1 2 3 4 5 6 7 1 10 SELECT imatvv FROM rel1 ROW COL IMATVV ----------------------------- 2 5 11 12 13 14 15 21 22 23 24 25 1 1 11 SELECT textv=9 FROM rel1 TEXTV --------- THIS IS AN EXAMPL E OF WRAPAROUN D OF TEXT THIS IS ANOTHER EXAMPLE OF TEXT The attribute name (attnamei) may be replaced by an attribute number (attnumi). It may also be a specific element of a vector or a mtrix. Thus the general form of the unconditional SELECT command is: SELECT {attname1 [ =fw1 ] } [attname2 [=fw2] ... ] FROM relname attnum1 [ =fw1 ] attname1(i) attname1(i, j) ALL To print all attributes from a relation where certain conditions are met: SELECT ALL FROM relname WHERE condition1 [{AND} condition2 ... ] OR For help for the where clause, see the WHERE entry. For help for the sorted by clause, see the SORT entry. For examples, see SELECT EXAMPLES. 4 EXAMPLES SELECT EXAMPLES ------ -------- Examples of SELECT and TALLY commands: SELECT ALL FROM AIRPLANE SELECT MODEL FROM AIRPLANE SELECT ALL FROM AIRPLANE WHERE WEIGHT GT 100000. *8 AND NUMPASS LT 200 SELECT AGE FROM PEOPLE WHERE NAME EQ BOB SELECT ALL FROM AIRPLANE SORTED BY MODEL=D TALLY MODEL FROM FLIGHTS TALLY MODEL FROM FLIGHTS WHERE CARRIER EQ UNITED SELECT ALL FROM DIMENS WHERE HEIGHT GTA WIDTH SELECT FILE TITLE=4 OWNER FROM PFDATA 4 WHERE_CLAUSE WHERE Clause ----- ------ Up to ten conditions may be combined using the Boolean operators of AND and OR. The conditions are combined from left to right. Each condition may be one of the following forms: attname EXISTS attname FAILS attname EQ MAX attname EQ MIN attname EQ value attname EQS value attname NE value attname GT value attname GE value attname LT value attname LE value attname EQ list attname NE list attname1 EQA attname2 attname1 NEA attname2 attname1 GTA attname2 attname1 GEA attname2 attname1 LTA attname2 attname1 LEA attname2 ROWS EQ rownumber ROWS NE rownumber ROWS LT rownumber ROWS LE rownumber ROWS GE rownumber ROWS GT rownumber ROWS EQ list ROWS NE list LIMIT EQ number where: EQ = Equals EQS = Contains the text string NE = Not equals GT = Greater than GE = Greater than or equal to LT = Less than LE = Less than or equal to EQA = Equals attribute NEA = Not equals attribute GTA = Greater than attribute GEA = Greater than or equal to attribute LTA = Less than attribute LEA = Less than or equal to attribute MAX = Maximum value MIN = Minimum value Attname, attname1, attname2 may refer to an element of a vector or a matrix. When an attribute has been assigned a value, then EXISTS will qualify those attributes. If an attribute has not been assigned a value, but was loaded with -0-, then FAILS will qualify those attributes. MAX and MIN comparison can only be made for integer, real and double precision attributes of fixed length equal to 1. Value in comparison statement must follow the rules of the LOAD command for vectors and matrices, i.e. if the attribute is of variable length or dimension, parentheses must be used to input a vector or a matrix value or a list of vector and matrix values. EQS applies to text strings only. In such a comparison, value is a text string and the comparison is true if value is found as a substring anywhere within the attribute for which comparison is requested. NE comparison when applied to matrices or vectors is true if the length or dimension is different from the length or dimension of the user specified comparison vector or matrix or if any vector or matrix elements differs. GT and LT comparisons for vector and matrix attributes are lexicographical, i.e. a comparison is made element by element (columnwise for matrices) and continued until a true or false condition is detected. If no such condition is detected after the last element is checked, a false condition is assumed. Comparison is made only for vectors and matrices of the same size as comparison data. GE and LE comparisons for vector and matrix attributes are similar to GT and LT comparisons except it continues if an equal condition is detected and if no condition is detected after the last element is checked, a true condition is assumed. Comparison rules for vector attributes apply also to real, integer and double precision attributes of fixed or variable length. A list is a simple list a1, a2, a3, ..., an of values where a value may be a vector or matrix. The comparison key words ending in A are used when comparing the value of one attribute to the value of another attribute in the same row of the relation. ROWS refer to row numbers in a relation. Note that a relation is loaded in input row order but that subsequent operations (changes) to the data base may cause the order of the rows to change. When the LIMIT clause is used, only the first LIMIT number of the rows that otherwise would qualify will actually qualify. Processing the WHERE condition can be speeded up greatly if index processing is used. Index processing involves using the indices created for KEY attributes rather than looking at each row of a relation to find the rows qualified by the WHERE conditions. Index processing will be used when the following are all true: 1) The last condition uses an attribute which is KEY 2) The last condition uses EQ 3) The last condition is not combined by OR with the other conditions. 4 SORT_BY_CLAUSE SORTED BY ------ -- The output can be sorted by specifying sorting attributes. The sorting order is user specified with default low to high. SELECT ... FROM relname + SORTED BY attname1 [{=A} ] [ attname2 [={A} ] ... ] + D D [ WHERE ... ] A and D stands for ascending and descending order respectively. If a sort on more than one attribute is requested, the output will first be ordered according to the first mentioned attribute. In case there are duplicates for the first sort attribute, these will be ordered by the second sort attribute, duplicates within this by the third and so on. A maximum of 5 sort attributes may be specified. When multiple attributes are used, ascending and descending order may be used in any combination. A maximum of five sort attributes may be specified. Variable length attributes may not be used as sort attributes. When fixed length attributes are used as sort attributes, only the first 20 characters and the first value is used for sort. 3 COMPUTE COMPUTE Command ------- ------- The COMPUTE command is used to compute simple functional values for an attribute. A WHERE clause is optional and uses the same syntax as is used in the SELECT command. COMPUTE {COUNT} attname FROM relname [WHERE ... ] MIN MAX AVE SUM There are some restrictions as to the type and word length of the attribute when using these computed functions. All of these functions exclude any -0- values when making their computations. The following table describes the attribute type and length restrictions for each function: FUNCTION ATTRIBUTE TYPE ATTRIBUTE LENGTH -------- -------------- ---------------- COUNT any any MIN any 1 (20 chars for text) MAX any 1 (20 chars for text) AVE any except TEXT 1 SUM any except TEXT 1 Examples of COMPUTE command: COMPUTE AVE NUMPASS FROM FLIGHTS COMPUTE MAX WEIGHT FROM FLIGHTS WHERE NUMPASS LT 100 COMPUTE COUNT NAME FROM PEOPLE WHERE AGE GT 30 3 MODIFICATION MODIFICATION COMMANDS ------------ -------- 4 CHANGE CHANGE Command ------ ------- The CHANGE command is used to change the value of an attribute in a relation where certain conditions are met. CHANGE {attname1} TO attname2 [IN relname] WHERE ... attname(i) attname(i, j) Value has the same form as descried in the LOAD command. The WHERE clause is required and and is described in the WHERE entry. If the relation name is not specified, the attribute is changed in all relations where the attribute is found and the conditions are met. For relations in which the change attribute is is present but in which one or more of the attributes used in the where clause are missing, an error message will be issued. 5 OWNER CHANGE OWNER Command ------ ----- ------- The CHANGE OWNER command is used to change the name of the data base owner password. Only a person whose password matches the curent owner password may use this command. priviledge. CHANGE OWNER TO newowner 5 PASSWORD CHANGE PASSWORD Command ------ -------- ------- If you are the data base owner, you may change the read or modify passwords by the following command CHANGE {RPW} TO newpass FOR relname MPW 4 DELETE DELETE Command ------ ------- The delete command removes data from the data base. For a more precise description see: DELETE DUPLICATES DELETE ROW DELETE KEY 5 ROW DELETE ROW Command ------ --- ------- The DELETE ROW command is used to delete selected rows in a relation. DELETE ROW FROM relname WHERE ... The name of the relation must be specified as well as a WHERE clause. The syntax for the WHERE clause is described in the WHERE entry. 5 DUPLICATES DELETE DUPLICATES Command ------ ---------- ------- This command is used to remove any duplicate rows from a relation. It is useful to use on new relations which have been created by any of the relational algebra commands (JOIN, INTERSECT, SUBTRACT, or PROJECT). The syntax for this command is: DELETE DUPLICATES [attname1, attname2, ...] from relname Duplicates are checked only for the specified (combination of) attribute(s). Default is to check for complete row (all attributes). 4 REMOVE REMOVE Command ------ ------- The REMOVE command is used to remove a relation definition and its data from the data base. REMOVE relname 4 RENAME RENAME Command ------ ------- For detailed information on the RENAME command see: RENAME ATTRIBUTE RENAME RELATIONS 5 ATTRIBUTE RENAME ATTRIBUTE Command ------ --------- ------- The RENAME attribute command is used to change the name of an attribute in the definition (schema) of the data base. RENAME [ATTRIBUTE] attname1 TO attname2 [ IN relname ] The old name is attname1 and the new name is attname2. If the name of the relation is not specified, the name change takes place in every relation that contains the old name. If relname is specified and attname1 is duplicate (or more), the first occurance will be changed. RULES and KEY defined for attname1 will automatically be redefined to apply for attname2. Examples of RENAME command: RENAME MODEL TO VERSION IN AIRPLANES RENAME NUMPASS TO CAPACITY 5 RELATION RENAME RELATION Command ------ -------- ------- You may change the name of a relation by the following command RENAME RELATION relname TO newname Note: RULES and KEYs applying to relname will aumatically apply to newname. 3 RELATIONAL_ALGEBRA RELATIONAL ALGEBRA COMMANDS ---------- ------- -------- 4 INTERSECT INTERSECT Command --------- ------- The INTERSECT command allows you to combine the rows of two relations into a third relation based on equality of values within a common set of attributes identified from a set of specified attributes. The syntax of the INTERSECT command is: INTERSECT relname1 WITH relname2 FORMING relname3 + [USING attname1 [attname2 ... attnamen]] The USING clause identifies which attributes that are included in the resulting relation. Common attributes used in the intersect process are identified within these. As an example, assume that you have the following two relations defined: REL-1 REL-2 NAME DEPT JOB DEPT JOB PAY ---------------------- -------------------- BOB A ENGR A ENGR 800 JIM C SUPR B ENGR 450 BOB B ENGR C ENGR 750 RAY C ENGR You may INTERSECT two relations restricted to specific sets of attributes (the USING clause) or use all attributes of both relations. In either case RIM will identify the common attributes. In the first case, suppose you wish to INTERSECT the two relations using attributes DEPT, NAME and JOB. The command for this would be: INTERSECT REL-1 WITH REL-2 FORMING REL-3 USING DEPT NAME JOB The result would be the new relation REL-3 shown below: REL-3 DEPT NAME JOB ----------------------- A BOB ENGR B BOB ENGR C RAY ENGR In this example there are no duplicate rows in REL-3. It is possible that the INTERSECT command will create duplicate rows. In general duplicate rows are not desired in a relation. Duplicates are not removed by the INTERSECT command but can be removed with the DELETE DUPLICATES command. Note also that by specifying which attributes the INTERSECT is using, you restrict the number of attributes in the resulting relation to only those specified in the USING clause. In another case, you may want RIM to use all the attributes in the two relations. In this instance, you would enter: INTERSECT REL-1 WITH REL-2 FORMING REL-4 The result would be REL-4 consisting of the attributes NAME, DEPT, JOB, and PAY, shown below with the resulting rows: REL-4 NAME DEPT JOB PAY ---------------------------------- BOB A ENGR 800 BOB B ENGR 450 RAY C ENGR 750 4 JOIN JOIN Command ---- ------- The JOIN command is a function operating on two relations to form a third relation. The purpose of the JOIN is to juxtapose two relations based on a specified attribute from each. The result is a third relation containing all the attributes from both relations. Rows are generated into the new relation based upon a specified comparison between the two JOIN attributes. In general a row from the first relation may generate zero, one or more rows depending upon how many rows in the second relation have the desired match. The syntax of the JOIN command is: JOIN relname1 USING attname1 WITH relname2 USING attname2 + FORMING relname3 [WHERE {EQ}] NE GT GE LT LE The conditional clause is different from the WHERE clause of select. In JOIN it applies only to the comparison of the two attributes upon which JOIN is based. If the WHERE clause is omitted (default), EQ is used. The comparisons involving order (GT etc.) refer to attname1 GT attname2 etc.. The comparison of the two single attributes follow the (lexicographical) rules of the where clause of select. As an example, consider the relations REL1 and REL2: REL1 REL2 A B C D E ----------------------------- ------------------------ 1 2 3 3 1 4 5 6 6 2 7 8 9 The following JOIN command: JOIN REL1 USING B WITH REL2 USING D + FORMING REL3 WHERE B LT D would produce: REL3 A B C D E -------------------------------------------------------- 1 2 3 3 1 1 2 3 6 2 4 5 6 6 2 The JOIN will function correctly on any comparison providing that you compare attributes of the same data type. All attribute names in the resultant relation must be unique for you to obtain accurate results when using SELECT or CHANGE commands on the relation. Any duplicate attribute names should be changed using the RENAME command before doing queries or updates to the new relation. In the case of duplicate attribute names, RENAME when applied to a specific relation will change the first attribute name. Note that if the constituient relations have no duplicate rows, the relation formed with JOIN will also have no duplicate rows. 4 PROJECT PROJECT Command ------- ------- The function of a PROJECT command is to create a new relation as a subset of an existing relation. You may want to create the new relation from the old one by removing attributes, removing rows, or both. The syntax for the PROJECT command is: PROJECT relname1 FROM relname2 USING {attname1 ... attnamen} + ALL [WHERE ...] The WHERE clause is optional but if specified it has the same syntax as specified in the WHERE entry. You are required to specify which attributes are to be retained in the new relation. The old relation is relname2 and the new relation is relname1. As an example consider the following relation: PEOPLE EMPNUM EMPNAME BOSS POSITION GROUP -------------------------------------------------- 2181 JONES SMITH MANAGER AADE 3964 ERICKSON BUSS APPL-MGR ACC 6543 GRAY PARKER ASST-MGR PHOTO 2233 SCHMITZ BUSS APPL-MGR ACC -------------------------------------------------- To create a new relation with EMPNAME and GROUP as the only attributes where no rows contains PARKER as BOSS enter the command: PROJECT TEMP1 FROM PEOPLE USING EMPNAME GROUP + WHERE BOSS NE PARKER TEMP1 EMPNAME GROUP ------------------- JONES AADE ERICKSON ACC SCHMITZ ACC The PROJECT command is useful to reduce the size of a relation when only a subset of the data is needed. RIM will not eliminate any duplicate rows formed in the new relation. You must do that yourself with the DELETE DUPLICATES command. 4 SUBTRACT SUBTRACT Command -------- ------- The SUBTRACT command is similar to the PROJECT command in that a new relation is formed from an existing relation, but rows are selected based upon the data of two relations rather than a WHERE clause within a single relation. Where the INTERSECT command looked for rows of two relations which matched up, the SUBTRACT does just the opposite. It looks for rows on in relation which do not match with any rows in the other relation. The syntax for the SUBTRACT command is: SUBTRACT relname1 FROM relname2 FORMING relname3 + [USING attname1 [attname2 ... attnamen]] All rows in the new relation will come from relname2. If the USING clause is not specified, then all attributes of relname2 will be attributes of relname3. relname1 is the relation that rows of relname2 are checked against for matches. As an example consider these two example relations: EMPDATA BOSSDATA EMPNUM EMPNAME BOSS BOSS POSITION GROUP ------------------------------ ----------------------------- 2181 JONES SMITH SMITH MANGER AADE 3964 ERICKSON BUSS PARKER ASST-MGR PHOTO 6543 GRAY PARKER BUSS APPL-MGR ACC 8461 BROWN WHITE 2233 SCHMITZ BUSS The following command will produce a new relation from EMPDATA: SUBTRACT BOSSDATA FROM EMPDATA FORMING TEMP USING EMPNAME BOSS The resulting relation TEMP would contain only one row: TEMP EMPNAME BOSS -------------------- BROWN WHITE 3 REPORT REPORT COMMANDS ------ -------- 4 NEWPAGE NEWPAGE Command ------- ------- This command causes a new page to be issued. It applies to batch output only. The command is: NEWPAGE 4 BLANK BLANK Command ----- ------- Blank lines can be output by using the command: BLANK n where n is the number of blank lines written. 4 TITLE TITLE Command ----- ------- The command: TITLE "titlestring" causes the text "titlestring" to be printed, centered on the line. If the length of "titlestring" is longer than current lines width, it will be truncated and a warning issued. 4 DATE DATE Command ---- ------- The command: DATE will cause the current date to be printed, centered on the line. 4 LINES LINES Command ----- ------- This command controls the number of lines per page (exclusive of title). The command: LINES n will establish page size to n lines. Default is 56. 4 WIDTH WIDTH Command ----- ------- This command controls the width of a printed line. The command: WIDTH n will establish a line width of n characters. Default is 78 if output is to a terminal, 132 if output is to a batch printer. 3 KEY KEY COMMANDS --- -------- 4 BUILD_KEY BUILD KEY Command ----- --- ------- This command is used to change an attribute from non-key to KEY. An index is built from existing data values by making a pass through current rows of the specified relation. This index is then used and maintained just as if the attribute had been declared to be KEY in the original data base definition. BUILD KEY FOR attname IN relname 4 DELETE_KEY DELETE KEY Command ------ --- ------- This command is used to change an attribute from KEY to non-key. The index file for that attribute is inactivated and no longer maintained or used once the attribute has been changed to non-key with this command. DELETE KEY FOR attname IN relname 3 UNLOAD UNLOAD Command ------ ------- The UNLOAD command permits you to off-load a portion or all of your data base onto a previously designated file (see OUTPUT command). The file will contain 80 character text records and will be readable by RIM on the same or on a different computer using the INPUT command. Default file name is OUTPUT. The syntax of this command is: UNLOAD [ dbname = newname ] (ALL ) + SCHEMA DATA [ relname1 [ = mpw1 ] relname2 [ = mpw2 ] ...] The mandatory part offers a choice between ALL, DATA and SCHEMA. Specifying SCHEMA will off-load the schema of your data base, DATA will off-load the data of your data base and ALL will off-load both schema and data. Optionally you may rename your data base by entering dbname = newname where dbname is the name of the currently open data base. By specifying relation names, you will only off-load data and/or schemas for the specific relations. The password associated with a relation name must be specified if your current user password does not allow you modify access to the relation. There are implicit password restrictions to the unload command as follows: If you are the data base owner, you may off-load any data and/or schema. If you are not the owner, you may off-load data and or schema for the relations for which you have modify access permission. Your password becomes the owner of the off-loaded data base. Rules, if any, will only be off-loaded if you are the owner of the data base and you have used the option ALL. 3 MISCELLANEOUS 4 OPEN OPEN Command ---- ------- The OPEN command is required whenever an existing data base is to be used. You specify the name of the data base. RIM uses the name of the data base to form the names of the three local files which contain the data base. OPEN dbname Only one RIM data base may be open at one time (if you don't CLOSE the present data base before opening a new one, RIM will automatically close the present data base). The OPEN command must be issued before any commands that require data from the data base can be processed. 4 CLOSE CLOSE Command ----- ------- The CLOSE command permits you to close a RIM data base without leaving RIM. The reason for doing this is to close one data base, then open or define a different one all within one RIM session. This command is not needed if only one RIM data base is accessed during a RIM session. This command results in data needed by the data base being copied from its incore working areas to the local data base files. CLOSE Note: the current data base will be closed for you when you leave RIM by issuing an EXIT command 4 INPUT INPUT Command ----- ------- This command causes RIM to read subsequent commands and/or data from a specified file. When RIM detects an end-of-file mark on the indicated file, RIM will return to the terminal or batch input file, as apppropriate, and continue to read input and/or data. The use of this command allows the user to define command procedures on file and then have RIM execute a set of commands without user interaction. INPUT filename A more explicit way to control return of input to your terminal or batch input file is to use INPUT INPUT as the last command which returns input, as appropriate, to the batch input file or user terminal. As an alternative, INPUT TERMINAL may be used. A more general use of this command is possible by causing a second alternate input file to be used from the first alternate file by use of the INPUT command. This nesting of alternate input files can be done to any depth. It should be noted that you must provide explicit returns on these alternate files using the INPUT command since the default is to return to your input file (terminal if applicable). 4 OUTPUT OUTPUT Command ------ ------- This command is used to specify the name of the output file. Specifying a file other than OUTPUT will result in the output from the RIM commands to be placed on a local file with the specified file name. The output file name may be changed as often as desired. The use of this command allows the user to get offline hardcopy output from RIM. OUTPUT filename OUTPUT TERMINAL will return the output to the user's terminal. 4 HELP HELP Command ---- ------- The HELP command provides the capability to obtain a description of the available RIM commands, a discussion of the general command syntax, a summary of all available commands, and general news about the RIM system. HELP is available at any time during execution except when in the interactive dialog (menu) mode. To receive help when in the command mode enter: HELP [{command name}] RIM WHERE SORT SYNTAX INPUT FORMAT SUMMARY NEWS You will then enter the HELP submodule and receive explanation of the selected option as: OPTION EXPLANATION ------ ----------- HELP previous command and syntax or, if first command identical to HELP RIM HELP command name indicated command and syntax HELP RIM list of commands for which help is available HELP SYNTAX description of the RIM command input format, basic syntax and data genration facilities HELP INPUT FORMAT an in-depth description of free-field input format and data generation facilities available in RIM HELP WHERE the RIM where clauses HELP SORT the RIM sort clause HELP SUMMARY summary of all available RIM commands HELP NEWS general news about the RIM system You will remain in the HELP submodule until you enter an END command which will return you to the command mode. The commands available inside the HELP submodule are identical to the HELP commands except that the keyword HELP is omitted. The HELP submodule displays information one screen at a time. After each screen you will have the option to continue displaying the text or to return to the HELP submodule by entering QUIT. 4 USER USER Command ---- ------- This command is used to identify your password to RIM. Your password is used to check against read and modify passwords specified for the relations. Each time this command is issued, the new password replaces the current password. The default password is the word NONE. USER password 4 ECHO ECHO Command ---- ------- This command is used to control printing of your input commands on the output file. The default is for echo to be off in interactive execution and on in batch. To activate echo print you enter: ECHO 4 NOECHO NOECHO Command ------ ------- The NOECHO command turns off the echo printing. NOECHO 4 TOLERANCE TOLERANCE Command --------- ------- For real and double precision attributes and for real and double precision vectors and matrices as well as for individual elements of such vectors and matrices, you may want to use a tolerance in qualifying equality, non equality and order. The tolerance applies to any real or double precision number you use in a WHERE clause. If A is an attribute with value a and r is a user specified number used in a WHERE clause and t a tolerance (positive, zero or negative), the following are true conditions: A EQ r if and only if r-t le a le r+t A NE r if and only if a lt r-t or a gt r+t A GT r if and only if a gt r-t A GE r if and only if a ge r-t A LT r if and only if a lt r+t A LE r if and only if a le r+t For real and double precision attributes of length greater than 1 and for real and double precision vectors and matrices, the above formulas are applied to the comparison of each element. If t is a percentage tolerance, t is to be replaced with t x r/100 in the above expressions to define true conditions for percentage tolerances. TOLERANCE tol [PERCENT] where tol is the tolerance and the presence or absence of the keyword PERCENT indicates whether tol is a percentage tolerance or or not. The TOLERANCE command can be used as many times as desired to reset the tolerance. A tolerance stays in effect for a session until a new tolerance is specified. The default value for tolerance is 0. 4 NOCHECK NOCHECK Command ------- ------- Rule checking applies to the CHANGE command and LOAD command to load or modify data. The default is that rules, if defined, are enforced. The NOCHECK command suppresses the rule checking. NOCHECK [RULES] 4 CHECK CHECK Command ----- ------- The CHECK command turns on rule checking. The CHECK and NOCHECK commands may be issued as many times as required anywhere in the input stream while in command mode. CHECK [RULES] 4 EXIT EXIT Command ---- ------- To leave the RIM system you issue the command: {EXIT} QUIT This command closes your current data base. Data needed by your data bases are copied from the incore working areas to the files whose names were determined by the OPEN command or by the schema name designated in the DEFINE submodule. 4 QUIT QUIT Command ---- ------- To leave the RIM system you issue the command: {QUIT} EXIT This command closes your current data base. Data needed by your data bases are copied from the incore working areas to the files whose names were determined by the OPEN command or by the schema name designated in the DEFINE submodule. 4 RELOAD RELOAD Command ------ ------- The RELOAD command is used whenever you want to rebuild the data files of your data base to recover unused space created by row deletions, certain attribute changes and relation removals. When a row is deleted, one of its variable length attributes changed so that it length increases, or when a relation is removed, the vacated space is not reused until you issue this command. If your data base has any KEY attributes, then the access pointer files maintainted for those attributes are also rebuilt. The syntax for this command is: RELOAD 3 SCHEMA QUERYING THE SCHEMA -------- --- ------ 4 LISTREL LISTREL Command ------- ------- The purpose of LISTREL is to provide you with information about the relations in your data base. There are three formats for the LISTREL command. The first consists of simply entering: LISTREL Using LISTREL in this fashion provides you with a list of all relations currently defined in your data base. If you wish to display the definition of a specific relation, then the syntax is: LISTREL relname The use of LISTREL in this manner also provides a count of the number of defined rows for the specified relation. LISTREL ALL This command will display the definitions of all relations in the data base, including counts of number of defined rows in each relation. 4 EXHIBIT EXHIBIT Command ------- ------- The purpose of the EXHIBIT command is to allow you to query the RIM dictionary to obtain the names of all relations having a specific set of attributes. For example, if you want to know which relations contain the attribute attname you would enter: EXHIBIT attname You would then obtain either a list of the relations having this attribute, or a message indicating that this attribute was not found in any relations in the data base. In other cases, you may wish to know which relations contain a list of attributes. This request is handled in a similar manner. Suppose that you wanted to know which relations contain both attname1 and attname2. The command would than be: EXHIBIT attname1 attname2 In general, the syntax of this command is: EXHIBIT attname1 [attname2 ... attnamen] 4 PRINT_RULES PRINT RULES Command ----- ----- ------- This command can be used by the person whose current password matches the owner of the data base definition to obtain a complete list of all constraint rules. PRINT RULES 2 SYNTAX Input Format, Data Generation and Syntax ----- ------ ---- ---------- --- ------ RIM is used by entering commands in response to input prompts. The input prompts vary with RIM submodule used. The commands always begin with a RIM keyword and may contain adiitional keywords and other text and numerical items. Keywords are described using capital letters. Three of the commands (DEFINE, HELP and LOAD) are used to enter submodules which have their own set of commands and prompts for defining a data base, for providing on-line help to the interactive user and for loading a data base. In describing commands, the following conventions are used: relname or name of a relation(s) relname1, relname2, ... attname or name of an attribute(s) attname1, attname2, ... value actual value(s) or (value may be a text string, value1, value2, ... scalar, vector or matrix) All relation and attribute names must contain at least 1 and no more than 8 alphanumeric characters. Many of the RIM commands have optional parts. These optional parts are enclosed in square brackets. [THIS IS OPTIONAL] Sometimes, a keyword is selected from a list of acceptable keywords. In this case the acceptable keywords are listed vertically with the first choice enclosed in brackets. {CHOOSE} ONE OF THESE RIM command keywords may be abbreviated. At least the first 3 characters in a keyword are required. The following 3 set of keywords are equivalent: 1) SELECT, FROM, WHERE DELETE DUPLICATES 2) SELEC FRO WHER DELET DUPL 3) SEL, FRO WHE, DEL DUP Commands in RIM are entered in a free-field format with blanks and commas as separators. RIM also provides powerful data repetition and data generation facilities. The following provides a short and non complete description of RIM conventions and data generation facilities. A more extensive description, intended for the more experienced RIM user, is contained in section INPUT FORMAT. Keywords and data values are separated by blanks and commas. If a command is too long for one 80 character line, it may be continued on succeeding line(s) by entering "+" as the last character on the line(s). RIM remembers the previous command. This enables you to re-use all or part of the previous command. This is done by using an asterisk to indicate which items of the previous command are to be re-used. A single asterisk means re-use thee corrosponding single item of th previous record. An asterisk followed by a number n means re-use the next n corresponding items. Two asterisks mean re-use all remaining corresponding items. The following are all equivalent: 1) THIS IS A COMMOND 2) THIS + IS+ A + COMMAND 3) * IS, A COMMAND 4) THIS *2 COMMAND 5) THIS ** Multiple commands may be entered on one line separated by a semicolon or a dollar sign . THIS IS FIRST ; THIS IS SECOND $ THIS IS THIRD Comments may be placed anywhere within a command by enclosing the comment between the characters *( and ). *(THIS IS A COMMENT) THIS IS NOT When numeric data is to be interpreted as text (alphanumeric) data, the numerals must be enclosed by quotation marks. "1234" When entering text strings which contain embedded blanks or commas, the entire string must be enclosed by quotation marks. "THIS IS A TEXT STRING" A text string may require continuation on additional line(s). The + sign convention can then be used within the quotation marks. "THIS IS+ A TEXT + STRING" It recommended as good practice not to use leading blanks in text strings. (The precise number of leading blanks in a string must be used when it is referenced) "THIS IS GOOD PRACTICE" " THIS IS NOT" Integer data are input as a string of digits without a decimal point. A sign may precede the digits 123 , -63, +56, 0 Real (floating point) numbers must include a decimal point or E for exponent. If a decimal point is not precent the E must be preceded by an integer. 1.3, .005, 0., 6.E-1, 6E-1, 0.60, -23.45 The absolute value of real number is limited to the range 1.0E-38 to 1.0e+38 2 SUMMARY SUMMARY ------- DEFINING A DATABASE SCHEMA: DEFINE dbname OWNER password ATTRIBUTES attname {REAL} [{length}] [KEY] INT VAR TEXT DOUB RVEC IVEC DVEC attname {RMAT} {row, col} [KEY] IMAT row, VAR DMAT VAR, VAR RELATIONS relname WITH attname1 [attname2 ... attnameN] PASSWORDS {READ PASSWORD} FOR {relname} IS PASSWORD RPW ALL {MODIFY PASSWORD} FOR {relname} IS PASSWORD MPW ALL RULES attname [IN relname] {EQ} value [{AND} ...] NE OR GT GE LT LE attname IN relname {EQA} attname IN relname [{AND} ... NEA OR GTA GEA LTA LEA END LOADING A RELATION: LOAD relname value1 value2 ... valueN END value : SCALARS val1 TEXT "text string" VECTOR (val1, val2, ...) MATRIX ((r1c1, r2c1, ...), (r1c2, r2c2, ...), ...) QUERYING A RELATION: SELECT {attname1 [=fld1], attname2 [=fld2], ...} FROM relname + attnum1 [=fld1], ... attname1(i), ... attname1(i, j), ... ALL [SORTED BY attname1 [={A}], [attname2 [={A}], ...]] + D D [WHERE ...] TALLY attname [={A}] FROM relname [WHERE ...] D WHERE CLAUSE : WHERE attname {EXISTS} [{AND} ...] FAILS OR EQ {value} EQS MAX NE MIN GT LT LE WHERE attname {EQA} attname [{AND} ...] NEA OR GTA GEA LTA LEA WHERE ROWS {EQ} rownumber [{AND} ...] NE OR LT LE GE GT WHERE {attname} {EQ} list [{AND} ...] ROWS NE OR WHERE LIMIT EQ number [{AND} ...] COMPUTATION COMMANDS: COMPUTE {COUNT} attname FROM relname [WHERE ...] MIN MAX AVE SUM MODIFICATION COMMANDS: CHANGE {attname} TO value [IN relname] WHERE ... attname(i) attname(i, j) CHANGE {RPW} TO newpass FOR relname MPW CHANGE OWNER TO newowner DELETE ROWS FROM relname WHERE ... DELETE DUPLICATES [attname1, attname2, ...] FROM relname DELETE RULE rulenumber RENAME ATTRIBUTE attname TO newname [IN relname] RENAME RELATION relname TO newname REMOVE relname RELATIONAL ALGEBRA COMMANDS: INTERSECT relname1 WITH relname2 FORMING relname3 + [USING attname1 [attname2, ...]] JOIN relname1 USING attname1 WITH relname2 USING attname2 + FORMING relname3 [WHERE {EQ}] NE GT GE LT LE SUBTRACT relname1 FROM relname2 FORMING relname3 + [USING attname1 [attname2, ...]] PROJECT relname1 FROM relname2 USING + {attname1, [attname2, ...]} [WHERE ...] ALL QUERYING THE SCHEMA: LISTREL [relname] ALL EXHIBIT attname [attname ...] PRINT RULES REPORT COMMANDS: NEWPAGE BLANK n TITLE "title" DATE LINES n WIDTH n KEY COMMANDS: BUILD KEY FOR attname IN relname DELETE KEY FOR attname IN relname RIM-TO-RIM COMMANDS: UNLOAD [dbname [=newdbname]] {SCHEMA} [relname1 [=mpw] + DATA ALL [relname2 [=mpw], ...] MISCELLANEOUS COMMANDS: OPEN dbname CLOSE INPUT {filename} TERMINAL OUTPUT {filename} TERMINAL EXIT QUIT MENU HELP [command name] USER password ECHO NOECHO CHECK NOCHECK TOLERANCE xx.xx [PERCENT] RELOAD 2 MENU MENU Command ---- ------- The MENU command places the user in menu mode. It may be entered at any point when in command mode except when in the DEFINE or LOAD modules. Menu mode is particulary useful for schema definition and data loading. 2 INPUT_FORMAT INPUT FORMAT ----- ------ Entering input through LXLREC -------- ----- ------- ------ LXLREC is a free-field input routine which separates user input into items which are grouped into records. Terminology ----------- line - one line of information with a maximum of 80 characters. A line corresponds to a card (for those old enough to remember card input). item - one piece of information. An item may be a real number, an integer or text. Items are delimited by blanks or commas. Multiple blanks count as a single blank. Multiple commas generate null items (see section on multiple commas). record - a collection or list of up to 100 items which is in response to a single request for data by the calling program. integer- all characters must be numeric except the first one which may be + or -. For example: -1 23 +10000 real - an item of the form i1.i2ei3 where i1 and i3 may be signed integers and i2 is an unsigned integer. The entire form is not necessary but at least one digit and either the . Or the e must be present. for example: 1. E-3 -2.7E+4 .0 text - any single item which is not an integer or real. If a text item looks like an integer or real or if it contains blanks or commas, it must be enclosed in quotes ("). Composing records --------- ------- Ordinarily records consist of one line. However, multiple records may be put on one line by separating them with dollars or semi-colons. Alternatively, a record may span several lines by ending all but the last line with a plus. In general items must be wholly contained on one line with the exception of quoted text items and comments. Special items - =, (, ) ------- ----- ------- Equals and left and right parentheses are treated as single items unless enclosed in quoted text items. Thus a=3. Is 3 items (two text and one real) rather than one item. "a=3." is one text item. This allows more convenient parsing of many commands. Multiple commas -------- ------ If more than one comma separates two items, each additional comma will generate a text item with Three characters "-0-". Thus, , , abc, , 2.5 is equivalent to -0-, abc, -0-, 2.5. Rules for text items ----- --- ---- ----- A quoted text item is terminated by a record separator (dollar or semi-colon). Quoted text items may be continued on multiple lines. If the trailing quote is omitted on the last item in a record, the quoted item is terminated at either the record separator, if any, or the last non-blank character on the line. Quotes may be included in quoted text items by doubling the quotes (e.g. "a, ""b" yields a, "b as a text string). The total number of characters for all text items in a record is limited to 2000. Some examples ---- -------- 1, 2. ABC "2." This record has four items - integer, real and two text 1 $ 2 This line is two records - each one integer 1 + 2 This is one record on two lines with two integers Comments -------- Comments may be included anywhere in the input stream by enclosing them between *( and ). For example *( this is a comment). comments are completely ignored by LXLREC. Empty lines between records are also ignored and may be used to paragraph input. An alternative form of comment is */..../ where slashes replace the parentheses. This may be used if parentheses are needed in the comment. Short cuts - data generation ----- ---- ---- ---------- Activities such as entering large volumes of data, repeating similiar records and reentering mis-typed records can be eased by using the LXLREC data generation facilities. Repeating items on previous record - *n, **, * --------- ----- -- -------- ------ ------- A data item of the form *n where n is an unsigned integer indicates that the next n items in that record are identical to the corresponding n items in the preceeding record. An isolated * is treated as *1. Double asterisks (**) indicate that the remaining items in the previous record are to be copied into the current record. Repeating an item in the current record - *=n *=n+step --------- -- ---- -- --- ------- ------ --- -------- An item of the form *=n, where n is an unsigned integer, indicates that the next n items are identical to the immediately preceding item. An item of the form *=n+step or *=n-step where step is an unsigned real or integer, indicates that the next n items are to be generated by consecutively incrementing the immediately preceding item. Generating multiple records - *+n ---------- -------- ------- --- A record beginning with *+n where n is an unsigned integer indicates that the next n records are to be generated from the preceding record. Each item of the generated record is formed by adding an item of the *+n record to the corresponding item of the immediately preceding input or generated record. A zero (integer) item should be inserted in an *+n record for text items in the preceding record. The number of items after the *+n must match the number in the preceding record. Note on generating items ---- -- ---------- ----- When increments are specified, either on the *+n record or as step on an *=n+step item they must match the item they are incrementing in type. It should be noted that the *+n record generation option is based on the expanded representation of the previous record. The generation does not operate on the card image of the preceding record if it contains data generation items. Therefore, it is not possible to repeat or increment an asterisk-type item. Examples -------- Consider the following seven input records to illustrate the data generation features. 1 2 3 4 5 6 7 8 9 10 11 12 2 1 *2 4 *=2 1 *=2+2 ** *+1 0 *=3 0 *=5 ** *+1 0 *=11 *+1 *12 *+1 ** ** Twelve data items are defined by each of these records. Each of the last six records is translated into the same internal record which is: 2 1 3 4 4 4 4 1 3 5 11 12 Note - the last five records could be replaced by the single record: *+5 ** Changing special characters -------- ------- ---------- It is possible to change the special characters LXLREC uses to break apart records. These special characters may either be changed to another character or set to null so that they are ignored. This is useful for reading specially formatted files or to allow special characters to be input as text items. to change special characters enter the following special comment as the only entry on a line between records. *(set keyword=newvalue) where keyword can be DOLLAR SEMI QUOTES BLANK PLUS COMMA and newvalue is either the word null or the new special character. For example, if one wanted to use dollars to delimit items rather than records and to not have commas delimit items, the following two lines could be entered. *(SET DOLLAR=NULL) *(SET COMMA=$) Note that commas could now be used in unquoted text strings and dollars could now be included in quoted text strings. Also, note that it is really the function that is being altered, not the character. Changing plus only changes the line continuation character, not the representation of real numbers. To restore the original condition after the above example, the following could be entered. *(SET DOLLAR=$) *(SET COMMA=, ) Warning - using the same character for multiple functions will produce undefined results...(undefined means even the author wouldn't want to guess what will happen). Echo ---- LXLREC will echo the input line as the default. Either the user or the calling program can switch echo on or off. The user accomplishes this by entering *(SET ECHO=ON) or *(SET ECHO=OFF) in the same manner as setting special characters. -h- rimptr.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]RIMPTR.BLK;1 C C *** / R I M P T R / *** C C RIM INTERNAL POINTERS C COMMON /RIMPTR/ IVAL,LIMVAL,CID,NID,NS,MID,INDCUR,INDMAX INTEGER CID C C VARIABLE DEFINITIONS: C IVAL----CURRENT TUPLE NUMBER C LIMVAL--COUNT OF TUPLES SATISFYING WHERE C CID-----CURRENT TUPLE ID C NID-----NEXT TUPLE ID C NS------SORTING AND INDEX FLAG C 0 = SEQUENTIAL SCAN OR DONE C 1 = SORTED RETRIEVAL C 2 = INDEXED RETRIEVAL (FIRST VALUE) C 3 = INDEXED RETRIEVAL (MULTIPLE VALUES) C MID-----MULTIPLE OCCURENCE ID VALUE (NEXT MOT INDEX) C INDCUR--CURRENT INDEX TO THE THE SET OF PARTITIONS IN USE C INDMAX--MAXIMUM NUMBER OF POINTERS IN USE C -h- rimtxt.txt Mon Dec 02 10:17:26 1985 DF1:[DBMS]RIMTXT.TXT;1 DEFINITIONS ATTRIBUTE: An attribute is a 1-8 character alphanumeric name used to identify a specific column of a relation. DOMAIN: A domain is the set of values which are permissible in a column of a two-dimensional table of data (relation). KEY: An attribute may be specified to be "KEY". This specification will cause RIM to build an index for the attribute. Under certain conditions, this index will greatly improve the system efficiency for queries and updates. RELATION: A relation is a two-dimensional table of data. The column headings are the attributes of the relation and the rows are the data occurences (tuples). ROW: A row is the set of values in a row of a two- dimensional table (relation). A row is sometimes referred to as a tuple. SCHEMA: The schema is the definition of the relations and their attributes that comprise the data base. The relation passwords and constraint rules also are part of the schema. SUMMARY This document is the user's guide (VAX/VMS) for the Relational Information Management System, Version 5 (RIM-5). The information presented consists of instructions for using RIM-5 as a standalone system and for using RIM-5 in conjunction with an application program. Section 1.0 presents the method of implementation and access for RIM-5, a discussion of the files used by RIM-5, and the general syntax of the RIM-5 command language. Section 2.0 presents instructions for the use of RIM-5 as a stadalone system in both menu and command modes. In the menu mode, you are prompted for the inputs required to create, update, and/or query the data base. The command mode, as an alternative, requires the direct input of RIM-5 commands to create, update, and/or query the data base. A discussion of all the available RIM-5 command is presented in this section. Section 3.0 presents the instructions for the application program interface. Any programming language that can call FORTRAN subroutines can be used. The appendices present a summary of the RIM-5 commands, a summary of the application program interface, a sample RIM FORTRAN program, a list of the current limitations, and a discussion of the LXLREC free field input routine. 1.0 OVERVIEW The Relational Information Management (RIM) System was originally developed as a prototype data base management system by Dennis L. Comfort and Wayne J. Erickson at The Boeing Company under NASA Contract NAS1-14700 (IPAD). Mr. Erickson at the University of Washington, and Frederick P. Gray at The Boeing Company made en- hancements to the system which culminated in RIM Version 4 (RIM- 4) . RIM-5, which is the version of RIM described in this document, was developed by Mr. Erickson for NASA and Mr. Gray and Geofferey Von Limbach for Boeing. RIM is based upon the relational algebra model for data management and has been used for both en- gineering and business data. The system is available as a stand- alone system and through an application program interface. The standalone system may be executed in two modes: menu or command. The menu mode prompts the user for the input required to create, update, and/or query the data base. The command mode requires the direct input of RIM commands. RIM-5 includes several enhancements relative to RIM-4, including: . highly portable FORTAN code . additional scientific attribute types fo vectors and matrices . variable length attributes . improved sort option . improved where clause . an initial set of report writing commands . introduction of tolerance for floating point numbers . additional schema modification commands . enhanced FORTAN interface . RIM-to-RIM communications file To the interactive/batch -h- rio.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]RIO.BLK;1 C C *** / R I O / *** C C RANDOM FILE RECORD COUNT C COMMON /RIO/ IRECPS(10) C C VARIABLE DEFINITIONS C IRECPS--ARRAY CONTAINING THE NEXT RECORD NUMBER FOR THE C RANDOM FILES (UNITS 30-39) C -h- rioin.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RIOIN.FOR;1 SUBROUTINE RIOIN(FILE,RECORD,BUFFER,NWDS,IOS) INCLUDE '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 INTEGER BUFFER(*) READ(FILE,REC=RECORD,IOSTAT=IOS) (BUFFER(I),I=1,NWDS) RETURN END -h- rioopn.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RIOOPN.FOR;1 SUBROUTINE RIOOPN(FNAME,FILE,NWDS,IOS) INCLUDE '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 'RIO.BLK' REAL*8 FNAME CHARACTER*8 NAME INTEGER FILE WRITE(NAME,100) FNAME 100 FORMAT(A8) OPEN(UNIT=FILE, FILE=NAME, ACCESS='DIRECT', X RECL=NWDS, ORGANIZATION='SEQUENTIAL', X STATUS='UNKNOWN',IOSTAT=IOS,SHARED) IUN = FILE - 29 IRECPS(IUN) = 0 RETURN END -h- rioout.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RIOOUT.FOR;1 SUBROUTINE RIOOUT(FILE,RECORD,BUFFER,NWDS,IOS) INCLUDE '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 'RIO.BLK' INTEGER FILE INTEGER RECORD INTEGER BUFFER(*) IUN = FILE - 29 IRECPS(IUN) = IRECPS(IUN) + 1 IF(RECORD.EQ.0) GO TO 100 WRITE(FILE,REC=RECORD,IOSTAT=IOS) (BUFFER(I),I=1,NWDS) RETURN 100 CONTINUE N = IRECPS(IUN) WRITE(FILE,REC=N,IOSTAT=IOS) (BUFFER(I),I=1,NWDS) RETURN END -h- rmatts.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMATTS.BLK;1 C C *** / R M A T T S / *** C C MISCELLANEOUS CONSTANTS -- ATTRIBUTE TYPES C COMMON /RMATTS/ KZVEC,KZMAT,KZVAR,KZINT,KZREAL,KZDOUB,KZTEXT, X KZIVEC,KZRVEC,KZDVEC,KZIMAT,KZRMAT,KZDMAT C -h- rmclos.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMCLOS.FOR;1 SUBROUTINE RMCLOS INCLUDE 'TEXT.BLK' C C PURPOSE: CLOSE A RIM DATABASE. C INCLUDE 'RIMCOM.BLK' INCLUDE 'CONST8.BLK' INCLUDE 'FLAGS.BLK' INCLUDE '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 -h- rmcons.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMCONS.FOR;1 SUBROUTINE RMCONS INCLUDE 'TEXT.BLK' C C PURPOSE: THIS ROUTINE INITIALIZES THE HOLLERITH CONSTANTS USED C BY RIM. THE CODE IS MACHINE DEPENDENT. C INCLUDE 'FLAGS.BLK' INCLUDE 'MISC.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'CONST8.BLK' INCLUDE 'RMATTS.BLK' INCLUDE '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 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 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 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 -h- rmdate.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMDATE.FOR;1 SUBROUTINE RMDATE(IT) INCLUDE 'TEXT.BLK' C C PURPOSE: RETURN THE CURRENT DATE IN YY/MM/DD FORMAT C C PARAMETERS: C IT------THE CURRENT DATE C INCLUDE 'MISC.BLK' INTEGER MONTH,DAY,YEAR REAL*8 IT BYTE SLASH DATA SLASH /1H// CALL IDATE(MONTH,DAY,YEAR) 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 -h- rmdbgt.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMDBGT.FOR;1 SUBROUTINE RMDBGT(NAMDB,DBSTAT) INCLUDE '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 -h- rmdblk.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMDBLK.FOR;1 SUBROUTINE RMDBLK(NAMDB) INCLUDE '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 'RIMCOM.BLK' RMSTAT = 0 RETURN END -h- rmdbpt.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMDBPT.FOR;1 SUBROUTINE RMDBPT INCLUDE '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 -h- rmdel.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMDEL.FOR;1 SUBROUTINE RMDEL(INDPTR) INCLUDE '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 'KEYDAT.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'MISC.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'BUFFER.BLK' INCLUDE '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 -h- rmfind.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMFIND.FOR;1 SUBROUTINE RMFIND(INDPTR,RNAME) INCLUDE '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 'FLAGS.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'VARDAT.BLK' INCLUDE 'KEYDAT.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'MISC.BLK' INCLUDE 'PTRCOM.BLK' INCLUDE 'RULCOM.BLK' INCLUDE 'WHCOM.BLK' C LOGICAL EQ INCLUDE '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 -h- rmgatt.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMGATT.FOR;1 SUBROUTINE RMGATT(ANAME,TYPE,MATVEC,VAR,LEN1,LEN2,COL,KEY) INCLUDE '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 'RIMPTR.BLK' INCLUDE 'RMATTS.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'MISC.BLK' INTEGER STATUS LOGICAL EQ INTEGER TYPE INTEGER MATVEC INTEGER LEN1,LEN2 INTEGER COL LOGICAL VAR LOGICAL KEY INCLUDE '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 -h- rmget.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMGET.FOR;1 SUBROUTINE RMGET(INDPTR,TUPLE) INCLUDE '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 'RIMCOM.BLK' INCLUDE 'VARDAT.BLK' INCLUDE 'PTRCOM.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'FLAGS.BLK' INCLUDE '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 -h- rmgrel.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMGREL.FOR;1 SUBROUTINE RMGREL(RNAME,LRPW,LMPW,LASTMD,NUMATT,NUMTUP) INCLUDE '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 'RIMCOM.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'CONST8.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'MISC.BLK' INTEGER STATUS INTEGER NUMATT INTEGER NUMTUP LOGICAL LRPW LOGICAL LMPW LOGICAL EQ INCLUDE 'DCLAR1.BLK' INCLUDE '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 -h- rmgtso.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMGTSO.FOR;1 SUBROUTINE RMGTSO(MAT,INDEX,IFLAG,LENGTH,INDPTR) INCLUDE '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 'SRTCOM.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'F2COM.BLK' INCLUDE '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 READ(INFIL) LENGTH,(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 -h- rmhelp.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMHELP.FOR;1 SUBROUTINE RMHELP INCLUDE '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 'RMATTS.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'FILES.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'MISC.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'SELCOM.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'DCLAR4.BLK' INCLUDE '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 WRITE (NOUT,1005) 1005 FORMAT(32H ENTER END TO END HELP OR A RIM , X 19HKEYWORD TO 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 WRITE (NOUT,2050) 2050 FORMAT(42H UNABLE TO FIND HELP FOR REQUESTED COMMAND ) GO TO 1000 2100 CONTINUE ITEXT = ITUP + BUFFER(ITUP+1) NC = BUFFER(ITEXT) NW = BUFFER(ITEXT-1) IF(NC.NE.1) WRITE(NOUT,2150)(BUFFER(ITEXT+I),I=1,NW) 2150 FORMAT(20A4) IF(NC.NE.1) GO TO 2300 C C PAGE BREAK C WRITE (NOUT,2250) 2250 FORMAT(28H MORE TEXT FOLLOWS - ENTER * , X 28H TO CONTINUE OR QUIT TO STOP ) 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 WRITE (NOUT,8005) 8005 FORMAT(32H HELP IS NOT CURRENTLY AVAILABLE ) GO TO 9000 8100 CONTINUE C C NON TEXT INPUT C WRITE (NOUT,8105) 8105 FORMAT(28H HELP REQUIRES TEXT COMMANDS ) GO TO 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 WRITE (NOUT,9005) 9005 FORMAT(20H ENTER NEXT COMMAND ) RETURN END -h- rmkeyw.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMKEYW.BLK;1 C C *** / R M K E Y W / *** C C RIM KEY WORDS C COMMON /RMKEYW/ KWBY,KWEQ,KWIN,KWIS,KWTO, X KWALL,KWEND,KWFOR,KWINT,KWKEY,KWMPW,KWRPW,KWVAR,KWZIP, X KWDATE,KWDMAT,KWDVEC,KWECHO,KWEXIT,KWFROM,KWHELP,KWIMAT, X KWIVEC,KWJOIN,KWLOAD,KWMENU,KWOPEN,KWQUIT,KWREAD,KWREAL, X KWRMAT,KWROWS,KWRULE,KWRVEC,KWTEXT,KWUSER,KWWITH,KWBLAN, X KWBUIL,KWCHEC,KWCLOS,KWCOUN,KWINPU,KWLIMI,KWLINE,KWOWNE, X KWPRIN,KWRULS,KWTALL,KWTITL,KWUSIN,KWWHER,KWWIDT,KWCHAN, X KWDEFI,KWDELE,KWDOUB,KWMODI,KWNOEC,KWOUTP,KWRELO,KWREMO, X KWRENA,KWSELE,KWSORT,KWTUPL,KWUNLO,KWCOMP,KWEXHI,KWFORM, X KWLIST,KWNEWP,KWNOCH,KWPERC,KWPROJ,KWATTR,KWDUPL,KWELEM, X KWINTS,KWPASS,KWRELA,KWSUBT,KWTERM,KWTOLE C REAL*8 KWBY,KWEQ,KWIN,KWIS,KWTO, X KWALL,KWEND,KWFOR,KWINT,KWKEY,KWMPW,KWRPW,KWVAR,KWZIP, X KWDATE,KWDMAT,KWDVEC,KWECHO,KWEXIT,KWFROM,KWHELP,KWIMAT, X KWIVEC,KWJOIN,KWLOAD,KWMENU,KWOPEN,KWQUIT,KWREAD,KWREAL, X KWRMAT,KWROWS,KWRULE,KWRVEC,KWTEXT,KWUSER,KWWITH,KWBLAN, X KWBUIL,KWCHEC,KWCLOS,KWCOUN,KWINPU,KWLIMI,KWLINE,KWOWNE, X KWPRIN,KWRULS,KWTALL,KWTITL,KWUSIN,KWWHER,KWWIDT,KWCHAN, X KWDEFI,KWDELE,KWDOUB,KWMODI,KWNOEC,KWOUTP,KWRELO,KWREMO, X KWRENA,KWSELE,KWSORT,KWTUPL,KWUNLO,KWCOMP,KWEXHI,KWFORM, X KWLIST,KWNEWP,KWNOCH,KWPERC,KWPROJ,KWATTR,KWDUPL,KWELEM, X KWINTS,KWPASS,KWRELA,KWSUBT,KWTERM,KWTOLE C -h- rmlatt.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMLATT.FOR;1 SUBROUTINE RMLATT(RNAME) INCLUDE '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 'RIMPTR.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'MISC.BLK' INTEGER STATUS LOGICAL EQ INCLUDE '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 -h- rmload.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMLOAD.FOR;1 SUBROUTINE RMLOAD(INDPTR,TUPLE) INCLUDE '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 'RIMCOM.BLK' INCLUDE 'VARDAT.BLK' INCLUDE 'KEYDAT.BLK' INCLUDE 'MISC.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'RULCOM.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'RMATTS.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE '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 -h- rmlook.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMLOOK.FOR;1 SUBROUTINE RMLOOK(MAT,INDEX,IFLAG,LENGTH) INCLUDE '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 'RMATTS.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'MISC.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'START.BLK' INCLUDE 'BUFFER.BLK' INCLUDE '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 -h- rmlrel.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMLREL.FOR;1 SUBROUTINE RMLREL INCLUDE '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 'RIMPTR.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'MISC.BLK' INCLUDE '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 -h- rmmain.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMMAIN.FOR;1 PROGRAM 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 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 'CONST4.BLK' INCLUDE 'CONST8.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'CDCDBS.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'FILES.BLK' INCLUDE 'SELCOM.BLK' INCLUDE 'DCLAR6.BLK' LOGICAL TTY INTEGER VER INTEGER UDXX INTEGER MACH(2) DATA VER /3H5.0/ DATA UDXX /4HUD23/ DATA MACH(1),MACH(2) /4H----,4H VAX/ 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 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,/) C C EXECUTION OPTION IS COMMAND BY DEFAULT - PRINT MESSAGE C IF(BATCH) GO TO 500 IF(.NOT.CONNI) GO TO 500 WRITE(NOUT,200) 200 FORMAT(/,1X,16HRIM COMMAND MODE,/, X 1X,26HENTER "MENU" FOR MENU MODE,/) GO TO 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 WRITE(NOUT,360) 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 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) WRITE(NOUT,7001) IDAY,ITIME 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 STOP END -h- rmopen.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMOPEN.FOR;1 SUBROUTINE RMOPEN(IFILE) INCLUDE 'TEXT.BLK' C C PURPOSE: OPEN A RIM DATABASE. C C PARAMETERS: C IFILE---NAME OF THE DATABASE INCLUDE 'CONST4.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'ATTBLE.BLK' INCLUDE 'MISC.BLK' INCLUDE '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 -h- rmput.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMPUT.FOR;1 SUBROUTINE RMPUT(INDPTR,TUPLE) INCLUDE '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 'KEYDAT.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'VARDAT.BLK' INCLUDE 'MISC.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'RULCOM.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'RMATTS.BLK' INCLUDE 'BUFFER.BLK' INCLUDE '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 -h- rmres.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMRES.FOR;1 SUBROUTINE RMRES(INDPTR) INCLUDE '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 'RIMCOM.BLK' INCLUDE 'VARDAT.BLK' INCLUDE 'KEYDAT.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'RULCOM.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'RELTBL.BLK' INCLUDE 'PTRCOM.BLK' INCLUDE 'MISC.BLK' INCLUDE '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 -h- rmrule.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMRULE.FOR;1 SUBROUTINE RMRULE(SWITCH) INCLUDE 'TEXT.BLK' C C PURPOSE: SET THE RULE CHECKING FLAG C C PARAMETERS: C SWITCH--0 MEANS NOCHECK, NOT 0 MEANS CHECK INCLUDE 'FLAGS.BLK' INTEGER SWITCH RUCK = .TRUE. IF(SWITCH.EQ.0) RUCK = .FALSE. RETURN END -h- rmsav.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMSAV.FOR;1 SUBROUTINE RMSAV(INDPTR) INCLUDE '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 'CONST8.BLK' INCLUDE 'MISC.BLK' INCLUDE 'KEYDAT.BLK' INCLUDE 'SRTCOM.BLK' INCLUDE 'RULCOM.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'VARDAT.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'PTRCOM.BLK' INCLUDE 'DCLAR4.BLK' DATA NEXPOS /0/ DATA NEXPOT /0/ DATA NBLK /1/ DATA SAVBLK /20*0/ 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 -h- rmsbuf.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMSBUF.BLK;1 C C *** / R M S B U F / *** C C SORT BUFFER FOR THE FORTRAN INTERFACE C COMMON /RMSBUF/ SORBUF(1542),INFIL(8),OUTFIL(8,6) INTEGER SORBUF INTEGER INFIL INTEGER OUTFIL C C VARIABLE DEFINITIONS: C SORBUF---SORT BUFFER FOR THE FASTIO READ/WRITE C INFIL----FASTIO FET FOR THE SORT INPUT FILE C OUTFIL---FASTIO FET FOR THE SORT OUTPUT FILE C -h- rmsort.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMSORT.FOR;1 SUBROUTINE RMSORT(INDPTR,ANAMES,NUMATT,SORTOR) INCLUDE '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 'RMATTS.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'VARDAT.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'SRTCOM.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'MISC.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'PTRCOM.BLK' INCLUDE 'INCORE.BLK' INCLUDE 'FLAGS.BLK' C INTEGER INFIL INTEGER OUTFIL LOGICAL SAORD INTEGER SORTOR(*) INCLUDE '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 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 -h- rmstrt.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMSTRT.FOR;1 SUBROUTINE RMSTRT INCLUDE 'TEXT.BLK' C C PURPOSE: INITIALIZE ALL NEEDED VARIABLES AND ARRAYS C INCLUDE 'RMATTS.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'CONST8.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'MISC.BLK' INCLUDE 'RELTBL.BLK' INCLUDE 'ATTBLE.BLK' INCLUDE 'INCORE.BLK' INCLUDE 'F1COM.BLK' INCLUDE 'F2COM.BLK' INCLUDE 'F3COM.BLK' INCLUDE 'RULCOM.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE '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 -h- rmtime.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMTIME.FOR;1 SUBROUTINE RMTIME(IT) INCLUDE 'TEXT.BLK' C C PURPOSE: RETURN THE CURRENT TIME C C PARAMETERS: C IT------THE CURRENT TIME IN HH.MM.SS FORMAT C INCLUDE 'MISC.BLK' REAL*8 IT CALL TIME(IT) CALL PUTT(IT,3,1H.) CALL PUTT(IT,6,1H.) RETURN END -h- rmtol.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMTOL.FOR;1 SUBROUTINE RMTOL(VAL,PERC) INCLUDE '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 '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 -h- rmuser.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMUSER.FOR;1 SUBROUTINE RMUSER(ID) INCLUDE 'TEXT.BLK' C C PURPOSE: SET THE CURRENT USERID TO THE USER SUPPLIED ID C INCLUDE 'FLAGS.BLK' INCLUDE 'MISC.BLK' INTEGER ID(*) C C SET THE USERID TO ID. C USERID = BLANK CALL STRMOV(ID,1,8,USERID,1) RETURN END -h- rmvarc.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMVARC.FOR;1 SUBROUTINE RMVARC(CTYP,TUPVAL) INCLUDE '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 'RMATTS.BLK' INCLUDE 'VARDAT.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE '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 -h- rmwher.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMWHER.FOR;1 SUBROUTINE RMWHER(INDPTR,ANAMES,OPERS,VALS,NUMVAL,NXTBOO,NUMBOO) INCLUDE '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 'FLAGS.BLK' INCLUDE 'RMATTS.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'CONST8.BLK' INCLUDE 'MISC.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'PTRCOM.BLK' C LOGICAL IFVAR LOGICAL IFLIM LOGICAL IFTUP INTEGER OPERS(*) INTEGER VALS(NUMBOO,*) INTEGER NUMVAL(*) INTEGER NXTBOO(*) INTEGER IDUM(2) INCLUDE '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 -h- rmzip.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RMZIP.FOR;1 SUBROUTINE RMZIP RETURN END -h- rnamea.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RNAMEA.FOR;1 SUBROUTINE RNAMEA(IATT) INCLUDE '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 'CONST8.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'FILES.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'MISC.BLK' INCLUDE 'DCLAR1.BLK' INCLUDE 'DCLAR6.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE '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 WRITE (NOUT,140) ANAME2,RELNAM 140 FORMAT(19H -ERROR- ATTRIBUTE ,A8, X 28H ALREADY EXISTS IN RELATION ,A8) GO TO 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 WRITE (NOUT,305)ANAME1,NUMT 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 WRITE (NOUT,9200)ANAME1 9200 FORMAT(19H -ERROR- ATTRIBUTE ,A8, X 29H IS NOT AN EXISTING ATTRIBUTE ) GO TO 9999 8300 CONTINUE C C TYPE/LENGTH DIFFERS C WRITE (NOUT,9300)ANAME2,ANAME1 9300 FORMAT(19H -ERROR- ATTRIBUTE ,A8, X 35H EXISTS - TYPE/LENGTH DIFFERS FROM ,A8) GO TO 9999 8400 CONTINUE WRITE (NOUT,9400) 9400 FORMAT(39H -ERROR- UNAUTHORIZED ACCESS FOR RENAME ) GO TO 9999 9997 CONTINUE WRITE(NOUT,9998) ANAME1,NUMR 9998 FORMAT(11H ATTRIBUTE ,A8,12H RENAMED IN ,I3, X 20H PLACES IN THE RULES) GO TO 9999 C C ALL DONE C 9999 CONTINUE RETURN END -h- rnamer.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RNAMER.FOR;1 SUBROUTINE RNAMER INCLUDE 'TEXT.BLK' C C SUBROUTINE TO RENAME A RELATION INCLUDING SUCH C NASTIES AS CHANGING THE RULES. C INCLUDE 'RMATTS.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'CONST8.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'ATTBLE.BLK' INCLUDE 'START.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'FILES.BLK' INCLUDE 'MISC.BLK' INCLUDE 'DCLAR1.BLK' INCLUDE 'DCLAR6.BLK' INCLUDE '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 WRITE(NOUT,9008) 9008 FORMAT(44H -ERROR- DUPLICATE RELATION NAME ENCOUNTERED) GO TO 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 WRITE (NOUT,5) 5 FORMAT(39H -ERROR- UNAUTHORIZED ACCESS FOR RENAME ) GO TO 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 WRITE(NOUT,9009) RNAME,NAMNEW 9009 FORMAT(10H RELATION ,A8,12H RENAMED TO ,A8) C 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 -h- roun.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]ROUN.FOR;1 REAL FUNCTION ROUN(REAL,NUMC,EF) INCLUDE '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 -h- rtoc.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RTOC.FOR;1 SUBROUTINE RTOC(STRING,CHAR1,NUM,VEAL) INCLUDE '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 -h- rtof.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RTOF.FOR;1 SUBROUTINE RTOF(STRING,CHAR1,NUM1,NUM2,VEAL) INCLUDE '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 'CONST4.BLK' INCLUDE '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 -h- rulcom.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]RULCOM.BLK;1 C C *** / R U L C O M / *** C C RULE CHECKING DATA C COMMON /RULCOM/ RIMRRC,RIMRDT,RULCNT,RULNUM(10),RULPTR(6),RULES REAL*8 RIMRRC REAL*8 RIMRDT INTEGER RULCNT INTEGER RULNUM INTEGER RULPTR LOGICAL RULES C C VARIABLE DEFINITIONS: C RIMRRC--NAME OF THE RULE RELATION C RIMRDT--NAME OF THE RULE DATA RELATION C RULES---.TRUE. IF RULES DEFINED (OTHERWISE .FALSE.) C RULCNT--NUMBER OF RULES APPLYING TO A GIVEN RELATION C RULNUM--RULE NUMBERS APPLYING TO A GIVEN RELATION C RULPTR--RULE DATA RELATION POINTERS (RIMPTR) C -h- ruldel.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RULDEL.FOR;1 SUBROUTINE RULDEL(RNAME,NUMRUL) INCLUDE '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 'CONST4.BLK' INCLUDE 'CONST8.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'FILES.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'MISC.BLK' INCLUDE '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 WRITE(NOUT,9000) 9000 FORMAT(29H -WARNING- RULES DO NOT EXIST ) RMSTAT = 110 GO TO 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 WRITE(NOUT,8001) NUMRUL 8001 FORMAT(15H -WARNING- RULE,I4,15H DOES NOT EXIST) RMSTAT = 110 9999 CONTINUE IF(EQ(K8RDT,RNAME)) WRITE(NOUT,9001) NDP 9001 FORMAT(2X,I6,14H RULES DELETED ) C C DONE. C RETURN END -h- rules.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RULES.FOR;1 SUBROUTINE RULES INCLUDE '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 'CONST8.BLK' INCLUDE 'FILES.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'MISC.BLK' LOGICAL EQ INTEGER RRC(3) INTEGER OLDNUM INTEGER RULENO C IF(EQ(USERID,OWNER)) GO TO 100 WRITE(NOUT,9000) 9000 FORMAT(20H -ERROR- YOU ARE NOT, X 33H AUTHORIZED TO LOOK AT THE RULES ) GO TO 999 100 CONTINUE C C LOOK FOR THE RULE RELATION CORRESPONDENCE TABLE. C I = LOCREL(K8RRC) IF(I.EQ.0) GO TO 200 WRITE(NOUT,9001) 9001 FORMAT(45H -WARNING- NO RULES DEFINED FOR THIS DATABASE ) GO TO 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 -h- rxrec.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]RXREC.FOR;1 FUNCTION RXREC(I) INCLUDE 'TEXT.BLK' C C THIS FUNCTION RETURNS THE REAL VALUE OF A REAL ITEM. C INCLUDE 'LXCARD.BLK' INCLUDE '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 -h- selcom.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]SELCOM.BLK;1 C C *** SELCOM *** C COMMON /SELCOM/ COL1(20),ITEMW(20),CURPOS(20),NUMCOL(20), X PGRAPH(20),ATYPE(20),LEN(20), X ROWD(20),COLD(20),FP(20), X SINGLE(20), X TITLE(38),MINUS(38),LINE(38),MCPL,LPP,NUMATT X ,UMCPL,ULPP,TRUNC(20),VAR(20) LOGICAL VAR,TRUNC INTEGER COL1,CURPOS,ATYPE,ROWD,COLD,FP,SINGLE INTEGER UMCPL,ULPP INTEGER PGRAPH,TITLE C C ARRAYS WITH INFO FOR EACH ATTRIBUTE C COL1......FIRST COLUMN IN LINE TO PRINT INTO C ITEMW.....NUMBER OF COLUMNS PER ITEM C CURPOS....CURRENT POSITION IN ATTRIBUTE (FOR PARAGRAPHING) C NUMCOL....NUMBER OF COLUMNS AVAILABLE FOR THIS ATTRIBUTE C PGRAPH....PARAGRAPH NUMBER INPUT BY USER OR ZERO C TRUNC.....TRUE IFF ROWS ARE TO BE TRUNCATED AS PARAGRAPHS C ATYPE.....ATTRIBUTE TYPE C LEN.......ATTRIBUTE LENGTH (WORDS EXCEPT TEXT IS CHARACTERS) C ROWD......ROW DIMENSION C COLD......COLUMN DIMENSION C VAR.......TRUE IFF VARIABLE ATTRIBUTE C FP........POINTER TO CELL IF FIXED POTION OF TUPLE C SINGLE....CONTAINS ROW/COL OR ENTRY FOR MAT(I,J)/VEC(J) ITEMS C C OTHER STUFF C LINE......OUTPUT LINE SPACE (NEEDS TO BE 150 CHARACTERS BIG) C TITLE.....TITLE LINE (ALSO 150 CHARS.) C MINUS.....LINE WITH THEM FUNNY LITTLE DASHES (ALSO 150 CHARS.) C MCPL......MAX COLUMNS PER LINE C UMCPL.....USER SPECIFIED MAX COLUMNS PER LINE C LPP.......LINES PER PAGE C ULPP......USER SPECIFIED LINES PER PAGE C NUMATT....NUMBER OF ATTRIBUTES THIS SELECT C -h- select.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SELECT.FOR;1 SUBROUTINE SELECT INCLUDE 'TEXT.BLK' C C THIS ROUTINE HANDLES THE SELECT COMMAND. C INCLUDE 'RMATTS.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'PROM.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'BLNKFL.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'FILES.BLK' INCLUDE 'MISC.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE '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 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 WRITE(NOUTR,104) 104 FORMAT(/,28H MORE TEXT FOLLOWS - ENTER * , X 28H TO CONTINUE OR QUIT TO STOP ) 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) WRITE (NOUTR,110) 110 FORMAT(1H1) 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 -h- selout.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SELOUT.FOR;1 SUBROUTINE SELOUT(MAT,IATT,ADONE) INCLUDE '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 'RMATTS.BLK' INCLUDE 'SELCOM.BLK' INCLUDE '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 -h- selpar.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SELPAR.FOR;1 SUBROUTINE SELPAR(ITALLY) INCLUDE '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 'RMATTS.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'CONST8.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'MISC.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'FILES.BLK' INCLUDE 'SELCOM.BLK' LOGICAL EQKEYW,END,IFALL LOGICAL ITALLY INTEGER STATUS INCLUDE '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 WRITE (NOUT,810) 810 FORMAT(58H -ERROR- ATTRIBUTE MUST BE VEC OR MAT FOR FOLLOWING PARE XNS) GO TO 9000 820 CONTINUE C C TRAILING PAREN IMPROPERLY SPECIFIED C WRITE (NOUT,830) 830 FORMAT(36H -ERROR- COULDN'T FIND CLOSING PAREN) GO TO 9000 840 CONTINUE C C VEC/MAT MISMATCH C WRITE (NOUT,850) 850 FORMAT(38H -ERROR- NUMBER OF DIMENSIONS MISMATCH) GO TO 9000 860 CONTINUE C C ROW/COL MUST BE POSITIVE INTEGER C WRITE (NOUT,870) 870 FORMAT(42H -ERROR- ROW/COL MUST BE POSITIVE INTEGERS) GO TO 9000 880 CONTINUE C C BAD INTEGER ATTRIBUTE C WRITE (NOUT,890) 890 FORMAT(49H -ERROR- IMPROPER INTEGER ATTRIBUTE SPECIFICATION ) GO TO 9000 900 CONTINUE C C OOPS - NOT ENOUGH ROOM C WRITE(NOUT,910) 910 FORMAT(25H -WARNING- LINE TRUNCATED ) 1000 CONTINUE MCPL = IP - 1 IF(NUMBAD.GT.0) GO TO 9000 RETURN 8000 CONTINUE C C PARAGRAPH NOT INTEGER C WRITE (NOUT,8010) 8010 FORMAT(41H -ERROR- IMPROPER PARAGRAPH SPECIFICATION ) GO TO 9000 8020 CONTINUE C C SINGLE TOO BIG C WRITE (NOUT,8030) 8030 FORMAT(39H -ERROR- REQUESTED ELEMENT OUT OF RANGE ) GO TO 9000 8040 CONTINUE C C TOO MAY ATTRIBUTES SPECIFIED C WRITE(NOUT,8050) 8050 FORMAT(46H -ERROR- ILLEGAL NUMBER OF ATTRIBUTES (MAX 20)) GO TO 9000 9000 CONTINUE C C BLEW IT C NUMATT = 0 CALL WARN(4,0,0) RETURN END -h- selput.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SELPUT.FOR;1 SUBROUTINE SELPUT(VAL,TYPE,WIDTH,START,STRING) INCLUDE 'TEXT.BLK' C C THIS ROUTINE PUTS AN ACTUAL VALUE (NON-TEXT) INTO STRING. C INCLUDE 'RMATTS.BLK' INCLUDE 'CONST4.BLK' INCLUDE '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 -h- setin.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SETIN.FOR;1 SUBROUTINE SETIN(HFILE) INCLUDE 'TEXT.BLK' C C SET THE INPUT FILE TO IFILE C INCLUDE 'CONST4.BLK' INCLUDE 'CONST8.BLK' INCLUDE '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 -h- setout.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SETOUT.FOR;1 SUBROUTINE SETOUT(HFILE) INCLUDE 'TEXT.BLK' C C SET THE OUTPUT FILE TO IFILE C INCLUDE 'CONST4.BLK' INCLUDE 'CONST8.BLK' INCLUDE '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 -h- setrul.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SETRUL.FOR;1 SUBROUTINE SETRUL INCLUDE '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 'RMATTS.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'CONST8.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE '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 -h- sorbuf.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]SORBUF.BLK;1 C C *** / S O R B U F / *** C C SORT BUFFER FOR THE STANDALONE SYSTEM C COMMON /SORBUF/ SORBUF(513),INFIL(8),OUTFIL(8) INTEGER SORBUF INTEGER INFIL INTEGER OUTFIL C C VARIABLE DEFINITIONS: C SORBUF---SORT BUFFER FOR THE FASTIO READ/WRITE C INFIL----FASTIO FET FOR THE SORT INPUT FILE C OUTFIL---FASTIO FET FOR THE SORT OUTPUT FILE C -h- sort.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SORT.FOR;1 SUBROUTINE SORT(NKSORT) INCLUDE '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 'RIMPTR.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'SRTCOM.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'FILES.BLK' INCLUDE 'MISC.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'INCORE.BLK' C INTEGER INFIL INTEGER OUTFIL C C OPEN THE INPUT SORT FILE C INFIL = 20 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 WRITE(NOUT,410) 410 FORMAT(36H -WARNING- NO ROWS AVAILABLE TO SORT) GO TO 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 WRITE(NOUT,445) 445 FORMAT(17H -ERROR- SORT I/O) NSORT = 0 GO TO 999 C 450 CONTINUE RMSTAT = 0 C 999 CONTINUE RETURN END -h- spout.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SPOUT.FOR;1 SUBROUTINE SPOUT(STRING,NUMC) INCLUDE 'TEXT.BLK' C C WRITE A LINE TO OUTPUT IGNORING TRAILING BLANKS C INCLUDE 'FILES.BLK' INCLUDE 'BLNKFL.BLK' INCLUDE '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 WRITE (NOUTR,30)(STRING(I),I=1,NW) 30 FORMAT(33A4) RETURN END -h- srtcom.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]SRTCOM.BLK;1 C C *** / S R T C O M / *** C C SORT COMMUNICATION COMMON BLOCK C COMMON /SRTCOM/ VARTYP(10),VARPOS(10),NSORTW, X LTUPLE,LTUMAX,LTUMIN,NSORT,NREAD, X NSOVAR,SORTYP(10),FIXLT INTEGER VARTYP INTEGER VARPOS LOGICAL SORTYP LOGICAL FIXLT C C VARIABLE DEFINITIONS: C C THE FOLLOWING THREE ARRAYS ARE USE BY THE SORT ROUTINES TO C HOLD THE INFORMATION ABOUT THE WORDS THAT ARE SORTED. C THE DIMENSION MAY WANT TO BE UPPED ON THE SMALLER MACHINES. C C THE SORT ROUTINES OPERATE ON SORT VARIABLES.A SORT C VARIABLE IS A SINGLE PRECISION INTEGER,A SINGLE PRECISION C REAL,A DOUBLE PRECISION REAL OR A ONE WORD TEXT . C C SORTYP(N)--ASCENDING OR DESCENDING SORT (TRUE OR FALSE) C VARTYP(N)--TYPE OF THE N-TH SORT VARIABLE C VARPOS(N)--POSITION IN TUPLE OF N-TH SORT VARIABLE C NOTE THAT FOR A DOUBLE PRECISION REAL C THIS IS FIRST WORD C NSORTW-----THE NUMBER OF WORDS IN THE SORT ARRAYS - CURRENTLY 10 C FIXLT------.TRUE. IF FIXED LENGTH TUPLES C .FALSE. IF VARIABLE LENGTH TUPLES C LTUPLE-----IF FIXLT .TRUE. THEN LENGTH (WORDS) OF A TUPLE C OTHERWISE LENGTH (WORDS) OF SORT FILE C LTUMAX-----MAX LENGTH (WORDS) OF VARIABLE LENGTH TUPLE C INCLUDES THE FIRST WORD (LENGTH) OF TUPLE C HAS NO MEANING IF FIXLT .TRUE. C LTUMIN-----SAME AS LTUMAX EXCEPT MIN LENGTH C NSORT------NUMBER OF TUPLES ON THE SORT FILE C NREAD------NUMBER OF TUPLES CURRENTLY READ FROM THE SORT FILE C NSOVAR-----NUMBER OF SORT VARIABLES (LE 10) C -h- stack.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]STACK.BLK;1 C C *** / S T A C K / *** C C VARIABLES FOR MOVING DOWN A BTREE INDEX C COMMON /STACK/ STACK(20),SP INTEGER STACK,SP C C VARIABLE DEFINITIONS C STACK---ARRAY OF STACK POINTERS C SP------INDEX TO THE STACK ARRAY C -h- start.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]START.BLK;1 C C *** / S T A R T / *** C C BTREE STARTING NODE RECORD NUMBER C COMMON /START/ START INTEGER START C C VARIABLE DEFINITIONS: C START---RECORD NUMBER FOR THE STARTING NODE IN A BTREE C -h- status.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]STATUS.FOR;1 SUBROUTINE STATUS(FILE,LFS) INCLUDE 'TEXT.BLK' CHARACTER*7 FILE LOGICAL EX LFS = 0 INQUIRE(FILE=FILE,EXIST=EX) IF(EX) LFS = 1 RETURN END -h- strmov.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]STRMOV.FOR;1 SUBROUTINE STRMOV(IST1,IPOS1,NCH,IST2,IPOS2) INCLUDE '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 BYTE 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 -h- subrel.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SUBREL.FOR;1 SUBROUTINE SUBREL INCLUDE '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 'RMATTS.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'FILES.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'MISC.BLK' C INTEGER PTABLE LOGICAL EQKEYW INCLUDE 'DCLAR1.BLK' INCLUDE '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 WRITE(NOUT,9000) 9000 FORMAT(55H -ERROR- RESULTANT RELATION DOES NOT HAVE A UNIQUE NAME) GO TO 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 WRITE(NOUT,9001) 9001 FORMAT(38H -ERROR- TOO MANY ATTRIBUTES SPECIFIED) GO TO 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 WRITE(NOUT,9002) RNAME1,RNAME2 9002 FORMAT(19H -ERROR- RELATIONS ,A8,5H AND ,A8, X26H HAVE NO COMMON ATTRIBUTES) GO TO 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 -h- subtrc.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SUBTRC.FOR;1 SUBROUTINE SUBTRC(RNAME1,RNAME3,MATN3,NCOL3,NATT3,PTABLE, XKEYCOL,KEYTYP) INCLUDE '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 'RMATTS.BLK' INCLUDE 'FILES.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'RIMPTR.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'WHCOM.BLK' INCLUDE '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 WRITE(NOUT,9000) NUM 9000 FORMAT(31H SUCCESSFUL SUBTRACT OPERATION , XI6,15H ROWS GENERATED) C C RETURN C RETURN END -h- swcon.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SWCON.FOR;1 SUBROUTINE SWCON(BUFFER,LBUF,INFIL,OUTFIL,IERR) INCLUDE '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 'CONST8.BLK' INCLUDE '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 '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 -h- swcost.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SWCOST.FOR;1 SUBROUTINE SWCOST(NOPASS,NREC,LREC,SORD,COST) INCLUDE '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 'SRTCOM.BLK' INTEGER SORD REAL IOPOSC,IOTRAC,COCOST,MOCOFI,MOCOAD INCLUDE 'DATA5.BLK' COST = NOPASS*(2*NREC*(IOPOSC+LREC*IOTRAC) X +NSORT*NSOVAR*.5*SORD*COCOST X +NREC*MOCOFI+NREC*(LREC-1)*MOCOAD) RETURN END -h- swfilo.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SWFILO.FOR;1 SUBROUTINE SWFILO(BUFFER,LTUP,LREC,NTUREC,NINTUP, X INFIL,OUTFIL) INCLUDE '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 '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 -h- swflfs.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SWFLFS.FOR;1 SUBROUTINE SWFLFS(INFIL,OUTFIL,SCFIL1,SCFIL2, X BUFFER,LBUF,LPRU,DPRU,IERR) INCLUDE '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 '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 -h- swhart.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SWHART.FOR;1 SUBROUTINE SWHART(INFIL,OUTFIL,BUFFER,LLL,IERR) INCLUDE 'TEXT.BLK' INCLUDE '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 READ(INFIL) I4,(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 -h- swhrtd.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SWHRTD.FOR;1 SUBROUTINE SWHRTD(NN,LL,BUFFER) INCLUDE '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 '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 -h- swhrti.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SWHRTI.FOR;1 SUBROUTINE SWHRTI(NN,LL,BUFFER) INCLUDE '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 '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 -h- swhrtr.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SWHRTR.FOR;1 SUBROUTINE SWHRTR(NN,LL,BUFFER) INCLUDE '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 '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 -h- swicst.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SWICST.FOR;1 SUBROUTINE SWICST(MM,M,N) INCLUDE '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 '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 -h- swidcp.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SWIDCP.FOR;1 INTEGER FUNCTION SWIDCP(I1,I2) INCLUDE '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 -h- swiicp.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SWIICP.FOR;1 INTEGER FUNCTION SWIICP(I1,I2) INCLUDE 'TEXT.BLK' SWIICP = 1 IF(I1 .LT. I2) RETURN IF(I1 .GT. I2) GO TO 10 SWIICP = 0 RETURN 10 SWIICP = -1 RETURN END -h- swinpo.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SWINPO.FOR;1 SUBROUTINE SWINPO(INFIL,OUTFIL,BUFFER,IERR) INCLUDE 'TEXT.BLK' INCLUDE '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 READ(INFIL) I4,(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 -h- swircp.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SWIRCP.FOR;1 INTEGER FUNCTION SWIRCP(I1,I2) INCLUDE '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 -h- switcp.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SWITCP.FOR;1 INTEGER FUNCTION SWITCP(I1,I2) INCLUDE 'TEXT.BLK' BYTE 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 -h- swshel.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SWSHEL.FOR;1 SUBROUTINE SWSHEL(M,N) INCLUDE '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 -h- swsink.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SWSINK.FOR;1 SUBROUTINE SWSINK(IP,IIP,NIP,BUFFER) INCLUDE '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 '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 -h- swsmfl.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SWSMFL.FOR;1 SUBROUTINE SWSMFL(BUFFER,CHAIN1,NCHAIN,LCHAIN,OUTREC,OUTCHN, X NTUREC,LTUP,LREC,INFIL,OUTFIL) INCLUDE '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 -h- swsmvl.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SWSMVL.FOR;1 SUBROUTINE SWSMVL(BUFFER,CHAIN1,NCHAIN,LCHAIN,OUTREC,OUTCHN, X INCH1,LREC,INFIL,OUTFIL) INCLUDE '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 -h- swunlo.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SWUNLO.FOR;1 SUBROUTINE SWUNLO(BUFFER,CHAIN1,NCHAIN,LCHAIN, X LTUP,LREC,INFIL,OUTFIL) INCLUDE '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 -h- swunvl.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SWUNVL.FOR;1 SUBROUTINE SWUNVL(BUFFER,CHAIN1,NCHAIN,LCHAIN, X INCH1,LREC,INFIL,OUTFIL) INCLUDE '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 -h- swvlfs.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SWVLFS.FOR;1 SUBROUTINE SWVLFS(INFIL,OUTFIL,SCFIL1,SCFIL2, X BUFFER,LBUF,LPRU,DPRU,IERR) INCLUDE '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 '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 -h- swvllo.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]SWVLLO.FOR;1 SUBROUTINE SWVLLO(BUFFER,LREC,NREC,INFIL,OUTFIL,NI) INCLUDE '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 '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 READ(INFIL) I11,(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 -h- tally.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]TALLY.FOR;1 SUBROUTINE TALLY INCLUDE 'TEXT.BLK' C C PURPOSE: THIS ROUTINE PROCESSES THE RIM TALLY COMMAND C C PARAMETERS: NONE C INCLUDE 'RMATTS.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'FILES.BLK' INCLUDE 'MISC.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'SELCOM.BLK' INCLUDE '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 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) WRITE(NOUTR,410) 410 FORMAT(1H1) 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 WRITE (NOUT,910) 910 FORMAT(40H -WARNING- NO VALID ATTRIBUTES SPECIFIED ) 999 CONTINUE LIMTU = LIMTUT CALL BLKCLR(10) RETURN END -h- test1.com Mon Dec 02 10:17:26 1985 DF1:[DBMS]TEST1.COM;1 $! $! COMMAND PROCEDURE TO RUN TEST1 OF RIM $! $! THIS TEST REQUIRES APPROXIMATELY 2 MINUTES TO RUN $! $ DELETE TEST1.DAT;* $ DELETE PLANES%.DAT;* $ RUN RIM INPUT ITEST1 $! $! END OF TEST1 PROCEDURE -h- test1.dat Mon Dec 02 10:17:26 1985 DF1:[DBMS]TEST1.DAT;1 INPUT LINE ... DEFINE PLANES BEGIN RIM SCHEMA COMPILATION INPUT LINE ... OWNER AGENT INPUT LINE ... ATTRIBUTES INPUT LINE ... WORD TEXT 8 KEY INPUT LINE ... WRDTYPE TEXT 9 INPUT LINE ... DESCRIP TEXT VAR INPUT LINE ... MFG TEXT 10 KEY INPUT LINE ... MODEL TEXT 10 INPUT LINE ... TYPE TEXT 10 KEY INPUT LINE ... NUMENG INT INPUT LINE ... ENGTYPE TEXT 10 INPUT LINE ... CRUSALT REAL INPUT LINE ... CRUSSPD REAL INPUT LINE ... CARRIER TEXT 10 KEY INPUT LINE ... FLIGHTNO INT INPUT LINE ... STRTCITY TEXT 10 INPUT LINE ... ENDCITY TEXT 10 INPUT LINE ... DAYOFWK TEXT 10 INPUT LINE ... PILOT TEXT 20 INPUT LINE ... RATING INT INPUT LINE ... RELATIONS INPUT LINE ... DEFIN WITH WORD WRDTYPE DESCRIP INPUT LINE ... AIRPLANS WITH MFG MODEL TYPE NUMENG ENGTYPE CRUSALT CRUSSPD INPUT LINE ... AIRLINES WITH CARRIER FLIGHTNO STRTCITY ENDCITY DAYOFWK MODEL INPUT LINE ... CREW WITH FLIGHTNO PILOT RATING INPUT LINE ... PASSWORDS INPUT LINE ... MODIFY PASSWORD FOR DEFIN IS DBA INPUT LINE ... MODIFY PASSWORD FOR AIRLINES IS AGENT INPUT LINE ... RPW FOR ALL IS AGENT INPUT LINE ... RULES INPUT LINE ... DAYOFWK NE SUN INPUT LINE ... RATING GT 0 AND RATING LT 10 INPUT LINE ... END RIM SCHEMA COMPILATION FOR PLANES IS COMPLETE INPUT LINE ... NEWPAGE 1 INPUT LINE ... USER DBA INPUT LINE ... LOAD DEFIN BEGIN -RIM- DATA LOADING INPUT LINE ... WORD ATTRIBUTE "NAMES USED IN THE PLANES DATA BASE." INPUT LINE ... WRDTYPE ATTRIBUTE "THE TYPE OF THE NAME: ATTRIBUTE OR RELATION." INPUT LINE ... DESCRIP * "A TEXTUAL DESCRIPTION OF THE WORDS USED IN THE DATA BASE." INPUT LINE ... MFG * "THE MANUFACTURER OF THE AIRPLANE." INPUT LINE ... MODEL * "THE AIRPLANE MODEL NUMBER." INPUT LINE ... TYPE * "THE AIRPLANE TYPE, I.E., PASSENGER, CARGO, ETC." INPUT LINE ... NUMENG * "THE NUMBER OF ENGINES ON THE AIRPLANE." INPUT LINE ... ENGTYPE * "THE ENGINE TYPE, I.E., JET, PROP, ETC." INPUT LINE ... CRUSALT * "THE AIRPLANE'S CRUISE ALTITIUDE." INPUT LINE ... CRUSSPD * "THE AIRPLANE'S CRUISE SPEED." INPUT LINE ... CARRIER * "THE AIRLINE CARRIER WHICH USES THE PLANES." INPUT LINE ... FLIGHTNO * "THE FLIGHT NUMBER OF OF A CARRIER'S ROUTE." INPUT LINE ... STRTCITY * "THE START CITY OF THE FLIGHT ROUTE." INPUT LINE ... ENDCITY * "THE END CITY OF THE FLIGHT ROUTE." INPUT LINE ... DAYOFWK * "DAY OF THE WEEK THAT THE FLIGHT ROUTE RUNS." INPUT LINE ... PILOT * "THE PILOT'S NAME." INPUT LINE ... RATING * "THE PILOT'S SKILL RATING." INPUT LINE ... AIRPLANS RELATION "RELATION CONTAINING THE AIRPLANE STOCK THAT A + INPUT LINE ... CARRIER OWNS ALONG WITH ALL PERTINENT DATA ON EACH AIRPLANE." INPUT LINE ... AIRLINES * "RELATION CONTAINING THE AIRLINE'S FLIGHT INFORMATION." INPUT LINE ... CREW * "THE CREW FLIGHT INFORMATION." INPUT LINE ... DEFIN * "RELATION CONTAINING THE DEFINITIONS OF ALL THE ATTRIBUTES + INPUT LINE ... AND THE RELATIONS USED IN THE PLANES DATA BASE." INPUT LINE ... LOAD AIRPLANS INPUT LINE ... BOEING B727-100 PASSENGER 3 JET 39000. 560. INPUT LINE ... BOEING B727-200 *5 INPUT LINE ... BOEING B747-200 PASSENGER 4 JET 43000. 580. INPUT LINE ... BOEING B737-200 PASSENGER 2 JET 35000. 590. INPUT LINE ... BOEING B747-SP PASSENGER 4 JET 45000. 600. INPUT LINE ... BOEING B747-F CARGO 4 JET 50000. 650. INPUT LINE ... DOUGLAS DC-9 PASSENGER 2 JET 39000. 550. INPUT LINE ... DOUGLAS DC-10 PASSENGER 3 JET 44000. 590. INPUT LINE ... LOCKHEED L-1011 PASSENGER 3 JET 46000. 550. INPUT LINE ... BURNER BLAIR CROPDUSTER 1 PROP 500. 110. INPUT LINE ... LOAD AIRLINES -ERROR- UNAUTHORIZED ACCESS TO RELATION AIRLINES END -RIM- DATA LOADING INPUT LINE ... USER AGENT INPUT LINE ... LOAD AIRLINES BEGIN -RIM- DATA LOADING INPUT LINE ... UNITED 58 PORTLAND SEATTLE MON B727-200 INPUT LINE ... UNITED 65 SEATTLE PORTLAND MON B727-100 INPUT LINE ... UNITED 120 *2 FRI B727-200 INPUT LINE ... UNITED 128 PORTLAND SEATTLE FRI B737-200 INPUT LINE ... CONT 234 SEATTLE PORTLAND THU DC-9 INPUT LINE ... CONT 235 SEATTLE PORTLAND SUN DC-9 -ERROR- THE DATA FAILS TO SATISFY THE FOLLOWING RULE RULE NUMBER 1 DAYOFWK NE SUN INPUT LINE ... CONT 187 *2 WED DC-9 INPUT LINE ... AIRWEST 18 *2 TUE BLAIR INPUT LINE ... UNITED 140 SEATTLE CHICAGO FRI DC-8 INPUT LINE ... AIRWEST 27 *2 SAT BLAIR INPUT LINE ... WESTERN 290 *2 SAT B707-200 INPUT LINE ... TWA 576 SEATTLE CHICAGO MON B747-200 INPUT LINE ... TWA 578 *2 WED B747-SP INPUT LINE ... TWA 624 *2 SAT B747-200 INPUT LINE ... AMERICAN 295 SEATTLE ROCHESTER SUN B727-200 -ERROR- THE DATA FAILS TO SATISFY THE FOLLOWING RULE RULE NUMBER 1 DAYOFWK NE SUN INPUT LINE ... AMERICAN 298 ROCHESTER SEATTLE MON B727-200 INPUT LINE ... AMERICAN 140 ROCHESTER CHICAGO TUE B727-100 INPUT LINE ... AMERICAN 145 CHICAGO SEATTLE TUE B727-200 INPUT LINE ... PANAM 245 SEATTLE TOKYO MON DC-10 INPUT LINE ... PANAM 247 SEATTLE TOKYO TUE L-1011 INPUT LINE ... PANAM 249 SEATTLE TOKYO THU L-1011 INPUT LINE ... PANAM 246 TOKYO SEATTLE TUE DC-10 INPUT LINE ... PANAM 248 TOKYO SEATTLE WED DC-10 INPUT LINE ... PANAM 250 TOKYO SEATTLE SAT DC-10 INPUT LINE ... IPAD-AIR -3 RENTON KENT THU BLAIR INPUT LINE ... IPAD-AIR -5 KENT RENTON FRI BLAIR INPUT LINE ... IPAD-AIR -6 RENTON RENTON MON BLAIR INPUT LINE ... IPAD-AIR -7 RENTON LANGLEY TUE BLAIR INPUT LINE ... LOAD CREW INPUT LINE ... -3 "FEARLESS FRED" 5 INPUT LINE ... -6 "DARING DANIEL" 3 INPUT LINE ... -5 "ROARING RALPH" 3 INPUT LINE ... 295 "DIEHARD DENNIS" 6 INPUT LINE ... 58 "BERNHARDT BOMBER" 1 INPUT LINE ... 18 "SMILING JACK" 0 -ERROR- THE DATA FAILS TO SATISFY THE FOLLOWING RULE RULE NUMBER 2 RATING GT 0 AND RATING LT 10 INPUT LINE ... NOCHECK INPUT LINE ... 18 "SMILING JACK" 0 INPUT LINE ... 27 "STEVE CANYON" 0 INPUT LINE ... END END -RIM- DATA LOADING INPUT LINE ... NEWPAGE 1 INPUT LINE ... LISTREL EXISTING RELATIONS AS OF 83/09/28 09.49.06 DEFIN AIRPLANS AIRLINES CREW INPUT LINE ... LIS ALL $ NOECHO $ NEWPAGE RELATION : DEFIN LAST MOD : 83/09/28 READ PASSWORD : YES SCHEMA : PLANES MODIFY PASSWORD : YES NAME TYPE LENGTH KEY WORD TEXT 8 CHARACTERS YES WRDTYPE TEXT 9 CHARACTERS DESCRIP TEXT VARIABLE CURRENT NUMBER OF ROWS = 21 RELATION : AIRPLANS LAST MOD : 83/09/28 READ PASSWORD : YES SCHEMA : PLANES MODIFY PASSWORD : NONE NAME TYPE LENGTH KEY MFG TEXT 10 CHARACTERS YES MODEL TEXT 10 CHARACTERS TYPE TEXT 10 CHARACTERS YES NUMENG INT 1 ENGTYPE TEXT 10 CHARACTERS CRUSALT REAL 1 CRUSSPD REAL 1 CURRENT NUMBER OF ROWS = 10 RELATION : AIRLINES LAST MOD : 83/09/28 READ PASSWORD : YES SCHEMA : PLANES MODIFY PASSWORD : YES NAME TYPE LENGTH KEY CARRIER TEXT 10 CHARACTERS YES FLIGHTNO INT 1 STRTCITY TEXT 10 CHARACTERS ENDCITY TEXT 10 CHARACTERS DAYOFWK TEXT 10 CHARACTERS MODEL TEXT 10 CHARACTERS CURRENT NUMBER OF ROWS = 26 RELATION : CREW LAST MOD : 83/09/28 READ PASSWORD : YES SCHEMA : PLANES MODIFY PASSWORD : NONE NAME TYPE LENGTH KEY FLIGHTNO INT 1 PILOT TEXT 20 CHARACTERS RATING INT 1 CURRENT NUMBER OF ROWS = 7 1 DEFINITIONS OF ALL NAMES USED IN THE PLANES DATA BASE 83/09/28 WORD WRDTYPE DESCRIP -------- --------- ------------------------------ WORD ATTRIBUTE NAMES USED IN THE PLANES DATA BASE. WRDTYPE ATTRIBUTE THE TYPE OF THE NAME: ATTRIBUTE OR RELATION. DESCRIP ATTRIBUTE A TEXTUAL DESCRIPTION OF THE WORDS USED IN THE DATA BASE. MFG ATTRIBUTE THE MANUFACTURER OF THE AIRPLANE. MODEL ATTRIBUTE THE AIRPLANE MODEL NUMBER. TYPE ATTRIBUTE THE AIRPLANE TYPE, I.E., PASSENGER, CARGO, ETC. NUMENG ATTRIBUTE THE NUMBER OF ENGINES ON THE AIRPLANE. ENGTYPE ATTRIBUTE THE ENGINE TYPE, I.E., JET, PROP, ETC. CRUSALT ATTRIBUTE THE AIRPLANE'S CRUISE ALTITIUDE. CRUSSPD ATTRIBUTE THE AIRPLANE'S CRUISE SPEED. CARRIER ATTRIBUTE THE AIRLINE CARRIER WHICH USES THE PLANES. FLIGHTNO ATTRIBUTE THE FLIGHT NUMBER OF OF A CARRIER'S ROUTE. STRTCITY ATTRIBUTE THE START CITY OF THE FLIGHT ROUTE. ENDCITY ATTRIBUTE THE END CITY OF THE FLIGHT ROUTE. DAYOFWK ATTRIBUTE DAY OF THE WEEK THAT THE FLIGHT ROUTE RUNS. PILOT ATTRIBUTE THE PILOT'S NAME. RATING ATTRIBUTE THE PILOT'S SKILL RATING. AIRPLANS RELATION RELATION CONTAINING THE AIRPLANE STOCK THAT A CARRIER OWNS ALONG WITH ALL PERTINENT DATA ON EACH AIRPLANE. AIRLINES RELATION RELATION CONTAINING THE AIRLINE'S FLIGHT INFORMATION. CREW RELATION THE CREW FLIGHT INFORMATION. DEFIN RELATION RELATION CONTAINING THE DEFINITIONS OF ALL THE ATTRIBUTES AND THE RELATIONS USED IN THE PLANES DATA BASE. 1 DEFINITIONS OF ALL ATTRIBUTES USED IN THE PLANES DATA BASE (SORTED BY ATTRIBUTE NAME) 83/09/28 WORD DESCRIP -------- ------------------------------ CARRIER THE AIRLINE CARRIER WHICH USES THE PLANES. CRUSALT THE AIRPLANE'S CRUISE ALTITIUDE. CRUSSPD THE AIRPLANE'S CRUISE SPEED. DAYOFWK DAY OF THE WEEK THAT THE FLIGHT ROUTE RUNS. DESCRIP A TEXTUAL DESCRIPTION OF THE WORDS USED IN THE DATA BASE. ENDCITY THE END CITY OF THE FLIGHT ROUTE. ENGTYPE THE ENGINE TYPE, I.E., JET, PROP, ETC. FLIGHTNO THE FLIGHT NUMBER OF OF A CARRIER'S ROUTE. MFG THE MANUFACTURER OF THE AIRPLANE. MODEL THE AIRPLANE MODEL NUMBER. NUMENG THE NUMBER OF ENGINES ON THE AIRPLANE. PILOT THE PILOT'S NAME. RATING THE PILOT'S SKILL RATING. STRTCITY THE START CITY OF THE FLIGHT ROUTE. TYPE THE AIRPLANE TYPE, I.E., PASSENGER, CARGO, ETC. WORD NAMES USED IN THE PLANES DATA BASE. WRDTYPE THE TYPE OF THE NAME: ATTRIBUTE OR RELATION. 1 DEFINITIONS OF ALL RELATIONS USED IN THE PLANES DATA BASE (SORTED BY RELATION NAME) 83/09/28 WORD DESCRIP -------- ------------------------------ AIRLINES RELATION CONTAINING THE AIRLINE'S FLIGHT INFORMATION. AIRPLANS RELATION CONTAINING THE AIRPLANE STOCK THAT A CARRIER OWNS ALONG WITH ALL PERTINENT DATA ON EACH AIRPLANE. CREW THE CREW FLIGHT INFORMATION. DEFIN RELATION CONTAINING THE DEFINITIONS OF ALL THE ATTRIBUTES AND THE RELATIONS USED IN THE PLANES DATA BASE. 1 INPUT LINE ... PRINT RULES RULE NUMBER 1 DAYOFWK NE SUN RULE NUMBER 2 RATING GT 0 AND RATING LT 10 INPUT LINE ... SELECT ALL FROM AIRPLANS MFG MODEL TYPE NUMENG ENGTYPE CRUSALT CRUSSPD ---------- ---------- ---------- -------- ---------- -------- -------- BOEING B727-100 PASSENGER 3 JET 39000. 560. BOEING B727-200 PASSENGER 3 JET 39000. 560. BOEING B747-200 PASSENGER 4 JET 43000. 580. BOEING B737-200 PASSENGER 2 JET 35000. 590. BOEING B747-SP PASSENGER 4 JET 45000. 600. BOEING B747-F CARGO 4 JET 50000. 650. DOUGLAS DC-9 PASSENGER 2 JET 39000. 550. DOUGLAS DC-10 PASSENGER 3 JET 44000. 590. LOCKHEED L-1011 PASSENGER 3 JET 46000. 550. BURNER BLAIR CROPDUSTER 1 PROP 500. 110. INPUT LINE ... SELECT ALL FROM AIRLINES CARRIER FLIGHTNO STRTCITY ENDCITY DAYOFWK MODEL ---------- -------- ---------- ---------- ---------- ---------- UNITED 58 PORTLAND SEATTLE MON B727-200 UNITED 65 SEATTLE PORTLAND MON B727-100 UNITED 120 SEATTLE PORTLAND FRI B727-200 UNITED 128 PORTLAND SEATTLE FRI B737-200 CONT 234 SEATTLE PORTLAND THU DC-9 CONT 187 SEATTLE PORTLAND WED DC-9 AIRWEST 18 SEATTLE PORTLAND TUE BLAIR UNITED 140 SEATTLE CHICAGO FRI DC-8 AIRWEST 27 SEATTLE CHICAGO SAT BLAIR WESTERN 290 SEATTLE CHICAGO SAT B707-200 TWA 576 SEATTLE CHICAGO MON B747-200 TWA 578 SEATTLE CHICAGO WED B747-SP TWA 624 SEATTLE CHICAGO SAT B747-200 AMERICAN 298 ROCHESTER SEATTLE MON B727-200 AMERICAN 140 ROCHESTER CHICAGO TUE B727-100 AMERICAN 145 CHICAGO SEATTLE TUE B727-200 PANAM 245 SEATTLE TOKYO MON DC-10 PANAM 247 SEATTLE TOKYO TUE L-1011 PANAM 249 SEATTLE TOKYO THU L-1011 PANAM 246 TOKYO SEATTLE TUE DC-10 PANAM 248 TOKYO SEATTLE WED DC-10 PANAM 250 TOKYO SEATTLE SAT DC-10 IPAD-AIR -3 RENTON KENT THU BLAIR IPAD-AIR -5 KENT RENTON FRI BLAIR IPAD-AIR -6 RENTON RENTON MON BLAIR IPAD-AIR -7 RENTON LANGLEY TUE BLAIR INPUT LINE ... NOECHO 1 AIRLINES SORTED BY STRTCITY 83/09/28 CARRIER FLIGHTNO STRTCITY ENDCITY DAYOFWK MODEL ---------- -------- ---------- ---------- ---------- ---------- AMERICAN 145 CHICAGO SEATTLE TUE B727-200 IPAD-AIR -5 KENT RENTON FRI BLAIR UNITED 58 PORTLAND SEATTLE MON B727-200 UNITED 128 PORTLAND SEATTLE FRI B737-200 IPAD-AIR -3 RENTON KENT THU BLAIR IPAD-AIR -6 RENTON RENTON MON BLAIR IPAD-AIR -7 RENTON LANGLEY TUE BLAIR AMERICAN 298 ROCHESTER SEATTLE MON B727-200 AMERICAN 140 ROCHESTER CHICAGO TUE B727-100 UNITED 65 SEATTLE PORTLAND MON B727-100 UNITED 120 SEATTLE PORTLAND FRI B727-200 CONT 234 SEATTLE PORTLAND THU DC-9 CONT 187 SEATTLE PORTLAND WED DC-9 AIRWEST 18 SEATTLE PORTLAND TUE BLAIR UNITED 140 SEATTLE CHICAGO FRI DC-8 AIRWEST 27 SEATTLE CHICAGO SAT BLAIR WESTERN 290 SEATTLE CHICAGO SAT B707-200 1 CARRIER FLIGHTNO STRTCITY ENDCITY DAYOFWK MODEL ---------- -------- ---------- ---------- ---------- ---------- TWA 576 SEATTLE CHICAGO MON B747-200 TWA 578 SEATTLE CHICAGO WED B747-SP TWA 624 SEATTLE CHICAGO SAT B747-200 PANAM 245 SEATTLE TOKYO MON DC-10 PANAM 247 SEATTLE TOKYO TUE L-1011 PANAM 249 SEATTLE TOKYO THU L-1011 PANAM 246 TOKYO SEATTLE TUE DC-10 PANAM 248 TOKYO SEATTLE WED DC-10 PANAM 250 TOKYO SEATTLE SAT DC-10 1 AIRLINES WHERE MFG EQ BOEING AND NUMENG GE 3 83/09/28 MFG MODEL TYPE NUMENG ENGTYPE CRUSALT CRUSSPD ---------- ---------- ---------- -------- ---------- -------- -------- BOEING B727-100 PASSENGER 3 JET 39000. 560. BOEING B727-200 PASSENGER 3 JET 39000. 560. BOEING B747-200 PASSENGER 4 JET 43000. 580. BOEING B747-SP PASSENGER 4 JET 45000. 600. BOEING B747-F CARGO 4 JET 50000. 650. 1 INPUT LINE ... WIDTH 0 INPUT LINE ... LINES 0 INPUT LINE ... SELECT CARRIER DAYOFWK FROM AIRLINES WHERE ENDCITY EQ PORTLAND CARRIER DAYOFWK ---------- ---------- UNITED MON UNITED FRI CONT THU CONT WED AIRWEST TUE INPUT LINE ... *5 SORTED BY DAYOFWK WHERE ENDCITY EQ SEATTLE CARRIER DAYOFWK ---------- ---------- UNITED FRI UNITED MON AMERICAN MON PANAM SAT AMERICAN TUE PANAM TUE PANAM WED INPUT LINE ... SELECT ALL FROM CREW SORTED BY RATING FLIGHTNO PILOT RATING -------- -------------------- -------- 18 SMILING JACK 0 27 STEVE CANYON 0 58 BERNHARDT BOMBER 1 -6 DARING DANIEL 3 -5 ROARING RALPH 3 -3 FEARLESS FRED 5 295 DIEHARD DENNIS 6 INPUT LINE ... TALLY STRTCITY FROM AIRLINES STRTCITY NUMBER OF OCCURRENCES ---------- --------------------- CHICAGO 1 KENT 1 PORTLAND 2 RENTON 3 ROCHESTER 2 SEATTLE 14 TOKYO 3 INPUT LINE ... TALLY FLIGHTNO=D FROM AIRLINES FLIGHTNO NUMBER OF OCCURRENCES -------- --------------------- 624 1 578 1 576 1 298 1 290 1 250 1 249 1 248 1 247 1 246 1 245 1 234 1 187 1 145 1 140 2 128 1 120 1 65 1 58 1 27 1 18 1 -3 1 -5 1 -6 1 -7 1 INPUT LINE ... NEWPAGE 1 INPUT LINE ... PROJECT BOEINGPL FROM AIRPLANS USING MODEL TYPE NUMENG CRUSALT + INPUT LINE ... CRUSSPD WHERE MFG EQ BOEING SUCCESSFUL PROJECT OPERATION 6 ROWS GENERATED INPUT LINE ... LISTREL BOEINGPL RELATION : BOEINGPL LAST MOD : 83/09/28 READ PASSWORD : YES SCHEMA : PLANES MODIFY PASSWORD : NONE NAME TYPE LENGTH KEY MODEL TEXT 10 CHARACTERS TYPE TEXT 10 CHARACTERS NUMENG INT 1 CRUSALT REAL 1 CRUSSPD REAL 1 CURRENT NUMBER OF ROWS = 6 INPUT LINE ... SELECT MODEL CRUSALT CRUSSPD FROM BOEINGPL MODEL CRUSALT CRUSSPD ---------- -------- -------- B727-100 39000. 560. B727-200 39000. 560. B747-200 43000. 580. B737-200 35000. 590. B747-SP 45000. 600. B747-F 50000. 650. INPUT LINE ... NEWPAGE 1 INPUT LINE ... INTERSECT AIRPLANS WITH AIRLINES FORMING FLIGHTS SUCCESSFUL INTERSECT OPERATION 24 ROWS GENERATED INPUT LINE ... LISTREL FLIGHTS RELATION : FLIGHTS LAST MOD : 83/09/28 READ PASSWORD : YES SCHEMA : PLANES MODIFY PASSWORD : YES NAME TYPE LENGTH KEY MFG TEXT 10 CHARACTERS MODEL TEXT 10 CHARACTERS TYPE TEXT 10 CHARACTERS NUMENG INT 1 ENGTYPE TEXT 10 CHARACTERS CRUSALT REAL 1 CRUSSPD REAL 1 CARRIER TEXT 10 CHARACTERS FLIGHTNO INT 1 STRTCITY TEXT 10 CHARACTERS ENDCITY TEXT 10 CHARACTERS DAYOFWK TEXT 10 CHARACTERS CURRENT NUMBER OF ROWS = 24 INPUT LINE ... SELECT CRUSALT FROM FLIGHTS WHERE STRTCITY EQ ROCHESTER AND ENDCITY + INPUT LINE ... EQ SEATTLE CRUSALT -------- 39000. INPUT LINE ... * CRUSSPD ** CRUSSPD -------- 560. INPUT LINE ... TALLY MFG FROM FLIGHTS MFG NUMBER OF OCCURRENCES ---------- --------------------- BOEING 10 BURNER 6 DOUGLAS 6 LOCKHEED 2 INPUT LINE ... NEWPAGE 1 INPUT LINE ... SUBTRACT AIRLINES FROM AIRPLANS FORMING LEFTOVER SUCCESSFUL SUBTRACT OPERATION 1 ROWS GENERATED INPUT LINE ... SUBTRACT AIRLINES FROM AIRPLANS FORMING LEFTOVR2 USING MODEL SUCCESSFUL SUBTRACT OPERATION 1 ROWS GENERATED INPUT LINE ... SELECT ALL FROM LEFTOVER MFG MODEL TYPE NUMENG ENGTYPE CRUSALT CRUSSPD ---------- ---------- ---------- -------- ---------- -------- -------- BOEING B747-F CARGO 4 JET 50000. 650. INPUT LINE ... SELECT ALL FROM LEFTOVR2 MODEL ---------- B747-F INPUT LINE ... EXHIBIT MFG RELATIONS CONTAINING MFG AIRPLANS FLIGHTS LEFTOVER INPUT LINE ... NEWPAGE 1 INPUT LINE ... USER AGENT INPUT LINE ... CHANGE DAYOFWK TO MON WHERE CARRIER EQ IPAD-AIR AND FLIGHTNO EQ -3 1 ROWS CHANGED IN RELATION AIRLINES 1 ROWS CHANGED IN RELATION FLIGHTS INPUT LINE ... CHANGE CARRIER TO HUGHES IN AIRLINES WHERE CARRIER EQ AIRWEST 2 ROWS CHANGED IN RELATION AIRLINES INPUT LINE ... EXHIBIT DAYOFWK RELATIONS CONTAINING DAYOFWK AIRLINES FLIGHTS INPUT LINE ... EXHIBIT MODEL RELATIONS CONTAINING MODEL AIRPLANS AIRLINES BOEINGPL FLIGHTS LEFTOVER LEFTOVR2 INPUT LINE ... RENAME DAYOFWK TO DAY ATTRIBUTE DAYOFWK RENAMED IN 2 RELATIONS ATTRIBUTE DAYOFWK RENAMED IN 0 PLACES IN THE RULES INPUT LINE ... RENAME MODEL TO PLANE IN FLIGHTS ATTRIBUTE MODEL RENAMED IN 1 RELATIONS ATTRIBUTE MODEL RENAMED IN 0 PLACES IN THE RULES INPUT LINE ... EXHIBIT DAYOFWK RELATIONS CONTAINING DAYOFWK -WARNING- ATTRIBUTE LIST DOES NOT OCCUR IN ANY RELATIONS INPUT LINE ... EXHIBIT DAY $ * MODEL $ * PLANE RELATIONS CONTAINING DAY AIRLINES FLIGHTS RELATIONS CONTAINING MODEL AIRPLANS AIRLINES BOEINGPL LEFTOVER LEFTOVR2 RELATIONS CONTAINING PLANE FLIGHTS INPUT LINE ... RENAME RELATION DEFIN TO DATADICT RELATION DEFIN RENAMED TO DATADICT INPUT LINE ... LISTREL DEFIN -ERROR- DEFIN IS NOT A RECOGNIZED RELATION NAME INPUT LINE ... LISTREL DATADICT RELATION : DATADICT LAST MOD : 83/09/28 READ PASSWORD : YES SCHEMA : PLANES MODIFY PASSWORD : YES NAME TYPE LENGTH KEY WORD TEXT 8 CHARACTERS YES WRDTYPE TEXT 9 CHARACTERS DESCRIP TEXT VARIABLE CURRENT NUMBER OF ROWS = 21 INPUT LINE ... CHANGE OWNER TO BOEING INPUT LINE ... USER BOEING INPUT LINE ... NEWPAGE 1 INPUT LINE ... LISTREL EXISTING RELATIONS AS OF 83/09/28 09.49.25 DATADICT AIRPLANS AIRLINES CREW BOEINGPL FLIGHTS LEFTOVER LEFTOVR2 INPUT LINE ... REMOVE LEFTOVR2 $ * CREW INPUT LINE ... LISTREL EXISTING RELATIONS AS OF 83/09/28 09.49.25 DATADICT AIRPLANS AIRLINES BOEINGPL FLIGHTS LEFTOVER INPUT LINE ... DELETE TUPLE FROM AIRLINES WHERE CARRIER EQ IPAD-AIR 4 ROWS DELETED IN RELATION AIRLINES INPUT LINE ... *3 FLIGHTS ** 4 ROWS DELETED IN RELATION FLIGHTS INPUT LINE ... PROJECT COMPANYS FROM AIRLINES USING CARRIER SUCCESSFUL PROJECT OPERATION 22 ROWS GENERATED INPUT LINE ... SELECT ALL FROM COMPANYS CARRIER ---------- UNITED UNITED UNITED UNITED CONT CONT HUGHES UNITED HUGHES WESTERN TWA TWA TWA AMERICAN AMERICAN AMERICAN PANAM PANAM PANAM PANAM PANAM PANAM INPUT LINE ... PROJECT BOEINGPL FROM AIRPLANS USING ALL WHERE MFG EQS "BOE" -ERROR- RESULTANT RELATION DOES NOT HAVE A UNIQUE NAME INPUT LINE ... SELECT ALL FROM BOEINGPL MODEL TYPE NUMENG CRUSALT CRUSSPD ---------- ---------- -------- -------- -------- B727-100 PASSENGER 3 39000. 560. B727-200 PASSENGER 3 39000. 560. B747-200 PASSENGER 4 43000. 580. B737-200 PASSENGER 2 35000. 590. B747-SP PASSENGER 4 45000. 600. B747-F CARGO 4 50000. 650. INPUT LINE ... NOECHO END RIM EXECUTION 83/09/28 09.49.26 -h- test2.com Mon Dec 02 10:17:26 1985 DF1:[DBMS]TEST2.COM;1 $! $! COMMAND PROCEDURE TO RUN TEST2 OF RIM $! $! THIS TEST REQUIRES APPROXIMATELY 10 MINUTES TO RUN $! $ DELETE TEST2.DAT;* $ DELETE ARODB%.DAT;* $ RUN RIM INPUT ITEST2 $! $! END OF TEST2 PROCEDURE -h- test2.dat Mon Dec 02 10:17:26 1985 DF1:[DBMS]TEST2.DAT;1 BEGIN RIM SCHEMA COMPILATION RIM SCHEMA COMPILATION FOR AERODB IS COMPLETE BEGIN -RIM- DATA LOADING END -RIM- DATA LOADING BEGIN -RIM- DATA LOADING END -RIM- DATA LOADING INPUT LINE ... NEWPAGE 1 INPUT LINE ... TITLE "INSTALLATION TEST COMMANDS" INSTALLATION TEST COMMANDS INPUT LINE ... BLANK 2 INPUT LINE ... PROJECT PROREL1 FROM AIRPORTS USING ALTITUDE COUNTRY + INPUT LINE ... WHERE ALTITUDE GT 5000 OR COUNTRY LT 500 SUCCESSFUL PROJECT OPERATION 1323 ROWS GENERATED INPUT LINE ... DELETE ROW FRO PROREL1 WHE ALTITUDE GE 5 AND COUNTRY LE 5000 1236 ROWS DELETED IN RELATION PROREL1 INPUT LINE ... BLANK 2 INPUT LINE ... INTERSECT PROREL1 WITH STATES FORMING INTREL1 SUCCESSFUL INTERSECT OPERATION 87 ROWS GENERATED INPUT LINE ... BLANK 2 INPUT LINE ... PROJECT PROREL2 FROM AIRPORTS USING RUNWAY COUNTRY + INPUT LINE ... WHERE ALTITUDE LT 7 SUCCESSFUL PROJECT OPERATION 246 ROWS GENERATED INPUT LINE ... BLANK 2 INPUT LINE ... BUILD KEY FOR COUNTRY IN PROREL2 ; *5 STATES INPUT LINE ... BLANK 2 INPUT LINE ... INTERSECT PROREL2 WITH STATES FORMING INTREL2 SUCCESSFUL INTERSECT OPERATION 242 ROWS GENERATED INPUT LINE ... BLANK 2 INPUT LINE ... SUBTRACT INTREL1 FROM INTREL2 FORMING SUBREL1 SUCCESSFUL SUBTRACT OPERATION 142 ROWS GENERATED INPUT LINE ... DEL ROW IN INTREL2 WHE COUNTRY GT 100 AND COUNTRY LT 500 74 ROWS DELETED IN RELATION INTREL2 INPUT LINE ... BLANK 2 INPUT LINE ... JOIN INTREL1 USING STATE WITH INTREL2 USING STATE FOR JOINREL1 -WARNING- COUNTRY IS A DUPLICATE ATTRIBUTE NAME YOU SHOULD RENAME IT BEFORE DOING QUERIES OR UPDATES -WARNING- STATE IS A DUPLICATE ATTRIBUTE NAME YOU SHOULD RENAME IT BEFORE DOING QUERIES OR UPDATES SUCCESSFUL JOIN OPERATION 270 ROWS GENERATED INPUT LINE ... BLANK 2 INPUT LINE ... BUILD KEY FOR STATE IN INTREL1 ; *5 INTREL2 INPUT LINE ... BLANK 2 INPUT LINE ... JOIN INTREL1 USING STATE WITH INTREL2 USING STATE FOR JOINREL2 -WARNING- COUNTRY IS A DUPLICATE ATTRIBUTE NAME YOU SHOULD RENAME IT BEFORE DOING QUERIES OR UPDATES -WARNING- STATE IS A DUPLICATE ATTRIBUTE NAME YOU SHOULD RENAME IT BEFORE DOING QUERIES OR UPDATES SUCCESSFUL JOIN OPERATION 270 ROWS GENERATED INPUT LINE ... NEWPAGE 1 INPUT LINE ... SELECT CITYNAME APTCODE FROM AIRPORTS SORTED BY APTCODE + INPUT LINE ... WHERE LAT-DIR EQ S AND ALTITUDE GT 10000 CITYNAME APTCODE ------------------------------ -------- ORURO, BOLIVIA ORU POTOSI, BOLIVIA POI INPUT LINE ... BLANK 5 INPUT LINE ... BUILD KEY FOR ALTITUDE IN AIRPORTS INPUT LINE ... TALLY RUNWAY = D FROM AIRPORTS WHERE ALTITUDE EQ 0 RUNWAY NUMBER OF OCCURRENCES -------- --------------------- 3940 1 3937 1 3000 1 1500 1 1300 1 0 163 INPUT LINE ... NEWPAGE 1 INPUT LINE ... COM AVE ALTITUDE FROM AIRPORTS AVE ALTITUDE ------------------------ 903 INPUT LINE ... BLANK 5 INPUT LINE ... RENAME COUNTRY TO NEWCOU IN JOINREL1 ; * STATE * NEWSTA ** ATTRIBUTE COUNTRY RENAMED IN 1 RELATIONS ATTRIBUTE STATE RENAMED IN 1 RELATIONS INPUT LINE ... BLANK 5 INPUT LINE ... CHANGE NEWCOU TO 9999 WHERE ALTITUDE GT 0 AND STATE EQS U.S. 25 ROWS CHANGED IN RELATION JOINREL1 INPUT LINE ... BLANK 5 INPUT LINE ... BUILD KEY FOR NEWSTA IN JOINREL1 INPUT LINE ... BLANK 5 INPUT LINE ... DELETE ROW FROM JOINREL1 WHERE NEWSTA EQS NEW 1 ROWS DELETED IN RELATION JOINREL1 INPUT LINE ... DELETE ROW FROM JOINREL1 WHERE NEWCOU EQ 1 210 ROWS DELETED IN RELATION JOINREL1 INPUT LINE ... NEWPAGE 1 INPUT LINE ... DEL DUP FROM JOINREL1 40 ROWS DELETED IN RELATION JOINREL1 INPUT LINE ... BLANK 5 INPUT LINE ... REMOVE PROREL1 ; * PROREL2 ; * INTREL1 ; * INTREL2 INPUT LINE ... * JOINREL1 ; * JOINREL2 INPUT LINE ... * SUBREL1 INPUT LINE ... DELETE KEY FOR ALTITUDE IN AIRPORTS ; *3 COUNTRY ** ; *3 + INPUT LINE ... STATE IN STATES INPUT LINE ... LIS ALL RELATION : AIRPORTS LAST MOD : 83/09/28 READ PASSWORD : NONE SCHEMA : AERODB MODIFY PASSWORD : NONE NAME TYPE LENGTH KEY APTCODE TEXT 8 CHARACTERS CITYCODE TEXT 8 CHARACTERS STAR TEXT 8 CHARACTERS LAT-DEG INT 1 LAT-MIN INT 1 LAT-DIR TEXT 8 CHARACTERS LON-DEG INT 1 LON-MIN INT 1 LON-DIR TEXT 8 CHARACTERS CITYNAME TEXT 30 CHARACTERS GMT INT 1 COUNTRY INT 1 RUNWAY INT 1 ALTITUDE INT 1 SURFACE TEXT 8 CHARACTERS LCN INT 1 AREA TEXT 8 CHARACTERS CURRENT NUMBER OF ROWS = 2609 RELATION : STATES LAST MOD : 83/09/28 READ PASSWORD : NONE SCHEMA : AERODB MODIFY PASSWORD : NONE NAME TYPE LENGTH KEY COUNTRY INT 1 YES STATE TEXT VARIABLE CURRENT NUMBER OF ROWS = 274 INPUT LINE ... EXIT END RIM EXECUTION 83/09/28 10.02.38 -h- test3.com Mon Dec 02 10:17:26 1985 DF1:[DBMS]TEST3.COM;1 $! $! COMMAND PROCEDURE TO RUN TEST3 OF RIM $! $! THIS TEST REQUIRES APPROXIMATELY 1 MINUTE TO RUN $! $ DELETE TEST3.DAT;* $ DELETE VERIFY%.DAT;* $ RUN RIM INPUT ITEST3 $! $ DELETE JUNK.DAT;* $! $! END OF TEST3 PROCEDURE -h- test4.com Mon Dec 02 10:17:26 1985 DF1:[DBMS]TEST4.COM;1 $! $! COMMAND PROCEDURE TO RUN TEST4 OF RIM $! $! THIS TEST REQUIRES APPROXIMATELY 1 MINUTE TO RUN $! $ DELETE TEST4.DAT;* $ DELETE FTNDB%.DAT;* $ RUN RIM INPUT ITEST4 $! $ FOR APPLPRO $ LINK APPLPRO,RIMLIB/LIB $ ASSIGN TEST4.DAT FOR006 $ RUN APPLPRO $ DEASSIGN FOR006 $! $! END OF TEST4 PROCEDURE -h- text.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]TEXT.BLK;1 C RM- 834 C **************************************************************** RM- 835 C RM- 836 C THIS ROUTINE IS PART OF RIM VERSION 5 (RIM-5) RM- 837 C RM- 838 C RIM-5 WAS DEVELOPED IN 1981 (MAY-AUGUST) BY BOEING'S RM- 839 C BESS AND IPAD (NASA CONTRACT NAS-14700) PROJECTS. RM- 840 C THIS PROGRAM IS SUBJECT TO THE RESTRICTIONS AND RM- 841 C DISCLAIMERS LISTED IN THE RIM-5 MAIN PROGRAM (RMMAIN). RM- 842 C RM- 843 C THE PRINCIPAL AUTHORS ARE RM- 844 C RM- 845 C WAYNE J. ERICKSON RM- 846 C DATA MANAGEMENT CONSULTANT RM- 847 C 2029 5TH STREET S.E. RM- 848 C PUYALLUP,WASHINGTON 98371 RM- 849 C FREDERIC P. GRAY JR. RM- 850 C BOEING COMERCIAL AIRPLANE COMPANY (BCAC) RM- 851 C GEOFFREY VONLIMBACH RM- 852 C BOEING COMPUTER SERVICES COMPANY (BCS) RM- 853 C RM- 854 C **************************************************************** RM- 855 -h- toled.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]TOLED.FOR;1 SUBROUTINE TOLED(K,V,N) INCLUDE '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 '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 -h- toler.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]TOLER.FOR;1 SUBROUTINE TOLER(K,V,N) INCLUDE '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 '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 -h- tty.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]TTY.FOR;1 LOGICAL FUNCTION TTY(I) C C DUMMY ROUTINE FOR TTY ON THE VAX -- ALWAYS TRUE C TTY = .TRUE. RETURN END -h- tuplea.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]TUPLEA.BLK;1 C C *** / T U P L E A / *** C C ONE TUPLE OF THE ATTRIBUTE RELATION - FORMERLY COLTBLE C COMMON /TUPLEA/ ATTNAM,RELNAM,ATTCOL,ATTLEN,ATTCHA,ATTWDS, X ATTYPE,ATTKEY REAL*8 ATTNAM REAL*8 RELNAM INTEGER ATTCOL INTEGER ATTLEN INTEGER ATTCHA INTEGER ATTWDS INTEGER ATTYPE INTEGER ATTKEY C C VARIABLE DEFINITIONS: C ATTNAM--NAME OF ATTRIBUTE C RELNAM--NAME OF RELATION C ATTCOL--STARTING COLUMN FOR ATTRIBUTE IN RELATION C ATTLEN--ATTRIBUTE LENGTH DATA - CALL ITOH(A,B,ATTLEN) C TYPE LENGTH A B C ------ ------- ------- ------- C TEXT FIXED NCHAR NWORDS C INT FIXED 0 NWORDS C REAL FIXED 0 NWORDS C DOUB FIXED 0 NWORDS (2*ITEMS) C IVEC FIXED ROWS NWORDS C RVEC FIXED ROWS NWORDS C DVEC FIXED ROWS NWORDS (2*ITEMS) C IMAT FIXED ROWS NWORDS (ROWS*COLS) C RMAT FIXED ROWS NWORDS (ROWS*COLS) C DMAT FIXED ROWS NWORDS (2*ROWS*COLS) C TEXT VAR 0 0 C INT VAR 0 0 C REAL VAR 0 0 C DOUB VAR 0 0 C IVEC VAR 0 0 C RVEC VAR 0 0 C DVEC VAR 0 0 C IMAT FIX-VAR ROWS 0 C RMAT FIX-VAR ROWS 0 C DMAT FIX-VAR ROWS 0 C IMAT VAR-VAR 0 0 C RMAT VAR-VAR 0 0 C DMAT VAR-VAR 0 0 C ATTCHA--THE "A" VALUE FROM ATTLEN C ATTWDS--THE "B" VALUE FROM ATTLEN C ATTYPE--VARIABLE TYPE (INT,REAL,TEXT,DOUB,ETC.) C ATTKEY--0 FOR NON-KEY ATTRIBUTES C BTREE START FOR KEY ATTRIBUTES C -h- tupler.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]TUPLER.BLK;1 C C *** / T U P L E R / *** C C ONE TUPLE OF THE RELTBL RELATION C COMMON /TUPLER/ NAME,RDATE,RPW,MPW,NCOL,NATT,NTUPLE,RSTART,REND REAL*8 NAME REAL*8 RDATE INTEGER RSTART INTEGER REND REAL*8 RPW REAL*8 MPW C C VARIABLE DEFINITIONS: C NAME----RELATION NAME C RDATE---DATE OF LAST MODIFICATION TO RELATION C NCOL----NUMBER OF COLUMNS OF FIXED LENGTH C NATT----NUMBER OF ATTRIBUTES C NTUPLE--NUMBER OF DEFINED TUPLES C RSTART--DATA FILE POINTER FOR THE START OF THE RELATION C REND----DATA FILE POINTER FOR THE END OF THE RELATION C RPW-----READ PASSWORD C MPW-----MODIFY PASSWORD C -h- typer.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]TYPER.FOR;1 SUBROUTINE TYPER(ATYPE,VECMAT,TYPE) INCLUDE '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 'RMATTS.BLK' INCLUDE 'MISC.BLK' INCLUDE '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 -h- undata.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]UNDATA.FOR;1 SUBROUTINE UNDATA (ALL,IRCNTR,IDAY,WORD1,LHASH,NAMOWN) INCLUDE '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 'RMATTS.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'DCLAR6.BLK' INCLUDE 'FILES.BLK' INCLUDE 'MISC.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'DCLAR1.BLK' INCLUDE 'DCLAR2.BLK' INCLUDE '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 WRITE (NOUTR,50) 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 WRITE (NOUTR,150) NAME 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 WRITE (NOUTR,700) 700 FORMAT (1X,3HEND) GO TO 75 800 CONTINUE RMSTAT = 0 RETURN END -h- undef.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]UNDEF.FOR;1 SUBROUTINE UNDEF (ALL,IRCNTR,IDAY,WORD1,LHASH,NAMOWN,NAMDB) INCLUDE '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 'RMATTS.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'DCLAR2.BLK' INCLUDE 'DCLAR6.BLK' INCLUDE 'FILES.BLK' INCLUDE 'MISC.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'DCLAR1.BLK' INCLUDE '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) WRITE (NOUTR,3) NAMDB 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) WRITE (NOUTR,4) 4 FORMAT (1X,10HATTRIBUTES) 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 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 C C 50 CONTINUE IF (IRCNTR .EQ. 0) GO TO 400 J = LOCREL(BLANK) WRITE (NOUTR,80) 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 (ICOUNT .NE. 1) WRITE (NOUTR,110) NAMES(1),WITH, X (NAMES(KK),KK=2,ICOUNT),IEND 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 WRITE (NOUTR,175) 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 WRITE (NOUTR,450) 450 FORMAT (1X,3HEND) RETURN END -h- unload.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]UNLOAD.FOR;1 SUBROUTINE UNLOAD INCLUDE '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 'CONST4.BLK' INCLUDE 'CONST8.BLK' INCLUDE 'FILES.BLK' INCLUDE 'BUFFER.BLK' INCLUDE 'FLAGS.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'DCLAR1.BLK' INCLUDE 'DCLAR2.BLK' INCLUDE 'DCLAR3.BLK' INCLUDE 'DCLAR6.BLK' INCLUDE '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 WRITE (NOUT,215) RNAME 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 WRITE (NOUT,275) RNAME 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 WRITE (NOUT,330) RNAME 330 FORMAT (/,2X,39H--WARNING-- YOU HAVE ALREADY SPECIFIED , X 14HRELATION NAME ,A8) GO TO 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 WRITE(NOUTR,425) 425 FORMAT(16H*(SET SEMI=NULL),/,18H*(SET DOLLAR=NULL)) IF (.NOT. LHASH) GO TO 480 CALL RMDATE (IDAY) CALL RMTIME (ITIME) WRITE (NOUTR,450) ITIME,IDAY 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 WRITE(NOUTR,490) 490 FORMAT(13H*(SET SEMI=;),/,15H*(SET DOLLAR=$)) GO TO 9999 8000 CONTINUE C C ERROR FOR UNLOADING ALL OF THE DATA C 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 C C INCORRECT SYNTAX ERROR MESSAGE C 9000 CONTINUE WRITE (NOUT,9001) 9001 FORMAT (/,2X,42H--ERROR-- INCORRECT SYNTAX FOR THE COMMAND,/) RMSTAT = 4 C C CLEAN UP AND END C 9999 CONTINUE CALL BLKCLR (10) RETURN END -h- update.com Mon Dec 02 10:17:26 1985 DF1:[DBMS]UPDATE.COM;1 $ FOR 'P1' $ LIBRARY RIMLIB 'P1' $ DELETE 'P1'.OBJ;* -h- updatf.cmd Mon Dec 02 10:17:26 1985 DF1:[DBMS]UPDATF.CMD;1 .ENABLE SUBSTITUTION .ENABLE QUIET F77 'P1'='P1'.FTN/NOTR/I4/F77 .TESTFILE RIMLIB.OLB .IF NE 1 .GOTO CR LBR RIMLIB='P1' .GOTO DE .CR: LBR RIMLIB/CR='P1' .DE: PIP 'P1'.OBJ;1/DE -h- utol.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]UTOL.FOR;1 PROGRAM UTOL BYTE L(160) BYTE NL(80) 100 CONTINUE READ(1,200,IOSTAT=IOS) L IF(IOS.NE.0) GO TO 9999 200 FORMAT(160A1) I = 1 K = 0 300 CONTINUE IF(I.GT.160) GO TO 1000 IF(L(I).NE.1H^) GO TO 400 I = I + 1 K = K + 1 CALL LOWER(L(I),NL(K)) I = I + 1 GO TO 300 400 CONTINUE IF(L(I).EQ.1H@) GO TO 500 K = K + 1 NL(K) = L(I) I = I + 1 GO TO 300 500 CONTINUE I = I + 2 K = K + 1 NL(K) = 1H: GO TO 300 1000 CONTINUE WRITE(2,1100) NL 1100 FORMAT(80A1) GO TO 100 9999 CONTINUE STOP END SUBROUTINE LOWER(I,LOW) BYTE I,LOW BYTE 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 -h- vardat.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]VARDAT.BLK;1 C C *** / V A R D A T / *** C C VARIABLE ATTRIBUTE DATA FOR THE FORTRAN INTERFACE C COMMON /VARDAT/ NUMVAR,POSVAR(2,5) INTEGER NUMVAR INTEGER POSVAR C C VARIABLE DEFINITION: C NUMVAR--NUMBER OF VARIABLE ATTRIBUTES (CURRENT RELATION) C POSVAR--ROW 1 - TUPLE COLUMN POINTERS FOR THE ATTRIBUTES C ROW 2 - ATTRIBUTE TYPES C -h- verify.com Mon Dec 02 10:17:26 1985 DF1:[DBMS]VERIFY.COM;1 $! $! COMMAND PROCEDURE TO VERIFY THE INSTALLATION OF RIM $! @TEST1 @TEST2 @TEST3 @TEST4 @COMPRE $! $! END OF VERIFY PROCEDURE $! -h- warn.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]WARN.FOR;1 SUBROUTINE WARN(NUM,WORD1,WORD2) INCLUDE '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 'CONST8.BLK' INCLUDE 'FILES.BLK' INCLUDE 'DCLAR6.BLK' C 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 99 RETURN END -h- whcom.blk Mon Dec 02 10:17:26 1985 DF1:[DBMS]WHCOM.BLK;1 C C *** / W H C O M / *** C C WHERE CLAUSE COMMON BLOCK C COMMON /WHCOM/ NBOO,BOO(10),KATTP(10),KATTL(10),KATTY(10), 1 KOMTYP(10),KOMPOS(10),KOMLEN(10),KOMPOT(10),KSTRT,MAXTU 2 ,LIMTU,WHRVAL(300),WHRLEN(100) INTEGER BOO INTEGER WHRVAL,WHRLEN C C VARIABLE DEFINITIONS: C NBOO----NUMBER OF SIMPLE BOOLEAN CONDITIONS (MAX 5) C BOO-----ARRAY OF CONDITION AND/OR CONNECTORS (3HAND,2HOR) C KATTP---ARRAY OF ATTRIBUTE COLUMN NUMBERS C (0 IF "TUPLE" WHERE CLAUSE) C KATTL---ARRAY OF ATTRIBUTE LENGTHS IN WORDS EXCEPT TEXT C IS IN CHARACTERS (0 IF "TUPLE" WHERE CLAUSE) C KATTY---ARRAY OF ATTRIBUTE TYPES C (0 IF "TUPLE" WHERE CLAUSE) C KOMTYP--ARRAY OF BOOLEAN COMPARISON INTEGER IDENTIFIERS C KOMPOS--ARRAY OF POSITION POINTERS IN WHRVAL C FOR THE START OF THE VALUE LIST C OR THE COLUMN NUMBER OF THE SECOND ATTRIBUTE C KOMLEN--ARRAY INDICATING THE NUMBER OF ITEMS IN THE C VALUE LIST C KOMPOT--ARRAY OF POINTERS TO WHRLEN C KSTRT---RECORD NUMBER OF THE STARTING NODE IN THE C B-TREE IF KEY PROCESSING IS USED C MAXTU---MAXIMUM TUPLE NUMBER REQUESTED OR 0 C LIMTU---MAXIMUM NUMBER OF TUPLES TO ACTUALLY PROCESS C WHRVAL--ARRAY OF VALUES POINTED TO BY KOMPOS C WHRLEN--ARRAY OF "ATTLEN" STYLE INFORMATION -h- where.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]WHERE.FOR;1 SUBROUTINE WHERE(IS) INCLUDE 'TEXT.BLK' C C PURPOSE: PROCESS A RIM WHERE CLAUSE C C PARAMETERS: C IS------POINTER TO WHERE IN IREC ARRAY INCLUDE 'RMATTS.BLK' INCLUDE 'RMKEYW.BLK' INCLUDE 'CONST4.BLK' INCLUDE 'MISC.BLK' INCLUDE 'RIMCOM.BLK' INCLUDE 'TUPLEA.BLK' INCLUDE 'TUPLER.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'FILES.BLK' INCLUDE 'RIMPTR.BLK' C LOGICAL EQKEYW LOGICAL IFLIM LOGICAL IFTUP INCLUDE '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 WRITE(NOUT,9002) 9002 FORMAT(52H -ERROR- MORE THAN 10 CONDITIONS IN THE WHERE CLAUSE) GO TO 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 WRITE(NOUT,9003) KOMPAR GO TO 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 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 WRITE(NOUT,9000) ATTYPE 9000 FORMAT(9H -ERROR- ,A4,42H ATTRIBUTES CANNOT BE USED WITH MIN OR MA XX) GO TO 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 WRITE(NOUT,9001) 9001 FORMAT(61H -ERROR- MULTI-WORD ATTRIBUTES CANNOT BE USED WITH MIN O XR MAX) GO TO 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 WRITE (NOUT,1582) 1582 FORMAT(46H -ERROR- EQS REQUIRES TEXT ELEMENTS AND VALUES ) GO TO 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 WRITE (NOUT,7010) 7010 FORMAT(31H -ERROR- WHERE CLAUSE TOO SHORT ) GO TO 8000 7100 CONTINUE WRITE (NOUT,7110) 7110 FORMAT(34H -ERROR- LIMIT KEYWORD REQUIRES EQ ) GO TO 8000 7200 CONTINUE WRITE (NOUT,7210) 7210 FORMAT(50H -ERROR- LIMIT KEYWORD REQUIRES A POSITIVE INTEGER ) GO TO 8000 7300 CONTINUE WRITE (NOUT,7310) 7310 FORMAT(47H -ERROR- ROW KEYWORD REQUIRES POSITIVE INTEGERS ) GO TO 8000 7400 CONTINUE WRITE (NOUT,7410) 7410 FORMAT(51H -ERROR- MIN/MAX SHOULD ONLY BE FOLLOWED BY AND/OR ) GO TO 8000 7500 CONTINUE WRITE (NOUT,7510) 7510 FORMAT(28H -ERROR- COMPARED ATTRIBUTES, X 36H MUST BE THE SAME IN TYPE AND LENGTH ) GO TO 8000 7600 CONTINUE WRITE (NOUT,7610) 7610 FORMAT(47H -ERROR- LISTS ARE ONLY VALID FOR EQ EQS AND NE) GO TO 8000 7700 CONTINUE WRITE(NOUT,7710) 7710 FORMAT(50H -ERROR- MIN/MAX NOT AVAILABLE FOR NULL ATTRIBUTES) GO TO 8000 7800 CONTINUE WRITE (NOUT,7810) 7810 FORMAT(55H -ERROR- FAILS/EXISTS SHOULD ONLY BE FOLLOWED BY AND/OR) GO TO 8000 C C UNABLE TO PROCESS THE WHERE CLAUSE. C 8000 CONTINUE IF(NBOO.NE.0) WRITE (NOUT,8010)NBOO 8010 FORMAT(9X,36HERROR DETECTED ON BOOLEAN CONDITION ,I2) RMSTAT = 4 C C QUIT. C 9999 CONTINUE IF(MAXTU.EQ.0) MAXTU = ALL9S CALL WHETOL RETURN END -h- whetol.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]WHETOL.FOR;1 SUBROUTINE WHETOL INCLUDE '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 'RMATTS.BLK' INCLUDE 'WHCOM.BLK' INCLUDE 'FLAGS.BLK' INCLUDE '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 -h- wrline.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]WRLINE.FOR;1 SUBROUTINE WRLINE (NC,ISTAT,LINE) INCLUDE '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 'CONST4.BLK' INCLUDE '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 -h- xhibit.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]XHIBIT.FOR;1 SUBROUTINE XHIBIT INCLUDE '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 'TUPLER.BLK' INCLUDE 'FILES.BLK' INCLUDE 'MISC.BLK' INCLUDE 'FLAGS.BLK' C LOGICAL EQ LOGICAL FLAG INCLUDE '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 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) 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 WRITE(NOUTR,9001) NAME 9001 FORMAT(5X,A8) FLAG = .TRUE. GO TO 200 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 WRITE(NOUT,9002) 9002 FORMAT(57H -WARNING- ATTRIBUTE LIST DOES NOT OCCUR IN ANY RELATION XS) GO TO 9999 C C INVALID SYNTAX FOR 'EXHIBIT' C 9900 CONTINUE WRITE(NOUT,9003) 9003 FORMAT(47H -ERROR- ILLEGAL NUMBER OF ATTRIBUTES SPECIFIED ) C C DONE WITH EXHIBIT C 9999 RETURN END -h- zeroit.for Mon Dec 02 10:17:26 1985 DF1:[DBMS]ZEROIT.FOR;1 SUBROUTINE ZEROIT(ARRAY,NWDS) INCLUDE '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