home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d5xx / d594 / analyrimsrc.lha / AnalyRimSrc / AnaRimSrcDoc.Zoo / analyrimp2.for < prev    next >
Text File  |  1991-09-30  |  584KB  |  24,891 lines
  1.       Subroutine RMMAIN
  2. C
  3. C  ****************************************************************
  4. C
  5. C  RELATIONAL INFORMATION MANAGEMENT SYSTEM (RIM) - VERSION 5
  6. C
  7. C  THIS PROGRAM IS AN IMPLEMENTATION OF THE RELATIONAL ALGEBRA
  8. C  MODEL OF DATA BASE MANAGEMENT.
  9. C
  10. C  THE PRINCIPAL AUTHORS ARE
  11. C
  12. C  WAYNE J. ERICKSON
  13. C    DATA MANAGEMENT CONSULTANT
  14. C    2029 5TH STREET S.E.
  15. C    PUYALLUP,WASHINGTON 98371
  16. C  FREDERIC P. GRAY JR.
  17. C    BOEING COMERCIAL AIRPLANE COMPANY (BCAC)
  18. C  GEOFFREY VONLIMBACH
  19. C    BOEING COMPUTER SERVICES COMPANY (BCS)
  20. C
  21. C  CONTRIBUTIONS TO RIM-5 CODE WERE ALSO MADE BY
  22. C
  23. C  LAURA B. HAMED (UNLOAD) AND
  24. C  STIG O. WAHLSTROM (SORT) OF BCS AND BCAC RESPECTIVELY.
  25. C
  26. C
  27. C Ported to Unix (specifically sun4) 8/1991 by
  28. C  Glenn C. Everhart
  29. C  Build is just "f77 rim.for".
  30. C  The port fixes things like case of input, gets file
  31. C operations and so on working, and does NOT use the sun
  32. C compiler's "vax fortran compatible" features.
  33. C Major other hacks by Glenn Everhart. User noticeable will be the
  34. C mixed case messages!
  35. C
  36. C This version of RIM also is modified for use with AnalytiCalc
  37. C by the replacement of console I/O with subroutine calls
  38. C so that I/O can be controlled more sensibly; this was done
  39. C by Glenn Everhart.
  40. C
  41. C  RIM-5 EXTENDS THE CAPABILITIES OF RIM-4
  42. C  PRIMARILY BY ADDING CAPABILITY FOR VARIABLE LENGTH
  43. C  ATTRIBUTES,ADDING SEVERAL ATTRIBUTE TYPES,IMPLEMENTING
  44. C  BOTH DIRECT AND MENU MODE,EXPANDING THE COMMAND LANGUAGE
  45. C  AND ENTENDING THE FORTRAN INTERFACE CAPABILITIES
  46. C
  47. C  RIM-5 IS WRITTEN IN FORTRAN 77 AND IS INTENDED TO
  48. C  BE EASILY IMPLEMENTED ON COMPUTERS SUPPORTING THIS
  49. C  LANGUAGE.
  50. C
  51. C  RIM WAS ORIGINALLY DEVELOPED UNDER THE IPAD PROJECT
  52. C  (NASA CONTRACT NAS-14700) BY WAYNE ERICKSON AND
  53. C  DENNIS COMFORT BOTH AT THAT TIME WITH BCS. EXTENSIONS
  54. C  TO RIM WERE THEN MADE BY WAYNE ERICKSON AND FRED GRAY
  55. C  RESULTING IN VERSION 4 (RIM-4) IN LATE 1980.
  56. C
  57. C  MAJOR MILESTONES IN THE DEVELOPMENT OF RIM:
  58. C
  59. C     1/78 TO 3/78 - WAYNE ERICKSON AND DENNIS COMFORT DEVELOP
  60. C                    VERSION 1 OF RIM AS PART OF THE IPAD PROJECT
  61. C     4/78 TO 9/78 - WAYNE AND DENNIS MAKE FURTHER ENHANCEMENTS TO
  62. C                    MAKE VERSION 2 WHILE AT IPAD
  63. C     6/79 TO 9/79 - WAYNE MAKES VERSION 3 OF RIM AT THE UNIVERSITY
  64. C                    OF WASHINGTON. THIS VERSION USED THE CDC
  65. C                    SEGMENTED LOADER AND THE FASTIO PACKAGE.
  66. C     9/79 TO 5/80 - WAYNE MAKES VERSION 4 OF RIM FOR THE UNIVERSITY
  67. C                    OF WASHINGTON AND BOEING/NASA. THIS VERSION COULD
  68. C                    HANDLE RELATIONS OF ANY LENGTH AND HAD KEY ELEMENTS
  69. C     5/80 TO 1/81 - FRED GRAY EXTENDS VERSION 4 AT BOEING TO INCLUDE
  70. C                    AN ENHANCED COMMAND LANGUAGE AND A MENU MODE OF
  71. C                    EXECUTION.
  72. C     9/80 TO 1/81 - WAYNE DEVELOPES A VAX VERSION OF RIM BASED ON THE
  73. C                    CDC VERSION.
  74. C     2/81 TO 9/81 - WAYNE TOGETHER WITH JEFF VON LIMBACH AND FRED GRAY
  75. C                    OF BOEING DEVELOP THE RIM PORTABLE VERSION (RIM-5).
  76. C
  77. C  ****************************************************************
  78. C
  79. C  RIM IS SUBJECT TO THE RESTRICTIONS AND DISCLAIMERS LISTED BELOW.
  80. C
  81. C  RESTRICTIONS AND DISCLAIMERS
  82. C
  83. C  THIS SOFTWARE IS PROVIDED BY THE BOEING COMPANY UNDER NASA CONTRACT
  84. C  NAS1-14700 (IPAD).  BOEING DEVELOPED AND/OR DISTRIBUTED IPAD SOFTWARE
  85. C  AND DOCUMENTATION MAY BE USED BY AUTHORIZED RECIPIENTS SUBJECT TO THE
  86. C  FOLLOWING LEGENDS.
  87. C
  88. C   BECAUSE OF ITS POSSIBLE COMMERCIAL VALUE, THIS DATA DEVELOPED
  89. C   UNDER U.S. GOVERNMENT CONTRACT NAS1-14700 IS BEING DISSEMINATED
  90. C   WITHIN THE U.S. IN ADVANCE OF GENERAL PUBLICATION.  THIS DATA MAY
  91. C   BE DUPLICATED AND USED BY THE RECIPIENT WITH THE EXPRESSED LIMIT-
  92. C   ATIONS THAT THE DATA WILL NOT BE PUBLISHED NOR WILL IT BE RELEASED
  93. C   TO FOREIGN PARTIES WITHOUT PRIOR PERMISSION OF THE BOEING COMPANY.
  94. C   RELEASE OF THIS DATA TO OTHER DOMESTIC PARTIES BY THE RECIPIENT
  95. C   SHALL ONLY BE MADE SUBJECT TO THESE LIMITATIONS.  THE LIMITATIONS
  96. C   CONTAINED IN THIS LEGEND WILL BE CONSIDERED VOID AFTER OCT. 15,
  97. C   1985.  THIS LEGEND SHALL BE MARKED ON ANY REPRODUCTION OF THIS
  98. C   DATA IN WHOLE OR IN PART.
  99. C
  100. C   BY ACCEPTANCE OF AND IN CONSIDERATION OF THE RECEIPT OF THE DOCU-
  101. C   MENT, DATA, OR SOFTWARE, PRODUCED BY THE BOEING COMPANY (BOEING)
  102. C   UNDER NATIONAL AERONAUTICS AND SPACE ADMINISTRATION (NASA) DEVEL-
  103. C   OPMENT CONTRACT NO. NAS1-14700 (IPAD), THE THIRD PARTY RECIPIENT,
  104. C   ITS SUCCESSORS AND ASSIGNS AGREE AS FOLLOWS:
  105. C
  106. C      DISTRIBUTION OF THIS SOFTWARE (INCLUDING RELATED DATA AND
  107. C      OTHER DOCUMENTATION) IS MADE BY BOEING ONLY AS AN
  108. C      ACCOMODATION TO NASA. THIS SOFTWARE IS PROVIDED TO ALL
  109. C      RECIPIENTS IN AN "AS IS" CONDITION. IN CONSIDERATION OF
  110. C      RECEIPT OF THIS SOFTWARE, THE REQUESTOR AND ANY SUBSEQUENT
  111. C      RECIPIENT ("RECIPIENT" HEREIN), AND THEIR SUCCESSORS AND
  112. C      ASSIGNS, AGREE AS FOLLOWS:  THE BOEING COMPANY MAKES NO
  113. C      WARRANTY WHATSOEVER IN CONNECTION WITH THIS SOFTWARE, AND THE
  114. C      RECIPIENT HEREBY WAIVES, RELEASES AND RENOUNCES ALL
  115. C      WARRANTIES,GUARANTEES, OBLIGATIONS, LIABILITIES, RIGHTS AND
  116. C      REMEDIES, EXPRESS OR IMPLIED, ARISING BY LAW, CONTRACT OR
  117. C      OTHERWISE WITH RESPECT TO SUCH SOFTWARE. THE RECIPIENT SHALL
  118. C      INCLUDE VERBATIM THE ENTIRE CONTENTS OF THIS DISCLAIMER,
  119. C      INCLUDING THIS SENTENCE, WITH ANY AND ALL COPIES OF THIS
  120. C      SOFTWARE WHICH IS PROVIDED TO ANY OTHER RECIPIENT.
  121. C
  122. C  ****************************************************************
  123. C
  124. C  PURPOSE: THIS PROGRAM CONTROLS THE TWO MAIN BRANCHES OF THE
  125. C           RIM SYSTEM -- MENU AND COMMAND. IF THE USER
  126. C           SELECTS THE MENU MODE, CONTROL IS PASSED TO THE
  127. C           SUBROUTINE INTCON, IF THE COMMAND MODE IS SELECTED CONTROL
  128. C           IS PASSED TO THE SUBROUTINE RIM. UPON AN "EXIT" THE
  129. C           RETURNING AND/OR REPLACING OF THE DATABASE FILES IS
  130. C           HANDLED BY MACHINE DEPENDENT ROUTINES, IE CDCPUT.
  131. C
  132.       INCLUDE rin:CONST4.BLK
  133.       INCLUDE rin:CONST8.BLK
  134.       INCLUDE rin:RMKEYW.BLK
  135.       INCLUDE rin:CDCDBS.BLK
  136.       INCLUDE rin:FLAGS.BLK
  137.       INCLUDE rin:FILES.BLK
  138.       INCLUDE rin:SELCOM.BLK
  139.       INCLUDE rin:DCLAR6.BLK
  140.       LOGICAL TTY
  141.       INTEGER VER
  142.       INTEGER UDXX
  143.       INTEGER MACH(2)
  144. C allow to pass into and out of RIM with only ONE initialization
  145. C call.
  146.     save inited
  147.     integer inited
  148.     data inited/0/
  149.       DATA VER /3H5.1/
  150.       DATA UDXX /4HUD23/
  151.       DATA MACH(1),MACH(2) /4H-Ana,4Hly--/
  152.     if(inited.ne.0)goto 3521
  153. C
  154. CBCS **** START
  155. C
  156. C  INITIALIZE - BATCH SHOULD BE FALSE ON OTHER MACHINES
  157. C
  158.       NUMOPN = 0
  159.       BATCH = .FALSE.
  160.       K = 0
  161.       IF(.NOT.TTY(K)) BATCH = .TRUE.
  162. C
  163. CBCS **** END
  164. C
  165. C  OPEN THE INPUT AND OUTPUT FILES AND INITIALIZE
  166. C
  167.       NINT = 5
  168.       NOUT = 6
  169.       NOUTR = 6
  170.       CALL LXCONS
  171.       CALL RMSTRT
  172.       CALL SETIN(K8IN)
  173.       CALL SETOUT(K8OUT)
  174.       ULPP = 0
  175.       UMCPL = 0
  176.       INTOPT = 0
  177.       NEXTOP = K8BEGI
  178.       ECHO = .FALSE.
  179.       CALL LXSET(KWECHO,K4OFF)
  180.       IF(.NOT.BATCH) GO TO 50
  181.       ECHO = .TRUE.
  182.       CALL LXSET(KWECHO,K4ON)
  183.    50 CONTINUE
  184. C
  185. C  GET THE DATE AND TIME
  186. C
  187.       CALL RMDATE(IDAY)
  188.       CALL RMTIME(ITIME)
  189. C
  190. C  SET THE PROMPT CHARACTER - CDC ONLY
  191. C
  192. CBCS **** START
  193. C
  194.       CALL LXSET(K4PROM,K4RP)
  195. C
  196. CBCS **** END
  197. C
  198. C  SET THE VERSION AND UPDATE IDENTIFIER
  199. C
  200. C
  201. C  PRINT THE RIM EXECUTION HEADER
  202. C
  203.     if (nout.eq.6)goto 3140
  204.       WRITE(NOUT,100) MACH(1),MACH(2),VER,UDXX,IDAY,ITIME
  205.   100 FORMAT(1X,11HBegin RIM -,2A4,8H Version,1X,A3,
  206.      X       3X,A4,10X,A8,4X,A8)
  207.     WRITE(NOUT,7200)
  208. 7200    FORMAT(' Updated 3/1986. }command spawns command.')
  209.     goto 3141
  210. 3140    continue
  211.       WRITE(c128wk,100) MACH(1),MACH(2),VER,UDXX,IDAY,ITIME
  212.       call atxto
  213. 3141    continue
  214.     inited=1
  215.     goto 3522
  216. 3521    continue
  217.     nextop=K8RIM
  218. 3522    continue
  219. C
  220. C  EXECUTION OPTION IS COMMAND BY DEFAULT - PRINT MESSAGE
  221. C
  222.       IF(BATCH) GO TO 500
  223.       IF(.NOT.CONNI) GO TO 500
  224.     if(nout.eq.6)goto 3142
  225.       WRITE(NOUT,200)
  226.   200 FORMAT(1X,16HRIM Command mode,
  227.      X         1X,26HEnter "MENU" for MENU mode)
  228.       GO TO 500
  229. 3142    continue
  230.     write(c128wk,200)
  231.     call atxto
  232.     goto 500
  233. C
  234. C  ****************************************************************
  235. C
  236. C             I N T E R A C T I V E      S E C T I O N
  237. C
  238. C  ****************************************************************
  239. C
  240. 350   CONTINUE
  241.     if(nout.eq.6)goto 3143
  242.     WRITE(NOUT,360)
  243.     goto 400
  244. 3143    continue
  245.     write(c128wk,360)
  246.     call atxto
  247.   360 FORMAT(1X,13HRIM menu mode)
  248.   400 CONTINUE
  249.       INTOPT = 0
  250.   410 CONTINUE
  251.       CALL INTCON(INTOPT)
  252.       IF(INTOPT.EQ.K4EXIT) GO TO 900
  253.       IF(INTOPT.EQ.K4QUIT) GO TO 850
  254.       IF(INTOPT.EQ.K4COM) GO TO 600
  255.       IF(INTOPT.EQ.K4QUE) GO TO 600
  256.       IF(INTOPT.EQ.K4LOD) GO TO 800
  257.       IF((INTOPT.NE.K4CRE).AND.(INTOPT.NE.K4UPD)) GO TO 400
  258. C
  259. C  SET THE INPUT FILE TO SCHEMA AND READ THE FIRST RECORD
  260. C
  261.       CALL SETIN(K8SCH)
  262.       LENREC = 0
  263.       CALL LXLREC(DUM,LENREC,DUM)
  264. C
  265. C  COMPILE THE SCHEMA AND SET INPUT BACK TO "INPUT"
  266. C
  267.       CALL CSC
  268.       CALL SETIN(K8IN)
  269.       GO TO 410
  270. C
  271. C  ****************************************************************
  272. C
  273. C                  D I R E C T      S E C T I O N
  274. C
  275. C  ****************************************************************
  276. C
  277.   500 CONTINUE
  278.       IF(NEXTOP.EQ.K8BEGI) GO TO 600
  279.       IF(NEXTOP.EQ.K8RIM  ) GO TO 600
  280.       IF(NEXTOP.EQ.K8DEFI) GO TO 700
  281.       IF(NEXTOP.EQ.K8LOAD) GO TO 800
  282.       IF(NEXTOP.EQ.K8MENU) GO TO 350
  283.       IF(NEXTOP.EQ.KWRETU) return
  284. C
  285. C  BRANCH TO STATEMENT 400 IF RIM WAS CALLED FROM THE
  286. C  MENU MODE
  287. C
  288.       IF(INTOPT.EQ.K4QUE) GO TO 400
  289.       IF(NEXTOP.EQ.K8EXIT  ) GO TO 900
  290. C
  291. C  CALL RIM FOR QUERY FUNCTIONS
  292. C
  293.   600 CONTINUE
  294.       CALL RIM
  295.       GO TO 500
  296. C
  297. C  CALL CSC TO DEFINE THE SCHEMA
  298. C
  299.   700 CONTINUE
  300.       CALL CSC
  301.       NEXTOP = K8RIM
  302.       GO TO 500
  303. C
  304. C  CALL DBLOAD TO LOAD THE DATABASE
  305. C
  306.   800 CONTINUE
  307.       CALL DBLOAD
  308.       NEXTOP = K8RIM
  309.       IF(INTOPT.EQ.K4LOD) GO TO 410
  310.       GO TO 500
  311. C
  312. C  ****************************************************************
  313. C
  314. C                       E X I T     S E C T I O N
  315. C
  316. C  ****************************************************************
  317. C
  318. C  DROP THE DATABASE FILES - QUIT
  319. C
  320.   850 CONTINUE
  321.       GO TO 9999
  322.   900 CONTINUE
  323.       IF(BATCH) GO TO 999
  324.       IF(.NOT.CONNI) GO TO 999
  325.       IF(.NOT.CONNO) CALL SETOUT(K8OUT)
  326.       CALL RMDBPT(NAMDB,DBSTAT)
  327. C
  328. C  PRINT THE CLOSING MESSAGE AND EXIT
  329. C
  330.   999 CONTINUE
  331.       CALL RMDATE(IDAY)
  332.       CALL RMTIME(ITIME)
  333. c      WRITE(NOUT,7001) IDAY,ITIME
  334. c 7001 FORMAT(1X,17HEnd RIM execution,25X,A8,4X,A8)
  335. C
  336. C  ERROR MESSAGES -------------------------------------------------
  337. C
  338.  8001 FORMAT(1X,41H-ERROR- Either "1" or "2" must be entered)
  339. C
  340.  9999 CONTINUE
  341.     Return
  342.       END
  343.       SUBROUTINE ADDDAT(INDEX,ID,ARRAY,LENGTH)
  344.       INCLUDE rin:TEXT.BLK
  345. C
  346. C  PURPOSE:   ADD A TUPLE TO THE DATA FILE
  347. C
  348. C  PARAMETERS:
  349. C         INDEX---BLOCK REFERENCE NUMBER
  350. C         ID------PACKED ID WORD WITH OFFSET,IOBN
  351. C         ARRAY---ARRAY TO RECEIVE THE TUPLE
  352. C         LENGTH--LENGTH OF THE TUPLE
  353.       INCLUDE rin:F2COM.BLK
  354.       INCLUDE rin:RIMCOM.BLK
  355.       INCLUDE rin:BUFFER.BLK
  356.       INCLUDE rin:FLAGS.BLK
  357. C
  358.       INTEGER OFFSET
  359.       INTEGER ARRAY(*)
  360. C
  361. C  UNPAC THE ID WORD.
  362. C
  363.       CALL ITOH(OFFSET,IOBN,ID)
  364. C
  365. C  CALCULATE THE NEW ID VALUE.
  366. C
  367.       IF(LF2WRD + LENGTH + 1 .LE. LENBF2) GO TO 100
  368.       LF2REC = LF2REC + 1
  369.       LF2WRD = 1
  370.   100 CONTINUE
  371.       CALL HTOI(LF2WRD,LF2REC,ID)
  372.       IF(IOBN.EQ.0) GO TO 500
  373. C
  374. C  SEE IF THE NEEDED BLOCK IS CURRENTLY IN CORE.
  375. C
  376.       NUMBLK = 0
  377.       DO 200 I=1,3
  378.       IF(IOBN.EQ.CURBLK(I)) NUMBLK = I
  379.   200 CONTINUE
  380.       IF(NUMBLK.NE.0) GO TO 400
  381.       NUMBLK = INDEX
  382. C
  383. C  WE MUST DO PAGING.
  384. C
  385. C  SEE IF THE CURRENT BLOCK NEEDS WRITING.
  386. C
  387.       IF(MODFLG(NUMBLK).EQ.0) GO TO 300
  388. C
  389. C  WRITE OUT THE CURRENT BLOCK.
  390. C
  391.       KQ1 = BLKLOC(NUMBLK)
  392.       CALL RIOOUT(FILE2,CURBLK(NUMBLK),BUFFER(KQ1),LENBF2,IOS)
  393.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  394.   300 CONTINUE
  395. C
  396. C  READ IN THE NEEDED BLOCK.
  397. C
  398.       CALL BLKCHG(NUMBLK,LENBF2,1)
  399.       KQ1 = BLKLOC(NUMBLK)
  400.       CALL RIOIN(FILE2,IOBN,BUFFER(KQ1),LENBF2,IOS)
  401.       CURBLK(NUMBLK) = IOBN
  402.       IF(IOS.EQ.0) GO TO 400
  403. C
  404. C  WRITE OUT THE RECORD FOR THE FIRST TIME.
  405. C
  406.       CALL RIOOUT(FILE2,IOBN,BUFFER(KQ1),LENBF2,IOS)
  407.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  408.   400 CONTINUE
  409.       MODFLG(NUMBLK) = 1
  410.       IFMOD = .TRUE.
  411. C
  412. C  FIX UP THE ID POINTER SO IT POINTS TO THE NEXT TUPLE.
  413. C
  414.       KQ0 = BLKLOC(NUMBLK) - 1
  415.       ISIGN = 1
  416.       IF(BUFFER(KQ0 + OFFSET).LT.0) ISIGN = -1
  417.       BUFFER(KQ0 + OFFSET) = ISIGN * ID
  418.       MODFLG(NUMBLK) = 1
  419.       IFMOD = .TRUE.
  420. C
  421. C  NOW MOVE THE NEW TUPLE.
  422. C
  423.   500 CONTINUE
  424.       CALL ITOH(OFFSET,IOBN,ID)
  425. C
  426. C  SEE IF THE NEEDED BLOCK IS CURRENTLY IN CORE.
  427. C
  428.       NUMBLK = 0
  429.       DO 600 I=1,3
  430.       IF(IOBN.EQ.CURBLK(I)) NUMBLK = I
  431.   600 CONTINUE
  432.       IF(NUMBLK.NE.0) GO TO 800
  433.       NUMBLK = INDEX
  434. C
  435. C  WE MUST DO PAGING.
  436. C
  437. C  SEE IF THE CURRENT BLOCK NEEDS WRITING.
  438. C
  439.       IF(MODFLG(NUMBLK).EQ.0) GO TO 700
  440. C
  441. C  WRITE OUT THE CURRENT BLOCK.
  442. C
  443.       KQ1 = BLKLOC(NUMBLK)
  444.       CALL RIOOUT(FILE2,CURBLK(NUMBLK),BUFFER(KQ1),LENBF2,IOS)
  445.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  446.   700 CONTINUE
  447. C
  448. C  READ IN THE NEEDED BLOCK.
  449. C
  450.       CALL BLKCHG(NUMBLK,LENBF2,1)
  451.       KQ1 = BLKLOC(NUMBLK)
  452.       CURBLK(NUMBLK) = IOBN
  453.       IF(LF2WRD.EQ.1) GO TO 750
  454.       CALL RIOIN(FILE2,IOBN,BUFFER(KQ1),LENBF2,IOS)
  455.       IF(IOS.EQ.0) GO TO 800
  456. C
  457. C  WRITE OUT THE RECORD FOR THE FIRST TIME.
  458. C
  459.   750 CONTINUE
  460.       CALL RIOOUT(FILE2,IOBN,BUFFER(KQ1),LENBF2,IOS)
  461.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  462.   800 CONTINUE
  463.       MODFLG(NUMBLK) = 1
  464.       IFMOD = .TRUE.
  465. C
  466. C  MOVE THE TUPLE TO THE PAGE.
  467. C
  468.       KQ0 = BLKLOC(NUMBLK) - 1
  469.       BUFFER(KQ0 + OFFSET) = 0
  470.       BUFFER(KQ0 + OFFSET + 1) = LENGTH
  471.       CALL BLKMOV(BUFFER(KQ0 + OFFSET + 2),ARRAY(1),LENGTH)
  472.       LF2WRD = LF2WRD + LENGTH + 2
  473. C
  474. C  ALL DONE.
  475. C
  476.       RETURN
  477.       END
  478.       SUBROUTINE ATTADD
  479.       INCLUDE rin:TEXT.BLK
  480. C
  481. C  PURPOSE:   ADD A NEW TUPLE TO THE ATTRIBUTE RELATION
  482. C
  483.       INCLUDE rin:TUPLEA.BLK
  484.       INCLUDE rin:ATTBLE.BLK
  485.       INCLUDE rin:F1COM.BLK
  486.       INCLUDE rin:FLAGS.BLK
  487. C
  488. C  GET THE PAGE FOR ADDING NEW TUPLES.
  489. C
  490.       MRSTRT = NAROW
  491.       CALL ATTPAG(MRSTRT)
  492.       I = MRSTRT
  493.       NAROW = NAROW + 1
  494.       IF(I.EQ.APBUF) NAROW = (APBUF * LF1REC) + 1
  495. C
  496. C  MOVE THE DATA FROM THE TUPLE TO THE BUFFER.
  497. C
  498.       ATTBLE(1,I) = NAROW
  499.       CALL BLKMOV(ATTBLE(2,I),ATTNAM,2)
  500.       CALL BLKMOV(ATTBLE(4,I),RELNAM,2)
  501.       ATTBLE(6,I) = ATTCOL
  502.       ATTBLE(7,I) = ATTLEN
  503.       ATTBLE(8,I) = ATTYPE
  504.       ATTBLE(9,I) = ATTKEY
  505.       ATTMOD = 1
  506.       IFMOD = .TRUE.
  507.       CROW = 0
  508.       LROW = 0
  509.       IF(I.LT.APBUF) RETURN
  510. C
  511. C  WE JUST FILLED A BUFFER. MAKE SURE ATTBLE GETS THE NEXT ONE.
  512. C
  513.       ATTBUF(1) = NAROW
  514.       MRSTRT = NAROW
  515.       CALL ATTPAG(MRSTRT)
  516.       RETURN
  517.       END
  518.       SUBROUTINE ATTDEL(STATUS)
  519.       INCLUDE rin:TEXT.BLK
  520. C
  521. C  PURPOSE:   DELETE THE CURRENT TUPLE FROM THE ATTRIBUTE RELATION
  522. C             BASED ON CONDITIONS SET UP IN LOCATT AND ATTGET
  523. C
  524. C  PARAMETERS:
  525. C         STATUS--STATUS VARIABLE - 0 MEANS OK, 1 MEANS NO WAY
  526.       INCLUDE rin:RMATTS.BLK
  527.       INCLUDE rin:ATTBLE.BLK
  528.       INCLUDE rin:START.BLK
  529.       INTEGER STATUS
  530. C
  531.       STATUS = 0
  532.       IF(LROW.EQ.0) GO TO 9000
  533. C
  534. C  CHANGE THE TUPLE STATUS FLAG TO DELETED.
  535. C
  536.       ATTBLE(1,LROW) = -ATTBLE(1,LROW)
  537.       ATTMOD = 1
  538.       GO TO 9999
  539. C
  540. C  UNABLE TO FIND WHAT WE ARE LOOKING FOR.
  541. C
  542.  9000 CONTINUE
  543.       STATUS = 1
  544.  9999 CONTINUE
  545.       RETURN
  546.       END
  547.       SUBROUTINE ATTGET(STATUS)
  548.       INCLUDE rin:TEXT.BLK
  549. C
  550. C  PURPOSE:   RETRIEVE THE NEXT TUPLE FROM THE ATTRIBUTE RELATION
  551. C             BASED ON CONDITIONS SET UP IN LOCATT
  552. C
  553. C  PARAMETERS:
  554. C         STATUS--STATUS VARIABLE - 0 MEANS OK, 1 MEANS NO WAY
  555.       INCLUDE rin:TUPLEA.BLK
  556.       INCLUDE rin:ATTBLE.BLK
  557.       INCLUDE rin:MISC.BLK
  558.       INTEGER STATUS
  559.       LOGICAL EQ
  560.       LOGICAL NE
  561. C
  562.       STATUS = 0
  563.       IF(CROW.EQ.0) GO TO 9000
  564. C
  565. C  SEE WHAT THE CALLER WANTS.
  566. C
  567.       IF(EQ(CRNAME,BLANK)) GO TO 1000
  568. C
  569. C  CRNAME IS SPECIFIED.
  570. C
  571.       I = CROW
  572.       GO TO 200
  573.   100 CONTINUE
  574.       CALL ATTPAG(MRSTRT)
  575. C
  576. C  LOOK FOR THE ATTRIBUTE IN THIS RELATION.
  577. C
  578.       I = MRSTRT
  579.   200 CONTINUE
  580.       IF(I.GT.APBUF) GO TO 300
  581.       IF(NE(ATTBLE(4,I),CRNAME)) GO TO 9000
  582.       IF(EQ(CANAME,BLANK)) GO TO 2000
  583.       IF(EQ(ATTBLE(2,I),CANAME)) GO TO 2000
  584.       I = I + 1
  585.       GO TO 200
  586. C
  587. C  GET THE NEXT PAGE.
  588. C
  589.   300 CONTINUE
  590.       MRSTRT = ATTBUF(1)
  591.       IF(MRSTRT.EQ.0) GO TO 9000
  592.       GO TO 100
  593. C
  594. C  SCAN FOR ATTRIBUTE WITHOUT RELATION SPECIFIED.
  595. C
  596.  1000 CONTINUE
  597.       I = CROW
  598.       GO TO 1200
  599.  1100 CONTINUE
  600.       CALL ATTPAG(MRSTRT)
  601.       I = MRSTRT
  602.  1200 CONTINUE
  603.       IF(I.GT.APBUF) GO TO 1400
  604.       IF(ATTBLE(1,I).LT.0) GO TO 1300
  605.       IF(EQ(ATTBLE(2,I),CANAME)) GO TO 2000
  606.  1300 CONTINUE
  607.       I = I + 1
  608.       GO TO 1200
  609. C
  610. C  GET THE NEXT PAGE.
  611. C
  612.  1400 CONTINUE
  613.       MRSTRT = ATTBUF(1)
  614.       IF(MRSTRT.EQ.0) GO TO 9000
  615.       GO TO 1100
  616. C
  617. C  MOVE THE STUFF FROM ROW CROW.
  618. C
  619.  2000 CONTINUE
  620.       CROW = I
  621.       CALL BLKMOV(ATTNAM,ATTBLE(2,CROW),2)
  622.       CALL BLKMOV(RELNAM,ATTBLE(4,CROW),2)
  623.       ATTCOL = ATTBLE(6,CROW)
  624.       ATTLEN = ATTBLE(7,CROW)
  625.       ATTYPE = ATTBLE(8,CROW)
  626.       ATTKEY = ATTBLE(9,CROW)
  627. C
  628. C  UNPAC THE LENGTH DATA
  629. C
  630.       CALL ITOH(ATTCHA,ATTWDS,ATTLEN)
  631.       LROW = CROW
  632.       CROW = CROW + 1
  633.       GO TO 9999
  634. C
  635. C  UNABLE TO FIND WHAT WE ARE LOOKING FOR.
  636. C
  637.  9000 CONTINUE
  638.       STATUS = 1
  639.       CROW = 0
  640.       LROW = 0
  641.  9999 CONTINUE
  642.       RETURN
  643.       END
  644.       SUBROUTINE ATTNEW(RNAME,NATT)
  645.       INCLUDE rin:TEXT.BLK
  646. C
  647. C  PURPOSE:   ADD A NEW RELATION TO THE ATTRIBUTE RELATION
  648. C
  649. C  PARAMETERS:
  650. C         RNAME---NAME OF A RELATION
  651. C         NATT----NUMBER OF ATTRIBUTES IN THE RELATION
  652.       INCLUDE rin:RMATTS.BLK
  653.       INCLUDE rin:ATTBLE.BLK
  654.       INCLUDE rin:F1COM.BLK
  655.       INCLUDE rin:START.BLK
  656.       INCLUDE rin:DCLAR1.BLK
  657. C
  658. C  ADJUST NAROW IF ALL ATTRIBUTES WILL NOT FIT ON THE PAGE.
  659. C
  660.       MRSTRT = NAROW
  661.       CALL ATTPAG(MRSTRT)
  662.       I = MRSTRT
  663.       IF((I + NATT).LE.APBUF) GO TO 100
  664.       NAROW = (APBUF * LF1REC) + 1
  665.       ATTBUF(1) = NAROW
  666.       ATTMOD = 1
  667.   100 CONTINUE
  668.       IF(START.NE.KSFRIA) KSFRIA = START
  669.       RETURN
  670.       END
  671.       SUBROUTINE ATTPAG(THEROW)
  672.       INCLUDE rin:TEXT.BLK
  673. C
  674. C  PURPOSE:   DO PAGING AS NEEDED FOR THE ATTRIBUTE RELATION
  675. C
  676. C  PARAMETERS:
  677. C         THEROW--INPUT - ROW WANTED
  678. C                 OUTPUT - ACTUAL ROW TO USE IN THE BUFFER
  679.       INCLUDE rin:ATTBLE.BLK
  680.       INCLUDE rin:RIMCOM.BLK
  681.       INCLUDE rin:F1COM.BLK
  682.       INTEGER THEROW
  683. C
  684. C  TURN THE REQUESTED ROW INTO A RECORD AND OFFSET.
  685. C
  686.       NNREC = ((THEROW - 1) / APBUF) + 1
  687.       NNROW = THEROW - ((NNREC - 1) * APBUF)
  688. C
  689. C  SEE IF WE ALREADY HAVE THIS RECORD IN THE BUFFER.
  690. C
  691.       IF(NNREC.EQ.CAREC) GO TO 300
  692. C
  693. C  WE MUST DO PAGING.
  694. C
  695. C  SEE IF THE CURRENT RECORD IN THE BUFFER HAS BEEN MODIFIED.
  696. C
  697.       IF(ATTMOD.EQ.0) GO TO 100
  698. C
  699. C  WRITE OUT THE CURRENT RECORD.
  700. C
  701.       CALL RIOOUT(FILE1,CAREC,ATTBUF,LENBF1,IOS)
  702.       IF(IOS.NE.0) RMSTAT = 2100 + IOS
  703. C
  704. C  READ IN THE NEEDED RECORD.
  705. C
  706.   100 CONTINUE
  707.       ATTMOD = 0
  708.       IF(NNREC.GT.LF1REC) GO TO 150
  709.       CALL RIOIN(FILE1,NNREC,ATTBUF,LENBF1,IOS)
  710.       IF(IOS.EQ.0) GO TO 200
  711. C
  712. C  THERE WAS NO DATA ON THE FILE - WRITE SOME.
  713. C
  714.   150 CONTINUE
  715.       CALL ZEROIT(ATTBUF,LENBF1)
  716.       CALL RIOOUT(FILE1,NNREC,ATTBUF,LENBF1,IOS)
  717.       IF(IOS.NE.0) RMSTAT = 2100 + IOS
  718.       LF1REC = LF1REC + 1
  719.   200 CONTINUE
  720.       CAREC = NNREC
  721. C
  722. C  SET THE POINTER TO THE ACTUAL ROW IN THE BUFFER.
  723. C
  724.   300 CONTINUE
  725.       THEROW = NNROW
  726.       RETURN
  727.       END
  728.       SUBROUTINE ATTPUT(STATUS)
  729.       INCLUDE rin:TEXT.BLK
  730. C
  731. C  PURPOSE:   REPLACE THE CURRENT TUPLE FROM THE ATTRIBUTE RELATION
  732. C             BASED ON CONDITIONS SET UP IN LOCATT AND ATTGET
  733. C
  734. C  PARAMETERS:
  735. C         STATUS--STATUS VARIABLE - 0 MEANS OK, 1 MEANS NO WAY
  736.       INCLUDE rin:FLAGS.BLK
  737.       INCLUDE rin:TUPLEA.BLK
  738.       INCLUDE rin:ATTBLE.BLK
  739.       INTEGER STATUS
  740. C
  741.       STATUS = 0
  742.       IF(LROW.EQ.0) GO TO 9000
  743. C
  744. C  MOVE THE STUFF TO ROW LROW.
  745. C
  746.       CALL BLKMOV(ATTBLE(2,LROW),ATTNAM,2)
  747.       CALL BLKMOV(ATTBLE(4,LROW),RELNAM,2)
  748.       ATTBLE(6,LROW) = ATTCOL
  749.       ATTBLE(7,LROW) = ATTLEN
  750.       ATTBLE(8,LROW) = ATTYPE
  751.       ATTBLE(9,LROW) = ATTKEY
  752.       ATTMOD = 1
  753.       IFMOD = .TRUE.
  754.       GO TO 9999
  755. C
  756. C  UNABLE TO FIND WHAT WE ARE LOOKING FOR.
  757. C
  758.  9000 CONTINUE
  759.       STATUS = 1
  760.  9999 CONTINUE
  761.       RETURN
  762.       END
  763.       SUBROUTINE BLKCHG(IND,NROWS,NCOLS)
  764.       INCLUDE rin:TEXT.BLK
  765. C
  766. C  PURPOSE:    CHANGE THE DIMENSIONS OF AN EXISTING BLOCK
  767. C
  768. C  PARAMETERS
  769. C     INPUT:   IND-----BLOCK INDEX
  770. C              NROWS---NUMBER OF ROWS
  771. C              NCOLS---NUMBER OF COLUMNS
  772.       INCLUDE rin:INCORE.BLK
  773.       INCLUDE rin:RIMCOM.BLK
  774.       INCLUDE rin:BUFFER.BLK
  775. C
  776. C  SEE IF THE BLOCK HAS EXISTING DATA.
  777. C
  778.       IF(BLOCKS(1,IND).NE.0) GO TO 100
  779. C
  780. C  USE BLKDEF SINCE THIS IS A NEW BLOCK.
  781. C
  782.       CALL BLKDEF(IND,NCOLS,NROWS)
  783.       RETURN
  784. C
  785. C  EXTRACT THE EXISTING DIMENSIONS.
  786. C
  787.   100 CONTINUE
  788.       KNR = BLOCKS(2,IND)
  789.       KNC = BLOCKS(3,IND)
  790.       NWOLD = KNR * KNC
  791.       KS = BLOCKS(1,IND)
  792. C
  793. C  SEE IF WE EXPAND OR CONTRACT.
  794. C
  795.       NWNEW = NROWS * NCOLS
  796.       IF(NWNEW.EQ.NWOLD) RETURN
  797.       NWADD = NWNEW - NWOLD
  798.       IF(NEXT + NWADD .GT. LIMIT) GO TO 7500
  799. C
  800. C  MAKE ROOM IN THE BUFFER.
  801. C
  802.       MOVE = NEXT - (KS+NWOLD)
  803.       IF(NWADD.GT.0) MOVE = -MOVE
  804.       IF(KS + NWOLD .LT. NEXT)
  805.      X CALL BLKMOV(BUFFER(KS+NWNEW),BUFFER(KS+NWOLD),MOVE)
  806.       IF(NWADD.GT.0) CALL ZEROIT(BUFFER(KS+NWOLD),NWADD)
  807. C
  808. C  UPDATE THE INCORE INDEX.
  809. C
  810.       BLOCKS(1,IND) = KS
  811.       BLOCKS(2,IND) = NROWS
  812.       BLOCKS(3,IND) = NCOLS
  813.       DO 200 I=1,NUMBL
  814.       IF(BLOCKS(1,I).EQ.0) GO TO 200
  815.       ITEST = BLOCKS(1,I)
  816.       IF(ITEST.LE.KS) GO TO 200
  817.       BLOCKS(1,I) = BLOCKS(1,I) + NWADD
  818.   200 CONTINUE
  819.       NEXT = NEXT + NWADD
  820.       RETURN
  821. C
  822. C  NOT ENOUGH ROOM.
  823. C
  824.  7500 CONTINUE
  825.       RMSTAT = 1001
  826.       RETURN
  827.       END
  828.       SUBROUTINE BLKCLN
  829.       INCLUDE rin:TEXT.BLK
  830. C
  831. C  PURPOSE: CLEAN OUT THE ENTIRE BUFFER AREA
  832. C
  833. C  PARAMETERS -- NONE
  834. C
  835.       INCLUDE rin:INCORE.BLK
  836.       INCLUDE rin:F2COM.BLK
  837.       INCLUDE rin:BUFFER.BLK
  838.       INCLUDE rin:RIMCOM.BLK
  839. C
  840. C  WRITE OUT ANY PAGES THAT HAVE BEEN MODIFIED
  841. C
  842.       DO 100 I=1,3
  843.       IF(MODFLG(I).EQ.0) GO TO 90
  844.       KQ1 = BLKLOC(I)
  845.       CALL RIOOUT(FILE2,CURBLK(I),BUFFER(KQ1),LENBF2,IOS)
  846.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  847.       MODFLG(I) = 0
  848.    90 CONTINUE
  849.       CURBLK(I) = 0
  850.   100 CONTINUE
  851. C
  852. C  ZERO OUT BLOCKS AND BUFFER
  853. C
  854.       CALL ZEROIT(BLOCKS(1,1),60)
  855.       NEXT = 1
  856.       NUMBL = 0
  857.       CALL ZEROIT(BUFFER(1),LIMIT)
  858.       RETURN
  859.       END
  860.       SUBROUTINE BLKCLR(IND)
  861.       INCLUDE rin:TEXT.BLK
  862. C
  863. C  PURPOSE:    CLEAR A BLOCK FROM THE INCORE BUFFER
  864. C
  865. C  PARAMETERS
  866. C     INPUT:   IND-----BLOCK INDEX
  867.       INCLUDE rin:INCORE.BLK
  868.       INCLUDE rin:BUFFER.BLK
  869. C
  870. C  SEE IF ANYTHING IS THERE NOW.
  871. C
  872.       IF(BLOCKS(1,IND).EQ.0) RETURN
  873.       KNR = BLOCKS(2,IND)
  874.       KNC = BLOCKS(3,IND)
  875.       NWOLD = KNR * KNC
  876.       KS = BLOCKS(1,IND)
  877. C
  878. C  ZERO OUT THE SPACE.
  879. C
  880.       CALL ZEROIT(BUFFER(KS),NWOLD)
  881. C
  882. C  COMPRESS THE REMAINING BLOCKS.
  883. C
  884.       MOVE = NEXT - (KS+NWOLD)
  885.       IF(KS+NWOLD.NE.NEXT)
  886.      X CALL BLKMOV(BUFFER(KS),BUFFER(KS + NWOLD),MOVE)
  887. C
  888. C  UPDATE THE INCORE INDEX.
  889. C
  890.       BLOCKS(1,IND) = 0
  891.       DO 100 I=1,NUMBL
  892.       IF(BLOCKS(1,I).EQ.0) GO TO 100
  893.       IF(BLOCKS(1,I).LE.KS) GO TO 100
  894.       BLOCKS(1,I) = BLOCKS(1,I) - NWOLD
  895.   100 CONTINUE
  896.       NEXT = NEXT - NWOLD
  897.       IF(IND.EQ.NUMBL) NUMBL = NUMBL - 1
  898.       RETURN
  899.       END
  900.       SUBROUTINE BLKDEF(IND,NROWS,NCOLS)
  901.       INCLUDE rin:TEXT.BLK
  902. C
  903. C  PURPOSE:    DEFINE A NEW BLOCK FOR THE INCORE BUFFER
  904. C
  905. C  PARAMETERS
  906. C     INPUT:   IND-----BLOCK INDEX
  907. C              NROWS---NUMBER OF ROWS
  908. C              NCOLS---NUMBER OF COLUMNS
  909.       INCLUDE rin:INCORE.BLK
  910.       INCLUDE rin:RIMCOM.BLK
  911.       INCLUDE rin:BUFFER.BLK
  912. C
  913. C  CLEAR ANY EXISTING BLOCK FOR THIS INDEX.
  914. C
  915.       IF(BLOCKS(1,IND).NE.0) CALL BLKCLR(IND)
  916. C
  917. C  SET UP THE NEW BLOCK.
  918. C
  919.       NWNEW = NROWS * NCOLS
  920.       IF(NEXT + NWNEW .GT.LIMIT) GO TO 7500
  921.       CALL ZEROIT(BUFFER(NEXT),NWNEW)
  922. C
  923. C  UPDATE THE INCORE INDEX.
  924. C
  925.       BLOCKS(1,IND) = NEXT
  926.       BLOCKS(2,IND) = NROWS
  927.       BLOCKS(3,IND) = NCOLS
  928.       NEXT = NEXT + NWNEW
  929.       IF(IND.GT.NUMBL) NUMBL = IND
  930.       RETURN
  931. C
  932. C  NOT ENOUGH ROOM.
  933. C
  934.  7500 CONTINUE
  935.       RMSTAT = 1001
  936.       RETURN
  937.       END
  938.       SUBROUTINE BLKEXT(IND,NROWS,NCOLS)
  939.       INCLUDE rin:TEXT.BLK
  940. C
  941. C  PURPOSE:    EXTRACT THE NUMBER OF ROWS AND COLUMNS FOR A BLOCK
  942. C
  943. C  PARAMETERS
  944. C     INPUT:   IND-----BLOCK INDEX
  945. C     OUTPUT:  NROWS---NUMBER OF ROWS
  946. C              NCOLS---NUMBER OF COLUMNS
  947.       INCLUDE rin:INCORE.BLK
  948. C
  949. C  EXTRACT THE DATA FROM BLOCKS.
  950. C
  951.       NROWS = BLOCKS(2,IND)
  952.       NCOLS = BLOCKS(3,IND)
  953.       RETURN
  954.       END
  955.       INTEGER FUNCTION BLKLOC(IND)
  956.       INCLUDE rin:TEXT.BLK
  957. C
  958. C  PURPOSE:    RETURN THE STARTING ADDRESS FOR THE REQUESTED BLOCK
  959. C
  960. C  PARAMETERS
  961. C     INPUT:   IND-----BLOCK INDEX
  962. C     OUTPUT:  BLKLOC--ADDRESS OF 1,1 ENTRY FOR THE BLOCK
  963.       INCLUDE rin:INCORE.BLK
  964.       INCLUDE rin:RIMCOM.BLK
  965.       KS = BLOCKS(1,IND)
  966.       IF(KS.EQ.0) GO TO 7500
  967.       BLKLOC = KS
  968.       RETURN
  969. C
  970. C  UNDEFINED BLOCK.
  971. C
  972.  7500 CONTINUE
  973.       RMSTAT = 1002
  974.       BLKLOC = 0
  975.       RETURN
  976.       END
  977.       SUBROUTINE BLKMOV(TO,FROM,NWORDS)
  978.       INCLUDE rin:TEXT.BLK
  979. C
  980. C  PURPOSE:   MOVE WORDS BETWEEN ARRAYS
  981. C
  982.       INTEGER TO(*),FROM(*)
  983.       IF(NWORDS.LT.0) GO TO 200
  984. C
  985. C  MOVE FROM THE FRONT OF THE ARRAYS.
  986. C
  987.       DO 100 I=1,NWORDS
  988.       TO(I) = FROM(I)
  989.   100 CONTINUE
  990.       RETURN
  991. C
  992. C  MOVE FROM THE REAR OF THE ARRAYS.
  993. C
  994.   200 CONTINUE
  995.       NW = -NWORDS
  996.       DO 300 I=1,NW
  997.       TO(NW+1-I) = FROM(NW+1-I)
  998.   300 CONTINUE
  999.       RETURN
  1000.       END
  1001.       SUBROUTINE BTADD(VALU,IPTR,TYPE)
  1002.       INCLUDE rin:TEXT.BLK
  1003. C
  1004. C  PURPOSE:   ADD NEW VALUES TO A BTREE
  1005. C
  1006. C  PARAMETERS
  1007. C    INPUT:  VALU----KEY VALUE TO PROCESS
  1008. C            IPTR----POINTER TO TUPLE HAVING THIS KEY VALUE
  1009. C            TYPE----TYPE OF VARIABLE BEING ADDED
  1010. C
  1011. C  SUBROUTINES USED
  1012. C         BTGET---PAGING ROUTINE
  1013. C         BTSERT--USED TO INSERT VALUES IN A BTREE
  1014. C         BTPUT---PAGING ROUTINE
  1015. C
  1016.       INCLUDE rin:RMATTS.BLK
  1017.       INCLUDE rin:F3COM.BLK
  1018.       INCLUDE rin:MISC.BLK
  1019.       INCLUDE rin:RIMCOM.BLK
  1020.       INCLUDE rin:BTBUF.BLK
  1021.       INCLUDE rin:START.BLK
  1022.       INCLUDE rin:STACK.BLK
  1023. C
  1024.       INTEGER VAL,VALT,VALU(*)
  1025.       REAL RVAL
  1026.       EQUIVALENCE (RVAL,VAL)
  1027.       INTEGER TYPE
  1028. C
  1029. C  INITIAL START OF THE SCAN.
  1030. C
  1031.       SP = 0
  1032.       KSTART = START
  1033.       VAL = VALU(1)
  1034.       ITYPE = TYPE
  1035.       IF(TYPE.EQ.KZTEXT) ITYPE = KZINT
  1036.       IP = IPTR
  1037.   100 CONTINUE
  1038.       SP = SP + 1
  1039.       STACK(SP) = KSTART
  1040. C
  1041. C  FETCH A NODE.
  1042. C
  1043.       CALL BTGET(KSTART,IN)
  1044.       KEND = IN + (LENBF3/3) - 1
  1045. C
  1046. C  LOOP THROUGH A NODE.
  1047. C
  1048.       DO 300 J=IN,KEND
  1049. C
  1050. C  CHECK FOR END-OF-LIST WORD.
  1051. C
  1052.       IF(VALUE(1,J).EQ.ENDWRD) GO TO 200
  1053. C
  1054. C  IF THE VALUE IS LT VAL THEN KEEP LOOKING.
  1055. C
  1056.       IF((ITYPE.EQ.KZINT).AND.(VALUE(1,J).LT.VAL)) GO TO 300
  1057.       IF((ITYPE.NE.KZINT).AND.(RVALUE(1,J).LT.RVAL)) GO TO 300
  1058. C
  1059. C  FOUND A BIGGER VALUE.
  1060. C
  1061.   200 CONTINUE
  1062. C
  1063. C  GO TO THE NEXT BRANCH IF THERE IS ONE.
  1064. C
  1065.       IF(VALUE(2,J).GE.0) GO TO 400
  1066.       KSTART = -VALUE(2,J)
  1067.       GO TO 100
  1068.   300 CONTINUE
  1069. C
  1070. C  WE DID NOT FIND THE END-OF-LIST WORD. DISASTER.
  1071. C
  1072.       GO TO 1000
  1073. C
  1074. C  ADD IT BETWEEN EXISTING VALUES.
  1075. C
  1076.   400 CONTINUE
  1077. C
  1078. C  CHECK FOR A DUPLICATE VALUE.
  1079. C
  1080.       IF(VALUE(1,J).NE.VAL) GO TO 500
  1081. C
  1082. C  WE HAVE A MULTIPLE VALUE. SEE IF THIS IS THE FIRST DUPLICATE.
  1083. C
  1084.       IF(VALUE(3,J).NE.0) GO TO 420
  1085. C
  1086. C  DO SPECIAL PROCESSING FOR THE FIRST MULTIPLE VALUE.
  1087. C
  1088.       IPTR1 = VALUE(2,J)
  1089.       IF(MOTADD.LT.LENBF3) GO TO 410
  1090.       MOTADD = 0
  1091.       MOTREC = LF3REC
  1092.       CALL BTGET(MOTREC,IN)
  1093.       LF3REC = LF3REC + 1
  1094.   410 CONTINUE
  1095.       CALL HTOI(MOTADD+1,MOTREC,KWORD)
  1096.       VALUE(3,J) = KWORD
  1097.       VALUE(2,J) = KWORD
  1098.       CALL BTPUT(STACK(SP))
  1099. C
  1100. C  ADD THE FIRST LINK TO THE MOT.
  1101. C
  1102.       CALL BTGET(MOTREC,IN)
  1103.       MOTIND = 3 * IN - 3
  1104.       MOTADD = MOTADD + 1
  1105.       MOTIND = MOTIND + MOTADD
  1106.       CORE(MOTIND+1) = IPTR1
  1107.       MOTADD = MOTADD + 1
  1108.       CALL BTPUT(MOTREC)
  1109.   420 CONTINUE
  1110. C
  1111. C  FIX UP THE END POINTER.
  1112. C
  1113.       IF(MOTADD.LT.LENBF3) GO TO 430
  1114.       MOTADD = 0
  1115.       MOTREC = LF3REC
  1116.       CALL BTGET(MOTREC,IN)
  1117.       LF3REC = LF3REC + 1
  1118.   430 CONTINUE
  1119.       CALL ITOH(MOTIND,MOTID,VALUE(2,J))
  1120.       CALL HTOI(MOTADD+1,MOTREC,VALUE(2,J))
  1121.       CALL BTPUT(STACK(SP))
  1122. C
  1123. C  GET THE END OF THE MOT TRAIL.
  1124. C
  1125.       CALL BTGET(MOTID,IN)
  1126.       IN = 3 * IN - 3
  1127.       MOTIND = MOTIND + IN
  1128. C
  1129. C  ADD THE NEXT LINK IN THE MOT.
  1130. C
  1131.       MOTADD = MOTADD + 1
  1132.       CALL HTOI(MOTADD,MOTREC,KWORD)
  1133.       CORE(MOTIND) = KWORD
  1134.       CALL BTPUT(MOTID)
  1135. C
  1136. C  NOW ADD THE POINTER TO THE MOT.
  1137. C
  1138.       CALL BTGET(MOTREC,IN)
  1139.       IN = 3 * IN - 3
  1140.       MOTADD = MOTADD + 1
  1141.       MOTIND = IN + MOTADD
  1142.       CORE(MOTIND) = IPTR
  1143.       CALL BTPUT(MOTREC)
  1144.       RETURN
  1145. C
  1146. C  THIS VALUE IS NOT IN THE BTREE YET.
  1147. C
  1148.   500 CONTINUE
  1149. C
  1150. C  CALL BTSERT TO INSERT THE DATA.
  1151. C
  1152.       VALT = VAL
  1153.       IPT = IP
  1154.   600 CONTINUE
  1155.       CALL BTSERT(VALT,IPT,STACK,SP,J,IN)
  1156.       IF(SP.EQ.0) RETURN
  1157. C
  1158. C  FETCH THE NEXT NODE UP THE STACK.
  1159. C
  1160.       CALL BTGET(STACK(SP),IN)
  1161. C
  1162. C  CALCULATE A NEW VALUE FOR J.
  1163. C
  1164.       KEND = IN + (LENBF3/3) - 1
  1165.       DO 700 J=IN,KEND
  1166.       IF(VALUE(1,J).EQ.ENDWRD) GO TO 600
  1167.       IF((ITYPE.EQ.KZINT).AND.(VALUE(1,J).LT.VAL)) GO TO 700
  1168.       IF((ITYPE.NE.KZINT).AND.(RVALUE(1,J).LT.RVAL)) GO TO 700
  1169. C
  1170. C  WE FOUND A BIGGER VALUE.
  1171. C
  1172.       GO TO 600
  1173.   700 CONTINUE
  1174. C
  1175. C  SOMETHING IS WRONG. WE CANNOT FIND A LARGER VALUE.
  1176. C
  1177.       RMSTAT = 1003
  1178.       RETURN
  1179. C
  1180. C  LOOKUP FOR A VALUE NOT IN THE TREE.
  1181. C
  1182.  1000 CONTINUE
  1183.       RETURN
  1184.       END
  1185.       SUBROUTINE BTGET(ID,NSTRT)
  1186.       INCLUDE rin:TEXT.BLK
  1187. C
  1188. C  PURPOSE:    RETREIVE OR SET UP A BTREE OR MOT NODE.
  1189. C
  1190. C  PARAMETERS
  1191. C     INPUT:   ID------DESIRED RECORD NUMBER
  1192. C     OUTPUT:  NSTRT---BUFFER INDEX FOR REQUESTED NODE
  1193. C
  1194.       INCLUDE rin:BTBUF.BLK
  1195.       INCLUDE rin:RIMCOM.BLK
  1196.       INCLUDE rin:F3COM.BLK
  1197. C
  1198. C  SEE IF THE BLOCK IS IN CORE.
  1199. C
  1200.       DO 100 NUMB=1,NUMIC
  1201.       IF(ID.EQ.ICORE(3,NUMB)) GO TO 1000
  1202.   100 CONTINUE
  1203. C
  1204. C  THE REQUESTED BLOCK IS NOT IN THE BUFFER.
  1205. C
  1206. C   DETERMINE WHICH SLOT IN THE BUFFER WE SHOULD USE.
  1207. C
  1208.       IF(NUMIC.GE.MAXIC) GO TO 200
  1209. C
  1210. C  STILL ROOM IN THE BUFFER.
  1211. C
  1212.       NUMIC = NUMIC + 1
  1213.       NUMB = NUMIC
  1214.       GO TO 500
  1215. C
  1216. C  WE MUST DETERMINE WHO WILL BE MOVED OUT.
  1217. C
  1218.   200 CONTINUE
  1219.       MINUMB = 1
  1220.       IF(MINUMB.EQ.LAST) MINUMB = 2
  1221.       MINUSE = ICORE(1,MINUMB)
  1222.       DO 300 NUMB=1,NUMIC
  1223.       IF(NUMB.EQ.LAST) GO TO 300
  1224.       NUMUSE = ICORE(1,NUMB)
  1225.       IF(NUMUSE.EQ.0) GO TO 400
  1226.       IF(NUMUSE.GT.MINUSE) GO TO 300
  1227.       MINUSE = NUMUSE
  1228.       MINUMB = NUMB
  1229.   300 CONTINUE
  1230. C
  1231. C  USE THE BLOCK THAT WAS USED THE LEAST.
  1232. C
  1233.       NUMB = MINUMB
  1234.   400 CONTINUE
  1235. C
  1236. C  BLOCK NUMB WILL BE USED.
  1237. C
  1238. C  SEE IF THE BLOCK CURRENTLY THERE MUST BE WRITTEN OUT.
  1239. C
  1240.       IF(ICORE(2,NUMB).EQ.0) GO TO 500
  1241. C
  1242. C  WRITE IT OUT.
  1243. C
  1244.       ISTRT = (NUMB-1) * LENBF3 + 1
  1245.       IEND = ISTRT + LENBF3 - 1
  1246.       IOBN = ICORE(3,NUMB)
  1247.       CALL RIOOUT(FILE3,IOBN,CORE(ISTRT),LENBF3,IOS)
  1248.       IF(IOS.NE.0) RMSTAT = 2300 + IOS
  1249.   500 CONTINUE
  1250. C
  1251. C  CHANGE THE ICORE ENTRY.
  1252. C
  1253.       ICORE(3,NUMB) = ID
  1254.       ICORE(2,NUMB) = 0
  1255. C
  1256. C  READ IN DESIRED BLOCK.
  1257. C
  1258.       ISTRT = (NUMB-1) * LENBF3 + 1
  1259.       CALL RIOIN(FILE3,ID,CORE(ISTRT),LENBF3,IOS)
  1260.       IF(ID.GE.LF3REC) GO TO 600
  1261.       IF(IOS.EQ.0) GO TO 1000
  1262.   600 CONTINUE
  1263.       CALL ZEROIT(CORE(ISTRT),LENBF3)
  1264.       CALL RIOOUT(FILE3,ID,CORE(ISTRT),LENBF3,IOS)
  1265.       IF(IOS.NE.0) RMSTAT = 2300 + IOS
  1266. C
  1267. C  UPDATE THE ICORE ARRAY AND SET NSTRT.
  1268. C
  1269.  1000 CONTINUE
  1270.       ICORE(1,NUMB) = ICORE(1,NUMB) + 1
  1271.       ISTRT = ((NUMB-1) * LENBF3) / 3 + 1
  1272.       NSTRT = ISTRT
  1273.       LAST = NUMB
  1274.       RETURN
  1275.       END
  1276.       SUBROUTINE BTINIT(START)
  1277.       INCLUDE rin:TEXT.BLK
  1278. C
  1279. C  PURPOSE:   INITIALIZE FOR A NEW BTREE
  1280. C
  1281. C  PARAMETERS:
  1282. C         START---NEW RECORD USED FOR THIS BTREE
  1283. C
  1284.       INCLUDE rin:F3COM.BLK
  1285.       INCLUDE rin:MISC.BLK
  1286.       INCLUDE rin:BTBUF.BLK
  1287. C
  1288.       INTEGER START
  1289. C
  1290. C  GET THE NEXT NODE.
  1291. C
  1292.       CALL BTGET(LF3REC,N1)
  1293. C
  1294. C  INSERT THE END-OF-LIST WORD.
  1295. C
  1296.       VALUE(1,N1) = ENDWRD
  1297.       VALUE(2,N1) = 1
  1298.       VALUE(3,N1) = 0
  1299. C
  1300. C  WRITE OUT THIS NODE.
  1301. C
  1302.       CALL BTPUT(LF3REC)
  1303.       START = LF3REC
  1304.       LF3REC = LF3REC + 1
  1305.       RETURN
  1306.       END
  1307.       SUBROUTINE BTLKI(VAL,IPTR,MOTID)
  1308.       INCLUDE rin:TEXT.BLK
  1309. C
  1310. C  PURPOSE:  LOOKUP PROCESSING ROUTINE FOR BTREES
  1311. C
  1312. C  PARAMETERS
  1313. C    INPUT:  VAL-----KEY VALUE TO PROCESS
  1314. C            IPTR----POINTER TO TUPLE HAVING THIS KEY VALUE
  1315. C            MOTID---MOT LINK
  1316. C
  1317. C  SUBROUTINES USED
  1318. C         BTGET---PAGING ROUTINE
  1319. C
  1320.       INCLUDE rin:F3COM.BLK
  1321.       INCLUDE rin:MISC.BLK
  1322.       INCLUDE rin:BTBUF.BLK
  1323.       INCLUDE rin:START.BLK
  1324. C
  1325.       INTEGER VAL
  1326. C
  1327. C  SET UP VARIABLES BASED ON THE ENTRY POINT.
  1328. C
  1329. C
  1330. C  INITIAL START OF THE SCAN.
  1331. C
  1332.       KSTART = START
  1333.   100 CONTINUE
  1334. C
  1335. C  FETCH A NODE.
  1336. C
  1337.       CALL BTGET(KSTART,IN)
  1338.       KEND = IN + (LENBF3/3) - 1
  1339. C
  1340. C  LOOP THROUGH A NODE.
  1341. C
  1342.       DO 300 J=IN,KEND
  1343. C
  1344. C  CHECK FOR END-OF-LIST WORD.
  1345. C
  1346.       IF(VALUE(1,J).EQ.ENDWRD) GO TO 200
  1347. C
  1348. C  IF THE VALUE IS LT VAL THEN KEEP LOOKING.
  1349. C
  1350.       IF(VALUE(1,J).LT.VAL) GO TO 300
  1351. C
  1352. C  FOUND A BIGGER VALUE.
  1353. C
  1354.   200 CONTINUE
  1355. C
  1356. C  GO TO THE NEXT BRANCH IF THERE IS ONE.
  1357. C
  1358.       IF(VALUE(2,J).GE.0) GO TO 400
  1359.       KSTART = -VALUE(2,J)
  1360.       GO TO 100
  1361.   300 CONTINUE
  1362. C
  1363. C  WE DID NOT FIND THE END-OF-LIST WORD. DISASTER.
  1364. C
  1365.       GO TO 500
  1366. C
  1367. C  DONE SCANNING THE BTREE.
  1368. C
  1369.   400 CONTINUE
  1370. C
  1371. C  CHECK FOR AN EQUAL VALUE.
  1372. C
  1373.       IF(VALUE(1,J).NE.VAL) GO TO 500
  1374. C
  1375. C  PROCESS WAS A LOOKUP. RETURN THE TUPLE POINTER.
  1376. C
  1377.       IPTR = VALUE(2,J)
  1378.       MOTID = VALUE(3,J)
  1379.       IF(MOTID.NE.0) CALL MOTSCN(MOTID,IPTR)
  1380.       RETURN
  1381. C
  1382. C  THIS VALUE IS NOT IN THE BTREE YET.
  1383. C
  1384.   500 CONTINUE
  1385.       IPTR = 0
  1386.       MOTID = 0
  1387.       RETURN
  1388.       END
  1389.       SUBROUTINE BTLKR(VAL,IPTR,MOTID)
  1390.       INCLUDE rin:TEXT.BLK
  1391. C
  1392. C  PURPOSE:  LOOKUP PROCESSING ROUTINE FOR BTREES
  1393. C
  1394. C  PARAMETERS
  1395. C    INPUT:  VAL-----KEY VALUE TO PROCESS
  1396. C            IPTR----POINTER TO TUPLE HAVING THIS KEY VALUE
  1397. C            MOTID---MOT LINK
  1398. C
  1399. C  SUBROUTINES USED
  1400. C         BTGET---PAGING ROUTINE
  1401. C
  1402.       INCLUDE rin:F3COM.BLK
  1403.       INCLUDE rin:MISC.BLK
  1404.       INCLUDE rin:BTBUF.BLK
  1405.       INCLUDE rin:START.BLK
  1406. C
  1407.       REAL VAL
  1408. C
  1409. C  SET UP VARIABLES BASED ON THE ENTRY POINT.
  1410. C
  1411. C
  1412. C  INITIAL START OF THE SCAN.
  1413. C
  1414.       KSTART = START
  1415.   100 CONTINUE
  1416. C
  1417. C  FETCH A NODE.
  1418. C
  1419.       CALL BTGET(KSTART,IN)
  1420.       KEND = IN + (LENBF3/3) - 1
  1421. C
  1422. C  LOOP THROUGH A NODE.
  1423. C
  1424.       DO 300 J=IN,KEND
  1425. C
  1426. C  CHECK FOR END-OF-LIST WORD.
  1427. C
  1428.       IF(VALUE(1,J).EQ.ENDWRD) GO TO 200
  1429. C
  1430. C  IF THE VALUE IS LT VAL THEN KEEP LOOKING.
  1431. C
  1432.       IF(RVALUE(1,J).LT.VAL) GO TO 300
  1433. C
  1434. C  FOUND A BIGGER VALUE.
  1435. C
  1436.   200 CONTINUE
  1437. C
  1438. C  GO TO THE NEXT BRANCH IF THERE IS ONE.
  1439. C
  1440.       IF(VALUE(2,J).GE.0) GO TO 400
  1441.       KSTART = -VALUE(2,J)
  1442.       GO TO 100
  1443.   300 CONTINUE
  1444. C
  1445. C  WE DID NOT FIND THE END-OF-LIST WORD. DISASTER.
  1446. C
  1447.       GO TO 500
  1448. C
  1449. C  DONE SCANNING THE BTREE.
  1450. C
  1451.   400 CONTINUE
  1452. C
  1453. C  CHECK FOR AN EQUAL VALUE.
  1454. C
  1455.       IF(RVALUE(1,J).NE.VAL) GO TO 500
  1456. C
  1457. C  PROCESS WAS A LOOKUP. RETURN THE TUPLE POINTER.
  1458. C
  1459.       IPTR = VALUE(2,J)
  1460.       MOTID = VALUE(3,J)
  1461.       IF(MOTID.NE.0) CALL MOTSCN(MOTID,IPTR)
  1462.       RETURN
  1463. C
  1464. C  THIS VALUE IS NOT IN THE BTREE YET.
  1465. C
  1466.   500 CONTINUE
  1467.       IPTR = 0
  1468.       MOTID = 0
  1469.       RETURN
  1470.       END
  1471.       SUBROUTINE BTLKT(VAL,IPTR,MOTID)
  1472.       INCLUDE rin:TEXT.BLK
  1473. C
  1474. C  PURPOSE:  LOOKUP PROCESSING ROUTINE FOR BTREES
  1475. C
  1476. C  PARAMETERS:
  1477. C    INPUT:  VAL-----KEY VALUE TO PROCESS
  1478. C            IPTR----POINTER TO TUPLE HAVING THIS KEY VALUE
  1479. C            MOTID---MOT LINK
  1480. C
  1481. C  HASH THE TEXT STRING INTO AN INTEGER AND CALL BTLKI.
  1482. C
  1483.       INTEGER VAL(*)
  1484.       IVAL = VAL(1)
  1485.       CALL BTLKI(IVAL,IPTR,MOTID)
  1486.       RETURN
  1487.       END
  1488.       SUBROUTINE BTMOVE(NEW,OLD,NV)
  1489.       INCLUDE rin:TEXT.BLK
  1490. C
  1491. C  PURPOSE:   MOVE NV VALUES FROM OLD TO NEW.
  1492. C
  1493.       INCLUDE rin:BTBUF.BLK
  1494.       INTEGER OLD
  1495.       IS = 1
  1496.       IF(NV.LT.0) IS = -1
  1497.       N = IS * NV
  1498.       DO 100 I=1,N
  1499.       IN = NEW + IS * (I - 1)
  1500.       IO = OLD + IS * (I - 1)
  1501.       VALUE(1,IN) = VALUE(1,IO)
  1502.       VALUE(2,IN) = VALUE(2,IO)
  1503.       VALUE(3,IN) = VALUE(3,IO)
  1504.   100 CONTINUE
  1505.       RETURN
  1506.       END
  1507.       SUBROUTINE BTPUT(ID)
  1508.       INCLUDE rin:TEXT.BLK
  1509. C
  1510. C  PURPOSE:    TURN ON THE WRITE FLAG ON THE INDICATED BLOCK
  1511. C
  1512. C  PARAMETERS
  1513. C     INPUT:   ID------RECORD NUMBER
  1514.       INCLUDE rin:F3COM.BLK
  1515.       INCLUDE rin:RIMCOM.BLK
  1516.       INCLUDE rin:FLAGS.BLK
  1517. C
  1518. C  LOOK FOR THIS BLOCK IN CORE.
  1519. C
  1520.       DO 100 NUMB=1,NUMIC
  1521.       IF(ID.EQ.ICORE(3,NUMB)) GO TO 200
  1522.   100 CONTINUE
  1523. C
  1524. C  DISASTER. WE CANNOT FIND THE BLOCK.
  1525. C
  1526.       RMSTAT = 1004
  1527.       RETURN
  1528. C
  1529. C  SET THE WRITE FLAG.
  1530. C
  1531.   200 CONTINUE
  1532.       ICORE(2,NUMB) = 1
  1533.       IFMOD = .TRUE.
  1534.       RETURN
  1535.       END
  1536.       SUBROUTINE BTREP(VALU,IPTR,IPTRO,TYPE)
  1537.       INCLUDE rin:TEXT.BLK
  1538. C
  1539. C  PURPOSE:   REPLACE VALUES IN A BTREE
  1540. C
  1541. C  PARAMETERS
  1542. C    INPUT:  VALU----KEY VALUE TO PROCESS
  1543. C         IPTR----NEW POINTER TO BE USED
  1544. C         IPTRO---OLD POINTER TO BE REPLACED
  1545. C         TYPE----TYPE OF VARIABLE BEING ADDED
  1546. C
  1547. C
  1548. C  SUBROUTINES USED
  1549. C         BTGET---PAGING ROUTINE
  1550. C         BTPUT---PAGING ROUTINE
  1551. C
  1552. C  DECLARATIVES
  1553. C
  1554.       INCLUDE rin:RMATTS.BLK
  1555.       INCLUDE rin:F3COM.BLK
  1556.       INCLUDE rin:MISC.BLK
  1557.       INCLUDE rin:BTBUF.BLK
  1558.       INCLUDE rin:START.BLK
  1559.       INCLUDE rin:STACK.BLK
  1560. C
  1561.       INTEGER VAL,VALU(*)
  1562.       REAL RVAL
  1563.       EQUIVALENCE (RVAL,VAL)
  1564.       INTEGER TYPE
  1565. C
  1566. C  INITIAL START OF THE SCAN.
  1567. C
  1568.       SP = 0
  1569.       KSTART = START
  1570.       VAL = VALU(1)
  1571.       ITYPE = TYPE
  1572.       IF(TYPE.EQ.KZTEXT) ITYPE = KZINT
  1573.       IP = IPTR
  1574.   100 CONTINUE
  1575.       SP = SP + 1
  1576.       STACK(SP) = KSTART
  1577. C
  1578. C  FETCH A NODE.
  1579. C
  1580.       CALL BTGET(KSTART,IN)
  1581.       KEND = IN + (LENBF3/3) - 1
  1582. C
  1583. C  LOOP THROUGH A NODE.
  1584. C
  1585.       DO 300 J=IN,KEND
  1586. C
  1587. C  CHECK FOR END-OF-LIST WORD.
  1588. C
  1589.       IF(VALUE(1,J).EQ.ENDWRD) GO TO 200
  1590. C
  1591. C  IF THE VALUE IS LT VAL THEN KEEP LOOKING.
  1592. C
  1593.       IF((ITYPE.EQ.KZINT).AND.(VALUE(1,J).LT.VAL)) GO TO 300
  1594.       IF((ITYPE.NE.KZINT).AND.(RVALUE(1,J).LT.RVAL)) GO TO 300
  1595. C
  1596. C  FOUND A BIGGER VALUE.
  1597. C
  1598.   200 CONTINUE
  1599. C
  1600. C  GO TO THE NEXT BRANCH IF THERE IS ONE.
  1601. C
  1602.       IF(VALUE(2,J).GE.0) GO TO 400
  1603.       KSTART = -VALUE(2,J)
  1604.       GO TO 100
  1605.   300 CONTINUE
  1606. C
  1607. C  WE DID NOT FIND THE END-OF-LIST WORD. DISASTER.
  1608. C
  1609.       GO TO 1000
  1610. C
  1611. C  END OF THE BTREE SEARCH.
  1612. C
  1613.   400 CONTINUE
  1614. C
  1615. C  CHECK FOR A DUPLICATE VALUE.
  1616. C
  1617.       IF(VALUE(1,J).NE.VAL) GO TO 1000
  1618.       IF(VALUE(3,J).NE.0) GO TO 450
  1619.       IF(VALUE(2,J).NE.IPTRO) GO TO 450
  1620.       VALUE(2,J) = IPTR
  1621.       CALL BTPUT(KSTART)
  1622.       GO TO 1000
  1623.   450 CONTINUE
  1624. C
  1625. C  WE HAVE A MULTIPLE VALUE. FOLLOW THE LINKS.
  1626. C
  1627. C  GET THE MOT NODE.
  1628. C
  1629.       MOTIND = 3 * J
  1630.       MOTIDP = STACK(SP)
  1631.       IF(VALUE(3,J).EQ.0) GO TO 1000
  1632.       CALL ITOH(MOTIND,MOTID,VALUE(3,J))
  1633. C
  1634. C  MOT LINK TRAIL.
  1635. C
  1636.   460 CONTINUE
  1637.       CALL BTGET(MOTID,IN)
  1638.       IN = 3 * IN - 3
  1639.       MOTIDP = MOTID
  1640.   470 CONTINUE
  1641.       MOTIND = MOTIND + IN
  1642.       IF(CORE(MOTIND+1).EQ.IPTRO) GO TO 500
  1643.       IF(CORE(MOTIND).EQ.0) GO TO 1000
  1644.       CALL ITOH(MOTIND,MOTID,CORE(MOTIND))
  1645. C
  1646. C  SEE IF WE ARE ON THE SAME MOT PAGE.
  1647. C
  1648.       IF(MOTID.EQ.MOTIDP) GO TO 470
  1649.       GO TO 460
  1650. C
  1651. C  REPLACE THE POINTER.
  1652. C
  1653.   500 CONTINUE
  1654.       CORE(MOTIND+1) = IPTR
  1655.       CALL BTPUT(MOTIDP)
  1656.       RETURN
  1657. C
  1658. C  LOOKUP FOR A VALUE NOT IN THE TREE.
  1659. C
  1660.  1000 CONTINUE
  1661.       RETURN
  1662.       END
  1663.       SUBROUTINE BTSERT(VAL,IP,STACK,SP,LOC,IN)
  1664.       INCLUDE rin:TEXT.BLK
  1665. C
  1666. C  INSERT VAL INTO LOC REFERENCED BY THE STACK POINTER.
  1667. C
  1668. C  SUBROUTINES USED
  1669. C         BTGET---PAGING ROUTINE
  1670. C         BTPUT---PAGING ROUTINE
  1671. C         BTMOVE--MOVES DATA BETWEEN AREAS
  1672. C
  1673.       INCLUDE rin:F3COM.BLK
  1674.       INCLUDE rin:BTBUF.BLK
  1675.       INCLUDE rin:START.BLK
  1676.       INTEGER VALT
  1677.       INTEGER VAL,STACK(*),SP
  1678. C
  1679.       KEND = IN + (LENBF3/3) - 1
  1680.       J = LOC
  1681. C
  1682. C  CHECK TO SEE IF THE NODE IS ALREADY FULL.
  1683. C
  1684.       IF(VALUE(2,KEND).NE.0) GO TO 100
  1685. C
  1686. C  STILL ROOM.
  1687. C
  1688.       NV = KEND - J
  1689.       CALL BTMOVE(KEND,KEND-1,-NV)
  1690.       VALUE(1,J) = VAL
  1691.       VALUE(2,J) = IP
  1692.       VALUE(3,J) = 0
  1693. C
  1694. C  WRITE OUT THIS NODE.
  1695. C
  1696.       CALL BTPUT(STACK(SP))
  1697.       SP = 0
  1698.       RETURN
  1699. C
  1700. C  WE NEED TO SPLIT THE NODE. SAVE THE CURRENT LAST VALUE.
  1701. C
  1702.   100 CONTINUE
  1703.       VALT = VALUE(1,KEND)
  1704.       IBT = VALUE(2,KEND)
  1705.       IMT = VALUE(3,KEND)
  1706. C
  1707. C  PUT THE NEW VALUE IN ITS PLACE.
  1708. C
  1709.       NV = KEND - J
  1710.       CALL BTMOVE(KEND,KEND-1,-NV)
  1711.       VALUE(1,J) = VAL
  1712.       VALUE(2,J) = IP
  1713.       VALUE(3,J) = 0
  1714. C
  1715. C  NEW VALUE IS IN
  1716. C
  1717. C  MOVE THE LOW PART
  1718. C
  1719.       NV = 2 * (LENBF3/3) / 3
  1720.       CALL BTGET(LF3REC,N2)
  1721.       CALL BTMOVE(N2,IN,NV)
  1722. C
  1723. C  WRITE OUT THIS NEW NODE.
  1724. C
  1725.       CALL BTPUT(LF3REC)
  1726.       L = N2 + NV - 1
  1727. C
  1728. C  SAVE IN A NEW NODE POINTER.
  1729. C
  1730.       VAL = VALUE(1,L)
  1731.       IP = -LF3REC
  1732. C
  1733. C  MOVE THE TOP OF THE OLD NODE TO THE BOTTOM.
  1734. C
  1735.       NV = (LENBF3/3) - NV
  1736.       CALL BTMOVE(IN,KEND-NV+1,NV)
  1737. C
  1738. C  RESTORE THE OLD LAST VALUE.
  1739. C
  1740.       L = NV
  1741.       VALUE(1,IN+L) = VALT
  1742.       VALUE(2,IN+L) = IBT
  1743.       VALUE(3,IN+L) = IMT
  1744. C
  1745. C  ZERO OUT THE REMAINDER OF THE NODE.
  1746. C
  1747.       NV = (LENBF3/3) - NV - 1
  1748.       IF(NV.LE.0) GO TO 300
  1749.       J = 3 * (KEND - IN - L)
  1750.       CALL ZEROIT(VALUE(1,IN+L+1),J)
  1751.   300 CONTINUE
  1752. C
  1753. C  WRITE OUT THIS NODE AGAIN.
  1754. C
  1755.       CALL BTPUT(STACK(SP))
  1756.       SP = SP - 1
  1757.       LF3REC = LF3REC + 1
  1758.       IF(SP.NE.0) RETURN
  1759. C
  1760. C  NEW STARTING NODE.
  1761. C
  1762.       CALL BTGET(LF3REC,N1)
  1763.       VALUE(1,N1) = VAL
  1764.       VALUE(2,N1) = IP
  1765.       VALUE(3,N1) = 0
  1766.       VALUE(1,N1+1) = VALT
  1767.       VALUE(2,N1+1) = -STACK(1)
  1768.       VALUE(3,N1+1) = 0
  1769.       CALL REUSE
  1770. C
  1771. C  WRITE OUT THIS NEW NODE.
  1772. C
  1773.       CALL BTPUT(LF3REC)
  1774.       START = LF3REC
  1775.       LF3REC = LF3REC + 1
  1776.       RETURN
  1777.       END
  1778.       SUBROUTINE BUILD
  1779.       INCLUDE rin:TEXT.BLK
  1780. C
  1781. C  PURPOSE:  BUILD A KEY INDEX FOR AN ATTRIBUTE IN A RELATION
  1782. C
  1783.       INCLUDE rin:RMATTS.BLK
  1784.       INCLUDE rin:RMKEYW.BLK
  1785.       INCLUDE rin:RIMPTR.BLK
  1786.       INCLUDE rin:TUPLEA.BLK
  1787.       INCLUDE rin:TUPLER.BLK
  1788.       INCLUDE rin:BUFFER.BLK
  1789.       INCLUDE rin:START.BLK
  1790.       INCLUDE rin:FILES.BLK
  1791.       INCLUDE rin:RIMCOM.BLK
  1792.       INCLUDE rin:FLAGS.BLK
  1793.       INCLUDE rin:MISC.BLK
  1794.       INCLUDE rin:WHCOM.BLK
  1795.       INCLUDE rin:SRTCOM.BLK
  1796.       INCLUDE rin:DCLAR1.BLK
  1797.       INTEGER COLUMN
  1798. C
  1799.       LOGICAL EQKEYW
  1800. C
  1801. C  SCAN THE COMMAND FOR PROPER SYNTAX.
  1802. C
  1803.       IF(.NOT.EQKEYW(2,KWKEY,3)) GO TO 7500
  1804.       IF(.NOT.EQKEYW(3,KWFOR,3)) GO TO 7500
  1805.       IF(.NOT.EQKEYW(5,KWIN,2)) GO TO 7500
  1806.       IF(LXITEM(DUM).GT.6) GO TO 7500
  1807. C
  1808. C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
  1809. C
  1810.       CALL RMDBLK(DBNAME)
  1811.       IF(RMSTAT.EQ.0) GO TO 50
  1812.       CALL WARN(RMSTAT,DBNAME,0)
  1813.       GO TO 8000
  1814. C
  1815. C  FIND THE ATTRIBUTE IN THE SPECIFIED RELATION.
  1816. C
  1817.    50 CONTINUE
  1818.       RNAME = BLANK
  1819.       CALL LXSREC(6,1,8,RNAME,1)
  1820.       ANAME = BLANK
  1821.       CALL LXSREC(4,1,8,ANAME,1)
  1822.       I = LOCREL(RNAME)
  1823.       IF(I.EQ.0) GO TO 100
  1824. C
  1825. C  UNRECOGIZED RELATION NAME.
  1826. C
  1827.       CALL WARN(1,RNAME,0)
  1828.       GO TO 8000
  1829.   100 CONTINUE
  1830. C
  1831. C  CHECK FOR MODIFY PERMISSION.
  1832. C
  1833.       I = LOCPRM(RNAME,2)
  1834.       IF(I.EQ.0) GO TO 150
  1835.       CALL WARN(9,RNAME,0)
  1836.       GO TO 8000
  1837. C
  1838. C  FIND THE ATTRIBUTE IN THE RELATION.
  1839. C
  1840.   150 CONTINUE
  1841.       I = LOCATT(ANAME,RNAME)
  1842.       IF(I.EQ.0) GO TO 200
  1843. C
  1844. C  THIS ATTRIBUTE IS NOT IN THIS RELATION.
  1845. C
  1846.       CALL WARN(3,ANAME,RNAME)
  1847.       GO TO 8000
  1848.   200 CONTINUE
  1849. C
  1850. C  ISSUE A WARNING IF ATTRIBUTE IS ALREADY A KEY.
  1851. C
  1852.       CALL ATTGET(ISTAT)
  1853.       IF(ATTKEY.EQ.0) GO TO 400
  1854.     if(nout.eq.6)goto 3144
  1855.       WRITE(NOUT,300) ANAME
  1856.   300 FORMAT(19H -ERROR- Attribute ,A8,
  1857.      X       17H Is Already A KEY )
  1858.       GO TO 8000
  1859. 3144    continue
  1860.     write(c128wk,300)
  1861.     call atxto
  1862.     goto 8000
  1863.   400 CONTINUE
  1864. C
  1865. C  DETERMINE THE COLUMN TO BE USED FOR THIS ATTRIBUTE.
  1866. C
  1867.       COLUMN = ATTCOL
  1868. C
  1869. C  INITIALIZE THE BTREE FOR THIS ELEMENT.
  1870. C
  1871.       CALL BTINIT(ATTKEY)
  1872.       START = ATTKEY
  1873.       CALL ATTPUT(ISTAT)
  1874. C
  1875. C  SORT THE KEY VALUES IF THERE ARE MORE THAN 100 OF THEM
  1876. C
  1877.       IF(NTUPLE.GT.100) GO TO 700
  1878. C
  1879. C   SCAN THROUGH ALL THE DATA FOR THIS RELATION.
  1880. C
  1881.   500 CONTINUE
  1882.       IF(NID.EQ.0) GO TO 900
  1883.       CID = NID
  1884.       CALL GETDAT(1,NID,ITUP,LENGTH)
  1885.       IF(NID.LT.0) GO TO 900
  1886.       IP = ITUP + COLUMN - 1
  1887.       IF(ATTWDS.NE.0) GO TO 600
  1888. C
  1889. C  ATTRIBUTE IS A VARIABLE LENGTH ATTRIBUTE.
  1890. C
  1891.       IP = BUFFER(IP) + ITUP + 1
  1892.   600 CONTINUE
  1893.       IF(BUFFER(IP).EQ.NULL) GO TO 500
  1894.       CALL BTADD(BUFFER(IP),CID,ATTYPE)
  1895.       GO TO 500
  1896. C
  1897. C  SORT KEY VALUES BEFORE BUILDING THE B-TREE
  1898. C
  1899.   700 CONTINUE
  1900.       LENGTH = 2
  1901.       NSOVAR = 1
  1902.       NKSORT = 3
  1903.       LIMTU = ALL9S
  1904.       SORTYP(1) = .TRUE.
  1905.       VARPOS(1) = 1
  1906.       L = 2
  1907.       IF(ATTYPE.EQ.KZTEXT) L = 4
  1908.       IF(ATTYPE.EQ.KZINT ) L = 1
  1909.       IF(ATTYPE.EQ.KZIVEC) L = 1
  1910.       IF(ATTYPE.EQ.KZIMAT) L = 1
  1911.       VARTYP(1) = L
  1912.       CALL SORT(NKSORT,ierr)
  1913.     if(ierr.eq.0)goto 770
  1914.     call warn(16)
  1915.     goto 8000
  1916. 770    continue
  1917. C
  1918. C  READ THE SORTED KEY VALUES AND BUILD THE BTREE
  1919. C
  1920.       CALL GTSORT(IP,1,-1,LENGTH)
  1921.   800 CONTINUE
  1922.       CALL GTSORT(IP,1,1,LENGTH)
  1923.       IF(RMSTAT.NE.0) GO TO 900
  1924.       IF(BUFFER(IP).EQ.NULL) GO TO 800
  1925.       CALL BTADD(BUFFER(IP),BUFFER(IP+1),ATTYPE)
  1926.       GO TO 800
  1927. C
  1928. C  ALL DONE.
  1929. C
  1930.   900 CONTINUE
  1931. C
  1932. C  RESTORE THE START TO THE BTREE TABLE.
  1933. C
  1934.       I = LOCATT(ANAME,RNAME)
  1935.       CALL ATTGET(ISTAT)
  1936.       ATTKEY = START
  1937.       CALL ATTPUT(ISTAT)
  1938.       GO TO 8000
  1939. C
  1940. C  SYNTAX ERROR.
  1941. C
  1942.  7500 CONTINUE
  1943.       CALL WARN(4,0,0)
  1944. C
  1945. C  RETURN
  1946. C
  1947.  8000 RETURN
  1948.       END
  1949.       SUBROUTINE CHANGE(MAT,NVAL)
  1950.       INCLUDE rin:TEXT.BLK
  1951. C
  1952. C  THIS ROUTINE PROCESSES A CHANGE IN RIM.
  1953. C
  1954. C  PARAMETERS:
  1955. C         MAT-----SCRATCH ARRAY FOR A TUPLE
  1956. C         NVAL----SCRATCH ARRAY FOR A TUPLE
  1957.       INCLUDE rin:RMATTS.BLK
  1958.       INCLUDE rin:RMKEYW.BLK
  1959.       INCLUDE rin:CONST4.BLK
  1960.       INCLUDE rin:SORBUF.BLK
  1961.       INCLUDE rin:RIMCOM.BLK
  1962.       INCLUDE rin:RIMPTR.BLK
  1963.       INCLUDE rin:FILES.BLK
  1964.       INCLUDE rin:RULCOM.BLK
  1965.       INCLUDE rin:FLAGS.BLK
  1966.       INCLUDE rin:WHCOM.BLK
  1967.       INCLUDE rin:BUFFER.BLK
  1968.       INCLUDE rin:START.BLK
  1969.       INCLUDE rin:TUPLEA.BLK
  1970.       INCLUDE rin:TUPLER.BLK
  1971.       INCLUDE rin:MISC.BLK
  1972. C
  1973. C  DIMENSION STATEMENTS.
  1974. C
  1975.       DIMENSION MAT(*)
  1976.       DIMENSION NVAL(*)
  1977.       INTEGER RULWHR(14)
  1978.       LOGICAL BYPASS
  1979.       INTEGER COLUMN
  1980.       LOGICAL NE
  1981.       LOGICAL SINGLE
  1982.       LOGICAL EQKEYW
  1983.       INTEGER EXTRA
  1984.       INCLUDE rin:DCLAR1.BLK
  1985.       NC = 0
  1986.       NOPE = 0
  1987. C
  1988. C  LOOK FOR THE WORD WHERE.
  1989. C
  1990.       ITEMS = LXITEM(ISTAT)
  1991.       J = LFIND(1,ITEMS,KWWHER,5)
  1992.       IF(J.NE.0) GO TO 100
  1993.     if(nout.eq.6)goto 3145
  1994.       WRITE(NOUT,9001)
  1995.  9001 FORMAT(48H -ERROR- WHERE Clause Required On CHANGE Command)
  1996.       GO TO 9999
  1997. 3145    continue
  1998.     write(c128wk,9001)
  1999.     call atxto
  2000.     goto 9999
  2001.   100 CONTINUE
  2002.       NEWL = ATTWDS
  2003.       NROW = ATTCHA
  2004. C
  2005. C     SINGLE INDICATES VEC(I) MAT(I,J) SPECIFICATION
  2006. C
  2007.       SINGLE = LXWREC(3,1).EQ.K4LPAR
  2008.       IF(.NOT.SINGLE) GO TO 200
  2009. C
  2010. C     CHECK SINGLE SYNTAX
  2011. C
  2012.       CALL TYPER(ATTYPE,MATV,ITYPE)
  2013.       IF(ITYPE.EQ.KZTEXT) GO TO 110
  2014.       NDIM = 1
  2015.       IF(MATV.EQ.KZMAT) NDIM = 2
  2016.       IF(LXWREC((4+NDIM),1).EQ.K4RPAR) GO TO 130
  2017.   110 CONTINUE
  2018.     if(nout.eq.6)goto 3146
  2019.       WRITE (NOUT,120)
  2020.   120 FORMAT(45H -ERROR- Bad VEC(I) or MAT(I,J) Specification )
  2021.       GO TO 9999
  2022. 3146    continue
  2023.     write(c128wk,120)
  2024.     call atxto
  2025.     goto 9999
  2026.   130 CONTINUE
  2027.       IROW = LXIREC(4)
  2028.       ICOL = LXIREC(5)
  2029.       IF(NDIM.EQ.1) ICOL = 1
  2030.       NEWL = 1
  2031.       IF(ITYPE.EQ.KZDOUB) NEWL = 2
  2032.       ID = 6 + NDIM
  2033. C
  2034. C  CHECK VALUE SYNTAX (ONLY ONE ITEM ALLOWED)
  2035. C
  2036.       JJ = ID + 1
  2037.       IF(EQKEYW(JJ,KWIN,2)) GO TO 135
  2038.       IF(EQKEYW(JJ,KWWHER,5)) GO TO 135
  2039.       GO TO 110
  2040.   135 CONTINUE
  2041.       CALL PARVAL(ID,NVAL,ATTYPE,NEWL,NROW,0,IERR)
  2042.       IF(IERR.NE.0) GO TO 9999
  2043.       IP = 0
  2044.       IF(ATTWDS.EQ.0) GO TO 400
  2045.       IF(NROW.EQ.0) NROW = ATTWDS
  2046.       IF(IROW.GT.NROW) GO TO 110
  2047.       IP = NROW*(ICOL-1) + IROW
  2048.       IF(ITYPE.EQ.KZDOUB) IP = 2*IP - 1
  2049.       IP = IP + ATTCOL - 1
  2050.       IF(MATV.NE.KZMAT) GO TO 400
  2051.       IF(IROW*ICOL.GT.ATTWDS) GO TO 110
  2052.       GO TO 400
  2053.   200 CONTINUE
  2054.       ID = 4
  2055.       CALL PARVAL(ID,NVAL,ATTYPE,NEWL,NROW,0,IERR)
  2056.       IF(IERR.NE.0) GO TO 9999
  2057.   400 CONTINUE
  2058. C
  2059. C  CHECK FOR RULES FOR THIS RELATION
  2060. C
  2061.       ANAME = ATTNAM
  2062.       RNAME = RELNAM
  2063.       BYPASS = .TRUE.
  2064.       IF(.NOT.RUCK) GO TO 460
  2065.       CALL CHKRUL(RNAME)
  2066.       I = LOCATT(ANAME,RNAME)
  2067.       CALL ATTGET(ISTAT)
  2068.       I = LOCREL(RNAME)
  2069.       CALL RELGET(ISTAT)
  2070.       IF(RMSTAT.LT.110) GO TO 450
  2071.     if(nout.eq.6)goto 3147
  2072.       IF(RMSTAT.EQ.110) WRITE(NOUT,410)
  2073.       IF(RMSTAT.EQ.111) WRITE(NOUT,420)
  2074.   410 FORMAT(35H -ERROR- Unrecognized RULE Relation)
  2075.   420 FORMAT(50H -ERROR- More Than 10 Rules Apply To This Relation)
  2076.       GO TO 9999
  2077. 3147    continue
  2078.       IF(RMSTAT.EQ.110) WRITE(c128wk,410)
  2079.       IF(RMSTAT.EQ.111) WRITE(c128wk,420)
  2080.     if(rmstat.eq.110.or.rmstat.eq.111)call atxto
  2081.     goto 9999
  2082.   450 CONTINUE
  2083.       IF(RUCK.AND.RULES) BYPASS = .FALSE.
  2084.       IF(BYPASS) GO TO 460
  2085. C
  2086. C  SAVE THE RULE WHERE CLAUSE
  2087. C
  2088.       RULWHR(1) = NBOO
  2089.       RULWHR(2) = BOO(1)
  2090.       RULWHR(3) = KATTP(1)
  2091.       RULWHR(4) = KATTL(1)
  2092.       RULWHR(5) = KATTY(1)
  2093.       RULWHR(6) = KOMTYP(1)
  2094.       RULWHR(7) = KOMPOS(1)
  2095.       RULWHR(8) = KOMLEN(1)
  2096.       RULWHR(9) = KOMPOT(1)
  2097.       RULWHR(10) = KSTRT
  2098.       RULWHR(11) = MAXTU
  2099.       RULWHR(12) = LIMTU
  2100.       RULWHR(13) = WHRVAL(1)
  2101.       RULWHR(14) = WHRLEN(1)
  2102.   460 CONTINUE
  2103. C
  2104. C  PROCESS THE WHERE CLAUSE.
  2105. C
  2106.       CALL WHERE(J)
  2107.       IF(RMSTAT.NE.0) GO TO 9999
  2108.       IF(BYPASS) GO TO 480
  2109. C
  2110. C  USE THE SORT BUFFER TO SAVE THE CHANGE WHERE CLAUSE
  2111. C
  2112.       CALL BLKMOV(SORBUF,NBOO,484)
  2113.   480 CONTINUE
  2114. C
  2115. C  RESTORE THE TUPLEA POINTERS.
  2116. C
  2117.       J = LOCATT(ANAME,RNAME)
  2118.       CALL ATTGET(ISTAT)
  2119. C
  2120. C  SEQUENCE THROUGH THE DATA.
  2121. C
  2122.   500 CONTINUE
  2123.       IF(BYPASS) GO TO 510
  2124. C
  2125. C  RESTORE THE CHANGE WHERE CLAUSE
  2126. C
  2127.       CALL BLKMOV(NBOO,SORBUF,484)
  2128.       CALL RMLOOK(MAT,1,0,LENGTH)
  2129.       IF(RMSTAT.NE.0) GO TO 9999
  2130. C
  2131. C  RESTORE THE RULE WHERE CLAUSE
  2132. C
  2133.       NBOO = RULWHR(1)
  2134.       BOO(1) = RULWHR(2)
  2135.       KATTP(1) = RULWHR(3)
  2136.       KATTL(1) = RULWHR(4)
  2137.       KATTY(1) = RULWHR(5)
  2138.       KOMTYP(1) = RULWHR(6)
  2139.       KOMPOS(1) = RULWHR(7)
  2140.       KOMLEN(1) = RULWHR(8)
  2141.       KOMPOT(1) = RULWHR(9)
  2142.       KSTRT = RULWHR(10)
  2143.       MAXTU = RULWHR(11)
  2144.       LIMTU = RULWHR(12)
  2145.       WHRVAL(1) = RULWHR(13)
  2146.       WHRLEN(1) = RULWHR(14)
  2147.       GO TO 520
  2148. C
  2149. C  NO RULES
  2150. C
  2151.   510 CONTINUE
  2152.       CALL RMLOOK(MAT,1,0,LENGTH)
  2153.       IF(RMSTAT.NE.0) GO TO 9999
  2154.   520 CONTINUE
  2155.       IF(IVAL.GT.NTUPLE) GO TO 9999
  2156.       START = ATTKEY
  2157.       COLUMN = ATTCOL
  2158. C
  2159. C  CHANGE IT.
  2160. C
  2161.       IF(SINGLE) GO TO 5000
  2162.       IF(ATTWDS.EQ.0) GO TO 2000
  2163. C
  2164. C  CHANGE IS TO A FIXED LENGTH ATTRIBUTE.
  2165. C
  2166.       NEWVAL = 1
  2167.       IF(MAT(COLUMN).EQ.NVAL(1)) NEWVAL = 0
  2168.       IVOLD = MAT(COLUMN)
  2169.       K = COLUMN - 1
  2170.       DO 600 L=1,ATTWDS
  2171.       MAT(K+L) = NVAL(L)
  2172.   600 CONTINUE
  2173.   700 CONTINUE
  2174.       IF(BYPASS) GO TO 800
  2175. C
  2176. C  SEE IF THE APPLICABLE RULES ARE SATISFIED
  2177. C
  2178.       CALL CHKTUP(MAT,ISTAT)
  2179. C
  2180. C  RESTORE THE TUPLEA POINTERS
  2181. C
  2182.       IF(ISTAT.GT.0) GO TO 710
  2183.       I = LOCATT(ANAME,RNAME)
  2184.       CALL ATTGET(XSTAT)
  2185.       IF(ISTAT.EQ.0) GO TO 800
  2186.       GO TO 720
  2187.   710 CONTINUE
  2188.     if(nout.eq.6)goto 3148
  2189.       WRITE(NOUT,9005) IVAL
  2190.     goto 3149
  2191. 3148    continue
  2192.     write(c128wk,9005)ival
  2193.     call atxto
  2194. 3149    continue
  2195.       ISNOUT = NOUTR
  2196.       NOUTR = NOUT
  2197.       CALL PRULE(ISTAT)
  2198.       NOUTR = ISNOUT
  2199.       GO TO 500
  2200.   720 CONTINUE
  2201.       ISTAT = -ISTAT
  2202.     if(nout.eq.6)goto 3140
  2203.       WRITE(NOUT,9006) ISTAT
  2204.     goto 3141
  2205. 3140    continue
  2206.     write(c128wk,9006)istat
  2207.     call atxto
  2208. 3141    continue
  2209.       GO TO 500
  2210.   800 CONTINUE
  2211.       IF((START.EQ.0).OR.(NEWVAL.EQ.0)) GO TO 1000
  2212.       CALL BTREP(IVOLD,0,CID,ATTYPE)
  2213.       IF(MAT(COLUMN).EQ.NULL) GO TO 1000
  2214.       ATTKEY = START
  2215.       CALL BTADD(MAT(COLUMN),CID,ATTYPE)
  2216.       IF(ATTKEY.EQ.START) GO TO 1000
  2217.       ATTKEY = START
  2218.       CALL ATTPUT(ISTAT)
  2219.  1000 CONTINUE
  2220.       CALL PUTDAT(1,CID,MAT,LENGTH)
  2221.       NC = NC + 1
  2222.       GO TO 500
  2223. C
  2224. C  CHANGE IS TO A VARIABLE LENGTH ATTRIBUTE.
  2225. C
  2226.  2000 CONTINUE
  2227.       NEWVAL = 1
  2228. C
  2229. C  FIND THE ACTUAL COLUMN FOR VARIABLE LENGTH STUFF.
  2230. C
  2231.       COLUMN = MAT(ATTCOL)
  2232.       KURLEN = MAT(COLUMN)
  2233.       IF(KURLEN.LT.NEWL) GO TO 3000
  2234.       COLUMN = COLUMN + 2
  2235.       IF(MAT(COLUMN).EQ.NVAL(1)) NEWVAL = 0
  2236.       IVOLD = MAT(COLUMN)
  2237.       K = COLUMN - 1
  2238.       DO 2200 L=1,NEWL
  2239.       MAT(K+L) = NVAL(L)
  2240.  2200 CONTINUE
  2241. C
  2242. C  RESET THE VARIABLE LENGTH STUFF
  2243. C
  2244.       MAT(COLUMN-2) = NEWL
  2245.       MAT(COLUMN-1) = NROW
  2246.       IF(BYPASS) GO TO 2300
  2247. C
  2248. C  SEE IF THE APPLICABLE RULES ARE SATISFIED
  2249. C
  2250.       CALL CHKTUP(MAT,ISTAT)
  2251. C
  2252. C  RESTORE THE TUPLEA POINTERS
  2253. C
  2254.       IF(ISTAT.GT.0) GO TO 2210
  2255.       I = LOCATT(ANAME,RNAME)
  2256.       CALL ATTGET(XSTAT)
  2257.       IF(ISTAT.EQ.0) GO TO 2300
  2258.       GO TO 2220
  2259.  2210 CONTINUE
  2260.     if(nout.eq.6)goto 3142
  2261.       WRITE(NOUT,9005) IVAL
  2262.     goto 3143
  2263. 3142    continue
  2264.     write(c128wk,9005)ival
  2265.     call atxto
  2266. 3143    continue
  2267.       ISNOUT = NOUTR
  2268.       NOUTR = NOUT
  2269.       CALL PRULE(ISTAT)
  2270.       NOUTR = ISNOUT
  2271.       GO TO 500
  2272.  2220 CONTINUE
  2273.       ISTAT = -ISTAT
  2274.     if(nout.eq.6)goto 3144
  2275.       WRITE(NOUT,9006) ISTAT
  2276.       GO TO 500
  2277. 3144    continue
  2278.     write(c128wk,9006)istat
  2279.     call atxto
  2280.     goto 500
  2281.  2300 CONTINUE
  2282.       IF(START.EQ.0) GO TO 2600
  2283.       IF(NEWVAL.EQ.0) GO TO 2600
  2284.       CALL BTREP(IVOLD,0,CID,ATTYPE)
  2285.       IF(MAT(COLUMN).EQ.NULL) GO TO 2600
  2286.       ATTKEY = START
  2287.       CALL BTADD(MAT(COLUMN),CID,ATTYPE)
  2288.       IF(ATTKEY.EQ.START) GO TO 2600
  2289.       ATTKEY = START
  2290.       CALL ATTPUT(ISTAT)
  2291.  2600 CONTINUE
  2292.       CALL PUTDAT(1,CID,MAT,LENGTH)
  2293.       NC = NC + 1
  2294.       GO TO 500
  2295. C
  2296. C  CHANGE IS TO A VARIABLE LENGTH ATTRIBUTE WITH THE NEW VALUE
  2297. C  BIGGER THAN THE OLD VALUE.
  2298. C
  2299.  3000 CONTINUE
  2300.       EXTRA = NEWL - KURLEN
  2301.       IF((LENGTH+EXTRA).GT.MAXCOL) GO TO 8100
  2302. C
  2303. C  NOW FIX UP THE MODIFIED TUPLE.
  2304. C
  2305.       I = LOCATT(ANAME,RNAME)
  2306.       CALL ATTGET(ISTAT)
  2307.       COLUMN = MAT(ATTCOL)
  2308.       IVOLD = MAT(COLUMN+2)
  2309. C
  2310. C  FIGURE OUT HOW TO SHIFT THE VARIABLE LENGTH STUFF AROUND.
  2311. C
  2312.       ISHIFT = KURLEN + 2
  2313.       MOVE = LENGTH - ISHIFT - COLUMN + 1
  2314.       IF(MOVE.GT.0)
  2315.      X CALL BLKMOV(MAT(COLUMN),MAT(COLUMN+ISHIFT),MOVE)
  2316. C
  2317. C  NOW REBUILD ALL VARIABLE LENGTH POINTERS.
  2318. C
  2319.       I = LOCATT(BLANK,NAME)
  2320.       DO 3500 I=1,NATT
  2321.       CALL ATTGET(ISTAT)
  2322.       IF(ISTAT.NE.0) GO TO 3500
  2323.       IF(ATTWDS.NE.0) GO TO 3500
  2324.       KURCOL = ATTCOL
  2325.       IF(MAT(KURCOL).LT.COLUMN) GO TO 3500
  2326. C
  2327. C  CHANGE THE POINTER TO POINT TO THE NEW LOCATION OF THE DATA.
  2328. C
  2329.       NEWVAL = 0
  2330.       MAT(KURCOL) = MAT(KURCOL) - ISHIFT
  2331.  3500 CONTINUE
  2332. C
  2333. C  PUT THE NEW VALUE IN ITS PLACE.
  2334. C
  2335.       I = LOCATT(ANAME,RNAME)
  2336.       CALL ATTGET(ISTAT)
  2337.       MAT(ATTCOL) = LENGTH - ISHIFT + 1
  2338.       COLUMN = MAT(ATTCOL)
  2339.       MAT(COLUMN) = NEWL
  2340.       MAT(COLUMN+1) = NROW
  2341.       COLUMN = COLUMN + 2
  2342.       K = COLUMN - 1
  2343.       DO 3600 L=1,NEWL
  2344.       MAT(K+L) = NVAL(L)
  2345.  3600 CONTINUE
  2346.       IF(BYPASS) GO TO 3900
  2347. C
  2348. C  SEE IF THE APPLICABLE RULES ARE SATISFIED
  2349. C
  2350.       CALL CHKTUP(MAT,ISTAT)
  2351. C
  2352. C  RESTORE THE TUPLEA POINTERS
  2353. C
  2354.       IF(ISTAT.GT.0) GO TO 3880
  2355.       I = LOCATT(ANAME,RNAME)
  2356.       CALL ATTGET(XSTAT)
  2357.       IF(ISTAT.EQ.0) GO TO 3900
  2358.       GO TO 3890
  2359.  3880 CONTINUE
  2360.     if (nout.eq.6)goto 3245
  2361.       WRITE(NOUT,9005) IVAL
  2362.     goto 3146
  2363. 3245    continue
  2364.     write(c128wk,9005)ival
  2365. 3246    continue
  2366.       ISNOUT = NOUTR
  2367.       NOUTR = NOUT
  2368.       CALL PRULE(ISTAT)
  2369.       NOUTR = ISNOUT
  2370.       GO TO 500
  2371.  3890 CONTINUE
  2372.       ISTAT = -ISTAT
  2373.     if(nout.eq.6)goto 3247
  2374.       WRITE(NOUT,9006) ISTAT
  2375.       GO TO 500
  2376. 3247    continue
  2377.     write(c128wk,9006)istat
  2378.     goto 500
  2379.  3900 CONTINUE
  2380. C
  2381. C  OLD TUPLE MUST BE DELETED AND THE CHANGED ONE ADDED.
  2382. C
  2383.       CALL DELDAT(1,CID)
  2384. C
  2385. C  ADD THE NEW TUPLE.
  2386. C
  2387.       CALL ADDDAT(1,REND,MAT,LENGTH+EXTRA)
  2388. C
  2389. C  CHANGE THE POINTERS FOR ANY KEY ATTRIBUTES.
  2390. C
  2391.       I = LOCATT(BLANK,NAME)
  2392.       DO 3400 I=1,NATT
  2393.       CALL ATTGET(ISTAT)
  2394.       IF(ISTAT.NE.0) GO TO 3400
  2395.       IF(ATTKEY.EQ.0) GO TO 3400
  2396.       START = ATTKEY
  2397.       KSTART = ATTKEY
  2398.       COLUMN = ATTCOL
  2399.       IF(ATTWDS.NE.0) GO TO 3100
  2400.       COLUMN = MAT(COLUMN) + 2
  2401.  3100 CONTINUE
  2402.       IF(NE(ATTNAM,ANAME)) GO TO 3200
  2403.       CALL BTREP(IVOLD,0,CID,ATTYPE)
  2404.       GO TO 3400
  2405.  3200 CONTINUE
  2406.       IF(MAT(COLUMN).NE.NULL) GO TO 3300
  2407.       CALL BTREP(MAT(COLUMN),0,CID,ATTYPE)
  2408.       GO TO 3400
  2409.  3300 CONTINUE
  2410.       CALL BTREP(MAT(COLUMN),REND,CID,ATTYPE)
  2411.       IF(START.EQ.KSTART) GO TO 3400
  2412.       ATTKEY = START
  2413.       CALL ATTPUT(ISTAT)
  2414.  3400 CONTINUE
  2415. C
  2416. C  UPDATE THE KEY VALUE FOR THE NEW ATTRIBUTE VALUE
  2417. C
  2418.       I = LOCATT(ANAME,RNAME)
  2419.       CALL ATTGET(ISTAT)
  2420.       START = ATTKEY
  2421.       IF(START.EQ.0) GO TO 4000
  2422.       IF(MAT(COLUMN).EQ.NULL) GO TO 4000
  2423.       CALL BTADD(MAT(COLUMN),REND,ATTYPE)
  2424.       IF(ATTKEY.EQ.START) GO TO 4000
  2425.       ATTKEY = START
  2426.       CALL ATTPUT(ISTAT)
  2427.  4000 CONTINUE
  2428.       IF(CID.EQ.RSTART) RSTART = NID
  2429. C
  2430. C     ACTUALLY ADD THE TUPLE
  2431. C
  2432.       CALL PUTDAT(1,REND,MAT,LENGTH+EXTRA)
  2433.       NC = NC + 1
  2434.       CALL RELPUT
  2435.       GO TO 500
  2436.  5000 CONTINUE
  2437. C
  2438. C     CHANGE A SINGLE WORD
  2439. C
  2440.       IVOLD = MAT(ATTCOL)
  2441.       IF(ATTWDS.NE.0) GO TO 5100
  2442.       IP = MAT(ATTCOL)
  2443.       NW = MAT(IP)
  2444.       NR = MAT(IP+1)
  2445.       COLUMN = IP + 2
  2446.       IVOLD = MAT(COLUMN)
  2447.       IF(NR.EQ.0) NR = NW
  2448.       IF(IROW.LE.NR) GO TO 5050
  2449.       IF(IROW*ICOL.LE.NW) GO TO 5050
  2450. C
  2451. C     OUT OF RANGE
  2452. C
  2453.       NOPE = NOPE + 1
  2454.       GO TO 500
  2455.  5050 CONTINUE
  2456.       IJ = NR*(ICOL-1) + IROW
  2457.       IF(ITYPE.EQ.KZDOUB) IJ = 2*IJ - 1
  2458.       IP = IP + IJ + 1
  2459.  5100 CONTINUE
  2460.       NEWVAL = 1
  2461.       IF(MAT(IP).EQ.NVAL(1)) NEWVAL = 0
  2462.       MAT(IP) = NVAL(1)
  2463.       IF(ITYPE.EQ.KZDOUB) MAT(IP+1) = NVAL(2)
  2464.       IF(IROW.NE.1) NEWVAL = 0
  2465.       IF(ICOL.NE.1) NEWVAL = 0
  2466.       GO TO 700
  2467. C
  2468. C  TUPLE LENGTH EXCCEDS MAXCOL
  2469. C
  2470.  8100 CONTINUE
  2471.     if(nout.eq.6)goto 3248
  2472.       WRITE(NOUT,8110) MAXCOL
  2473.  8110 FORMAT(36H -ERROR- Relation Row Length Exceeds,I5)
  2474.       GO TO 9999
  2475. 3248    continue
  2476.     write(c128wk,8110)maxcol
  2477.     call atxto
  2478.     goto 9999
  2479. C
  2480. C  DONE
  2481. C
  2482.  9999 CONTINUE
  2483.     if(nout.eq.6)goto 35
  2484.       WRITE(NOUT,9003) NC,NAME
  2485.  9003 FORMAT(2X,I6,26H ROWS Changed In Relation ,A8)
  2486.       IF(NOPE.EQ.0) RETURN
  2487.       WRITE(NOUT,9004)NOPE
  2488.  9004 FORMAT(11H -WARNING- ,I5,33H Rows Had Incompatible Dimensions )
  2489.       RETURN
  2490. 35    continue
  2491.       WRITE(c128wk,9003) NC,NAME
  2492.     call atxto
  2493.       IF(NOPE.EQ.0) RETURN
  2494.       WRITE(c128wk,9004)NOPE
  2495.     call atxto
  2496.     return
  2497.  9005 FORMAT(12H -ERROR- ROW,I4,22H Fails To Satisfy The ,
  2498.      X       14HFollowing RULE)
  2499.  9006 FORMAT(32H -ERROR- Unable To Process RULE ,I3)
  2500.       END
  2501.       SUBROUTINE CHKATT(JUNK,NUMELE,ERROR)
  2502.       INCLUDE rin:TEXT.BLK
  2503. C
  2504. C  THIS ROUTINE EDITS THE ATTRIBUTE LIST ON THE RELATION CARDS
  2505. C  AND CREATES THE NEW RELATIONS BASED ON THE CARDS.  THE EXISTENCE
  2506. C  OF THESE NEW RELATIONS IS RECORDED IN RIMS INTERNAL TABLES.
  2507. C
  2508. C  PARAMETERS:
  2509. C         JUNK----SCRATCH ARRAY WITH NEW ATTRIBUTE NAMES
  2510. C         NUMELE--THE NUMBER OF ATTRIBUTES IN JUNK
  2511. C         ERROR---COUNT OF THE ERRORS ENCOUNTERED
  2512. C
  2513.       INCLUDE rin:TUPLEA.BLK
  2514.       INCLUDE rin:TUPLER.BLK
  2515.       INCLUDE rin:FILES.BLK
  2516.       INCLUDE rin:MISC.BLK
  2517. C
  2518.       INTEGER ERROR
  2519.       LOGICAL EQ
  2520.       INTEGER IFLAG
  2521.       INTEGER CSTART
  2522.       INTEGER JUNK(5,*)
  2523.       INCLUDE rin:DCLAR1.BLK
  2524. C
  2525.       NCOLS = 0
  2526.       IFLAG = 0
  2527. C
  2528. C  SEARCH THE LIST
  2529. C
  2530.       ITEMS = LXITEM(IDUMMY)
  2531.       RNAME = BLANK
  2532.       DO 600 I=3,ITEMS
  2533.       ANAME = BLANK
  2534.       CALL LXSREC(I,1,8,ANAME,1)
  2535. C
  2536. C  LOOK FOR THIS ATTRIBUTE AMONG EXISTING ATTRIBUTES.
  2537. C
  2538.       J = LOCATT(ANAME,RNAME)
  2539.       IF(J.NE.0) GO TO 100
  2540.       CALL ATTGET(IDUMMY)
  2541.       NCHAR = ATTCHA
  2542.       NWORDS = ATTWDS
  2543.       GO TO 500
  2544. C
  2545. C  LOOK FOR THIS ATTRIBUTE AMONG NEW ATTRIBUTES.
  2546. C
  2547.   100 CONTINUE
  2548.       IF(NUMELE.EQ.0) GO TO 300
  2549.       DO 200 J=1,NUMELE
  2550.       IF(EQ(JUNK(1,J),ANAME)) GO TO 400
  2551.   200 CONTINUE
  2552. C
  2553. C  CANNOT FIND THIS ATTRIBUTE.
  2554. C
  2555.   300 CONTINUE
  2556.     if(nout.eq.6)goto 3140
  2557.       WRITE(NOUT,9000) ANAME
  2558.     goto 3141
  2559. 3140    continue
  2560.     write(c128wk,9000) aname
  2561.     call atxto
  2562. 3141    continue
  2563.  9000 FORMAT(9H -ERROR- ,A8,26H is an Undefined Attribute )
  2564.       ERROR = ERROR + 1
  2565.       IFLAG = 1
  2566.       GO TO 600
  2567.   400 CONTINUE
  2568.       CALL ITOH(NCHAR,NWORDS,JUNK(4,J))
  2569.   500 CONTINUE
  2570. C
  2571. C  THE NUMBER OF WORDS NEEDED DEPEND ON THE ATTRIBUTE TYPE.
  2572. C
  2573.       IF(NWORDS.EQ.0) NWORDS = 1
  2574.       NCOLS = NCOLS + NWORDS
  2575.   600 CONTINUE
  2576.       IF(IFLAG.EQ.1) GO TO 999
  2577.       IF(NCOLS.LE.MAXCOL) GO TO 700
  2578.     if(nout.eq.6)goto 3142
  2579.       WRITE(NOUT,9001) MAXCOL
  2580.     goto 3143
  2581. 3142    continue
  2582.     write(c128wk,9001)maxcol
  2583.     call atxto
  2584. 3143    continue
  2585.  9001 FORMAT(36H -ERROR- Relation Row Length Exceeds,I5)
  2586.       ERROR = ERROR + 1
  2587.       GO TO 999
  2588.   700 CONTINUE
  2589. C
  2590. C  LOAD THIS RELATION USING TUPLER AND TUPLEA.
  2591. C
  2592.       RNAME = BLANK
  2593.       CALL LXSREC(1,1,8,RNAME,1)
  2594.       NATT = ITEMS - 2
  2595.       CALL ATTNEW(RNAME,NATT)
  2596. C
  2597. C  SET UP THE NEW TUPLER.
  2598. C
  2599.       NAME = RNAME
  2600.       CALL RMDATE(RDATE)
  2601.       NCOL = NCOLS
  2602.       NTUPLE = 0
  2603.       RSTART = 0
  2604.       REND = 0
  2605.       RPW = NONE
  2606.       MPW = NONE
  2607.       CALL RELADD
  2608. C
  2609. C  NOW ADD TO THE ATTRIBUTE RELATION VIA TUPLEA.
  2610. C
  2611.       CSTART = 1
  2612.       DO 1600 I=3,ITEMS
  2613.       ANAME = BLANK
  2614.       CALL LXSREC(I,1,8,ANAME,1)
  2615. C
  2616. C  LOOK FOR THIS ATTRIBUTE AMONG EXISTING ATTRIBUTES.
  2617. C
  2618.       RNAME = BLANK
  2619.       J = LOCATT(ANAME,RNAME)
  2620.       IF(J.NE.0) GO TO 1100
  2621.       CALL ATTGET(IDUMMY)
  2622.       RELNAM = NAME
  2623.       ATTCOL = CSTART
  2624.       GO TO 1500
  2625. C
  2626. C  LOOK FOR THIS ATTRIBUTE AMONG NEW ATTRIBUTES.
  2627. C
  2628.  1100 CONTINUE
  2629.       IF(NUMELE.EQ.0) GO TO 1500
  2630.       DO 1200 J=1,NUMELE
  2631.       IF(EQ(JUNK(1,J),ANAME)) GO TO 1400
  2632.  1200 CONTINUE
  2633.  1400 CONTINUE
  2634.       ATTNAM = ANAME
  2635.       RELNAM = NAME
  2636.       ATTCOL = CSTART
  2637.       ATTLEN = JUNK(4,J)
  2638.       ATTYPE = JUNK(3,J)
  2639.       ATTKEY = JUNK(5,J)
  2640.  1500 CONTINUE
  2641.       CALL ITOH(NCHAR,NWORDS,ATTLEN)
  2642.       IF(NWORDS.EQ.0) NWORDS = 1
  2643.       CSTART = CSTART + NWORDS
  2644.       IF(ATTKEY.NE.0) CALL BTINIT(ATTKEY)
  2645.       CALL ATTADD
  2646.  1600 CONTINUE
  2647. C
  2648. C  DONE
  2649. C
  2650.   999 RETURN
  2651.       END
  2652.       SUBROUTINE CHKREL (PERM,WORD1,ISTAT,NAMOWN)
  2653.       INCLUDE rin:TEXT.BLK
  2654. C
  2655. C  PURPOSE:  CHECKS PERMISSION TO SEE IF USER CAN UNLOAD THIS
  2656. C            RELATION.  PERM SET TO TRUE IF USER CAN.
  2657. C
  2658. C  INPUTS:
  2659. C            WORD1-------COMMAND SPECIFIED (ALL,DATA,OR SCHEMA)
  2660. C          ISTAT------------WAS THE RELATION GET SUCCESSFUL?
  2661. C          NAMOWN-----------USERID
  2662. C
  2663. C  OUTPUT:
  2664. C            PERM-------TRUE IF USER HAS PERMISSION TO UNLOAD
  2665. C                       FALSE OTHERWISE
  2666. C
  2667.       INCLUDE rin:CONST4.BLK
  2668.       INCLUDE rin:CONST8.BLK
  2669.       INCLUDE rin:DCLAR2.BLK
  2670.       INCLUDE rin:DCLAR6.BLK
  2671.       INCLUDE rin:TUPLER.BLK
  2672.       INCLUDE rin:FLAGS.BLK
  2673.       INTEGER ISTAT
  2674.       LOGICAL PERM
  2675.       PERM = .TRUE.
  2676.       CALL RELGET (ISTAT)
  2677.       IF (ISTAT .NE. 0) GO TO 10
  2678. C
  2679. C  CHECK FOR RULES RELATION
  2680. C
  2681.       IF((NAME.EQ.K8RRC).OR.(NAME.EQ.K8RDT)) GO TO 10
  2682. C
  2683. C  CHECK FOR OWNER
  2684. C
  2685.       IF(OWNER.EQ.NAMOWN) GO TO 20
  2686. C
  2687. C  CHECK FOR MODIFY PASSWORD
  2688. C
  2689.       IF ((MPW .EQ. K4NONE) .OR. (MPW .EQ. NAMOWN)) GO TO 20
  2690.    10 CONTINUE
  2691.       PERM = .FALSE.
  2692.    20 CONTINUE
  2693.       RETURN
  2694.       END
  2695.       SUBROUTINE CHKRUL(RNAME)
  2696.       INCLUDE rin:TEXT.BLK
  2697. C
  2698. C  PURPOSE: CHECK IF RULES APPLY TO THE CURRENT RELATION
  2699. C
  2700. C  PARAMETERS:  RNAME--RELATION NAME TO CHECK
  2701. C
  2702.       INCLUDE rin:CONST4.BLK
  2703.       INCLUDE rin:CONST8.BLK
  2704.       INCLUDE rin:RIMCOM.BLK
  2705.       INCLUDE rin:RULCOM.BLK
  2706.       INCLUDE rin:TUPLEA.BLK
  2707.       INCLUDE rin:MISC.BLK
  2708.       INCLUDE rin:RIMPTR.BLK
  2709.       INCLUDE rin:BUFFER.BLK
  2710.       INCLUDE rin:WHCOM.BLK
  2711.       INCLUDE rin:DCLAR1.BLK
  2712.       RULES = .TRUE.
  2713. C
  2714. C  LOCATE THE RULES RELATION
  2715. C
  2716.       I = LOCREL(RIMRRC)
  2717.       IF(I.EQ.0) GO TO 100
  2718.       RULES = .FALSE.
  2719.       GO TO 999
  2720. C
  2721. C  SET UP A WHERE CLAUSE FOR THE RULES RELATION
  2722. C
  2723.   100 CONTINUE
  2724.       NBOO = 0
  2725.       I = LOCATT(K8NAM,RIMRRC)
  2726.       IF(I.NE.0) GO TO 200
  2727.       CALL ATTGET(I)
  2728.       IF(I.EQ.0) GO TO 300
  2729. C
  2730. C  BAD RULES RELATION
  2731. C
  2732.   200 CONTINUE
  2733.       RULES = .FALSE.
  2734.       RMSTAT = 110
  2735.       GO TO 999
  2736. C
  2737. C  LOAD WHCOM
  2738. C
  2739.   300 CONTINUE
  2740.       NBOO = 1
  2741.       BOO(1) = K4AND
  2742.       KATTP(1) = ATTCOL
  2743.       KATTL(1) = ATTLEN
  2744.       KATTY(1) = ATTYPE
  2745.       KOMTYP(1) = 2
  2746.       KOMPOS(1) = 1
  2747.       KOMLEN(1) = 1
  2748.       KOMPOT(1) = 1
  2749.       KSTRT = 0
  2750.       MAXTU = ALL9S
  2751.       LIMTU = ALL9S
  2752.       WHRVAL(1) = IBLANK
  2753.       CALL STRMOV(RNAME,1,8,WHRVAL,1)
  2754.       WHRLEN(1) = ATTLEN
  2755.       NS = 0
  2756. C
  2757. C  RETRIEVE THE RULE NUMBERS THAT APPLY AND STORE IN RULNUM
  2758. C
  2759.       RULCNT = 0
  2760.   400 CONTINUE
  2761.       CALL RMLOOK(IP,2,1,LEN)
  2762.       IF(RMSTAT.NE.0) GO TO 500
  2763.       RULCNT = RULCNT + 1
  2764.       IF(RULCNT.LE.10) GO TO 450
  2765. C
  2766. C  TOO MANY RULES
  2767. C
  2768.       RULES = .FALSE.
  2769.       RMSTAT = 111
  2770.       GO TO 999
  2771.   450 CONTINUE
  2772.       RULNUM(RULCNT) = BUFFER(IP+2)
  2773.       GO TO 400
  2774. C
  2775. C IF RULES APPLY SET UP DATA POINTERS AND WHERE CLAUSE FOR RULE NUMBERS
  2776. C
  2777.   500 CONTINUE
  2778.       IF(RULCNT.NE.0) GO TO 600
  2779.       RULES = .FALSE.
  2780.       GO TO 999
  2781. C
  2782. C  SET RELATION POINTERS
  2783. C
  2784.   600 CONTINUE
  2785.       I = LOCREL(RIMRDT)
  2786.       IF(I.EQ.0) GO TO 700
  2787.       RULES = .FALSE.
  2788.       RMSTAT = 110
  2789.       GO TO 999
  2790. C
  2791. C  STORE THE RELATION POINTERS IN RULPTR
  2792. C
  2793.   700 CONTINUE
  2794.       CALL BLKMOV(RULPTR,IVAL,6)
  2795. C
  2796. C  LOAD WHCOM
  2797. C
  2798.       I = LOCATT(K8NUM,RIMRDT)
  2799.       IF(I.NE.0) GO TO 200
  2800.       CALL ATTGET(I)
  2801.       IF(I.NE.0) GO TO 200
  2802.       KATTP(1) = ATTCOL
  2803.       KATTL(1) = ATTLEN
  2804.       KATTY(1) = ATTYPE
  2805.       WHRVAL(1) = 0
  2806.       WHRLEN(1) = ATTLEN
  2807. C
  2808.   999 CONTINUE
  2809.       RETURN
  2810.       END
  2811.       SUBROUTINE CHKTUP(TUPLE,ISTAT)
  2812.       INCLUDE rin:TEXT.BLK
  2813. C
  2814. C  PURPOSE:  THIS ROUTINE SEES IF A TUPLE SATISFIES THE RULE.
  2815. C
  2816. C  PARAMETERS:
  2817. C         TUPLE---DATA MATRIX TUPLE
  2818. C         RNAME---RELATION NAME
  2819. C         ISTAT---STATUS FLAG  0 FOR OK, 1 FOR NOT OK, -1 FOR TILT
  2820.       INCLUDE rin:RMATTS.BLK
  2821.       INCLUDE rin:CONST4.BLK
  2822.       INCLUDE rin:RIMCOM.BLK
  2823.       INCLUDE rin:MISC.BLK
  2824.       INCLUDE rin:RIMPTR.BLK
  2825.       INCLUDE rin:TUPLEA.BLK
  2826.       INCLUDE rin:TUPLER.BLK
  2827.       INCLUDE rin:RULCOM.BLK
  2828.       INCLUDE rin:WHCOM.BLK
  2829.       INCLUDE rin:RELTBL.BLK
  2830. C
  2831.       INCLUDE rin:FLAGS.BLK
  2832.       INCLUDE rin:DCLAR1.BLK
  2833. C  DIMENSION STATEMENTS.
  2834. C
  2835.       LOGICAL OK,QUAL
  2836.       INTEGER TUPLE(*)
  2837.       INTEGER ARRAY(24)
  2838.       INTEGER KOM(6)
  2839.       INTEGER SAVTUR(13)
  2840.       INTEGER SAVTUP(6)
  2841.       INTEGER SAVSCR(25)
  2842.       EQUIVALENCE (KOM(1),K4KOM(1))
  2843. C
  2844. C     NO TOLERANCE FOR RULES
  2845. C
  2846.       TOLSAV = TOL
  2847.       TOL = 0.
  2848. C
  2849. C  SAVE THE DATA FOR THE RELATION BEING LOADED
  2850. C
  2851.       RNAME = NAME
  2852.       MWDS = 5 + ((8-1)/CHPWD + 1)*4
  2853.       CALL BLKMOV(SAVTUR,NAME,MWDS)
  2854.       CALL BLKMOV(SAVTUP,IVAL,6)
  2855. C
  2856. C  PROCESS THE RULES
  2857. C
  2858.       QUAL = .TRUE.
  2859.       DO 2000 K=1,RULCNT
  2860. C
  2861. C  RESTORE THE RULE RELATION POINTERS
  2862. C
  2863.       CALL BLKMOV(IVAL,RULPTR,6)
  2864.       WHRVAL(1) = RULNUM(K)
  2865. C
  2866. C  SET UP TO FIND THIS RULE.
  2867. C
  2868.   100 CONTINUE
  2869.       CALL RMLOOK(ARRAY,2,0,LEN)
  2870.       IF(RMSTAT.NE.0) GO TO 1000
  2871. C
  2872. C  GET THE ATTRIBUTE NAME.
  2873. C
  2874.       I = LOCATT(ARRAY(4),RNAME)
  2875.       IF(I.NE.0) GO TO 9997
  2876.       CALL ATTGET(JSTAT)
  2877.       IF(JSTAT.NE.0) GO TO 9997
  2878.       NATTP = ATTCOL
  2879.       IF(ATTWDS.NE.0) GO TO 200
  2880. C
  2881. C  VARIABLE LENGTH ATTRIBUTE.
  2882. C
  2883.       NATTP = TUPLE(NATTP)
  2884.       ATTWDS = TUPLE(NATTP)
  2885.       ATTCHA = 0
  2886.       IF(ATTYPE.EQ.KZTEXT) ATTCHA = TUPLE(NATTP+1)
  2887.       IF(ATTYPE.EQ.KZIMAT) ATTCHA = TUPLE(NATTP+1)
  2888.       IF(ATTYPE.EQ.KZRMAT) ATTCHA = TUPLE(NATTP+1)
  2889.       IF(ATTYPE.EQ.KZDMAT) ATTCHA = TUPLE(NATTP+1)
  2890.       NATTP = NATTP + 2
  2891.   200 CONTINUE
  2892.       ITYPE = ATTYPE
  2893. C
  2894. C  GET THE BOOLEAN OPERATOR.
  2895. C
  2896.       NBOOT = LOCBOO(ARRAY(8))
  2897.       IF(NBOOT.GT.10) GO TO 300
  2898. C
  2899. C  VALUE COMPARISON.
  2900. C
  2901.       OK = .FALSE.
  2902.       CALL KOMPXX(TUPLE(NATTP),ARRAY(15),ATTWDS,NBOOT,OK,ITYPE)
  2903.       GO TO 600
  2904. C
  2905. C  ATTRIBUTE COMPARISON.
  2906. C  SAVE THE CURRENT RULE POINTERS AND WHERE STUFF
  2907. C
  2908.   300 CONTINUE
  2909.       CALL BLKMOV(SAVSCR,IVAL,6)
  2910.       SAVSCR(7) = NBOO
  2911.       SAVSCR(8) = BOO(1)
  2912.       SAVSCR(9) = KATTP(1)
  2913.       SAVSCR(10) = KATTL(1)
  2914.       SAVSCR(11) = KATTY(1)
  2915.       SAVSCR(12) = KOMTYP(1)
  2916.       SAVSCR(13) = KOMPOS(1)
  2917.       SAVSCR(14) = KOMLEN(1)
  2918.       SAVSCR(15) = KOMPOT(1)
  2919.       SAVSCR(16) = KSTRT
  2920.       SAVSCR(17) = MAXTU
  2921.       SAVSCR(18) = LIMTU
  2922.       SAVSCR(19) = WHRVAL(1)
  2923.       SAVSCR(20) = WHRVAL(2)
  2924.       SAVSCR(21) = WHRLEN(1)
  2925.       CALL BLKMOV(SAVSCR(22),LRROW,4)
  2926. C
  2927. C  PREPARE TO CALL RMLOOK.
  2928. C
  2929.       NBOOT = NBOOT - 11
  2930.       NP = NATTP - 1
  2931.       DO 400 I=1,ATTWDS
  2932.       WHRVAL(I) = TUPLE(NP+I)
  2933.   400 CONTINUE
  2934.       CALL HTOI(ATTCHA,ATTWDS,WHRLEN(1))
  2935.       RMSTAT = 0
  2936.       I = LOCREL(ARRAY(13))
  2937.       IF(I.NE.0) GO TO 500
  2938. C
  2939. C  SET UP A WHERE CLAUSE FOR THE ATTRIBUTE VALUE
  2940. C
  2941.       NBOO = 0
  2942.       I = LOCATT(ARRAY(11),ARRAY(13))
  2943.       IF(I.NE.0) GO TO 500
  2944.       CALL ATTGET(I)
  2945.       IF(I.NE.0) GO TO 500
  2946.       NBOO = 1
  2947.       BOO(1) = K4AND
  2948.       KATTP(1) = ATTCOL
  2949.       KATTL(1) = ATTLEN
  2950.       KATTY(1) = ATTYPE
  2951.       KOMTYP(1) = LOCBOO(KOM(NBOOT))
  2952.       KOMPOS(1) = 1
  2953.       KOMLEN(1) = 1
  2954.       KOMPOT(1) = 1
  2955.       CALL RMLOOK(NP,1,1,LEN)
  2956.   500 CONTINUE
  2957.       OK = .FALSE.
  2958.       IF(RMSTAT.EQ.0) OK = .TRUE.
  2959.       IF(NBOOT.NE.1) OK = .NOT.OK
  2960. C
  2961. C  RESTORE THE POINTERS AND THE WHERE CLAUSE
  2962. C
  2963.       CALL BLKMOV(IVAL,SAVSCR,6)
  2964.       NBOO = SAVSCR(7)
  2965.       BOO(1) = SAVSCR(8)
  2966.       KATTP(1) = SAVSCR(9)
  2967.       KATTL(1) = SAVSCR(10)
  2968.       KATTY(1) = SAVSCR(11)
  2969.       KOMTYP(1) = SAVSCR(12)
  2970.       KOMPOS(1) = SAVSCR(13)
  2971.       KOMLEN(1) = SAVSCR(14)
  2972.       KOMPOT(1) = SAVSCR(15)
  2973.       KSTRT = SAVSCR(16)
  2974.       MAXTU = SAVSCR(17)
  2975.       LIMTU = SAVSCR(18)
  2976.       WHRVAL(1) = SAVSCR(19)
  2977.       WHRVAL(2) = SAVSCR(20)
  2978.       WHRLEN(1) = SAVSCR(21)
  2979.       CALL BLKMOV(LRROW,SAVSCR(22),4)
  2980.   600 CONTINUE
  2981.       IF(ARRAY(2).EQ.K4AND) QUAL = QUAL.AND.OK
  2982.       IF(ARRAY(2).EQ.K4OR) QUAL = QUAL.OR.OK
  2983. C
  2984. C  GO GET THE NEXT CONDITION IN THIS RULE.
  2985. C
  2986.       GO TO 100
  2987. C
  2988. C  DONE WITH A RULE.
  2989. C
  2990.  1000 CONTINUE
  2991.       ISTAT = 1
  2992.       IF(QUAL) ISTAT = 0
  2993.       IF(ISTAT.NE.0) GO TO 9998
  2994.  2000 CONTINUE
  2995.       GO TO 9999
  2996. C
  2997. C  TUPLE FAILS TO SATISFY RULE
  2998. C
  2999.  9998 CONTINUE
  3000.       ISTAT = RULNUM(K)
  3001.       GO TO 9999
  3002. C
  3003. C  UNABLE TO PROCESS RULES
  3004. C
  3005.  9997 CONTINUE
  3006.       ISTAT = -RULNUM(K)
  3007.  9999 CONTINUE
  3008. C
  3009. C  RESTORE THE RELATION DATA
  3010. C
  3011.       CALL BLKMOV(NAME,SAVTUR,MWDS)
  3012.       I = LOCREL(NAME)
  3013.       LRROW = LRROW + 1
  3014.       CALL BLKMOV(IVAL,SAVTUP,6)
  3015.       TOL = TOLSAV
  3016.       RETURN
  3017.       END
  3018.       SUBROUTINE CMPUTE
  3019.       INCLUDE rin:TEXT.BLK
  3020. C
  3021. C  PURPOSE:    PROCESS COMPUTE COMMANDS
  3022. C
  3023. C
  3024.       INCLUDE rin:RMATTS.BLK
  3025.       INCLUDE rin:RMKEYW.BLK
  3026.       INCLUDE rin:CONST4.BLK
  3027.       INCLUDE rin:FILES.BLK
  3028.       INCLUDE rin:MISC.BLK
  3029.       INCLUDE rin:TUPLEA.BLK
  3030.       INCLUDE rin:TUPLER.BLK
  3031.       INCLUDE rin:RIMCOM.BLK
  3032.       INCLUDE rin:BUFFER.BLK
  3033. C  DATA AND DIMENSION:
  3034.       INTEGER FTYPE
  3035.       INTEGER KVAL
  3036.       REAL RVAL
  3037.       EQUIVALENCE (KVAL,RVAL)
  3038.       INTEGER LINE(7)
  3039.       LOGICAL EQKEYW
  3040.       INCLUDE rin:DCLAR1.BLK
  3041.       INCLUDE rin:DCLAR6.BLK
  3042. C
  3043. C  FIND THE ATTRIBUTE IN THE ATTRIBUTE TABLE.
  3044.       INTEGER SWITCP
  3045.       INTEGER IT(5)
  3046.       REAL RIT(5)
  3047.       EQUIVALENCE (IT,RIT)
  3048.       LIT = (20-1)/CHPWD+1
  3049. C
  3050.       ANAME = BLANK
  3051.       CALL LXSREC(3,1,8,ANAME,1)
  3052.       I = LOCATT(ANAME,NAME)
  3053.       IF(I.EQ.0) GO TO 100
  3054.       CALL WARN(3,ANAME,NAME)
  3055.       GO TO 9999
  3056.   100 CONTINUE
  3057. C
  3058. C  GET THE TYPE AND LENGTH FOR THIS ATTRIBUTE.
  3059. C
  3060.       CALL ATTGET(ISTAT)
  3061.       CALL TYPER(ATTYPE,MATVEC,ITYPE)
  3062. C
  3063. C  DETERMINE THE TYPE OF FUNCTION REQUESTED.
  3064. C
  3065.       FTYPE = 0
  3066.       IF(LXWREC(2,1).EQ.K4MIN ) FTYPE = 1
  3067.       IF(LXWREC(2,1).EQ.K4MAX ) FTYPE = 2
  3068.       IF(LXWREC(2,1).EQ.K4AVE ) FTYPE = 3
  3069.       IF(LXWREC(2,1).EQ.K4SUM ) FTYPE = 4
  3070.       IF(EQKEYW(2,KWCOUN,5)) FTYPE = 5
  3071.       IF(FTYPE.NE.0) GO TO 300
  3072.     if(nout.eq.6)goto 3144
  3073.       WRITE(NOUT,9000)
  3074.  9000 FORMAT(35H -ERROR- Unrecognized Function Type  )
  3075.       GO TO 9999
  3076. 3144    continue
  3077.     write(c128wk,9000)
  3078.     call atxto
  3079.     goto 9999
  3080. C
  3081. C  PROCESS THE FUNCTION.
  3082. C
  3083.   300 CONTINUE
  3084.       IF(ATTWDS.LT.LIT) LIT = ATTWDS
  3085.       WHAT = BLANK
  3086.       CALL LXSREC(2,1,8,WHAT,1)
  3087.       IF(FTYPE.GT.2) GO TO 550
  3088. C
  3089. C  MIN - MAX
  3090. C
  3091.       IF(ATTWDS.EQ.1) GO TO 320
  3092.       IF((ATTWDS.EQ.2).AND.(ITYPE.EQ.KZDOUB)) GO TO 320
  3093.       IF((ATTWDS.GT.0).AND.(ITYPE.EQ.KZTEXT)) GO TO 320
  3094.       GO TO 8000
  3095. C
  3096. C  GET THE FIRST TUPLE
  3097. C
  3098.   320 CONTINUE
  3099.       CALL RMLOOK(IP,1,1,LENGTH)
  3100.       IPX = IP+ATTCOL-2
  3101.   325 CONTINUE
  3102.       DO 330 K=1,LIT
  3103.       IT(K) = BUFFER(IPX+K)
  3104.   330 CONTINUE
  3105.   350 CONTINUE
  3106.       CALL RMLOOK(IP,1,1,LENGTH)
  3107.       IF(RMSTAT.NE.0) GO TO 500
  3108.       IPX = IP+ATTCOL-2
  3109.       IF(BUFFER(IPX+1).EQ.NULL) GO TO 350
  3110.       IF(IT(1).EQ.NULL) GO TO 325
  3111.       IF(ITYPE.NE.KZTEXT) GO TO 390
  3112. C
  3113. C  TEXT COMPARE
  3114. C
  3115.       DO 360 K=1,LIT
  3116.       J = SWITCP(IT(K),BUFFER(IPX+K))
  3117.       IF(J.GT.0) GO TO 370
  3118.       IF(J.LT.0) GO TO 380
  3119.   360 CONTINUE
  3120.       GO TO 350
  3121.   370 CONTINUE
  3122.       IF(FTYPE.EQ.2) GO TO 325
  3123.       GO TO 350
  3124.   380 CONTINUE
  3125.       IF(FTYPE.EQ.1) GO TO 325
  3126.       GO TO 350
  3127. C
  3128. C  REAL,INT,DOUBLE
  3129. C
  3130.   390 CONTINUE
  3131.       IF(ITYPE.NE.KZINT) GO TO 400
  3132.       IF((FTYPE.EQ.1).AND.(BUFFER(IPX+1).LT.IT(1))) GO TO 325
  3133.       IF((FTYPE.EQ.2).AND.(BUFFER(IPX+1).GT.IT(1))) GO TO 325
  3134.       GO TO 350
  3135.   400 CONTINUE
  3136.       KVAL = BUFFER(IPX+1)
  3137.       IF((FTYPE.EQ.1).AND.(RVAL.LT.RIT(1))) GO TO 325
  3138.       IF((FTYPE.EQ.2).AND.(RVAL.GT.RIT(1))) GO TO 325
  3139.       GO TO 350
  3140.   500 CONTINUE
  3141.       GO TO 2000
  3142.   550 CONTINUE
  3143.       IF(FTYPE.GT.4) GO TO 750
  3144. C
  3145. C  AVE OR SUM.
  3146. C
  3147.       IF(ITYPE.EQ.KZDOUB) GO TO 560
  3148.       IF(ATTWDS.NE.1) GO TO 8000
  3149. C
  3150. C  DETERMINE IF WE HAVE REAL OR INT TYPE.
  3151. C
  3152.       IF(ITYPE.EQ.KZINT) GO TO 650
  3153.       IF(ITYPE.NE.KZREAL) GO TO 8100
  3154. C
  3155. C  REAL ATTRIBUTE.
  3156. C
  3157.   560 CONTINUE
  3158.       IF(ATTWDS.GT.2) GO TO 8000
  3159.       KOUNT = 0
  3160.       TOT = 0.0
  3161.   575 CONTINUE
  3162.       CALL RMLOOK(IP,1,1,LENGTH)
  3163.       IF(RMSTAT.NE.0) GO TO 625
  3164.       IF(BUFFER(IP+ATTCOL-1).EQ.NULL) GO TO 600
  3165.       KOUNT = KOUNT + 1
  3166.       KVAL = BUFFER(IP+ATTCOL-1)
  3167.       TOT = TOT + RVAL
  3168.   600 CONTINUE
  3169.       GO TO 575
  3170.   625 CONTINUE
  3171.       AVE = NULL
  3172.       IF(KOUNT.NE.0) AVE = TOT / FLOAT(KOUNT)
  3173.       RVAL = TOT
  3174.       IT(1) = KVAL
  3175.       IF(FTYPE.NE.3) GO TO 2000
  3176.       RVAL = AVE
  3177.       IT(1) = KVAL
  3178.       GO TO 2000
  3179.   650 CONTINUE
  3180. C
  3181. C  INT ATTRIBUTE.
  3182. C
  3183.       KOUNT = 0
  3184.       ITOT = 0
  3185.   675 CONTINUE
  3186.       CALL RMLOOK(IP,1,1,LENGTH)
  3187.       IF(RMSTAT.NE.0) GO TO 725
  3188.       IF(BUFFER(IP+ATTCOL-1).EQ.NULL) GO TO 700
  3189.       KOUNT = KOUNT + 1
  3190.       ITOT = ITOT + BUFFER(IP+ATTCOL-1)
  3191.   700 CONTINUE
  3192.       GO TO 675
  3193.   725 CONTINUE
  3194.       IAVE = NULL
  3195.       IF(KOUNT.NE.0) IAVE = ITOT / KOUNT
  3196.       IT(1) = ITOT
  3197.       IF(FTYPE.EQ.3) IT(1) = IAVE
  3198.       GO TO 2000
  3199.   750 CONTINUE
  3200. C
  3201. C  COUNT.
  3202. C
  3203.       KOUNT = 0
  3204.   775 CONTINUE
  3205.       CALL RMLOOK(IP,1,1,LENGTH)
  3206.       IF(RMSTAT.NE.0) GO TO 800
  3207.       KOUNT = KOUNT + 1
  3208.       GO TO 775
  3209.   800 CONTINUE
  3210.       IT(1) = KOUNT
  3211.       ITYPE = KZINT
  3212. C
  3213. C  PRINT OUT THE RESULTS.
  3214. C
  3215.  2000 CONTINUE
  3216. C
  3217. C  BLANK FILL LINE
  3218. C
  3219.       DO 2010 I=1,7
  3220.  2010 LINE(I) = IBLANK
  3221.       IF(IT(1).NE.NULL) GO TO 2050
  3222. C
  3223. C  NULL VALUE
  3224. C
  3225.       CALL STRMOV(NULL,1,3,LINE,7)
  3226.       GO TO 2100
  3227. C
  3228. C  WE HAVE A VALUE
  3229. C
  3230.  2050 CONTINUE
  3231.       IF(ITYPE.EQ.KZINT) CALL ITOC(LINE,7,10,IT,IERR)
  3232.       IF(ITYPE.EQ.KZREAL) CALL RTOC(LINE,7,10,IT)
  3233.       IF(ITYPE.EQ.KZDOUB) CALL RTOC(LINE,7,10,IT)
  3234.       IF(ITYPE.EQ.KZTEXT) CALL STRMOV(IT,1,CHPWD*LIT,LINE,7)
  3235.  2100 CONTINUE
  3236.     if(noutr.eq.6)goto 3146
  3237.       WRITE(NOUTR,9100) WHAT,ANAME
  3238.  9100 FORMAT(3X,A6,A8)
  3239.       WRITE(NOUTR,9200)
  3240.  9200 FORMAT(27H   ------------------------)
  3241.       CALL SPOUT(LINE,28)
  3242.       GO TO 9999
  3243. 3146    continue
  3244.       WRITE(c128wk,9100) WHAT,ANAME
  3245.     call atxto
  3246.       WRITE(c128wk,9200)
  3247.     call atxto
  3248.       CALL SPOUT(LINE,28)
  3249.     goto 9999
  3250. C
  3251. C  ERROR MESSAGES.
  3252. C
  3253. C  ATTRIBUTE LENGTH IS GREATER THAN 1.
  3254. C
  3255.  8000 CONTINUE
  3256.     if(nout.eq.6)goto 3147
  3257.       WRITE(NOUT,9400)
  3258.  9400 FORMAT(26H -ERROR- FUNCTION Will Not,
  3259.      X       42H Work On Multi-word or VARIABLE Attributes)
  3260.       GO TO 9999
  3261. 3147    continue
  3262.     write(c128wk,9400)
  3263.     call atxto
  3264.     goto 9999
  3265. C
  3266. C  TYPE IMPROPER FOR THE FUNCTION.
  3267. C
  3268.  8100 CONTINUE
  3269.     if(nout.eq.6)goto 3148
  3270.       WRITE(NOUT,9500)
  3271.     goto 9999
  3272. 3148    continue
  3273.     write(c128wk,9500)
  3274.     call atxto
  3275.  9500 FORMAT(32H -ERROR- FUNCTION Type Will Only,
  3276.      X       39H Work on REAL,DOUBLE and INT Attributes)
  3277.  9999 CONTINUE
  3278.       RETURN
  3279.       END
  3280.       SUBROUTINE LEFT(I,J)
  3281. C
  3282. C  PULL OFF LEFT HALF OF THE J WORD AND PUT INTO I
  3283. C
  3284.       INTEGER I,J
  3285.       INTEGER*2 K(2)
  3286.       INTEGER IK
  3287.       EQUIVALENCE (IK,K(1))
  3288.       IK = J
  3289.       I = K(1)
  3290.       RETURN
  3291.       END
  3292.       SUBROUTINE RIGHT(I,J)
  3293. C
  3294. C  PULL OFF THE RIGHT HALF OF THE J WORD AND PUT INTO I
  3295. C
  3296.       INTEGER I,J
  3297.       INTEGER*2 K(2)
  3298.       INTEGER IK
  3299.       EQUIVALENCE (IK,K(1))
  3300.       IK = J
  3301.       I = K(2)
  3302.       RETURN
  3303.       END
  3304.       SUBROUTINE CSC
  3305.       INCLUDE rin:TEXT.BLK
  3306. C
  3307. C  THIS PROGRAM IS THE CONCEPTUAL SCHEMA COMPILER FOR RIM. CSC
  3308. C  COMPILES RIM CONCEPTUAL SCHEMAS INTO RIM INTERNAL SCHEMAS. ALL
  3309. C  CONCEPTUAL SCHEMAS ARE EXPRESSED IN TERMS OF THE RELATIONAL MODEL.
  3310. C
  3311.       INCLUDE rin:CONST4.BLK
  3312.       INCLUDE rin:CONST8.BLK
  3313.       INCLUDE rin:RMKEYW.BLK
  3314.       INCLUDE rin:RIMCOM.BLK
  3315.       INCLUDE rin:FLAGS.BLK
  3316.       INCLUDE rin:FILES.BLK
  3317.       INCLUDE rin:MISC.BLK
  3318. C
  3319.       LOGICAL EQKEYW
  3320.       LOGICAL EQ
  3321.       INTEGER ERROR
  3322.       INTEGER EFLAG,RFLAG
  3323.       INTEGER DBSTAT
  3324.       INCLUDE rin:DCLAR2.BLK
  3325.       INCLUDE rin:DCLAR6.BLK
  3326. C
  3327.       EFLAG = 0
  3328.       RFLAG = 0
  3329.       NUMELE  = 0
  3330.       ERROR = 0
  3331.       NEWCSN = 0
  3332.       CALL RMDATE(IDAY)
  3333. C
  3334. C  SET THE PROMPT CHARACTER TO D (DEFINE)
  3335. C
  3336.       CALL LXSET(K4PROM,K4DP)
  3337. C
  3338. C  BEGIN PROCESSING.
  3339. C
  3340.     if(nout.eq.6)goto 3140
  3341.       WRITE (NOUT,9000)
  3342.  9000 FORMAT(29H Begin RIM Schema Compilation)
  3343.       GO TO 110
  3344. 3140    continue
  3345.     write(c128wk,9000)
  3346.     goto 110
  3347. C
  3348.   100 CONTINUE
  3349. C
  3350. C  EDIT DATA BASE NAME.
  3351. C
  3352.       CALL LODREC
  3353. C
  3354. C  CHECK FOR END,INPUT, OR HELP
  3355. C
  3356.       IF(EQKEYW(1,KWEND,3)) GO TO 800
  3357.   110 CONTINUE
  3358.       IF((EQKEYW(1,KWDEFI,6)).AND.(LXITEM(IDUMMY).EQ.2)) GO TO 120
  3359.     if(nout.eq.6)goto 3141
  3360.       WRITE (NOUT,9001)
  3361.     goto 3142
  3362. 3141    continue
  3363.     write(c128wk,9001)
  3364.     call atxto
  3365. 3142    continue
  3366.  9001 FORMAT(31H -ERROR- Missing Data Base Name)
  3367.       IF(.NOT.BATCH) GO TO 100
  3368.       ERROR = ERROR + 1
  3369.       IF(ERROR.LT.10) GO TO 100
  3370.       GO TO 950
  3371.   120 CONTINUE
  3372. C
  3373. C  CHECK THAT THE NAME IS LESS THAN 6 CHARACTERS.
  3374. C
  3375.       IF((LXLENC(2).GE.1).AND.(LXLENC(2).LE.6)) GO TO 145
  3376.     if(nout.eq.6)goto 3143
  3377.       WRITE (NOUT,9002)
  3378.     goto 3144
  3379. 3143    continue
  3380.     write(c128wk,9002)
  3381.     call atxto
  3382. 3144    continue
  3383.  9002 FORMAT(39H -ERROR- The Database Name Must Be 1-6 ,
  3384.      X       23HAlphanumeric Characters)
  3385.       IF(.NOT.BATCH) GO TO 100
  3386.       ERROR = ERROR + 1
  3387.       IF(ERROR.LT.10) GO TO 100
  3388.       GO TO 950
  3389. C
  3390. C  STORE DATA BASE NAME
  3391. C
  3392.   145 CONTINUE
  3393.       NAMDB = BLANK
  3394.       CALL LXSREC(2,1,8,NAMDB,1)
  3395. C
  3396. C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
  3397. C
  3398.       CALL RMDBLK(NAMDB)
  3399.       IF(RMSTAT.NE.0) GO TO 150
  3400.       CALL RMDBGT(NAMDB,DBSTAT)
  3401.       IF(DBSTAT.NE.0) GO TO 100
  3402.       CALL RMOPEN(NAMDB)
  3403.       IF((RMSTAT.EQ.15).OR.(RMSTAT.EQ.0)) GO TO 155
  3404.   150 CALL WARN(RMSTAT,DBNAME,0)
  3405.       GO TO 999
  3406.   155 CONTINUE
  3407.       NEWCSN = 1
  3408.       IF(DFLAG) RFLAG = 1
  3409. C
  3410. C  EDIT OWNER CLAUSE
  3411. C
  3412.   200 CONTINUE
  3413.       CALL LODREC
  3414. C
  3415. C  CHECK FOR END,INPUT, OR HELP
  3416. C
  3417.       IF(EQKEYW(1,KWEND,3)) GO TO 800
  3418.       IF(EQKEYW(1,KWOWNE,5)) GO TO 220
  3419.       IF((DFLAG).AND.(EQ(OWNER,USERID))) GO TO 350
  3420.       GO TO 230
  3421. C
  3422.   220 CONTINUE
  3423.       IF(LXITEM(IDUMMY).EQ.2) GO TO 260
  3424.   230 CONTINUE
  3425.     if(nout.eq.6)goto 3145
  3426.       WRITE (NOUT,9003)
  3427.     goto 3146
  3428. 3145    write(c128wk,9003)
  3429.     call atxto
  3430. 3146    continue
  3431.  9003 FORMAT(35H -ERROR- An Owner Must Be Specified)
  3432.       IF(.NOT.BATCH) GO TO 200
  3433.       ERROR = ERROR + 1
  3434.       IF(ERROR.LT.10) GO TO 200
  3435.       GO TO 950
  3436. C
  3437.   260 CONTINUE
  3438.       IF(.NOT.DFLAG) GO TO 290
  3439.       NAMOWN = BLANK
  3440.       CALL LXSREC(2,1,8,NAMOWN,1)
  3441.       IF(EQ(OWNER,NAMOWN)) GO TO 300
  3442.     if(nout.eq.6)goto 3147
  3443.       WRITE (NOUT,9004)
  3444.     goto 3148
  3445. 3147    continue
  3446.     write(c128wk,9004)
  3447.     call atxto
  3448. 3148    continue
  3449.  9004 FORMAT(59H -ERROR- Unauthorized Access To Data Base Schema Definit
  3450.      Xion)
  3451.       IF(.NOT.BATCH) GO TO 200
  3452.       ERROR = ERROR + 1
  3453.       IF(ERROR.LT.10) GO TO 200
  3454.       GO TO 950
  3455.   290 CONTINUE
  3456.       IF((LXLENC(2).GE.1).AND.(LXLENC(2).LE.8)) GO TO 295
  3457.       CALL WARN(7,KWOWNE,BLANK)
  3458.       IF(.NOT.BATCH) GO TO 200
  3459.       ERROR = ERROR + 1
  3460.       IF(ERROR.LT.10) GO TO 200
  3461.       GO TO 950
  3462.   295 CONTINUE
  3463.       OWNER = BLANK
  3464.       CALL LXSREC(2,1,8,OWNER,1)
  3465. C
  3466. C  SEARCH FOR ATTRIBUTES, RELATIONS, RULES, PASSWORDS, OR END
  3467. C
  3468.   300 CONTINUE
  3469.       CALL LODREC
  3470.   350 CONTINUE
  3471.       IF(EQKEYW(1,KWELEM,8)) GO TO 400
  3472.       IF(EQKEYW(1,KWATTR,10)) GO TO 400
  3473.       IF(EQKEYW(1,KWRELA,9)) GO TO 500
  3474.       IF(EQKEYW(1,KWRULS,5)) GO TO 600
  3475.       IF(EQKEYW(1,KWPASS,9)) GO TO 700
  3476.       IF(EQKEYW(1,KWEND,3)) GO TO 800
  3477. C
  3478. C  ERROR.
  3479. C
  3480.       CALL WARN(4,0,0)
  3481.       IF(.NOT.BATCH) GO TO 300
  3482.       ERROR = ERROR + 1
  3483.       IF(ERROR.LT.10) GO TO 300
  3484.       GO TO 950
  3485. C
  3486. C  PROCESS ATTRIBUTES.
  3487. C
  3488.   400 CONTINUE
  3489.       CALL LODELE(NUMELE,ERROR)
  3490.       EFLAG = 1
  3491.       GO TO 350
  3492. C
  3493. C
  3494. C  PROCESS RELATIONS.
  3495. C
  3496.   500 CONTINUE
  3497.       IF(DFLAG) GO TO 525
  3498.       IF(EFLAG.EQ.1) GO TO 525
  3499.     if(nout.eq.6)goto 3149
  3500.       WRITE (NOUT,9005)
  3501.  9005 FORMAT(' -ERROR- No Attributes Defined - Relation Definition i'
  3502.      X's Impossible')
  3503. C 9005 FORMAT(66H -ERROR- NO ATTRIBUTES DEFINED - RELATION DEFINITION IS
  3504. C     XIMPOSSIBLE)
  3505.       ERROR = ERROR + 1
  3506.       GO TO 300
  3507. 3149    continue
  3508.     write(c128wk,9005)
  3509.     call atxto
  3510.     error=error+1
  3511.     goto 300
  3512.   525 CONTINUE
  3513.       CALL LODREL(NUMELE,ERROR)
  3514.       RFLAG = 1
  3515.       GO TO 350
  3516. C
  3517. C  PROCESS RULES.
  3518. C
  3519.   600 CONTINUE
  3520.       IF(RFLAG.EQ.1) GO TO 625
  3521.     if(nout.eq.6)goto 3240
  3522.       WRITE (NOUT,9006)
  3523.  9006 FORMAT(74H -ERROR- Relations And Attributes Must Be Defined In Ord
  3524.      Xer To Define Rules)
  3525.       ERROR = ERROR + 1
  3526.       GO TO 300
  3527. 3240    continue
  3528.     write(c128wk,9006)
  3529.     call atxto
  3530.     error = error + 1
  3531.     goto 300
  3532. C
  3533. C
  3534.   625 CONTINUE
  3535.       CALL LODRUL
  3536.       GO TO 350
  3537. C
  3538. C  PROCESS PASSWORDS.
  3539. C
  3540.   700 CONTINUE
  3541.       IF(RFLAG.EQ.1) GO TO 725
  3542.     if(nout.eq.6)goto 3241
  3543.       WRITE (NOUT,9007)
  3544.  9007 FORMAT(63H -ERROR- Relations Must Be Defined In Order To Assign Pa
  3545.      Xsswords)
  3546.       ERROR = ERROR + 1
  3547.       GO TO 300
  3548. 3241    continue
  3549.     write(c128wk,9007)
  3550.     call atxto
  3551.     error=error+1
  3552.     goto 300
  3553. C
  3554.   725 CONTINUE
  3555.       CALL LODPAS(ERROR)
  3556.       GO TO 350
  3557. C
  3558. C  PROCESS END.
  3559. C
  3560.   800 CONTINUE
  3561. C
  3562. C  SET THE RETURN CODE AND MAKE SURE A SCHEMA HAS BEEN DEFINED
  3563. C
  3564.       NEXTOP = K8RIM
  3565.       IF(NEWCSN.EQ.0) GO TO 999
  3566.       IF(.NOT.BATCH) ERROR = 0
  3567.       IF(ERROR.NE.0) GO TO 950
  3568.     if(nout.eq.6)goto 3242
  3569.       WRITE (NOUT,9008) DBNAME
  3570.  9008 FORMAT(28H RIM Schema Compilation For ,A8,12H Is Complete)
  3571.     goto 3243
  3572. 3242    continue
  3573.     write(c128wk,9008) dbname
  3574.     call atxto
  3575. 3243    continue
  3576. C
  3577. C  BUFFER THE SCHEMA AND DATABASE OUT
  3578. C
  3579.       DFLAG = .TRUE.
  3580.       IFMOD = .TRUE.
  3581.       CALL RMOPEN(DBNAME)
  3582.       IF(RMSTAT.NE.0) CALL WARN(RMSTAT,DBNAME,0)
  3583.       GO TO 999
  3584. C
  3585. C  ERROR PROCESSING.
  3586. C
  3587.   950 CONTINUE
  3588.     if(nout.eq.6)goto 3244
  3589.       WRITE (NOUT,9009)
  3590.     goto 3245
  3591. 3244    continue
  3592.     write(c128wk,9009)
  3593.     call atxto
  3594. 3245    continue
  3595.  9009 FORMAT(43H -WARNING- Errors In RIM Schema Compilation)
  3596.       DFLAG = .TRUE.
  3597.       IFMOD = .TRUE.
  3598.       CALL RMOPEN(DBNAME)
  3599.       IF(RMSTAT.NE.0) CALL WARN(RMSTAT,DBNAME,0)
  3600. C
  3601. C  RETURN.
  3602. C
  3603.   999 CONTINUE
  3604. C
  3605. C RESET THE PROMPT CHARACTER TO R
  3606. C
  3607.       CALL LXSET(K4PROM,K4RP)
  3608.       CALL BLKCLR(10)
  3609.       RETURN
  3610.       END
  3611.       SUBROUTINE DBLOAD
  3612.       INCLUDE rin:TEXT.BLK
  3613. C
  3614. C  THIS ROUTINE IS THE DRIVER FOR LOADING DATA VALUES IN THE
  3615. C  RIM DATA BASE.
  3616. C
  3617.       INCLUDE rin:CONST8.BLK
  3618.       INCLUDE rin:RMKEYW.BLK
  3619.       INCLUDE rin:CONST4.BLK
  3620.       INCLUDE rin:TUPLER.BLK
  3621.       INCLUDE rin:RULCOM.BLK
  3622.       INCLUDE rin:FILES.BLK
  3623.       INCLUDE rin:BUFFER.BLK
  3624.       INCLUDE rin:MISC.BLK
  3625.       INCLUDE rin:FLAGS.BLK
  3626.       INCLUDE rin:RIMCOM.BLK
  3627. C
  3628.       LOGICAL EQKEYW
  3629.       INCLUDE rin:DCLAR1.BLK
  3630. C
  3631. C  CALL RMDBLK TO MAKE SURE THE DATABASE CAN BE MODIFIED
  3632. C
  3633.       CALL RMDBLK(DBNAME)
  3634.       IF(RMSTAT.EQ.0) GO TO 50
  3635.       CALL WARN(RMSTAT,DBNAME,0)
  3636.       GO TO 1000
  3637.    50 CONTINUE
  3638. C
  3639. C  SET THE PROMPT CHARACTER TO L (LOAD)
  3640. C
  3641.       CALL LXSET(K4PROM,K4LP)
  3642. C
  3643. C  LOOK FOR THE RELATION NAME.
  3644. C
  3645.     if(nout.eq.6)goto 3140
  3646.       WRITE(NOUT,9000)
  3647.  9000 FORMAT(25H BEGIN -RIM- DATA LOADING )
  3648.       GO TO 200
  3649. 3140    continue
  3650.     write(c128wk,9000)
  3651.     call atxto
  3652.     goto 200
  3653.   100 CONTINUE
  3654.       CALL LODREC
  3655.   200 CONTINUE
  3656.       IF(EQKEYW(1,KWLOAD,4)) GO TO 300
  3657.       IF(EQKEYW(1,KWEND,3)) GO TO 1000
  3658.     if(nout.eq.6)goto 3141
  3659.       WRITE(NOUT,9001)
  3660.  9001 FORMAT(46H -ERROR- Unrecognized LOAD Command - Retype It)
  3661.       GO TO 100
  3662. 3141    continue
  3663.     write(c128wk,9001)
  3664.     call atxto
  3665.     goto 100
  3666. C
  3667. C  RELATION NAME SPECIFIED.
  3668. C
  3669.   300 CONTINUE
  3670.       IF(LXITEM(IDUMMY).EQ.2) GO TO 400
  3671.     if(nout.eq.6)goto 3142
  3672.       WRITE(NOUT,9002)
  3673.  9002 FORMAT(46H -ERROR- Missing Relation Name On LOAD Command)
  3674.       GO TO 100
  3675. 3142    continue
  3676.     write(c128wk,9002)
  3677.     call atxto
  3678.     goto 100
  3679.   400 CONTINUE
  3680.       RNAME = BLANK
  3681.       CALL LXSREC(2,1,8,RNAME,1)
  3682. C
  3683. C  CHECK FOR RULES FOR THIS RELATION
  3684. C
  3685.       CALL CHKRUL(RNAME)
  3686.       IF(RMSTAT.LT.110) GO TO 450
  3687.     if(nout.eq.6)goto 35
  3688.       IF(RMSTAT.EQ.110) WRITE(NOUT,410)
  3689.       IF(RMSTAT.EQ.111) WRITE(NOUT,420)
  3690.   410 FORMAT(35H -ERROR- Unrecognized Rule Relation )
  3691.   420 FORMAT(50H -ERROR- More Than 10 Rules Apply To This Relation)
  3692.       GO TO 1000
  3693. 35    continue
  3694.       IF(RMSTAT.EQ.110) WRITE(c128wk,410)
  3695.       IF(RMSTAT.EQ.111) WRITE(c128wk,420)
  3696.     if(rmstat.eq.110.or.rmstat.eq.111)call atxto
  3697.     goto 1000
  3698.   450 CONTINUE
  3699.       I = LOCREL(RNAME)
  3700.       IF(I.EQ.0) GO TO 600
  3701.   500 CONTINUE
  3702. C
  3703. C  UNRECOGNIZED RELATION NAME.
  3704. C
  3705.       CALL WARN(1,RNAME,0)
  3706.       GO TO 100
  3707.   600 CONTINUE
  3708.       CALL RELGET(ISTAT)
  3709.       IF(ISTAT.NE.0) GO TO 500
  3710. C
  3711. C  CHECK FOR AUTHORITY.
  3712. C
  3713.       L = LOCPRM(RNAME,2)
  3714.       IF(L.EQ.0) GO TO 700
  3715.       CALL WARN(9,RNAME,0)
  3716.       GO TO 1000
  3717. C
  3718. C  CALL LOADIT TO READ THE ACTUAL DATA CARDS.
  3719. C
  3720.   700 CONTINUE
  3721.       CALL BLKDEF(10,1,MAXCOL)
  3722.       KQ1 = BLKLOC(10)
  3723.       CALL LOADIT(BUFFER(KQ1))
  3724. C
  3725. C  UPDATE THE DATE OF LAST MODIFICATION.
  3726. C
  3727.       CALL RMDATE(RDATE)
  3728.       CALL RELPUT
  3729.       CALL BLKCLR(10)
  3730.       GO TO 200
  3731. C
  3732. C  END OF LOADING.
  3733. C
  3734.  1000 CONTINUE
  3735.     if(nout.eq.6)goto 3145
  3736.       WRITE(NOUT,9003)
  3737.     goto 3146
  3738. 3145    continue
  3739.     write(c128wk,9003)
  3740.     call atxto
  3741. 3146    continue
  3742.  9003 FORMAT(23H End -RIM- Data Loading )
  3743. C
  3744. C  SET THE PROMPT CHARACTER BACK TO R (RIM)
  3745. C
  3746.       CALL LXSET(K4PROM,K4RP)
  3747.       RETURN
  3748.       END
  3749.       SUBROUTINE DELDAT(INDEX,ID)
  3750.       INCLUDE rin:TEXT.BLK
  3751. C
  3752. C  PURPOSE:   DELINK A TUPLE FROM THE DATA FILE
  3753. C
  3754. C  PARAMETERS:
  3755. C         INDEX---BLOCK REFERENCE NUMBER
  3756. C         ID------PACKED ID WORD WITH OFFSET,IOBN
  3757.       INCLUDE rin:F2COM.BLK
  3758.       INCLUDE rin:RIMCOM.BLK
  3759.       INCLUDE rin:BUFFER.BLK
  3760.       INCLUDE rin:FLAGS.BLK
  3761. C
  3762.       INTEGER OFFSET
  3763. C
  3764. C  UNPAC THE ID WORD.
  3765. C
  3766.       CALL ITOH(OFFSET,IOBN,ID)
  3767. C
  3768. C  SEE IF THE NEEDED BLOCK IS CURRENTLY IN CORE.
  3769. C
  3770.       NUMBLK = 0
  3771.       DO 200 I=1,3
  3772.       IF(IOBN.EQ.CURBLK(I)) NUMBLK = I
  3773.   200 CONTINUE
  3774.       IF(NUMBLK.NE.0) GO TO 400
  3775.       NUMBLK = INDEX
  3776. C
  3777. C  WE MUST DO PAGING.
  3778. C
  3779. C  SEE IF THE CURRENT BLOCK NEEDS WRITING.
  3780. C
  3781.       IF(MODFLG(NUMBLK).EQ.0) GO TO 300
  3782. C
  3783. C  WRITE OUT THE CURRENT BLOCK.
  3784. C
  3785.       KQ1 = BLKLOC(NUMBLK)
  3786.       CALL RIOOUT(FILE2,CURBLK(NUMBLK),BUFFER(KQ1),LENBF2,IOS)
  3787.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  3788.   300 CONTINUE
  3789. C
  3790. C  READ IN THE NEEDED BLOCK.
  3791. C
  3792.       CALL BLKCHG(NUMBLK,LENBF2,1)
  3793.       KQ1 = BLKLOC(NUMBLK)
  3794.       CALL RIOIN(FILE2,IOBN,BUFFER(KQ1),LENBF2,IOS)
  3795.       CURBLK(NUMBLK) = IOBN
  3796.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  3797.   400 CONTINUE
  3798.       MODFLG(NUMBLK) = 1
  3799.       IFMOD = .TRUE.
  3800. C
  3801. C  CHANGE THE ID POINTER.
  3802. C
  3803.       KQ0 = BLKLOC(NUMBLK) - 1
  3804.       BUFFER(KQ0 + OFFSET) = -BUFFER(KQ0 + OFFSET)
  3805.       MODFLG(NUMBLK) = 1
  3806.       IFMOD = .TRUE.
  3807.       IF(BUFFER(KQ0 + OFFSET).NE.0) RETURN
  3808. C
  3809. C  SPECIAL STUFF FOR DELETING THE LAST TUPLE.
  3810. C
  3811.       CALL HTOI(1,0,BUFFER(KQ0 + OFFSET))
  3812.       BUFFER(KQ0 + OFFSET) = -BUFFER(KQ0 + OFFSET)
  3813.       RETURN
  3814.       END
  3815.       SUBROUTINE DELDUP(MAT)
  3816.       INCLUDE rin:TEXT.BLK
  3817. C
  3818. C     DELETE DUPLICATES ROUTINE
  3819. C     MAT IS INPUT STORAGE OF LENGTH AT LEAST (MOST) THE FIXED
  3820. C     PORTION OF THE RELATION.  WHEN ATTRIBUTES ARE SPECIFIED, THIS
  3821. C     IS USED TO FLAG WHICH ARE NOT TO BE COMPARED (SET MAT TO 0) AND
  3822. C     WHICH ARE FIXED TO BE COMPARED (SET MAT TO 1) AND WHICH ARE
  3823. C     VARIABLE TO BE COMPARED (SET MAT TO -1).
  3824. C
  3825. C     METHOD - 1. SET MAT OR ALL
  3826. C              2. LOOP ON TUPLES
  3827. C                 3. LOOP ON SUBSEQUENT TUPLES
  3828. C                    IF NOT DUPLICATE GO TO 3
  3829. C                    IF DUPLICATE DELETEI FIRST TUPLE (INCLUDING KEYS)
  3830. C                    AND GO TO 2.
  3831. C              4. WHEN DONE RESET RSTART AND NTUPLE, PRINT MESSAGE,
  3832. C                  AND RETURN
  3833. C
  3834.       INCLUDE rin:F2COM.BLK
  3835.       INCLUDE rin:START.BLK
  3836.       INCLUDE rin:RIMPTR.BLK
  3837.       INCLUDE rin:RMKEYW.BLK
  3838.       INCLUDE rin:TUPLER.BLK
  3839.       INCLUDE rin:TUPLEA.BLK
  3840.       INCLUDE rin:FILES.BLK
  3841.       INCLUDE rin:MISC.BLK
  3842.       INCLUDE rin:BUFFER.BLK
  3843.       DIMENSION MAT(*)
  3844.       LOGICAL IFALL
  3845.       INTEGER COLUMN
  3846.       INCLUDE rin:DCLAR1.BLK
  3847. C
  3848. C     SEE IF THERE IS MORE THAN ONE TUPLE
  3849. C
  3850. C
  3851. C     LOCATE WORD FROM
  3852. C
  3853.       ITEMS = LXITEM(IDUMMY)
  3854.       J = LFIND(1,ITEMS,KWFROM,4)
  3855.       IFALL = .TRUE.
  3856.       IF(J.EQ.3) GO TO 200
  3857.       IFALL = .FALSE.
  3858. C
  3859. C     SET UP FOR SPECIFIED ATTRIBUTES
  3860. C
  3861.       DO 10 I=1,NCOL
  3862.       MAT(I) = 0
  3863.    10 CONTINUE
  3864.       II = ITEMS - 2
  3865.       DO 100 I=3,II
  3866.       ANAME = BLANK
  3867.       CALL LXSREC(I,1,8,ANAME,1)
  3868.       IF(LOCATT(ANAME,NAME).EQ.0) GO TO 20
  3869.       CALL WARN(3,ANAME,NAME)
  3870.       GO TO 9999
  3871.    20 CONTINUE
  3872.       CALL ATTGET(ISTAT)
  3873. C
  3874. C     GOT ATTRIBUTE - SET MAT
  3875. C
  3876.       MAT(ATTCOL) = -1
  3877.       IF(ATTWDS.EQ.0) GO TO 100
  3878. C
  3879. C     FIXED SET ALL COLUMNS
  3880. C
  3881.       NUM = ATTCOL - 1
  3882.       DO 60 J=1,ATTWDS
  3883.       NUM = NUM + 1
  3884.       MAT(NUM) = 1
  3885.    60 CONTINUE
  3886.   100 CONTINUE
  3887.   200 CONTINUE
  3888. C
  3889. C     DO DOUBLE LOOP ON TUPLES
  3890. C     ND COUNTS DELETED TUPLES
  3891. C     IID SAVES NEW RSTART
  3892. C
  3893.       ND = 0
  3894.       IF(NTUPLE.LE.1) GO TO 700
  3895. C
  3896. C  WRITE OUT PAGE 2 IF IT HAS BEEN MODIFIED
  3897. C
  3898.       IF(MODFLG(2).EQ.0) GO TO 250
  3899.       KQ2 = BLKLOC(2)
  3900.       CALL RIOOUT(FILE2,CURBLK(2),BUFFER(KQ2),LENBF2,IOS)
  3901.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  3902.       MODFLG(2) = 0
  3903.       CURBLK(2) = 0
  3904.   250 CONTINUE
  3905.       IID = NID
  3906.   300 CONTINUE
  3907. C
  3908. C     GET THE FIRST TUPLE
  3909. C
  3910.       IF(NID.EQ.0) GO TO 600
  3911.       CALL ITOH(N1,N2,NID)
  3912.       IF(N2.EQ.0) GO TO 600
  3913. C
  3914. C     FORCE INTO POSITION OTHER THAN 2
  3915. C
  3916.       ISAVE = CURBLK(2)
  3917.       CURBLK(2) = 0
  3918.       CID = NID
  3919.       CALL GETDAT(1,NID,IP1,LEN1)
  3920.       CURBLK(2) = ISAVE
  3921.       IF(NID.LT.0) GO TO 600
  3922.       IP1 = IP1 - 1
  3923. C
  3924. C     LOOP ON LATER TUPLES
  3925. C
  3926.       KNID = NID
  3927.       KCID = CID
  3928.   400 CONTINUE
  3929. C
  3930. C     GET THE FOLLOWING TUPLES
  3931. C
  3932.       IF(KNID.EQ.0) GO TO 300
  3933.       CALL ITOH(N1,N2,KNID)
  3934.       IF(N2.EQ.0) GO TO 300
  3935.       CALL GETDAT(2,KNID,IP2,LEN2)
  3936.       IF(KNID.LT.0) GO TO 300
  3937.       IP2 = IP2 - 1
  3938. C
  3939. C     COMPARE THE TWO TUPLES
  3940. C
  3941.       IF(IFALL) GO TO 500
  3942.       DO 490 I=1,NCOL
  3943.       IF(MAT(I).EQ.0) GO TO 490
  3944.       IF(MAT(I).LT.0) GO TO 450
  3945. C
  3946. C     FIXED COMPARE
  3947. C
  3948.       IF(BUFFER(IP1+I).NE.BUFFER(IP2+I)) GO TO 400
  3949.       GO TO 490
  3950.   450 CONTINUE
  3951. C
  3952. C     VARIABLE
  3953. C
  3954.       JP1 = BUFFER(IP1+I) + IP1
  3955.       JP2 = BUFFER(IP2+I) + IP2
  3956.       IF(BUFFER(JP1) .NE. BUFFER(JP2)) GO TO 400
  3957.       NW = BUFFER(JP1) + 1
  3958.       DO 460 J=1,NW
  3959.       JP1 = JP1 + 1
  3960.       JP2 = JP2 + 1
  3961.       IF(BUFFER(JP1).NE.BUFFER(JP2)) GO TO 400
  3962.   460 CONTINUE
  3963.   490 CONTINUE
  3964.       GO TO 550
  3965.   500 CONTINUE
  3966. C
  3967. C     CHECK ALL
  3968. C
  3969.       IF(LEN1.NE.LEN2) GO TO 400
  3970.       DO 520 I=1,LEN1
  3971.       IF(BUFFER(IP1+I).NE.BUFFER(IP2+I)) GO TO 400
  3972.   520 CONTINUE
  3973.   550 CONTINUE
  3974. C
  3975. C     DUPLICATE FOUND - DELINK IT
  3976. C
  3977.       CALL DELDAT (1,KCID)
  3978. C
  3979. C     PROCESS ANY KEY ATTRIBUTES
  3980. C
  3981.       J = LOCATT(BLANK,NAME)
  3982.   560 CONTINUE
  3983.       CALL ATTGET(ISTAT)
  3984.       IF(ISTAT.NE.0) GO TO 580
  3985.       IF(ATTKEY.EQ.0) GO TO 560
  3986.       COLUMN = ATTCOL
  3987.       IF(ATTWDS.NE.0) GO TO 570
  3988.       COLUMN = BUFFER(IP1+ATTCOL) + 2
  3989.   570 CONTINUE
  3990.       START = ATTKEY
  3991.       CALL BTREP(BUFFER(IP1+COLUMN),0,KCID,ATTYPE)
  3992.       GO TO 560
  3993.   580 CONTINUE
  3994.       IF (KCID .EQ. IID) IID = NID
  3995.       ND = ND + 1
  3996.       GO TO 300
  3997. C
  3998. C     CHANGE THE STARTING ID IF NEEDED
  3999. C
  4000.   600 CONTINUE
  4001.       CALL RELGET(ISTAT)
  4002.       RSTART = IID
  4003.       NTUPLE = NTUPLE - ND
  4004.       CALL RELPUT
  4005.   700 CONTINUE
  4006.     if(nout.eq.6)goto 3140
  4007.       WRITE (NOUT,9001) ND,NAME
  4008.     goto 9999
  4009. 3140    continue
  4010.     write(c128wk,9001)nd,name
  4011.     call atxto
  4012.  9001 FORMAT(2X,I6,26H ROWS Deleted In Relation ,A8)
  4013.  9999 CONTINUE
  4014.       RETURN
  4015.       END
  4016.       SUBROUTINE DELETE(MAT)
  4017.       INCLUDE rin:TEXT.BLK
  4018. C
  4019. C  THIS ROUTINE PROCESSES A DELETE IN RIM.
  4020. C
  4021. C  PARAMETERS
  4022. C         MAT-----ARRAY TO HOLD ONE TUPLE
  4023.       INCLUDE rin:START.BLK
  4024.       INCLUDE rin:TUPLER.BLK
  4025.       INCLUDE rin:RMKEYW.BLK
  4026.       INCLUDE rin:TUPLEA.BLK
  4027.       INCLUDE rin:RIMCOM.BLK
  4028.       INCLUDE rin:RIMPTR.BLK
  4029.       INCLUDE rin:FILES.BLK
  4030.       INCLUDE rin:MISC.BLK
  4031.       INTEGER COLUMN
  4032. C
  4033. C  DIMENSION STATEMENTS.
  4034. C
  4035.       DIMENSION MAT(*)
  4036. C
  4037.       ND = 0
  4038. C
  4039. C  PROCESS THE WHERE CLAUSE.
  4040. C
  4041.       ITEMS = LXITEM(ISTAT)
  4042.       LW = LFIND(1,ITEMS,KWWHER,5)
  4043.       IF(LW.NE.0) GO TO 100
  4044.     if(nout.eq.6)goto 3140
  4045.       WRITE(NOUT,9000)
  4046.  9000 FORMAT(55H -ERROR- A WHERE Clause is REQUIRED on a DELETE Command)
  4047.       GO TO 9999
  4048. 3140    continue
  4049.     write(c128wk,9000)
  4050.     call atxto
  4051.     goto 9999
  4052.   100 CONTINUE
  4053.       CALL WHERE(LW)
  4054.       IF(RMSTAT.NE.0) GO TO 9999
  4055. C
  4056. C  SEQUENCE THROUGH THE DATA DELETING TUPLES.
  4057. C
  4058.       IF(NTUPLE.LE.0) GO TO 9999
  4059.       IID = CID
  4060.   200 CONTINUE
  4061.       CALL RMLOOK(MAT,1,0,LENGTH)
  4062.       IF(RMSTAT.NE.0) GO TO 700
  4063. C
  4064. C  DELINK THIS TUPLE.
  4065. C
  4066.       CALL DELDAT(1,CID)
  4067. C
  4068. C  PROCESS ANY KEY ATTRIBUTES.
  4069. C
  4070.       J = LOCATT(BLANK,NAME)
  4071.   400 CONTINUE
  4072.       CALL ATTGET(ISTAT)
  4073.       IF(ISTAT.NE.0) GO TO 600
  4074.       IF(ATTKEY.EQ.0) GO TO 400
  4075.       COLUMN = ATTCOL
  4076.       IF(ATTWDS.NE.0) GO TO 500
  4077.       COLUMN = MAT(ATTCOL)
  4078.       KURLEN = MAT(COLUMN)
  4079.       COLUMN = COLUMN + 2
  4080.   500 CONTINUE
  4081.       START = ATTKEY
  4082.       CALL BTREP(MAT(COLUMN),0,CID,ATTYPE)
  4083.       GO TO 400
  4084.   600 CONTINUE
  4085.       IF(CID.EQ.IID) IID = NID
  4086.       ND = ND + 1
  4087.       GO TO 200
  4088. C
  4089. C  CHANGE THE STARTING ID IF NEEDED.
  4090. C
  4091.   700 CONTINUE
  4092.       CALL RELGET(ISTAT)
  4093.       RSTART = IID
  4094.       NTUPLE = NTUPLE - ND
  4095.       CALL RELPUT
  4096.       RMSTAT = 0
  4097.  9999 CONTINUE
  4098.     if(nout.eq.6)goto 3142
  4099.       WRITE(NOUT,9001) ND,NAME
  4100.  9001 FORMAT(2X,I6,26H Rows Deleted In Relation ,A8)
  4101. C
  4102. C  DONE.
  4103. C
  4104.       RETURN
  4105. 3142    continue
  4106.     write(c128wk,9001)nd,name
  4107.     call atxto
  4108.     return
  4109.       END
  4110.       SUBROUTINE DROPF(IFILE)
  4111.       INCLUDE rin:TEXT.BLK
  4112.     logical here
  4113.     integer fileno
  4114.       REAL*8 IFILE
  4115.       CHARACTER*8 NFILE
  4116.       WRITE(NFILE,100) IFILE
  4117.   100 FORMAT(A8)
  4118.     inquire(file=nfile,number=fileno,exist=here,iostat=ios)
  4119.     if(.not.here)return
  4120. C no need to delete a file that is missing
  4121.     if(ios.ne.0)fileno=30
  4122.     if(fileno.lt.0)fileno=30
  4123.       OPEN(UNIT=fileno,FILE=NFILE,STATUS='OLD',IOSTAT=IOS)
  4124.       IF(IOS.NE.0) RETURN
  4125.       CLOSE(UNIT=fileno,STATUS='DELETE')
  4126.       RETURN
  4127.       END
  4128.       LOGICAL FUNCTION EQ(WORD1,WORD2)
  4129.       INCLUDE rin:TEXT.BLK
  4130. C
  4131. C  PURPOSE:   COMPARE WORD1 AND WORD2 FOR EQ
  4132. C
  4133. C  PARAMETERS:
  4134. C         WORD1---A WORD OF TEXT
  4135. C         WORD2---ANOTHER WORD OF TEXT
  4136. C         EQ------.TRUE. IF WORD1.EQ.WORD2
  4137. C                 .FALSE. IF NOT EQ
  4138.       INCLUDE rin:DCLAR6.BLK
  4139. C
  4140.       EQ = WORD1.EQ.WORD2
  4141.       RETURN
  4142.       END
  4143.       LOGICAL FUNCTION EQKEYW(I,KEYW,LEN)
  4144.       INCLUDE rin:TEXT.BLK
  4145. C
  4146. C     THIS FUNCTION COMPARES KEYW WITH ITEM I WHICH HAS BEEN
  4147. C     INPUT THRU LXLREC.
  4148. C
  4149. C     INPUT - I........ITEM NUMBER
  4150. C             KEYW.....STRING WITH KEYWORD IN IT
  4151. C             LEN......LENGTH OF FULL KEYWORD
  4152. C     OUTPUT- EQKEYW....TRUE. IFF
  4153. C                             A. ITEM I IS TEXT
  4154. C                         AND B. NUMBER OF CHARACTERS IN ITEM I
  4155. C                                IS GE MIN(3,LEN) AND LE LEN.
  4156. C                         AND C. ITEM IT MATCHES KEYWORD TO MINIMUM
  4157. C                                OF 8 AND THE NUMBER OF CHARACTERS
  4158. C                                IN ITEM I.
  4159. C
  4160.       INCLUDE rin:RMATTS.BLK
  4161.       INTEGER KEYW(*)
  4162.       EQKEYW = .FALSE.
  4163.       IF(LXID(I).NE.KZTEXT) GO TO 1000
  4164.       N = LXLENC(I)
  4165.       MIN = 3
  4166.       IF(LEN.LT.MIN) MIN = LEN
  4167.       IF(N.LT.MIN) GO TO 1000
  4168.       IF(N.GT.LEN) GO TO 1000
  4169.       IF(N.GT.8) N = 8
  4170. C
  4171. C     COMPARE CHARACTERS
  4172. C
  4173.       DO 10 J=1,N
  4174.       CALL GETT(KEYW,J,ICHAR)
  4175.       IF(LXCREC(I,J).NE.ICHAR) GO TO 1000
  4176.    10 CONTINUE
  4177.       EQKEYW = .TRUE.
  4178.  1000 CONTINUE
  4179.       RETURN
  4180.       END
  4181.       SUBROUTINE F1CLO
  4182.       INCLUDE rin:TEXT.BLK
  4183. C
  4184. C  PURPOSE:   CLOSE THE RIM DIRECTORY FILE - FILE 1
  4185. C
  4186.       INCLUDE rin:CONST8.BLK
  4187.       INCLUDE rin:F1COM.BLK
  4188.       INCLUDE rin:RIMCOM.BLK
  4189.       INCLUDE rin:ATTBLE.BLK
  4190.       INCLUDE rin:RELTBL.BLK
  4191.       INCLUDE rin:FLAGS.BLK
  4192. C
  4193. C  WRITE OUT THE RELATION BUFFER IF IT WAS MODIFIED.
  4194. C
  4195.       IF(RELMOD.EQ.0) GO TO 100
  4196.       CALL RIOOUT(FILE1,CRREC,RELBUF,LENBF1,IOS)
  4197.       IF(IOS.NE.0) RMSTAT = 2100 + IOS
  4198.   100 CONTINUE
  4199.       CRREC = 0
  4200.       RELMOD = 0
  4201. C
  4202. C  WRITE OUT THE ATTRIBUTE BUFFER IF IT WAS MODIFIED.
  4203. C
  4204.       IF(ATTMOD.EQ.0) GO TO 200
  4205.       CALL RIOOUT(FILE1,CAREC,ATTBUF,LENBF1,IOS)
  4206.       IF(IOS.NE.0) RMSTAT = 2100 + IOS
  4207.   200 CONTINUE
  4208.       CAREC = 0
  4209.       ATTMOD = 0
  4210. C
  4211. C  ZERO OUT RELBUF AND MOVE CONTROL VARIABLES THERE.
  4212. C
  4213.       CALL ZEROIT(RELBUF,LENBF1)
  4214.       CALL BLKMOV(RELBUF(1),DBNAME,2)
  4215.       CALL BLKMOV(RELBUF(3),K8RMDT,2)
  4216.       CALL BLKMOV(RELBUF(5),OWNER,2)
  4217.       CALL BLKMOV(RELBUF(7),DBDATE,2)
  4218.       CALL BLKMOV(RELBUF(9),DBTIME,2)
  4219.       RELBUF(11) = LF1REC
  4220.       RELBUF(12) = NRROW
  4221.       RELBUF(13) = NAROW
  4222. C
  4223. C  WRITE OUT THE CONTROL BLOCK.
  4224. C
  4225.       CALL RIOOUT(FILE1,1,RELBUF,LENBF1,IOS)
  4226.       IF(IOS.NE.0) RMSTAT = 2100 + IOS
  4227.       RETURN
  4228.       END
  4229.       SUBROUTINE F1OPN(FILE)
  4230.       INCLUDE rin:TEXT.BLK
  4231. C
  4232. C  PURPOSE:   OPEN THE RIM DIRECTORY FILE - FILE 1
  4233. C
  4234. C  PARAMETERS:
  4235. C         FILE----NAME OF THE FILE TO USE FOR FILE1
  4236.       INCLUDE rin:CONST8.BLK
  4237.       INCLUDE rin:F1COM.BLK
  4238.       INCLUDE rin:RIMCOM.BLK
  4239.       INCLUDE rin:ATTBLE.BLK
  4240.       INCLUDE rin:RELTBL.BLK
  4241.       INCLUDE rin:FLAGS.BLK
  4242.       LOGICAL EQ
  4243.       INCLUDE rin:DCLAR4.BLK
  4244. C
  4245. C  OPEN THE DIRECTORY FILE.
  4246. C
  4247.       CALL RIOOPN(FILE,FILE1,LENBF1,IOS)
  4248.       IF(IOS.NE.0) RMSTAT = 2100 + IOS
  4249. C
  4250. C  READ IN THE FIRST RECORD FROM THIS FILE.
  4251. C
  4252.       CALL RIOIN(FILE1,1,RELBUF,LENBF1,IOS)
  4253.       IF(IOS.NE.0) GO TO 500
  4254.       CRREC = 0
  4255. C
  4256. C  MOVE THE CONTROL DATA TO WHERE IT IS NEEDED.
  4257. C
  4258.       IF(EQ(RELBUF(3),K8RMDT)) GO TO 100
  4259.       RMSTAT = 10
  4260.       GO TO 1000
  4261.   100 CONTINUE
  4262.       IF(EQ(RELBUF(1),DBNAME)) GO TO 200
  4263.       RMSTAT = 11
  4264.       GO TO 1000
  4265.   200 CONTINUE
  4266.       CALL BLKMOV(OWNER,RELBUF(5),2)
  4267.       CALL BLKMOV(DBDATE,RELBUF(7),2)
  4268.       CALL BLKMOV(DBTIME,RELBUF(9),2)
  4269.       LF1REC = RELBUF(11)
  4270.       NRROW = RELBUF(12)
  4271.       NAROW = RELBUF(13)
  4272. C
  4273. C  SUCCESSFUL OPEN.
  4274. C
  4275.       DFLAG = .TRUE.
  4276.       RMSTAT = 0
  4277.       GO TO 9999
  4278. C
  4279. C  EMPTY FILE 1 - WRITE THE FIRST RECORD ON IT.
  4280. C
  4281.   500 CONTINUE
  4282.       CALL ZEROIT(RELBUF,LENBF1)
  4283.       CALL RIOOUT(FILE1,1,RELBUF,LENBF1,IOS)
  4284.       LF1REC = 1
  4285.       CAREC = 0
  4286.       CRREC = 0
  4287.       NRROW = 74
  4288.       NAROW = 227
  4289.       RMSTAT = 15
  4290.       GO TO 1000
  4291. C
  4292. C  UNABLE TO OPEN FILE 1.
  4293. C
  4294.  1000 CONTINUE
  4295.       DFLAG = .FALSE.
  4296.  9999 RETURN
  4297.       END
  4298.       SUBROUTINE F2CLO
  4299.       INCLUDE rin:TEXT.BLK
  4300. C
  4301. C  PURPOSE:    CLOSE THE DATA RANDOM IO FILE - FILE 2
  4302. C
  4303.       INCLUDE rin:CONST8.BLK
  4304.       INCLUDE rin:F2COM.BLK
  4305.       INCLUDE rin:RIMCOM.BLK
  4306.       INCLUDE rin:BUFFER.BLK
  4307.       INCLUDE rin:FLAGS.BLK
  4308. C
  4309.       INTEGER REC1
  4310. C
  4311. C  SEQUENCE THROUGH THE BUFFERS LOOKING FOR WRITE FLAGS.
  4312. C
  4313.       REC1 = 0
  4314.       DO 400 NUMB=1,4
  4315.       IF(NUMB.EQ.4) GO TO 100
  4316.       IF(CURBLK(NUMB).EQ.1) GO TO 100
  4317.       IF(MODFLG(NUMB).EQ.0) GO TO 400
  4318. C
  4319. C  WRITE IT OUT.
  4320. C
  4321.       KQ1 = BLKLOC(NUMB)
  4322.       CALL RIOOUT(FILE2,CURBLK(NUMB),BUFFER(KQ1),LENBF2,IOS)
  4323.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  4324.       MODFLG(NUMB) = 0
  4325.       CURBLK(NUMB) = 0
  4326.       CALL BLKCLR(NUMB)
  4327.       GO TO 400
  4328.   100 CONTINUE
  4329.       IF(REC1.EQ.1) GO TO 400
  4330.       IF(NUMB.NE.4) GO TO 200
  4331. C
  4332. C  READ IN THE CONTROL BLOCK FIRST.
  4333. C
  4334.       CALL BLKCHG(1,LENBF2,1)
  4335.       KQ1 = BLKLOC(1)
  4336.       CALL RIOIN(FILE2,1,BUFFER(KQ1),LENBF2,IOS)
  4337.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  4338.       GO TO 300
  4339. C
  4340. C  WRITE OUT THE CONTROL BLOCK.
  4341. C
  4342.   200 CONTINUE
  4343.       KQ1 = BLKLOC(NUMB)
  4344.   300 CONTINUE
  4345.       KQ0 = KQ1 - 1
  4346.       CALL BLKMOV(BUFFER(KQ0 + 1),DBNAME,2)
  4347.       CALL BLKMOV(BUFFER(KQ0 + 3),K8RMDT,2)
  4348.       CALL BLKMOV(BUFFER(KQ0 + 5),OWNER,2)
  4349.       CALL BLKMOV(BUFFER(KQ0 + 7),DBDATE,2)
  4350.       CALL BLKMOV(BUFFER(KQ0 + 9),DBTIME,2)
  4351.       BUFFER(KQ0 + 11) = LENBF2
  4352.       BUFFER(KQ0 + 12) = LF2REC
  4353.       BUFFER(KQ0 + 13) = LF2WRD
  4354.       CALL RIOOUT(FILE2,1,BUFFER(KQ1),LENBF2,IOS)
  4355.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  4356.       REC1 = 1
  4357.       IF(NUMB.EQ.4) GO TO 400
  4358.       MODFLG(NUMB) = 0
  4359.       CURBLK(NUMB) = 0
  4360.   400 CONTINUE
  4361.       RETURN
  4362.       END
  4363.       SUBROUTINE F2OPN(FILE)
  4364.       INCLUDE rin:TEXT.BLK
  4365. C
  4366. C  PURPOSE:    OPEN A DATA RANDOM IO PAGING FILE - FILE 2
  4367. C
  4368. C  PARAMETERS:
  4369. C     INPUT:   FILE----NAME OF THE FILE TO USE FOR FILE 2
  4370. C
  4371.       INCLUDE rin:CONST8.BLK
  4372.       INCLUDE rin:F2COM.BLK
  4373.       INCLUDE rin:FLAGS.BLK
  4374.       INCLUDE rin:BUFFER.BLK
  4375.       INCLUDE rin:RIMCOM.BLK
  4376.       LOGICAL EQ
  4377.       INCLUDE rin:DCLAR4.BLK
  4378. C
  4379. C  OPEN UP THE PAGED DATA FILE.
  4380. C
  4381.       CALL RIOOPN(FILE,FILE2,LENBF2,IOS)
  4382.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  4383. C
  4384. C  SEE IF THE FILE EXISTS YET. IF SO, READ CONTROL DATA.
  4385. C
  4386.       CALL BLKDEF(1,LENBF2,1)
  4387.       KQ1 = BLKLOC(1)
  4388.       KQ0 = KQ1 - 1
  4389.       CALL RIOIN(FILE2,1,BUFFER(KQ1),LENBF2,IOS)
  4390.       IF(IOS.NE.0) GO TO 100
  4391.       IF(.NOT.EQ(DBNAME,BUFFER(KQ0 + 1))) GO TO 8000
  4392.       IF(.NOT.EQ(K8RMDT,BUFFER(KQ0 + 3))) GO TO 8000
  4393.       IF(.NOT.EQ(OWNER,BUFFER(KQ0 + 5))) GO TO 8000
  4394.       IF(.NOT.EQ(DBDATE,BUFFER(KQ0 + 7))) GO TO 8000
  4395.       IF(.NOT.EQ(DBTIME,BUFFER(KQ0 + 9))) GO TO 8000
  4396.       LENBF2 = BUFFER(KQ0 + 11)
  4397.       LF2REC = BUFFER(KQ0 + 12)
  4398.       LF2WRD = BUFFER(KQ0 + 13)
  4399.       GO TO 200
  4400. C
  4401. C  INITIALIZE THE CONTROL VARIABLES.
  4402. C
  4403.   100 CONTINUE
  4404.       LF2REC = 1
  4405.       LF2WRD = 20
  4406. C
  4407. C  WRITE OUT THE CONTROL BLOCK FOR THE FIRST TIME.
  4408. C
  4409.       CALL ZEROIT(BUFFER(KQ1),LENBF2)
  4410.       CALL BLKMOV(BUFFER(KQ0 + 1),DBNAME,2)
  4411.       CALL BLKMOV(BUFFER(KQ0 + 3),K8RMDT,2)
  4412.       CALL BLKMOV(BUFFER(KQ0 + 5),OWNER,2)
  4413.       CALL BLKMOV(BUFFER(KQ0 + 7),DBDATE,2)
  4414.       CALL BLKMOV(BUFFER(KQ0 + 9),DBTIME,2)
  4415.       BUFFER(KQ0 + 11) = LENBF2
  4416.       BUFFER(KQ0 + 12) = LF2REC
  4417.       BUFFER(KQ0 + 13) = LF2WRD
  4418.       CALL RIOOUT(FILE2,1,BUFFER(KQ1),LENBF2,IOS)
  4419.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  4420.   200 CONTINUE
  4421. C
  4422. C  INITIALIZE THE CONTROL BLOCKS.
  4423. C
  4424.       CURBLK(1) = 1
  4425.       CURBLK(2) = 0
  4426.       CURBLK(3) = 0
  4427.       CALL ZEROIT(MODFLG,3)
  4428.       RETURN
  4429. C
  4430. C  CONTROL VALUES DO NOT MATCH VALUES FROM FILE 1.
  4431. C
  4432.  8000 CONTINUE
  4433.       RMSTAT = 12
  4434.       RETURN
  4435.       END
  4436.       SUBROUTINE F3CLO
  4437.       INCLUDE rin:TEXT.BLK
  4438. C
  4439. C  PURPOSE:    CLOSE THE B-TREE RANDOM IO FILE - FILE 3
  4440. C
  4441.       INCLUDE rin:CONST8.BLK
  4442.       INCLUDE rin:F3COM.BLK
  4443.       INCLUDE rin:RIMCOM.BLK
  4444.       INCLUDE rin:BTBUF.BLK
  4445.       INCLUDE rin:FLAGS.BLK
  4446. C
  4447. C  SEQUENCE THROUGH THE INCORE BLOCKS LOOKING FOR WRITE FLAGS.
  4448. C
  4449.       DO 100 NUMB=1,NUMIC
  4450.       IF(ICORE(2,NUMB).EQ.0) GO TO 100
  4451. C
  4452. C  WRITE IT OUT.
  4453. C
  4454.       ISTRT = (NUMB-1) * LENBF3 + 1
  4455.       CALL RIOOUT(FILE3,ICORE(3,NUMB),CORE(ISTRT),LENBF3,IOS)
  4456.       IF(IOS.NE.0) RMSTAT = 2300 + IOS
  4457.   100 CONTINUE
  4458. C
  4459. C  WRITE OUT THE CONTROL BLOCK.
  4460. C
  4461.       CALL ZEROIT(CORE,LENBF3)
  4462.       CALL BLKMOV(CORE(1),DBNAME,2)
  4463.       CALL BLKMOV(CORE(3),K8RMDT,2)
  4464.       CALL BLKMOV(CORE(5),OWNER,2)
  4465.       CALL BLKMOV(CORE(7),DBDATE,2)
  4466.       CALL BLKMOV(CORE(9),DBTIME,2)
  4467.       CORE(11) = LENBF3
  4468.       CORE(12) = LF3REC
  4469.       CORE(13) = MOTREC
  4470.       CORE(14) = MOTADD
  4471.       CALL RIOOUT(FILE3,1,CORE,LENBF3,IOS)
  4472.       IF(IOS.NE.0) RMSTAT = 2300 + IOS
  4473.       RETURN
  4474.       END
  4475.       SUBROUTINE F3OPN(FILE)
  4476.       INCLUDE rin:TEXT.BLK
  4477. C
  4478. C  PURPOSE:    OPEN A B-TREE RANDOM IO PAGING FILE - FILE 3
  4479. C
  4480. C  PARAMETERS:
  4481. C     INPUT:   FILE----NAME OF THE FILE TO USE FOR FILE 3
  4482. C
  4483.       INCLUDE rin:CONST8.BLK
  4484.       INCLUDE rin:F3COM.BLK
  4485.       INCLUDE rin:FLAGS.BLK
  4486.       INCLUDE rin:BTBUF.BLK
  4487.       INCLUDE rin:START.BLK
  4488.       INCLUDE rin:RIMCOM.BLK
  4489.       LOGICAL EQ
  4490.       INCLUDE rin:DCLAR4.BLK
  4491. C
  4492. C  OPEN UP THE BTREE AND MOT FILE.
  4493. C
  4494.       CALL RIOOPN(FILE,FILE3,LENBF3,IOS)
  4495.       IF(IOS.NE.0) RMSTAT = 2300 + IOS
  4496. C
  4497. C  SEE IF THE FILE EXISTS YET. IF SO, READ CONTROL DATA.
  4498. C
  4499.       CALL RIOIN(FILE3,1,CORE,LENBF3,IOS)
  4500.       IF(IOS.NE.0) GO TO 100
  4501.       IF(.NOT.EQ(DBNAME,CORE(1))) GO TO 8000
  4502.       IF(.NOT.EQ(K8RMDT,CORE(3))) GO TO 8000
  4503.       IF(.NOT.EQ(OWNER,CORE(5))) GO TO 8000
  4504.       IF(.NOT.EQ(DBDATE,CORE(7))) GO TO 8000
  4505.       IF(.NOT.EQ(DBTIME,CORE(9))) GO TO 8000
  4506.       LENBF3 = CORE(11)
  4507.       LF3REC = CORE(12)
  4508.       MOTREC = CORE(13)
  4509.       MOTADD = CORE(14)
  4510.       GO TO 200
  4511. C
  4512. C  INITIALIZE THE CONTROL VARIABLES.
  4513. C
  4514.   100 CONTINUE
  4515.       START = 0
  4516.       LF3REC = 2
  4517.       MOTREC = 0
  4518.       MOTADD = LENBF3 + 1
  4519. C
  4520. C  WRITE OUT THE CONTROL BLOCK FOR THE FIRST TIME.
  4521. C
  4522.       CALL ZEROIT(CORE,LENBF3)
  4523.       CALL BLKMOV(CORE(1),DBNAME,2)
  4524.       CALL BLKMOV(CORE(3),K8RMDT,2)
  4525.       CALL BLKMOV(CORE(5),OWNER,2)
  4526.       CALL BLKMOV(CORE(7),DBDATE,2)
  4527.       CALL BLKMOV(CORE(9),DBTIME,2)
  4528.       CORE(11) = LENBF3
  4529.       CORE(12) = LF3REC
  4530.       CORE(13) = MOTREC
  4531.       CORE(14) = MOTADD
  4532.       CALL RIOOUT(FILE3,1,CORE,LENBF3,IOS)
  4533.       IF(IOS.NE.0) RMSTAT = 2300 + IOS
  4534.   200 CONTINUE
  4535. C
  4536. C  INITIALIZE THE TREE COMMON BLOCK.
  4537. C
  4538.       NUMIC = 0
  4539.       LAST = 0
  4540.       CALL ZEROIT(ICORE(1,1),60)
  4541.       RETURN
  4542. C
  4543. C  CONTROL VALUES DO NOT MATCH VALUES FROM FILE 1.
  4544. C
  4545.  8000 CONTINUE
  4546.       RMSTAT = 12
  4547.       RETURN
  4548.       END
  4549.       SUBROUTINE FILCH(STRING,CHAR1,NUM,CHAR)
  4550.       INCLUDE rin:TEXT.BLK
  4551. C
  4552. C     THIS ROUTINE STUFFS NUM CHAR'S INTO STRING
  4553. C     STARTING AT CHAR1.
  4554. C
  4555.       INTEGER CHAR,STRING(*)
  4556.       INTEGER CHAR1
  4557.       DO 10 I=1,NUM
  4558.       CALL PUTT(STRING,CHAR1+I-1,CHAR)
  4559.    10 CONTINUE
  4560.       RETURN
  4561.       END
  4562.       SUBROUTINE GETDAT(INDEX,ID,LOCTUP,LENGTH)
  4563.       INCLUDE rin:TEXT.BLK
  4564. C
  4565. C  PURPOSE:  GET A TUPLE FROM THE DATA FILE
  4566. C
  4567. C  PARAMETERS:
  4568. C         INDEX---BLOCK REFERENCE NUMBER
  4569. C         ID------PACKED ID WORD WITH START,PRU
  4570. C         LOCTUP--OFFSET IN BUFFER FOR THE TUPLE
  4571. C         LENGTH---LENGTH OF THE TUPLE
  4572.       INCLUDE rin:F2COM.BLK
  4573.       INCLUDE rin:RIMCOM.BLK
  4574.       INCLUDE rin:BUFFER.BLK
  4575.       INCLUDE rin:RIMPTR.BLK
  4576. C
  4577.       INTEGER OFFSET
  4578. C
  4579. C  UNPAC THE ID WORD.
  4580. C
  4581.       CALL ITOH(OFFSET,IOBN,ID)
  4582.   100 CONTINUE
  4583. C
  4584. C  MAKE SURE WE HAVE A VALID ID.
  4585. C
  4586.       IF(IOBN.GT.LF2REC) GO TO 600
  4587.       IF(OFFSET.GT.LENBF2) GO TO 600
  4588. C
  4589. C  SEE IF THE NEEDED BLOCK IS CURRENTLY IN CORE.
  4590. C
  4591.       NUMBLK = 0
  4592.       DO 200 I=1,3
  4593.       IF(IOBN.EQ.CURBLK(I)) NUMBLK = I
  4594.   200 CONTINUE
  4595.       IF(NUMBLK.NE.0) GO TO 400
  4596.       NUMBLK = INDEX
  4597. C
  4598. C  WE MUST DO PAGING.
  4599. C
  4600. C  SEE IF THE CURRENT BLOCK NEEDS WRITING.
  4601. C
  4602.       IF(MODFLG(NUMBLK).EQ.0) GO TO 300
  4603. C
  4604. C  WRITE OUT THE CURRENT BLOCK.
  4605. C
  4606.       KQ1 = BLKLOC(NUMBLK)
  4607.       CALL RIOOUT(FILE2,CURBLK(NUMBLK),BUFFER(KQ1),LENBF2,IOS)
  4608.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  4609.   300 CONTINUE
  4610. C
  4611. C  READ IN THE NEEDED BLOCK.
  4612. C
  4613.       CALL BLKCHG(NUMBLK,LENBF2,1)
  4614.       KQ1 = BLKLOC(NUMBLK)
  4615.       CALL RIOIN(FILE2,IOBN,BUFFER(KQ1),LENBF2,IOS)
  4616.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  4617.       CURBLK(NUMBLK) = IOBN
  4618.       MODFLG(NUMBLK) = 0
  4619.   400 CONTINUE
  4620. C
  4621. C  MOVE THE DESIRED DATA.
  4622. C
  4623.       KQ0 = BLKLOC(NUMBLK) - 1
  4624.       ID = BUFFER(KQ0 + OFFSET)
  4625.       IF(ID.GE.0) GO TO 500
  4626. C
  4627. C  THIS TUPLE IS NOT ACTIVE. GO TO THE NEXT ONE.
  4628. C
  4629.       ID = -ID
  4630.       CID = ID
  4631.       ISOFF = OFFSET
  4632.       CALL ITOH(OFFSET,IOBN,ID)
  4633.       IF(IOBN.NE.0) GO TO 100
  4634. C
  4635. C  WE HAVE AN INACTIVE LAST TUPLE.
  4636. C
  4637.       ID = -ID
  4638.       OFFSET = ISOFF
  4639.   500 CONTINUE
  4640.       LOCTUP = KQ0 + OFFSET + 2
  4641.       LENGTH = BUFFER(LOCTUP - 1)
  4642.       RETURN
  4643. C
  4644. C  BAD ID VALUE.
  4645. C
  4646.   600 CONTINUE
  4647.       ID = 0
  4648.       RETURN
  4649.       END
  4650.       SUBROUTINE GETT(STR1,IC1,WORD)
  4651.       INCLUDE rin:TEXT.BLK
  4652. C
  4653. C  PURPOSE:   GET THE IC1 CHARACTER FROM STR1 AND PUT IN WORD
  4654. C
  4655. C  PARAMETERS:
  4656. C     STR1----STRING OF CHARACTERS
  4657. C     IC1-----THE CHARACTER WANTED
  4658. C     WORD----WORD TO GET THE CHARACTER (LEFT JUSTIFIED, BLANK FILL)
  4659. C
  4660.       Character*1 STR1(1)
  4661.       INTEGER WORD
  4662.       INTEGER CHWORD
  4663.       Character*1 CHAR(4)
  4664.       EQUIVALENCE (CHWORD,CHAR(1))
  4665.       INTEGER BLANK
  4666.       DATA BLANK /4H    /
  4667.       CHWORD = BLANK
  4668.       CHAR(1) = STR1(IC1)
  4669.       WORD = CHWORD
  4670.       RETURN
  4671.       END
  4672.       SUBROUTINE GTSORT(MAT,INDEX,IFLAG,LENGTH)
  4673.       INCLUDE rin:TEXT.BLK
  4674. C
  4675. C  PURPOSE:  READ IN TUPLES FROM THE SORTED DATA FILE
  4676. C
  4677. C  PARAMETERS:
  4678. C            MAT-----ARRAY TO HOLD ONE TUPLE (IF IFLAG = 1)
  4679. C                    POINTER TO TUPLE IN BUFFER (IF IFLAG = 0)
  4680. C           INDEX---PAGE BUFFER TO USE
  4681. C            IFLAG---0 IF THE TUPLE IS RETURNED IN MAT
  4682. C                    1 IF THE BUFFER POINTER IS RETURNED IN MAT
  4683. C                   -1 OPEN THE SORT FILE AND INITIALIZE
  4684. C            LENGTH--LENGTH OF TUPLE IN WORDS
  4685. C            INDPTR--MULTIPLE RMHUNT INDEX - USED TO ASSIGN FILES
  4686. C
  4687.       INCLUDE rin:SRTCOM.BLK
  4688.       INCLUDE rin:WHCOM.BLK
  4689.       INCLUDE rin:RIMCOM.BLK
  4690.       INCLUDE rin:BUFFER.BLK
  4691.       INCLUDE rin:F2COM.BLK
  4692.       INCLUDE rin:MISC.BLK
  4693. C
  4694.       DIMENSION MAT(*)
  4695.       INTEGER INFIL
  4696.       INFIL = 20
  4697. C
  4698. C  IF IFLAG IS NOT -1 SKIP THE SORT FILE/BUFFER INITIALIZATION
  4699. C
  4700.       IF(IFLAG.NE.-1) GO TO 500
  4701. C
  4702. C  FIRST CALL -----
  4703. C
  4704. C  REWIND THE SORT FILE NEEDED
  4705. C
  4706.       REWIND INFIL
  4707. C
  4708. C  ESTABLISH THE BUFFER POINTER
  4709. C
  4710. C  SEE IF THE CURRENT BLOCK NEEDS WRITING
  4711. C
  4712.       IF(INDEX.GT.3) GO TO 200
  4713.       IF(MODFLG(INDEX).EQ.0) GO TO 100
  4714. C
  4715. C  WRITE OUT THE CURRENT BLOCK
  4716. C
  4717.       KQ1 = BLKLOC(INDEX)
  4718.       CALL RIOOUT(FILE2,CURBLK(INDEX),BUFFER(KQ1),LENBF2,IOS)
  4719.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  4720.   100 MODFLG(INDEX) = 0
  4721.       CURBLK(INDEX) = 0
  4722. C
  4723. C  ESTABLISH THE NEW BUFFER BLOCK
  4724. C
  4725.   200 CONTINUE
  4726.       CALL BLKCHG(INDEX,MAXCOL,1)
  4727. C
  4728. C  SET THE TUPLES READ COUNTED TO 0
  4729. C
  4730.       NREAD = 0
  4731. C
  4732. C  ALL INITIALIZATION COMPLETE -- RETURN
  4733. C
  4734.       RETURN
  4735. C
  4736. C  READ IN A TUPLE FROM THE SORT FILE
  4737. C
  4738.   500 CONTINUE
  4739.       CALL BLKCHG(INDEX,MAXCOL,1)
  4740.       KQ1 = BLKLOC(INDEX) - 1
  4741.       NREAD = NREAD + 1
  4742.       IF(NREAD.GT.LIMTU) GO TO 900
  4743.       IF(NREAD.GT.NSORT) GO TO 900
  4744.       IF(FIXLT) GO TO 600
  4745. C
  4746. C  VARIABLE LENGTH TUPLES
  4747. C
  4748. c      READ(INFIL) LENGTH,(BUFFER(KQ1+K),K=1,LENGTH)
  4749.       READ(INFIL) LENGTH
  4750.       READ(INFIL) (BUFFER(KQ1+K),K=1,LENGTH)
  4751.       GO TO 700
  4752. C
  4753. C  FIXED LENGTH TUPLES
  4754. C
  4755.   600 CONTINUE
  4756.       READ(INFIL) (BUFFER(KQ1+K),K=1,LENGTH)
  4757. C
  4758. C  TUPLE READ - SET MAT AND RMSTAT
  4759. C
  4760.   700 CONTINUE
  4761.       RMSTAT = 0
  4762.       MAT(1) = KQ1 + 1
  4763.       IF(IFLAG.NE.0) GO TO 999
  4764. C
  4765. C  LOAD TUPLE INTO MAT
  4766. C
  4767.       DO 800 K=1,LENGTH
  4768.       MAT(K) = BUFFER(KQ1+K)
  4769.   800 CONTINUE
  4770.       GO TO 999
  4771. C
  4772. C  ALL DONE - SET RMSTAT AND CLOSE THE FILE
  4773. C
  4774.   900 CONTINUE
  4775.       RMSTAT = -1
  4776.       CALL BLKCLR(INDEX)
  4777.       CLOSE(UNIT=INFIL,STATUS='DELETE')
  4778. C
  4779.   999 CONTINUE
  4780.       RETURN
  4781.       END
  4782.       SUBROUTINE HASH(TEMP,N)
  4783.       INCLUDE rin:TEXT.BLK
  4784.       INTEGER TEMP(8)
  4785.       DO 20 I=1,N
  4786.       J = TEMP(7)
  4787.       TEMP(7) = TEMP(1)
  4788.       TEMP(1) = TEMP(4)
  4789.       TEMP(4) = TEMP(6)
  4790.       TEMP(6) = TEMP(8)
  4791.       TEMP(8) = TEMP(3)
  4792.       TEMP(3) = TEMP(5)
  4793.       TEMP(5) = TEMP(2)
  4794.       TEMP(2) = J
  4795.    20 CONTINUE
  4796.       RETURN
  4797.       END
  4798.       SUBROUTINE HASHIN(PASS,NUM,HASHP,ICHAR)
  4799.       INCLUDE rin:TEXT.BLK
  4800. C
  4801. C     THIS ROUTINE HASHES AN 8 CHARACTER PASSWORD INTO A 16
  4802. C     CHARACTER HASHED PASSWORD.
  4803. C     1. ADD 8 CHARACTERS OF GARBAGE EVERY OTHER ONE.
  4804. C     2. ADD OLD PASSWORD SWITCHING E'S AND BLANKS.
  4805. C     3. CYCLE 1ST AND LAST HALF NUM TIMES.
  4806. C     4. PACK INTO OUTPUT STRING
  4807. C
  4808.       INCLUDE rin:CONST4.BLK
  4809.       INCLUDE rin:CONST8.BLK
  4810.       INCLUDE rin:MISC.BLK
  4811.       INTEGER TEMP(16)
  4812.       INTEGER PASS(*)
  4813. C
  4814. C     WORD1 CONTAINS THE HASH SEQUENCE
  4815. C
  4816.       J = 0
  4817.       DO 10 I=2,16,2
  4818.       J = J+1
  4819.       CALL GETT (K8XXX,J,TEMP(I))
  4820.    10 CONTINUE
  4821.       J = 0
  4822.       DO 20 I=1,15,2
  4823.       J = J + 1
  4824.       CALL GETT(PASS,J,TEMP(I))
  4825.       K = TEMP(I)
  4826.       IF (TEMP(I) .EQ. IBLANK) K = K4E
  4827.       IF (TEMP(I) .EQ. K4E) K = IBLANK
  4828.       TEMP(I) = K
  4829.    20 CONTINUE
  4830.       CALL HASH(TEMP(1),NUM)
  4831.       CALL HASH(TEMP(9),NUM)
  4832.       CALL HASH(TEMP(4),NUM)
  4833.       DO 30 I=1,16
  4834.       CALL PUTT(HASHP,I + ICHAR - 1,TEMP(I))
  4835.    30 CONTINUE
  4836.       RETURN
  4837.       END
  4838.       SUBROUTINE GETL(LINE,NUMC)
  4839.       DIMENSION LINE(20)
  4840.       DIMENSION LINEX(20)
  4841.       INTEGER BLANK
  4842.       DATA BLANK /1H /
  4843.       READ (2,10)LINEX
  4844.    10 FORMAT(20A4)
  4845.       LINE(1) = BLANK
  4846.       LINE(20) = BLANK
  4847.       M1 = NSCAN(LINEX,80,-80,1H ,1,1)
  4848.       IF(M1.LE.0) M1 = 2
  4849.       ISHIFT = 2
  4850.       IF(M1.EQ.1) ISHIFT = 1
  4851.       IF(LINEX(1).EQ.'ENDD') ISHIFT = 1
  4852.       IF(LINEX(1).EQ.'ENDC') ISHIFT = 1
  4853.       IF(M1.NE.1) M1 = M1 + 1
  4854.       CALL STRMOV(LINEX,1,79,LINE,ISHIFT)
  4855.       NUMC = M1
  4856.       RETURN
  4857.       END
  4858.       SUBROUTINE HTOI(I,J,K)
  4859.       INCLUDE rin:TEXT.BLK
  4860. C
  4861. C  PURPOSE:   PACK I AND J INTO K
  4862. C
  4863. C  OFFSET I BY MULTIPLYING BY 100000.
  4864. C
  4865.       K = J + (100000 * I)
  4866.       RETURN
  4867.       END
  4868.       INTEGER FUNCTION IEXP(REAL)
  4869.       INCLUDE rin:TEXT.BLK
  4870. C
  4871. C     THIS FUNCTION RETURNS THE BASE TEN EXPONENT OF A REAL
  4872. C
  4873.       IE = -1000000
  4874.       IF(REAL.EQ.0.) GO TO 999
  4875.       X = ALOG10(ABS(REAL))
  4876.       IE = INT(X) + 1
  4877.       IF(X.LT.0.) IE = 1 + (INT(1000.+X)-1000)
  4878.   999 CONTINUE
  4879.       IEXP = IE
  4880.       RETURN
  4881.       END
  4882.       FUNCTION IFRT(WORD)
  4883.       INCLUDE rin:TEXT.BLK
  4884. C
  4885. C  PURPOSE:   HASH WORD IN TO AN INTEGER
  4886. C
  4887. C  PARAMETERS:
  4888. C         WORD----A WORD OF TEXT
  4889. C         IFRT----AN INTEGER WHICH CORRESPONDS TO THE WORD
  4890. C
  4891.       REAL*8 WORD
  4892.       REAL*8 CHWORD
  4893.       Character*1 CH(8)
  4894.       EQUIVALENCE (CH(1),CHWORD)
  4895.       INTEGER POWER
  4896. C
  4897.       CHWORD = WORD
  4898.       NUM = 0
  4899.       POWER = 1
  4900. C
  4901. C  TURN LETTERS INTO NUMBERS.
  4902. C
  4903.       DO 100 I=1,8
  4904.       K = CH(9-I)
  4905.       K = K + 10
  4906.       NUM = NUM + K * POWER
  4907.       POWER = POWER * 10
  4908.   100 CONTINUE
  4909.       IFRT = NUM
  4910.       RETURN
  4911.       END
  4912.       SUBROUTINE INTCON(INTOPT)
  4913.       INCLUDE rin:TEXT.BLK
  4914. C
  4915. C  PURPOSE:  THIS ROUTINE PROMPTS THE USER FOR THE EXECUTION
  4916. C            OPTION DESIRED (CREATE,UPDATE OR QUERY) AND CALLS
  4917. C            THE APPROPRIATE SUBROUTINES.
  4918. C
  4919. C  PARAMETERS: INTOPT - MENU MODE OPTION CODE
  4920. C                       4HMENU - DISPLAY MENU
  4921. C                       3HCRE -- CREATE MODE
  4922. C                       3HUPD -- UPDATE MODE
  4923. C                       3HQUE -- QUERY MODE
  4924. C
  4925.       INCLUDE rin:RMATTS.BLK
  4926.       INCLUDE rin:RMKEYW.BLK
  4927.       INCLUDE rin:CONST4.BLK
  4928.       INCLUDE rin:FLAGS.BLK
  4929.       INCLUDE rin:FILES.BLK
  4930.       INCLUDE rin:RIMCOM.BLK
  4931.       INCLUDE rin:MISC.BLK
  4932. C
  4933.       INTEGER DBSTAT
  4934.       LOGICAL EQKEYW
  4935.       INCLUDE rin:DCLAR2.BLK
  4936. C
  4937. C     ******************************************************
  4938. C
  4939. C               I N I T I A L I Z A T I O N
  4940. C
  4941. C     ******************************************************
  4942. C
  4943.       NAMDB = DBNAME
  4944.       IF((INTOPT.EQ.K4CRE).OR.(INTOPT.EQ.K4UPD)) GO TO 150
  4945.       IF(INTOPT.EQ.K4LOD) GO TO 255
  4946. C
  4947. C     REQUEST THE EXECUTION OPTION - IDBT
  4948. C       IDBT = 1: CREATE A NEW DATABASE
  4949. C       IDBT = 2: UPDATE AN EXISTING DATABASE
  4950. C       IDBT = 3: QUERY
  4951. C       IDBT = 4: COMMAND MODE
  4952. C       IDBT = 5: EXIT
  4953. C
  4954.       IDBT = 0
  4955.   100 CONTINUE
  4956.     if(nout.eq.6)goto 1
  4957.          WRITE(NOUT,110)
  4958.   110 FORMAT(/,1X,35HSelect the execution option desired,/
  4959.      1   5X,24H1) CREATE a new database,/
  4960.      2   5X,30H2) UPDATE an existing database,/
  4961.      3   5X,29H3) QUERY an existing database,/
  4962.      4   5X,21H4) Enter COMMAND mode,/
  4963.      5   5X, 7H5) Exit,/)
  4964.     goto 2
  4965. 1    continue
  4966.     write(c128wk,3140)
  4967. 3140    format(' Sel opt: 1=CREATE,2=UPDATE,3=QUERY,4=CMDMODE,5=EXIT:')
  4968.     call atxto
  4969. 2    continue
  4970.       CALL LXLREC(DUM1,0,LXERR)
  4971.       IXID1 = LXID(1)
  4972.       IF(IXID1.EQ.K4EOF) GO TO 998
  4973.       IXREC1 = 0
  4974.       IF(IXID1.EQ.KZINT) IXREC1 = LXIREC(1)
  4975.       IF(EQKEYW(1,KWQUIT,4)) GO TO 997
  4976.       IF(EQKEYW(1,KWEXIT,4)) GO TO 998
  4977.       IDBT = IXREC1
  4978.       IF(IDBT.EQ.4) GO TO 400
  4979.       IF(IDBT.EQ.5) GO TO 998
  4980.       IF(IDBT.GT.0.AND.IDBT.LT.5) GO TO 120
  4981.     if(nout.eq.6)goto 3
  4982.       WRITE(NOUT,8001)
  4983.       GO TO 100
  4984.  
  4985. 3    continue
  4986.     write(c128wk,8001)
  4987.     call atxto
  4988.     goto 100
  4989. C
  4990. C     REQUEST THE DATABASE NAME - NAMDB
  4991. C
  4992. 120    continue
  4993.     if(nout.eq.6)goto 4
  4994.        WRITE(NOUT,130)
  4995.     goto 5
  4996. 4    continue
  4997.     write(c128wk,130)
  4998.     call atxto
  4999. 5    continue
  5000.   130 FORMAT(1X,31HEnter the NAME of the database:)
  5001.       CALL LXLREC(DUM1,0,LXERR)
  5002.       IXID1 = LXID(1)
  5003.       IF(IXID1.EQ.K4EOF) GO TO 120
  5004.       IXREC1 = LXWREC(1,1)
  5005.       IF(EQKEYW(1,KWQUIT,4)) GO TO 997
  5006.       IXLEN = LXLENC(1)
  5007.       IF((IXID1.EQ.KZTEXT).AND.(IXLEN.LE.6)) GO TO 140
  5008.     if(nout.eq.6)goto 6
  5009.       WRITE(NOUT,8002)
  5010.       GO TO 120
  5011. 6    continue
  5012.     write(c128wk,8002)
  5013.     call atxto
  5014.     goto 120
  5015.   140 NAMDB = BLANK
  5016.       CALL LXSREC(1,1,8,NAMDB,1)
  5017.       IF(IDBT.NE.1) GO TO 180
  5018. C
  5019. C  CREATE MODE - CALL INTDEF TO DEFINE THE SCHEMA
  5020. C
  5021.       INTOPT = K4CRE
  5022. C
  5023. C  CHECK THAT THE DATABASE MAY BE MODIFIED
  5024. C
  5025.       CALL RMDBLK(NAMDB)
  5026.       IF(RMSTAT.NE.0) GO TO 215
  5027.       CALL INTDEF(NAMDB,INTOPT)
  5028.       IF(INTOPT.EQ.0) GO TO 100
  5029.       GO TO 999
  5030. C
  5031. C  DETERMINE IF THE DATABASE IS TO BE LOADED INTERACTIVELY
  5032. C
  5033.   150 CONTINUE
  5034. C
  5035. C     DETERMINE IF THE DATABASE IS TO BE LOADED
  5036. C
  5037.   160 CONTINUE
  5038.       if(nout.eq.6)goto 7
  5039.       WRITE(NOUT,170)
  5040.     goto 8
  5041. 7    continue
  5042.     write(c128wk,170)
  5043.     call atxto
  5044. 8    continue
  5045.   170 FORMAT(1X,42HDo you want to LOAD the database - Y or N:)
  5046.       CALL LXLREC(DUM1,0,LXERR)
  5047.       IXID1 = LXID(1)
  5048.       IF(IXID1.EQ.K4EOF) GO TO 260
  5049.       IXREC1 = 0
  5050.       IF(IXID1.EQ.KZINT) IXREC1 = LXIREC(1)
  5051.       IF(IXID1.EQ.KZTEXT) IXREC1 = LXWREC(1,1)
  5052.       IF(EQKEYW(1,KWQUIT,4)) GO TO 997
  5053.       IF(IXREC1.EQ.K4Y) GO TO 250
  5054.       IF(IXREC1.EQ.K4N) GO TO 260
  5055.     if(nout.eq.6)goto 9
  5056.       WRITE(NOUT,8004)
  5057.       GO TO 160
  5058. 9    continue
  5059.     write(c128wk,8004)
  5060.     call atxto
  5061.     goto 160
  5062. C
  5063. C  QUERY AND UPDATE MODE - GET THE DATABASE
  5064. C
  5065.   180 CONTINUE
  5066.       CALL RMDBGT(NAMDB,DBSTAT)
  5067.       IF(DBSTAT.EQ.0) GO TO 200
  5068.       IF(DBSTAT.EQ.1) GO TO 100
  5069.       GO TO 997
  5070.   200 CONTINUE
  5071. C
  5072. C     CHECK THAT USER DATABASE NAME MATCHES THE FILE DATABASE NAME
  5073. C
  5074.       CALL RMOPEN(NAMDB)
  5075.       IF(RMSTAT.EQ.0) GO TO 210
  5076.       CALL WARN(RMSTAT,NAMDB,0)
  5077.       RMSTAT = 0
  5078.       GO TO 120
  5079.   210 CONTINUE
  5080.       IF(IDBT.EQ.3) GO TO 300
  5081. C
  5082. C  CHECK THAT THE DATABASE MAY BE MODIFIED
  5083. C
  5084.       CALL RMDBLK(NAMDB)
  5085.       IF(RMSTAT.EQ.0) GO TO 220
  5086.   215 CALL WARN(RMSTAT,NAMDB,0)
  5087.       RMSTAT = 0
  5088.       GO TO 100
  5089. C
  5090. C     REQUEST THE UPDATE OPTION
  5091. C       1 -- DEFINE ADDITIONAL RELATIONS
  5092. C            (BRANCH TO THE DEFINE SECTION)
  5093. C       2 -- LOAD ADDITIONAL DATA
  5094. C            (BRANCH TO THE LOAD SECTION)
  5095. C
  5096.   220 Continue
  5097.     if(nout.eq.6)goto 10
  5098.     WRITE(NOUT,230)
  5099.   230 FORMAT(/,1X,32HSelect the UPDATE option desired,/
  5100.      1      5X,30H1) Define additional relations,/
  5101.      2      5X,23H2) Load additional data,/)
  5102.     goto 11
  5103. 10    continue
  5104.     write(c128wk,3142)
  5105. 3142    format(' Select UPDATE option: 1=define more relations,',
  5106.      1 '2=load more data:')
  5107.     call atxto
  5108. 11    continue
  5109.       CALL LXLREC(DUM1,0,LXERR)
  5110.       IXID1 = LXID(1)
  5111.       IF(IXID1.EQ.K4EOF) GO TO 220
  5112.       IXREC1 = 0
  5113.       IF(IXID1.EQ.KZINT) IXREC1 = LXIREC(1)
  5114.       IF(IXID1.EQ.KZTEXT) IXREC1 = LXWREC(1,1)
  5115.       IF(EQKEYW(1,KWQUIT,4)) GO TO 997
  5116.       IF(IXREC1.EQ.1) GO TO 240
  5117.       IF(IXREC1.EQ.2) GO TO 250
  5118.     if(nout.eq.6)goto 12
  5119.       WRITE(NOUT,8003)
  5120.       GO TO 220
  5121. 12    continue
  5122.     write(c128wk,8003)
  5123.     call atxto
  5124.     goto 220
  5125. C
  5126. C  ADD NEW RELATIONS
  5127. C
  5128.   240 CONTINUE
  5129.       INTOPT = K4UPD
  5130.       CALL INTDEF(NAMDB,INTOPT)
  5131.       IF(INTOPT.EQ.0) GO TO 100
  5132.       GO TO 999
  5133. C
  5134. C  LOAD ADDITIONAL DATA
  5135. C
  5136.   250 CONTINUE
  5137.       INTOPT = 0
  5138.   255 CONTINUE
  5139.       CALL INTLOD(INTOPT)
  5140.       IF(INTOPT.EQ.K4QUE) GO TO 260
  5141.       GO TO 999
  5142. C
  5143. C  DETERMINE IF THE DATABASE IS TO BE QUERIED
  5144. C
  5145.   260 CONTINUE
  5146. C
  5147. C     DETERMINE IF THE DATABASE IS TO BE QUERIED
  5148. C
  5149.   270 Continue
  5150.     if(nout.eq.6)goto 13
  5151.     WRITE(NOUT,280) NAMDB
  5152.   280 FORMAT(/,1X,5HThe ",A7,35H" Database has been created/updated,/,/,
  5153.      1  1X,48HDo you want to QUERY the database at this time -,
  5154.      2     7H Y or N,/)
  5155.     goto 14
  5156. 13    continue
  5157.     write(c128wk,3145)NAMDB
  5158. 3145    format(' The "',A7,'" Database is creat/updat. QUERY'
  5159.      1  ' it now (Y/N)?')
  5160.     call atxto
  5161. 14    continue
  5162.       CALL LXLREC(DUM1,0,LXERR)
  5163.       IXID1 = LXID(1)
  5164.       IF(IXID1.EQ.K4EOF) GO TO 100
  5165.       IXREC1 = 0
  5166.       IF(IXID1.EQ.KZINT) IXREC1 = LXIREC(1)
  5167.       IF(IXID1.EQ.KZTEXT) IXREC1 = LXWREC(1,1)
  5168.       IF(IXREC1.EQ.K4QUIT) GO TO 997
  5169.       IF(IXREC1.EQ.K4Y) GO TO 300
  5170.       IF(IXREC1.EQ.K4N) GO TO 100
  5171.     if(nout.eq.6)goto 15
  5172.       WRITE(NOUT,8004)
  5173.       GO TO 270
  5174. 15    continue
  5175.     write(c128wk,8004)
  5176.     call atxto
  5177.     goto 270
  5178. C
  5179. C  QUERY
  5180. C
  5181.   300 CONTINUE
  5182.     if(nout.eq.6)goto 16
  5183.       WRITE(NOUT,310)
  5184.   310 FORMAT(/,1X,16HRIM Command mode,/)
  5185.     goto 17
  5186. 16    continue
  5187.     write(c128wk,3417)
  5188. 3417    format(' RIM Command Mode')
  5189.     call atxto
  5190. 17    continue
  5191.       INTOPT = K4QUE
  5192.       GO TO 999
  5193. C
  5194. C  COMMAND MODE
  5195. C
  5196.   400 CONTINUE
  5197.       INTOPT = K4COM
  5198.     if(nout.eq.6)goto 36
  5199.       WRITE(NOUT,310)
  5200.       GO TO 999
  5201. 36    continue
  5202.     write(c128wk,3417)
  5203.     call atxto
  5204.     goto 999
  5205. C
  5206. C  QUIT
  5207. C
  5208.   997 CONTINUE
  5209.       INTOPT = K4QUIT
  5210.       GO TO 999
  5211. C
  5212. C  EXIT
  5213. C
  5214.   998 CONTINUE
  5215.       INTOPT = K4EXIT
  5216.       CALL RMCLOS
  5217.   999 CONTINUE
  5218.       RETURN
  5219. C
  5220. C     ERROR MESSAGES ---------------------------------------
  5221. C
  5222.  8001 FORMAT(1X,49H-ERROR- Either "1","2","3" or "4" must be entered)
  5223.  8002 FORMAT(1X,38H-ERROR- The database NAME must be 1-6 ,
  5224.      1           23Halphanumeric characters)
  5225.  8003 FORMAT(1X,41H-ERROR- Either "1" or "2" must be entered)
  5226.  8004 FORMAT(1X,41H-ERROR- Either "Y" or "N" must be entered)
  5227. C
  5228.       END
  5229.       SUBROUTINE INTDEF(NAMDB,INTOPT)
  5230.       INCLUDE rin:TEXT.BLK
  5231. C
  5232. C  PURPOSE: THIS ROUTINE PROMPTS THE USER FOR THE INFORMATION
  5233. C           REQUIRED TO CREATE A RIM SCHEMA SOURCE FILE.
  5234. C           RELATIONS, ATTRIBUTES, AND PASSWORDS ARE DEFINED WITH THIS
  5235. C           ROUTINE. RULES ARE NOT CURRENTLY IMPLEMENTED.
  5236. C
  5237. C  PARAMETERS: NAMDB -- DATABASE NAME IN H FORMAT
  5238. C              INTOPT - MENU MODE OPTION CODE - SET TO 0 IF "QUIT"
  5239. C
  5240. C
  5241.       INCLUDE rin:RMATTS.BLK
  5242.       INCLUDE rin:RMKEYW.BLK
  5243.       INCLUDE rin:CONST4.BLK
  5244.       INCLUDE rin:BUFFER.BLK
  5245.       INCLUDE rin:FLAGS.BLK
  5246.       INCLUDE rin:FILES.BLK
  5247.       INCLUDE rin:TUPLEA.BLK
  5248.       INCLUDE rin:RELTBL.BLK
  5249.       INCLUDE rin:MISC.BLK
  5250. C
  5251.       DIMENSION IREL(25,53),IRELX(25),IATT(100),IATTX(100,4),IEDIT(10)
  5252. C
  5253. C  EQUIVALENCE THE LOCAL ARRAYS TO BUFFER - ALLOW TWO WORDS IN BUFFER
  5254. C  FOR EACH WORD IN THE LOCAL ARRAYS - SOLVES THE REAL*8 PROBLEM
  5255. C
  5256.       EQUIVALENCE (BUFFER(1),IREL(1,1))
  5257.       EQUIVALENCE (BUFFER(2651),IRELX(1))
  5258.       EQUIVALENCE (BUFFER(2701),IATT(1))
  5259.       EQUIVALENCE (BUFFER(2901),IATTX(1,1))
  5260.       LOGICAL EQKEYW
  5261.       INTEGER TWO
  5262.       INTEGER STATUS
  5263.       INCLUDE rin:DCLAR1.BLK
  5264.       INCLUDE rin:DCLAR2.BLK
  5265.       INCLUDE rin:DCLAR3.BLK
  5266.       INCLUDE rin:DCLAR5.BLK
  5267. C
  5268. C  CLEAR OUT ANY PAGE DATA LEFT IN BUFFER
  5269. C
  5270.       CALL BLKCLN
  5271. C
  5272. C     ******************************************************
  5273. C
  5274. C               D E F I N E   S E C T I O N
  5275. C
  5276. C     ******************************************************
  5277. C
  5278.       IRCD = 0
  5279.       IATC = 0
  5280.       TWO = 22
  5281. C
  5282. C     REQUEST THE DATABASE OWNER - NAMOWN
  5283. C
  5284.   100 Continue
  5285.     if(nout.eq.6)goto 3140
  5286.     WRITE(NOUT,110)
  5287.     goto 3141
  5288. 3140    continue
  5289.     write(c128wk,110)
  5290.     call atxto
  5291. 3141    continue
  5292.   110 FORMAT(1X,37HEnter The Name Of The Database Owner:)
  5293.   120 CALL LXLREC(DUM1,0,LXERR)
  5294.       IXID1 = LXID(1)
  5295.       IF(IXID1.EQ.K4EOF) GO TO 100
  5296.       IXREC1 = LXWREC(1,1)
  5297.       IF(IXREC1.EQ.K4QUIT) GO TO 998
  5298.       IXLEN = LXLENC(1)
  5299.       IF((IXID1.EQ.KZTEXT).AND.(IXLEN.LE.8)) GO TO 130
  5300.     if(nout.eq.6)goto 3142
  5301.       WRITE(NOUT,8002)
  5302.       GO TO 100
  5303. 3142    continue
  5304.     write(c128wk,8002)
  5305.     call atxto
  5306.     goto 100
  5307.   130 NAMOWN = BLANK
  5308.       CALL LXSREC(1,1,8,NAMOWN,1)
  5309. C
  5310. C     CHECK THE DATABASE OWNER
  5311. C
  5312.       IF(INTOPT.EQ.K4CRE) GO TO 140
  5313.       IF(NAMOWN.EQ.OWNER) GO TO 140
  5314.     if(nout.eq.6)goto 1
  5315.       WRITE(NOUT,8028)
  5316.       GO TO 120
  5317. 1    continue
  5318.     write(c128wk,8028)
  5319.     call atxto
  5320.     goto 120
  5321.   140 CONTINUE
  5322. C
  5323. C  OPEN THE SCHEMA SOURCE FILE
  5324. C
  5325.       OPEN(UNIT=TWO,FILE='SCHEMA',STATUS='UNKNOWN')
  5326.       REWIND TWO
  5327.   310 IRCD = IRCD + 1
  5328.       IF(IRCD.LE.25) GO TO 320
  5329.     if(nout.eq.6)goto 2
  5330.       WRITE(NOUT,8020)
  5331.     goto 3
  5332. 2    continue
  5333.     write(c128wk,8020)
  5334.     call atxto
  5335. 3    continue
  5336.       IRCD = 25
  5337.       GO TO 830
  5338. C
  5339. C     REQUEST THE RELATION NAME - IREL(IRCD,1) WHERE
  5340. C     IRCD IS THE COUNT OF RELATIONS
  5341. C
  5342.   320 Continue
  5343.     if(nout.eq.6)goto 4
  5344.     WRITE(NOUT,330)
  5345.     goto 5
  5346. 4    continue
  5347.     write(c128wk,330)
  5348.     call atxto
  5349. 5    continue
  5350.   330 FORMAT(1X,41HEnter The Name Assigned To This Relation:)
  5351.       CALL LXLREC(DUM1,0,LXERR)
  5352.       IXID1 = LXID(1)
  5353.       IF(IXID1.EQ.K4EOF) GO TO 320
  5354.       IXREC1 = LXWREC(1,1)
  5355.       IF(IXREC1.EQ.K4QUIT) GO TO 998
  5356.       IXLEN = LXLENC(1)
  5357.       IF((IXID1.EQ.KZTEXT).AND.(IXLEN.LE.8)) GO TO 340
  5358.     if(nout.eq.6)goto 6
  5359.       WRITE(NOUT,8006)
  5360.       GO TO 320
  5361. 6    continue
  5362.     write(c128wk,8006)
  5363.     call atxto
  5364.     goto 320
  5365.   340 RNAME = BLANK
  5366.       CALL LXSREC(1,1,8,RNAME,1)
  5367.       IREL(IRCD,1) = RNAME
  5368. C
  5369. C     CHECK DUPLICATED RELATIONS
  5370. C
  5371.       IF(INTOPT.EQ.K4CRE) GO TO 350
  5372.       I = LOCREL(RNAME)
  5373.       IF(I.NE.0) GO TO 350
  5374.     if(Nout.eq.6)goto 7
  5375.       WRITE(NOUT,8029) RNAME
  5376.       GO TO 320
  5377. 7    continue
  5378.     write(c128wk,8029)rname
  5379.     goto 320
  5380.   350 CONTINUE
  5381.       IF(IRCD.EQ.1) GO TO 380
  5382.       JEND = IRCD - 1
  5383.       DO 370 J=1,JEND
  5384.       IF(RNAME.NE.IREL(J,1)) GO TO 370
  5385.     if(nout.eq.6)goto 8
  5386.       WRITE(NOUT,8029) RNAME
  5387.       GO TO 320
  5388. 8    continue
  5389.     write(c128wk,8029) rname
  5390.     call atxto
  5391.     goto 320
  5392.   370 CONTINUE
  5393.   380 CONTINUE
  5394. C
  5395. C     REQUEST THE RELATION PASSWORDS
  5396. C
  5397.   390 Continue
  5398.     if(nout.eq.6)goto 9
  5399.       WRITE(NOUT,400)
  5400.     goto 10
  5401.   400 FORMAT(1X,42HEnter The READ PASSWORD for This Relation:)
  5402. 9    continue
  5403.     write(c128wk,400)
  5404.     call atxto
  5405. 10    continue
  5406.       CALL LXLREC(DUM1,0,LXERR)
  5407.       RPW1 = BLANK
  5408.       IXID1 = LXID(1)
  5409.       IF(IXID1.EQ.K4EOF) GO TO 420
  5410.       IXREC1 = LXWREC(1,1)
  5411.       IF(IXREC1.EQ.K4QUIT) GO TO 998
  5412.       IXLEN = LXLENC(1)
  5413.       IF((IXID1.EQ.KZTEXT).AND.(IXLEN.LE.8)) GO TO 410
  5414.     if(nout.eq.6)goto 11
  5415.       WRITE(NOUT,8017)
  5416.       GO TO 390
  5417. 11    continue
  5418.     write(c128wk,8017)
  5419.     call atxto
  5420.     goto 390
  5421.   410 RPW1 = BLANK
  5422.       CALL LXSREC(1,1,8,RPW1,1)
  5423.   420 Continue
  5424.     if(nout.eq.6)goto 12
  5425.       WRITE(NOUT,430)
  5426.     goto 13
  5427.   430 FORMAT(1X,44HEnter the MODIFY PASSWORD for This Relation:)
  5428. 12    continue
  5429.     write(c128wk,430)
  5430.     call atxto
  5431. 13    continue
  5432.       CALL LXLREC(DUM1,0,LXERR)
  5433.       MPW1 = BLANK
  5434.       IXID1 = LXID(1)
  5435.       IF(IXID1.EQ.K4EOF) GO TO 450
  5436.       IXREC1 = LXWREC(1,1)
  5437.       IF(IXREC1.EQ.K4QUIT) GO TO 998
  5438.       IXLEN = LXLENC(1)
  5439.       IF((IXID1.EQ.KZTEXT).AND.(IXLEN.LE.8)) GO TO 440
  5440.     if(nout.eq.6)goto 14
  5441.       WRITE(NOUT,8017)
  5442.       GO TO 420
  5443. 14    continue
  5444.     write(c128wk,8017)
  5445.     call atxto
  5446.     goto 420
  5447.   440 MPW1 = BLANK
  5448.       CALL LXSREC(1,1,8,MPW1,1)
  5449.   450 IREL(IRCD,52) = RPW1
  5450.       IREL(IRCD,53) = MPW1
  5451. C
  5452. C     REQUEST THE ATTRIBUTE NAMES, TYPES, LENGTHS,
  5453. C     AND WHICH ARE KEYS
  5454. C     3HEND INDICATES THAT ALL ATTRIBUTES FOR THE CURRENT
  5455. C     RELATION HAVE BEEN DEFINED
  5456. C
  5457.     if(nout.eq.6)goto 15
  5458.       WRITE(NOUT,500)
  5459.   500 FORMAT(/,1X,37HENTER THE ATTRIBUTES OF THIS RELATION,/,
  5460.      1        1X,23HENTER END WHEN COMPLETE,/,
  5461.      2        5X,31HNAME    TYPE    LENGTH (IF > 1)  ,
  5462.      3           18H    "KEY" (IF KEY),/)
  5463.     goto 16
  5464. 15    continue
  5465.     write(c128wk,3148)
  5466. 3148    format(' Enter attributes, END when done. NAME, TYPE,'
  5467.      1  ' LENGTH (if >1)',
  5468.      1  ' "KEY" (if key)')
  5469.     call atxto
  5470. 16    continue
  5471.       IATL = 0
  5472.   510 CALL LXLREC(DUM1,0,LXERR)
  5473.       LENR = 1
  5474.       LENC = 1
  5475.       KEY = IBLANK
  5476.       MTYP = 0
  5477.       IXID1 = LXID(1)
  5478.       IF(IXID1.EQ.K4EOF) GO TO 800
  5479. C
  5480. C     CHECK FOR END AND THAT THE ATTRIBUTE NAME IS TEXT
  5481. C
  5482.       IXREC1 = LXWREC(1,1)
  5483.       IF(IXREC1.EQ.K4QUIT) GO TO 998
  5484.       IF(IXREC1.EQ.K4END) GO TO 800
  5485.       IXLEN = LXLENC(1)
  5486.       IF((IXID1.EQ.KZTEXT).AND.(IXLEN.LE.8)) GO TO 520
  5487.     if(nout.eq.6)goto 17
  5488.       WRITE(NOUT,8007)
  5489.       GO TO 510
  5490. 17    continue
  5491.     write(c128wk,8007)
  5492.     call atxto
  5493.     goto 510
  5494. C
  5495. C     CHECK ATTRIBUTE TYPE
  5496. C
  5497.   520 ANAME = BLANK
  5498.       CALL LXSREC(1,1,8,ANAME,1)
  5499.       LPOS = 3
  5500.       IXREC2 = 0
  5501.       IF(EQKEYW(2,KWINT ,7)) IXREC2 = KZINT
  5502.       IF(EQKEYW(2,KWREAL,4)) IXREC2 = KZREAL
  5503.       IF(EQKEYW(2,KWTEXT,4)) GO TO 530
  5504.       IF(EQKEYW(2,KWDOUB,6)) IXREC2 = KZDOUB
  5505.       IF(EQKEYW(2,KWIVEC,4)) IXREC2 = KZIVEC
  5506.       IF(EQKEYW(2,KWRVEC,4)) IXREC2 = KZRVEC
  5507.       IF(EQKEYW(2,KWDVEC,4)) IXREC2 = KZDVEC
  5508.       IF(IXREC2.NE.0) GO TO 550
  5509.       IF(EQKEYW(2,KWIMAT,4)) IXREC2 = KZIMAT
  5510.       IF(EQKEYW(2,KWRMAT,4)) IXREC2 = KZRMAT
  5511.       IF(EQKEYW(2,KWDMAT,4)) IXREC2 = KZDMAT
  5512.       IF(IXREC2.NE.0) GO TO 540
  5513.     if(nout.eq.6)goto 18
  5514.       WRITE(NOUT,8008)
  5515.       GO TO 510
  5516. 18    continue
  5517.     write(c128wk,8008)
  5518.     call atxto
  5519.     goto 510
  5520. C
  5521. C  SET DEFAULT TO 8 CHARACTERS FOR TEXT
  5522. C
  5523.   530 LENR = 8
  5524.       IXREC2 = KZTEXT
  5525.       GO TO 550
  5526.   540 MTYP = 1
  5527.   550 CONTINUE
  5528. C
  5529. C  CHECK ATTRIBUTE LENGTH
  5530. C
  5531.       IXITEM = LXITEM(NUM)
  5532.       IF(IXITEM.EQ.2) GO TO 700
  5533. C
  5534. C  GET THE FIRST DIMENSION (LENGTH)
  5535. C
  5536.       IXREC3 = LXWREC(LPOS,1)
  5537.       IF(IXREC3.EQ.K4KEY) GO TO 670
  5538.       IF(IXREC3.NE.KZVAR) GO TO 610
  5539. C
  5540. C  VARIABLE LENGTH ATTRIBUTE
  5541. C
  5542.       LENR = IXREC3
  5543.       GO TO 620
  5544. C
  5545. C  FIXED LENGTH ATTRIBUTE
  5546. C
  5547.   610 CONTINUE
  5548.       IXID3 = LXID(LPOS)
  5549.       IF(IXID3.NE.KZINT) GO TO 630
  5550.       LENR = LXIREC(LPOS)
  5551.       IF((LENR.LE.0).OR.(LENR.GT.MAXCOL)) GO TO 630
  5552.       IF(MTYP.EQ.1) GO TO 640
  5553.   620 IF(IXITEM.EQ.LPOS) GO TO 700
  5554.       GO TO 670
  5555.   630 Continue
  5556.     if(nout.eq.6)goto 19
  5557.     WRITE(NOUT,8009)
  5558.       GO TO 510
  5559. 19    continue
  5560.     write(c128wk,8009)
  5561.     call atxto
  5562.     goto 510
  5563. C
  5564. C  MATRIX ATTRIBUTE - GET COLUMN DIMENSION
  5565. C
  5566.   640 CONTINUE
  5567.       IXREC3 = LXWREC(LPOS+1,1)
  5568.       IF(IXREC3.NE.KZVAR) GO TO 650
  5569. C
  5570. C  VARIABLE COLUMN DIMENSION
  5571. C
  5572.       LENC = IXREC3
  5573.       GO TO 660
  5574. C
  5575. C  FIXED LENGTH COLUMN DIMENSION
  5576. C
  5577.   650 CONTINUE
  5578.       IXID3 = LXID(LPOS+1)
  5579.       IF(IXID3.NE.KZINT) GO TO 630
  5580.       LENC = LXIREC(LPOS+1)
  5581.       LEN = LENR*LENC
  5582.       IF((LEN.LE.0).OR.(LEN.GT.MAXCOL)) GO TO 630
  5583.   660 IF(IXITEM.EQ.(LPOS+1)) GO TO 700
  5584.   670 CONTINUE
  5585. C
  5586. C     CHECK IF KEY ATTRIBUTE
  5587. C
  5588.       IXRECX = LXWREC(IXITEM,1)
  5589.       IF(IXRECX.NE.K4KEY) GO TO 680
  5590.       KEY = K4KEY
  5591.       GO TO 700
  5592.   680 CONTINUE
  5593.       IF((MTYP.EQ.1).AND.(IXRECX.EQ.KZVAR)) GO TO 700
  5594.     if(nout.eq.6)goto 20
  5595.       WRITE(NOUT,8018)
  5596.       GO TO 510
  5597. 20    continue
  5598.     write(c128wk,8018)
  5599.     call atxto
  5600.     goto 510
  5601. C
  5602. C     STORE THE ATTRIBUTE NAME IN IREL(IRCD,IATL+1) WHERE
  5603. C     IRCD IS THE COUNT OF RELATIONS AND IATL IS THE
  5604. C     COUNT OF ATTRIBUTES FOR THE CURRENT RELATION
  5605. C
  5606.   700 IATL = IATL + 1
  5607.       IF(IATL.LE.50) GO TO 710
  5608.     if(nout.eq.6)goto 21
  5609.       WRITE(NOUT,8021)
  5610.     goto 22
  5611. 21    continue
  5612.     write(c128wk,8021)
  5613.     call atxto
  5614. 22    continue
  5615.       IATL = 50
  5616.       GO TO 800
  5617.   710 IREL(IRCD,IATL+1) = ANAME
  5618. C
  5619. C     CHECK IF THIS ATTRIBUTE HAS ALREADY BEEN DEFINED
  5620. C     IF IT HAS CHECK THAT A REDEFINITION HAS NOT OCCURED
  5621. C
  5622.       IF(INTOPT.EQ.K4CRE) GO TO 760
  5623. C
  5624. C  CHECK EXISTING ATTRIBUTES
  5625. C
  5626.       I = LOCATT(ANAME,BLANK)
  5627.       IF(I.NE.0) GO TO 760
  5628. C
  5629. C  EXISTING ATTRIBUTE - GET DEFINITION
  5630. C
  5631.       CALL ATTGET(STATUS)
  5632.       IF(STATUS.NE.0) GO TO 760
  5633.       IF(IXREC2.NE.ATTYPE) WRITE(NOUT,8014) ATTYPE
  5634.       LEN1 = 0
  5635.       LEN2 = 0
  5636.       IF(LENR.EQ.KZVAR) GO TO 720
  5637.       LEN1 = LENR
  5638.       IF(LENC.EQ.KZVAR) GO TO 720
  5639.       LEN2 = LENR
  5640.       IF(ATTYPE.EQ.KZTEXT) LEN2 = ((LENR-1)/CHPWD) + 1
  5641.       IF(MTYP.EQ.1) LEN2 = LENR*LENC
  5642.       CALL TYPER(ATTYPE,DUM1,LEN)
  5643.       IF(LEN.EQ.KZDOUB) LEN2 = 2*LEN2
  5644.       IF(ATTYPE.EQ.KZINT ) LEN1 = 0
  5645.       IF(ATTYPE.EQ.KZREAL) LEN1 = 0
  5646.       IF(ATTYPE.EQ.KZDOUB) LEN1 = 0
  5647.   720 CONTINUE
  5648.     if(nout.eq.6)goto 23
  5649.       IF(LEN1.NE.ATTCHA) WRITE(NOUT,8015) ATTCHA
  5650.       IF(LEN2.NE.ATTWDS) WRITE(NOUT,8015) ATTWDS
  5651.     goto 24
  5652. 23    continue
  5653.       IF(LEN1.NE.ATTCHA) WRITE(c128wk,8015) ATTCHA
  5654.     if(len1.ne.attcha)call atxto
  5655.       IF(LEN2.NE.ATTWDS) WRITE(c128wk,8015) ATTWDS
  5656.     if(len2.ne.attwds)call atxto
  5657. 24    continue
  5658. C
  5659. C  CHECK KEY
  5660. C
  5661.       LEN = K4KEY
  5662.       IF(ATTKEY.EQ.0) LEN = IBLANK
  5663.     if(nout.eq.6)goto 25
  5664.       IF(KEY.NE.LEN) WRITE(NOUT,8019) IXREC1
  5665.       GO TO 510
  5666. 25    continue
  5667.     if(key.eq.len)goto 510
  5668.     write(c128wk,8019) ixrec1
  5669.     call atxto
  5670.     goto 510
  5671.   760 CONTINUE
  5672.       IF(IATC.EQ.0) GO TO 780
  5673. C
  5674. C  CHECK NEW ATTRIBUTES
  5675. C
  5676.       DO 770 J=1,IATC
  5677.       IF(ANAME.NE.IATT(J)) GO TO 770
  5678.     if(nout.eq.6)goto 26
  5679.       IF(IXREC2.NE.IATTX(J,1)) WRITE(NOUT,8014) IATTX(J,1)
  5680.       IF(LENR.NE.IATTX(J,2)) WRITE(NOUT,8015) IATTX(J,2)
  5681.       IF(LENC.NE.IATTX(J,3)) WRITE(NOUT,8015) IATTX(J,3)
  5682.       IF(KEY.NE.IATTX(J,4)) WRITE(NOUT,8019) IXREC1
  5683.       GO TO 510
  5684. 26    continue
  5685.       IF(IXREC2.NE.IATTX(J,1)) WRITE(c128wk,8014) IATTX(J,1)
  5686.       IF(IXREC2.NE.IATTX(J,1)) call atxto
  5687.       IF(LENR.NE.IATTX(J,2)) WRITE(c128wk,8015) IATTX(J,2)
  5688.       IF(LENR.NE.IATTX(J,2)) call atxto
  5689.       IF(LENC.NE.IATTX(J,3)) WRITE(c128wk,8015) IATTX(J,3)
  5690.       IF(LENC.NE.IATTX(J,3)) call atxto
  5691.       IF(KEY.NE.IATTX(J,4)) WRITE(c128wk,8019) IXREC1
  5692.       IF(KEY.NE.IATTX(J,4)) call atxto
  5693.     goto 510
  5694.   770 CONTINUE
  5695. C
  5696. C     STORE THE ATTRIBUTE DATA IN IATT
  5697. C       IATT(IATC) = ATTRIBUTE NAME
  5698. C       IATTX(IATC,1) = ATTRIBUTE TYPE
  5699. C       IATTX(IATC,2) = ATTRIBUTE LENGTH - ROW DIMENSION IF MATRIX
  5700. C       IATTX(IATC,3) = COLUMN DIMENSION IF MATRIX
  5701. C       IATTX(IATC,4) = KEY INDICATOR (BLANK OR 3HKEY)
  5702. C       IATC         = COUNT OF UNIQUE ATTRIBUTES
  5703. C
  5704.   780 IATC = IATC + 1
  5705.       IF(IATC.LE.100) GO TO 790
  5706.     if(nout.eq.6)goto 27
  5707.       WRITE(NOUT,8022)
  5708.       IATC = 100
  5709.       GO TO 800
  5710. 27    continue
  5711.     write(c128wk,8022)
  5712.     call atxto
  5713.     iatc = 100
  5714.     goto 800
  5715.   790 IATT(IATC) = ANAME
  5716.       IATTX(IATC,1) = IXREC2
  5717.       IATTX(IATC,2) = LENR
  5718.       IATTX(IATC,3) = LENC
  5719.       IATTX(IATC,4) = KEY
  5720.       GO TO 510
  5721. C
  5722. C     STORE THE NUMBER OF COLUMNS (NO ATTRIBUTES + 1) FOR
  5723. C     THE CURRENT RELATION IN IRELX(IRCD)
  5724. C
  5725.   800 IRELX(IRCD) = IATL + 1
  5726.       IF(IATL.GT.0) GO TO 810
  5727.     if(nout.eq.6)goto 28
  5728.       WRITE(NOUT,8031) IREL(IRCD,1)
  5729.     goto 29
  5730. 28    continue
  5731.     write(c128wk,8031) irel(ircd,1)
  5732.     call atxto
  5733. 29    continue
  5734.       IREL(IRCD,1) = BLANK
  5735.       IREL(IRCD,52) = BLANK
  5736.       IREL(IRCD,53) = BLANK
  5737.       IRCD = IRCD - 1
  5738. C
  5739. C     CHECK FOR ADDITIONAL RELATION DEFINITIONS
  5740. C     (BRANCH TO 310 IF YES)
  5741. C
  5742.   810 Continue
  5743.     if(nout.eq.6)goto 30
  5744.     WRITE(NOUT,820)
  5745.   820 FORMAT(/,1X,45HDO YOU HAVE ADDITIONAL RELATIONS TO DEFINE - ,
  5746.      1           6HY OR N,/)
  5747.     goto 31
  5748. 30    continue
  5749.     write(c128wk,3340)
  5750. 3340    format(' Do you have more relations to define [Y/N]:')
  5751.     call atxto
  5752. 31    continue
  5753.       CALL LXLREC(DUM1,0,LXERR)
  5754.       IXID1 = LXID(1)
  5755.       IF(IXID1.EQ.K4EOF) GO TO 830
  5756.       IXREC1 = 0
  5757.       IF(IXID1.EQ.KZINT) IXREC1 = LXIREC(1)
  5758.       IF(IXID1.EQ.KZTEXT) IXREC1 = LXWREC(1,1)
  5759.       IF(IXREC1.EQ.K4QUIT) GO TO 998
  5760.       IF(IXREC1.EQ.K4Y) GO TO 310
  5761.       IF(IXREC1.EQ.K4N) GO TO 830
  5762.     if(nout.eq.6)goto 32
  5763.       WRITE(NOUT,8010)
  5764.       GO TO 810
  5765. 32    continue
  5766.     write(c128wk,8010)
  5767.     call atxto
  5768.     goto 810
  5769. C
  5770. C     DEFINE THE RIM SCHEMA SOURCE FILE
  5771. C
  5772. C     WRITE THE DATABASE NAME AND OWNER
  5773. C
  5774.   830 Continue
  5775.     WRITE(TWO,840) NAMDB,NAMOWN
  5776.   840 FORMAT(2X,7HDEFINE ,A8/2X,6HOWNER ,A8)
  5777. C
  5778. C     WRITE THE LIST OF ELEMENTS (ATTRIBUTES), ELEMENT TYPES,
  5779. C     AND LENGTHS
  5780. C
  5781.       WRITE(TWO,850)
  5782.   850 FORMAT(2X,10HATTRIBUTES)
  5783.       DO 930 J=1,IATC
  5784.       IF(IATTX(J,2).EQ.KZVAR) GO TO 870
  5785.       MTYP = IATTX(J,1)
  5786.       IF((MTYP.EQ.KZIMAT).OR.(MTYP.EQ.KZRMAT).OR.(MTYP.EQ.KZDMAT))
  5787.      1     GO TO 890
  5788.       WRITE(TWO,860) IATT(J),IATTX(J,1),IATTX(J,2),IATTX(J,4)
  5789.   860 FORMAT(2X,A8,2X,A4,2X,I4,6X,A3)
  5790.       GO TO 930
  5791.   870 Continue
  5792.     WRITE(TWO,880) IATT(J),IATTX(J,1),IATTX(J,2),IATTX(J,4)
  5793.   880 FORMAT(2X,A8,2X,A4,3X,A3,6X,A3)
  5794.       GO TO 930
  5795. C
  5796. C MATRIX
  5797. C
  5798.   890 IF(IATTX(J,3).EQ.KZVAR) GO TO 910
  5799.       WRITE(TWO,900) IATT(J),IATTX(J,1),IATTX(J,2),IATTX(J,3),IATTX(J,4)
  5800.   900 FORMAT(2X,A8,2X,A4,2X,I4,I4,2X,A3)
  5801.       GO TO 930
  5802.   910 WRITE(TWO,920) IATT(J),IATTX(J,1),IATTX(J,2),IATTX(J,3),IATTX(J,4)
  5803.   920 FORMAT(2X,A8,2X,A4,2X,I4,1X,A3,2X,A3)
  5804.   930 CONTINUE
  5805. C
  5806. C     WRITE THE RELATIONS - IF CONTINUATION IS REQUIRED
  5807. C     A + IS INSERTED AT THE END OF THE LINE
  5808. C
  5809.       IF(IRCD.EQ.0) GO TO 1040
  5810.       WRITE(TWO,950)
  5811.   950 FORMAT(2X,9HRELATIONS)
  5812.       DO 1000 J=1,IRCD
  5813.       NUM = IRELX(J) - 1
  5814.       K1 = 1
  5815.       K2 = 4
  5816.   960 IEND = IBLANK
  5817.       IF(NUM.GT.4) IEND = K4PLUS
  5818.       IF(NUM.LT.4) K2 = NUM
  5819.       IF(K1.EQ.1)WRITE(TWO,970)IREL(J,1),(IREL(J,K1+K),K=1,K2),IEND
  5820.       IF(K1.GT.1)WRITE(TWO,980) (IREL(J,K1+K),K=1,K2),IEND
  5821.   970 FORMAT(2X,A8,5H WITH,4(2X,A8),2X,A1)
  5822.   980 FORMAT(15X,4(2X,A8),2X,A1)
  5823.       IF(NUM.LE.4) GO TO 1000
  5824.       K1 = K1 + 4
  5825.       NUM = NUM - 4
  5826.       GO TO 960
  5827.  1000 CONTINUE
  5828. C
  5829. C     WRITE THE PASSWORDS
  5830. C
  5831.       WRITE(TWO,1010)
  5832.  1010 FORMAT(2X,9HPASSWORDS)
  5833.       DO 1030 J=1,IRCD
  5834.       RPW1 = IREL(J,52)
  5835.       MPW1 = IREL(J,53)
  5836.       IF(RPW1.NE.BLANK) WRITE(TWO,1020) IREL(J,1),RPW1
  5837.       IF(MPW1.NE.BLANK) WRITE(TWO,1021) IREL(J,1),MPW1
  5838.  1020 FORMAT(2X,4HREAD,14H PASSWORD FOR ,A8,4H IS ,A8)
  5839.  1021 FORMAT(2X,6HMODIFY,14H PASSWORD FOR ,A8,4H IS ,A8)
  5840.  1030 CONTINUE
  5841. C
  5842. C     WRITE THE END RECORD
  5843. C
  5844.  1040 CONTINUE
  5845.       WRITE(TWO,1050)
  5846.  1050 FORMAT(2X,3HEND)
  5847. C
  5848.  1110 CONTINUE
  5849.       IF(INTOPT.EQ.K4CRE) GO TO 999
  5850.       IF(NAMDB.EQ.DBNAME) GO TO 1120
  5851.     if(nout.eq.6)goto 33
  5852.       WRITE(NOUT,8027) NAMDB
  5853.       GO TO 998
  5854. 33    continue
  5855.     write(c128wk,8027)namdb
  5856.     call atxto
  5857.     goto 998
  5858.  1120 IF(NAMOWN.EQ.OWNER) GO TO 999
  5859.     if(nout.eq.6)goto 34
  5860.       WRITE(NOUT,8030)
  5861.       GO TO 998
  5862. 34    continue
  5863.     write(c128wk,8030)
  5864.     call atxto
  5865.     goto 998
  5866. C
  5867. C  RETURN AND CALL CSC TO COMPILE THE SCHEMA
  5868. C
  5869.   998 CONTINUE
  5870.       INTOPT = 0
  5871.   999 CONTINUE
  5872.       REWIND TWO
  5873. C
  5874. C  CLOSE THE SCHEMA SOURCE FILE
  5875. C
  5876.       CLOSE(UNIT=TWO)
  5877.       RETURN
  5878. C
  5879. C     ERROR MESSAGES ---------------------------------------
  5880. C
  5881.  8002 FORMAT(1X,39H-ERROR- The Database Owner Must Be 1-8 ,
  5882.      1           23HAlphanumeric Characters)
  5883.  8006 FORMAT(1X,36H-ERROR- Relation Names Must Be TEXT ,
  5884.      1           16H(1-8 characters))
  5885.  8007 FORMAT(1X,37H-ERROR- Attribute Names Must Be TEXT ,
  5886.      1           16H(1-8 characters),1X,17HReenter Last Line)
  5887.  8008 FORMAT(' Error - Type must be one of INT,REAL,TEXT,DOUB,IVEC',
  5888.      1  'RVEC,DVEC,IMAT,RMAT, or DMAT. Reenter line.')
  5889.  8009 FORMAT(1X,44H-ERROR- The Number Of Words In An Attribute ,
  5890.      1           41HMust Be A Positive Integer Less Than 1023,
  5891.      2        1X,17HReenter Last Line)
  5892.  8010 FORMAT(1X,41H-ERROR- Either "Y" or "N" Must Be Entered)
  5893.  8014 FORMAT(1X,34H-ERROR- Attribute Type Redefined (,A4,
  5894.      1           19H Type Will Be Used))
  5895.  8015 FORMAT(1X,44H-ERROR- Attribute Length Redefined (Length =,
  5896.      1             I3,14H Will Be Used))
  5897.  8017 FORMAT(1X,39H-ERROR- The Relation Passwords Must Be ,
  5898.      1           23HAlphanumeric Characters)
  5899.  8018 FORMAT(1X,32H-ERROR- The KEY Entry Is Illegal,
  5900.      1        9X,17HReenter Last Line)
  5901.  8019 FORMAT(1X,48H-ERROR- KEY Specification Changed For Attribute ,
  5902.      1           A10,1X,27HOriginal Specification Used)
  5903.  8020 FORMAT(1X,41H-ERROR- 25 Relations Is The Current Limit,
  5904.      1        9X,30HRelation Processing Terminated)
  5905.  8021 FORMAT(1X,42H-ERROR- 50 Attributes Is The Current Limit,
  5906.      1        9X,30HRelation Processing Terminated)
  5907.  8022 FORMAT(1X,50H-ERROR- 100 Unique Attributes Is The Current Limit,
  5908.      1       9X,30HRelation Processing Terminated)
  5909.  8027 FORMAT(1X,26H-ERROR- The Database Name ,A6,10H Does Not ,
  5910.      1           27HMatch The Database Contents)
  5911.  8028 FORMAT(1X,36H-ERROR- Unauthorized Access To The ,
  5912.      1           9HDatabase ,1X,17HEnter Authorized ,
  5913.      2           15HOwner or "QUIT")
  5914.  8029 FORMAT(1X,17H-ERROR- Relation ,A10,15H Already Exists)
  5915.  8030 FORMAT(1X,35H-ERROR- Unauthorized Access To The ,
  5916.      1           15HDatabase Schema)
  5917.  8031 FORMAT(1X,19H-WARNING- Relation ,A10,15H Does Not Have ,
  5918.      X   20HAny Legal Attributes)
  5919. C
  5920.       END
  5921.       SUBROUTINE INTLOD(INTOPT)
  5922.       INCLUDE rin:TEXT.BLK
  5923.       INCLUDE rin:FILES.BLK
  5924.       INCLUDE rin:RMATTS.BLK
  5925.       INCLUDE rin:CONST4.BLK
  5926.       INCLUDE rin:CONST8.BLK
  5927.       INCLUDE rin:RMKEYW.BLK
  5928.       INCLUDE rin:MISC.BLK
  5929.       INCLUDE rin:FLAGS.BLK
  5930.       INCLUDE rin:TUPLER.BLK
  5931.       INCLUDE rin:TUPLEA.BLK
  5932.       INCLUDE rin:DCLAR1.BLK
  5933.       INCLUDE rin:DCLAR3.BLK
  5934.       INTEGER STATUS
  5935.       LOGICAL EQ,NE
  5936.       LOGICAL EQKEYW
  5937.       IF(INTOPT.EQ.0) GO TO 90
  5938. C
  5939. C  ASK IF MORE RELATIONS ARE TO BE LOADED
  5940. C
  5941.    10 Continue
  5942.     if(nout.eq.6)goto 3140    
  5943.     WRITE(NOUT,20)
  5944.     goto 3141
  5945. 3140    continue
  5946.     write(c128wk,20)
  5947.     call atxto
  5948. 3141    continue
  5949.    20 FORMAT(51H Do You Have Additional Relations To Load - Y OR N:)
  5950.       CALL LXLREC(DUM1,0,LXERR)
  5951.       IDX = LXID(1)
  5952.       IF(IDX.EQ.K4EOF) GO TO 80
  5953.       IF(EQKEYW(1,KWQUIT,4)) GO TO 997
  5954.       IF(EQKEYW(1,KWEXIT,4)) GO TO 998
  5955.       IRECX = IBLANK
  5956.       CALL LXSREC(1,1,1,IRECX,1)
  5957.       IF(IRECX.EQ.K4N) GO TO 80
  5958.       IF(IRECX.EQ.K4Y) GO TO 90
  5959.     if(nout.eq.6)goto 3142
  5960.       WRITE(NOUT,8004)
  5961.       GO TO 10
  5962. 3142    continue
  5963.     write(c128wk,8004)
  5964.     call atxto
  5965.     goto 10
  5966. C
  5967. C  NO MORE RELATIONS TO LOAD
  5968. C
  5969.    80 CONTINUE
  5970.       INTOPT = K4QUE
  5971.       GO TO 999
  5972. C
  5973. C  LOAD A RELATION
  5974. C
  5975.    90 CONTINUE
  5976. C
  5977. C  CHECK FOR VALID RELATIONS
  5978. C
  5979.       I = LOCREL(BLANK)
  5980.       IF(I.EQ.0) GO TO 200
  5981.     if(nout.eq.6)goto 3143
  5982.       WRITE(NOUT,100)
  5983.   100 FORMAT(32H -WARNING- Relation Tables Empty )
  5984.       INTOPT = K4EXIT
  5985.       GO TO 999
  5986.  
  5987. 3143    continue
  5988.     write(c128wk,100)
  5989.     call atxto
  5990.       INTOPT = K4EXIT
  5991.       GO TO 999
  5992. C
  5993. C  DISPLAY AVAILABLE RELATIONS
  5994. C
  5995.   200 CONTINUE
  5996.     if(nout.eq.6)goto 3144
  5997.       WRITE(NOUT,210)
  5998.     goto 3145
  5999. 3144    continue
  6000.     write(c128wk,210)
  6001.     call atxto
  6002. 3145    continue
  6003.   210 FORMAT(33H Select The Relation To Be Loaded)
  6004.       K = 0
  6005.   220 CALL RELGET(STATUS)
  6006.       IF(STATUS.NE.0) GO TO 250
  6007.       IF(EQ(NAME,K8RDT)) GO TO 220
  6008.       IF(EQ(NAME,K8RRC)) GO TO 220
  6009.       K = K + 1
  6010.     if(nout.eq.6)goto 3146
  6011.       WRITE(NOUT,230) K,NAME
  6012.   230 FORMAT(4X,I2,2H) ,A8)
  6013.       GO TO 220
  6014. 3146    continue
  6015.     write(c128wk,230)k,name
  6016.     call atxto
  6017.     goto 220
  6018. C
  6019. C  GET THE USERS SELECTION
  6020. C
  6021.   250 CONTINUE
  6022.       CALL LXLREC(DUM1,0,LXERR)
  6023.       IDX = LXID(1)
  6024.       IF(IDX.EQ.K4EOF) GO TO 10
  6025.       IRECX = LXIREC(1)
  6026.       IF(EQKEYW(1,KWQUIT,4)) GO TO 997
  6027.       IF(EQKEYW(1,KWEXIT,4)) GO TO 998
  6028.       IF((IRECX.GE.1).AND.(IRECX.LE.K)) GO TO 260
  6029.     if(nout.eq.6)goto 3147
  6030.       WRITE(NOUT,8001) K
  6031.       GO TO 250
  6032. 3147    continue
  6033.     write(c128wk,8001)k
  6034.     call atxto
  6035.     goto 250
  6036. C
  6037. C  LOCATE THE REQUESTED SELECTION
  6038. C
  6039.   260 CONTINUE
  6040.       I = LOCREL(BLANK)
  6041.       K = 0
  6042.   270 CALL RELGET(STATUS)
  6043.       IF(STATUS.NE.0) GO TO 998
  6044.       IF(EQ(NAME,K8RDT)) GO TO 270
  6045.       IF(EQ(NAME,K8RRC)) GO TO 270
  6046.       K = K + 1
  6047.       IF(IRECX.EQ.K) GO TO 300
  6048.       GO TO 270
  6049. C
  6050. C  CHECK PERMISSION TO MODIFY THE RELATION
  6051. C
  6052.   300 CONTINUE
  6053.       IF(EQ(MPW,NONE)) GO TO 360
  6054.       IF(EQ(MPW,USERID)) GO TO 360
  6055.       IF(EQ(USERID,OWNER)) GO TO 360
  6056.     if(nout.eq.6)goto 3148
  6057.       WRITE(NOUT,310)
  6058.   310 FORMAT(45H Enter the MODIFY PASSWORD for This Relation: )
  6059.     goto 3149
  6060. 3148    continue
  6061.     write(c128wk,310)
  6062.     call atxto
  6063. 3149    continue
  6064.       CALL LXLREC(DUM1,0,LXERR)
  6065.       MPW1 = NONE
  6066.       IDX = LXID(1)
  6067.       IF(IDX.EQ.K4EOF) GO TO 350
  6068.       IF(EQKEYW(1,KWQUIT,4)) GO TO 997
  6069.       IF(EQKEYW(1,KWEXIT,4)) GO TO 998
  6070.       IF((IDX.EQ.KZTEXT).AND.(LXLENC(1).LE.8)) GO TO 340
  6071.     if(nout.eq.6)goto 3150
  6072.       WRITE(NOUT,8002)
  6073.       GO TO 300
  6074. 3150    continue
  6075.     write(c128wk,8002)
  6076.     call atxto
  6077.     goto 300
  6078. C
  6079. C  CHECK THE PASSWORD
  6080. C
  6081.   340 CONTINUE
  6082.       MPW1 = BLANK
  6083.       CALL LXSREC(1,1,8,MPW1,1)
  6084.   350 CONTINUE
  6085.       IF(EQ(MPW1,MPW)) GO TO 355
  6086.       IF(EQ(MPW1,OWNER)) GO TO 355
  6087.     if(nout.eq.6)goto 3151
  6088.       WRITE(NOUT,8003) NAME
  6089.       GO TO 10
  6090. 3151    continue
  6091.     write(c128wk,8003)name
  6092.     call atxto
  6093.     goto 10
  6094. C
  6095. C  GET THE ATTRIBUTES FOR THIS RELATION
  6096. C
  6097.   355 CONTINUE
  6098.       USERID = MPW1
  6099.   360 CONTINUE
  6100.       I = LOCATT(BLANK,NAME)
  6101.     if(nout.eq.6)goto 3152
  6102.       WRITE(NOUT,370)
  6103.   370 FORMAT(44H Enter The Attribute Values In The Specified,
  6104.      X          9H Sequence,24H Enter END When Complete)
  6105.     goto 3153
  6106. 3152    continue
  6107.     write(c128wk,370)
  6108.     call atxto
  6109. 3153    continue
  6110.       NUM = 0
  6111.   400 CALL ATTGET(STATUS)
  6112.       IF(STATUS.NE.0) GO TO 450
  6113.       NUM = NUM + 1
  6114.       NAMES(NUM) = ATTNAM
  6115.       IF(NUM.LT.8) GO TO 400
  6116.     if(nout.eq.6)goto 3154
  6117.       WRITE(NOUT,410) (NAMES(J),J=1,7)
  6118.     goto 3155
  6119. 3154    continue
  6120.     write(c128wk,410) (names(j),j=1,7)
  6121.     call atxto
  6122. 3155    continue
  6123.   410 FORMAT(7(1X,A8),2X,1H+)
  6124.       NUM = 1
  6125.       NAMES(1) = NAMES(8)
  6126.       GO TO 400
  6127. C
  6128. C  PRINT LAST LINE OF ATTRIBUTES
  6129. C
  6130.   450 Continue
  6131.     if(nout.eq.6)goto 3156
  6132.     WRITE(NOUT,460) (NAMES(J),J=1,NUM)
  6133.     goto 3157
  6134. 3156    continue
  6135.     write(c128wk,460) (names(j),j=1,num)
  6136.     call atxto
  6137. 3157    continue
  6138.   460 FORMAT(7(1X,A8))
  6139. C
  6140. C  GO GET THE DATA - CALL DBLOAD
  6141. C
  6142.       NAMES(1) = BLANK
  6143.       NAMES(2) = BLANK
  6144.       CALL STRMOV(KWLOAD,1,4,NAMES,1)
  6145.       CALL STRMOV(NAME,1,8,NAMES,6)
  6146.       CALL LXLREC(NAMES,16,LXERR)
  6147.       INTOPT = K4LOD
  6148.       GO TO 999
  6149. C
  6150. C  QUIT
  6151. C
  6152.   997 CONTINUE
  6153.       INTOPT = K4QUIT
  6154.       GO TO 999
  6155. C
  6156. C  EXIT
  6157. C
  6158.   998 CONTINUE
  6159.       INTOPT = K4EXIT
  6160.       GO TO 999
  6161. C
  6162.   999 CONTINUE
  6163.       RETURN
  6164. C
  6165. C  ERROR MESSAGES -----
  6166. C
  6167.  8001 FORMAT(37H -ERROR- An Integer In The Range 1 To,I3,
  6168.      X         16H Must Be Entered)
  6169.  8002 FORMAT(43H -ERROR- Passwords Must Be 1-8 Alphanumeric,
  6170.      X         11H Characters)
  6171.  8003 FORMAT(41H -ERROR- Unauthorized Access To Relation ,A8)
  6172.  8004 FORMAT(42H -ERROR- Either "Y" or "N" Must Be Entered)
  6173.       END
  6174.       INTEGER FUNCTION ISCAN(STR1,IC1,LC1,STR2,IC2,LC2,J1)
  6175.       INCLUDE rin:TEXT.BLK
  6176. C
  6177. C  PURPOSE:   LOCATE THE FIRST CHARACTER IN STR1 WHICH DOES
  6178. C             MATCH THE CHARACTERS IN STR2
  6179. C
  6180. C  PARAMETERS:
  6181. C     STR1----FIRST HOLLERITH STRING
  6182. C     IC1-----STARTING CHARACTER IN STR1 TO START THE SCAN
  6183. C     LC1-----LENGTH OF STR1
  6184. C     STR2----SECOND HOLLERITH STRING
  6185. C     IC2-----STARTING CHARACTER IN STR2
  6186. C     LC2-----LENGTH OF STR2
  6187. C     J1------CHARACTER POSITION IN STR1 OF FIRST MATCH
  6188. C             0 IF ALL NO MATCH
  6189. C     ISCAN---CHARACTER POSITION IN STR2 OF FIRST MATCH
  6190. C             0 IF ALL NO MATCH
  6191. C
  6192.       Character*1 STR1(*)
  6193.       Character*1 STR2(*)
  6194. C
  6195. C  IF LC1 IS NEGATIVE THE SCAN IS RIGHT TO LEFT.
  6196. C
  6197.       INC = 1
  6198.       IF(LC1.LT.0) INC = -1
  6199.       LC = INC * LC1
  6200.       I1 = IC1
  6201. C
  6202. C  SCAN STR1.
  6203. C
  6204.       DO 200 I=1,LC
  6205.       I2 = IC2 - 1
  6206.       DO 100 J=1,LC2
  6207.       I2 = I2 + 1
  6208.       IF(STR1(I1).EQ.STR2(I2)) GO TO 300
  6209.   100 CONTINUE
  6210.       I1 = I1 + INC
  6211.   200 CONTINUE
  6212. C
  6213. C  NO CHARACTERS MATCH.
  6214. C
  6215.       ISCAN = 0
  6216.       J1 = 0
  6217.       RETURN
  6218. C
  6219. C  WE FOUND A MATCHING CHARACTER.
  6220. C
  6221.   300 CONTINUE
  6222.       ISCAN = I2
  6223.       J1 = I1
  6224.       RETURN
  6225.       END
  6226.       SUBROUTINE ISECT(RNAME1,RNAME3,MATN3,NCOL3,NATT3,PTABLE,
  6227.      XKEYCOL,KEYTYP)
  6228.       INCLUDE rin:TEXT.BLK
  6229. C
  6230. C  THIS ROUTINE PERFORMS THE ACTUAL INTERSECT BETWEEN
  6231. C  RELATION 1 AND 2 FORMING 3
  6232. C
  6233. C  PARAMETERS:
  6234. C         NAME1---NAME OF THE FIRST RELATION
  6235. C         MATN3---DATA TUPLE FOR RELATION 3
  6236. C         NCOL3---NUMBER OF FIXED LENGTH COLUMNS IN MATN3
  6237. C         NATT3---NUMBER OF ATTRIBUTES IN MATN3
  6238. C         PTABLE--POINTER TABLE FOR THIS INTERSECT
  6239. C         KEYCOL--COLUMN OF MATN2 USED FOR SUPPLYING KEY VALUES
  6240. C         KEYTYP--ATTRIBUTE TYPE OF MATN1 USED FOR KEY VALUES
  6241.       INCLUDE rin:MISC.BLK
  6242.       INCLUDE rin:RMATTS.BLK
  6243.       INCLUDE rin:FILES.BLK
  6244.       INCLUDE rin:TUPLER.BLK
  6245.       INCLUDE rin:RIMPTR.BLK
  6246.       INCLUDE rin:RIMCOM.BLK
  6247.       INCLUDE rin:BUFFER.BLK
  6248.       INCLUDE rin:WHCOM.BLK
  6249.       INCLUDE rin:DCLAR1.BLK
  6250.       DIMENSION MATN3(*)
  6251.       INTEGER PTABLE(7,*)
  6252.       INTEGER ATTLEN
  6253.       INTEGER ENDCOL
  6254. C
  6255. C  INITIALIZE THE MATRIX POINTERS.
  6256. C
  6257.       IERR = 0
  6258.       IDST = 0
  6259.       IDNEW = 0
  6260.       IDCUR = NID
  6261. C
  6262. C  GET THE PARAMETERS FOR THE FIRST MATRIX.
  6263. C
  6264.       I = LOCREL(RNAME1)
  6265.       IDM1 = NID
  6266.       NSP = 0
  6267.       IF(KSTRT.NE.0) NSP = 2
  6268.       NTUP3 = 0
  6269. C
  6270. C  SEQUENCE THROUGH MATN2.
  6271. C
  6272.   100 CONTINUE
  6273.       IF(IDCUR.EQ.0) GO TO 1000
  6274.       CALL ITOH(N1,N2,IDCUR)
  6275.       IF(N2.EQ.0) GO TO 1000
  6276.       CALL GETDAT(2,IDCUR,MATN2,NCOL2)
  6277.       IF(IDCUR.LT.0) GO TO 1000
  6278. C
  6279. C  MOVE THE COMPARISON VALUE INTO THE WHCOM ARRAYS.
  6280. C
  6281.       CALL ITOH(NCHAR,NWORDS,KATTL(1))
  6282.       IP = MATN2 + KEYCOL - 1
  6283.       IF(NWORDS.NE.0) GO TO 110
  6284. C
  6285. C  SPECIAL GYRATIONS FOR VARIABLE LENGTH STUFF.
  6286. C
  6287.       IP2 = BUFFER(IP)
  6288.       IP = MATN2 + IP2 + 1
  6289.   110 CONTINUE
  6290.       WHRVAL(1) = BUFFER(IP)
  6291.       NID = IDM1
  6292.       NS = NSP
  6293.   200 CONTINUE
  6294.       CALL RMLOOK(MATN1,1,1,NCOL1)
  6295.       IF(RMSTAT.NE.0) GO TO 100
  6296. C
  6297. C  CHECK TO SEE IF THE ATTRIBUTES MATCH.
  6298. C
  6299.       K = 1
  6300.   300 CONTINUE
  6301.       CALL PTRS(IPT1,IPT2,K,NATT3,PTABLE,LEN,ITYPE)
  6302. C
  6303. C  IF K IS 0 WE HAVE LOOKED AT ALL THE COMMON ATTRIBUTES.
  6304. C
  6305.       IF(K.EQ.0) GO TO 400
  6306.       I1 = MATN1 + IPT1 - 1
  6307.       I2 = MATN2 + IPT2 - 1
  6308.       IF(LEN.EQ.0) GO TO 320
  6309.       DO 310 I=1,LEN
  6310.       IF(BUFFER(I1).NE.BUFFER(I2)) GO TO 200
  6311.       I1 = I1 + 1
  6312.       I2 = I2 + 1
  6313.   310 CONTINUE
  6314. C
  6315. C  A MATCH. LOOK AT MORE ATTRIBUTES.
  6316. C
  6317.       GO TO 300
  6318. C
  6319. C  VARIABLE LENGTH ATTRIBUTE PROCESSING.
  6320. C
  6321.   320 CONTINUE
  6322.       IPT1 = BUFFER(I1)
  6323.       IPT2 = BUFFER(I2)
  6324.       I1 = MATN1 + IPT1 - 1
  6325.       I2 = MATN2 + IPT2 - 1
  6326.       IF(BUFFER(I1).NE.BUFFER(I2)) GO TO 200
  6327.       LEN = BUFFER(I1)
  6328.       I1 = I1 + 2
  6329.       I2 = I2 + 2
  6330.       DO 340 I=1,LEN
  6331.       IF(BUFFER(I1).NE.BUFFER(I2)) GO TO 200
  6332.       I1 = I1 + 1
  6333.       I2 = I2 + 1
  6334.   340 CONTINUE
  6335.       GO TO 300
  6336. C
  6337. C  OKAY -- NOW LOAD THE DATA.
  6338. C
  6339.   400 CONTINUE
  6340.       ENDCOL = NCOL3
  6341.       DO 900 KLM=1,NATT3
  6342.       KOL1 = PTABLE(3,KLM)
  6343.       KOL2 = PTABLE(4,KLM)
  6344.       KOL3 = PTABLE(5,KLM)
  6345.       ATTLEN = PTABLE(6,KLM)
  6346.       CALL ITOH(NCHAR,NWORDS,ATTLEN)
  6347.       IF(NWORDS.EQ.0) GO TO 700
  6348.       DO 600 I=1,NWORDS
  6349.       IF(KOL1.EQ.0) GO TO 500
  6350. C
  6351. C  LOAD THE ATTRIBUTE FROM MATN1.
  6352. C
  6353.       I1 = MATN1 + KOL1 - 1
  6354.       MATN3(KOL3) = BUFFER(I1)
  6355.       KOL3 = KOL3 + 1
  6356.       KOL1 = KOL1 + 1
  6357.       GO TO 600
  6358.   500 CONTINUE
  6359. C
  6360. C  LOAD THE ATTRIBUTE FROM MATN2.
  6361. C
  6362.       I2 = MATN2 + KOL2 - 1
  6363.       MATN3(KOL3) = BUFFER(I2)
  6364.       KOL3 = KOL3 + 1
  6365.       KOL2 = KOL2 + 1
  6366.   600 CONTINUE
  6367.       GO TO 900
  6368.   700 CONTINUE
  6369.       ENDCOL = ENDCOL + 1
  6370.       MATN3(KOL3) = ENDCOL
  6371.       IF(KOL1.EQ.0) GO TO 710
  6372. C
  6373. C  USE POINTERS FROM MATN1.
  6374. C
  6375.       I1 = MATN1 + KOL1 - 1
  6376.       KOL1 = BUFFER(I1)
  6377.       I2 = MATN1 + KOL1 - 1
  6378.       NWORDS = BUFFER(I2)
  6379.       GO TO 720
  6380.   710 CONTINUE
  6381. C
  6382. C  USE POINTERS FROM MATN2.
  6383. C
  6384.       I2 = MATN2 + KOL2 - 1
  6385.       KOL2 = BUFFER(I2)
  6386.       I2 = MATN2 + KOL2 - 1
  6387.       NWORDS = BUFFER(I2)
  6388.   720 CONTINUE
  6389. C
  6390. C  LOAD UP THE VALUES.
  6391. C
  6392.       IF((ENDCOL+NWORDS+1).GT.MAXCOL) GO TO 950
  6393.       MATN3(ENDCOL) = NWORDS
  6394.       NWORDS = NWORDS + 1
  6395.       DO 800 I=1,NWORDS
  6396.       ENDCOL = ENDCOL + 1
  6397.       I2 = I2 + 1
  6398.       MATN3(ENDCOL) = BUFFER(I2)
  6399.   800 CONTINUE
  6400.   900 CONTINUE
  6401.       CALL ADDDAT(3,IDNEW,MATN3,ENDCOL)
  6402.       IF(IDST.EQ.0) IDST = IDNEW
  6403.       NTUP3 = NTUP3 + 1
  6404. C
  6405. C  LOOK FOR MORE IN MATN1.
  6406. C
  6407.       GO TO 200
  6408. C
  6409. C  TUPLE LENGTH EXCEEDS MAXCOL
  6410. C
  6411.   950 CONTINUE
  6412.       IERR = 1
  6413.     if(nout.eq.6)goto 3140
  6414.       WRITE(NOUT,960) MAXCOL
  6415.   960 FORMAT(36H -ERROR- Relation Row Length Exceeds,I5)
  6416.     goto 3141
  6417. 3140    continue
  6418.     write(c128wk,960)
  6419.     call atxto
  6420. 3141    continue
  6421. C
  6422. C  ALL DONE.
  6423. C
  6424.  1000 CONTINUE
  6425.       I = LOCREL(RNAME3)
  6426.       CALL RELGET(ISTAT)
  6427.       RSTART = IDST
  6428.       REND = IDNEW
  6429.       NTUPLE = NTUP3
  6430.       CALL RELPUT
  6431.       NUM = NTUP3
  6432.     if(nout.eq.6)goto 3142
  6433.       IF(IERR.EQ.0) WRITE(NOUT,9000) NUM
  6434.  9000 FORMAT(32H Successful INTERSECT Operation ,
  6435.      XI6,15H Rows Generated)
  6436. C
  6437. C  RETURN
  6438. C
  6439.       RETURN
  6440. 3142    continue
  6441.       IF(IERR.ne.0)return
  6442.     write(c128wk,9000)num
  6443.     call atxto
  6444.     return
  6445.       END
  6446.       SUBROUTINE ISREL
  6447.       INCLUDE rin:TEXT.BLK
  6448. C
  6449. C  THIS ROUTINE FINDS THE INTERSECTION OF TWO RELATIONS BASED UPON
  6450. C  ATTRIBUTES.  THE RESULT FROM THIS PROCESS IS A PHYSICAL
  6451. C  RELATION WHICH HAS TUPLES CONTRUCTED FROM BOTH RELATIONS
  6452. C  WHERE COMMON ATTRIBUTES MATCH.
  6453. C
  6454. C  THE SYNTAX FOR THE INTERSECT COMMAND IS:
  6455. C
  6456. C   INTERSECT REL1 WITH REL2 FORMING REL3 [USING ATTR1 ATTR2...ATTR-N]
  6457. C
  6458.       INCLUDE rin:RMATTS.BLK
  6459.       INCLUDE rin:RMKEYW.BLK
  6460.       INCLUDE rin:CONST4.BLK
  6461.       INCLUDE rin:FLAGS.BLK
  6462.       INCLUDE rin:RIMPTR.BLK
  6463.       INCLUDE rin:RIMCOM.BLK
  6464.       INCLUDE rin:TUPLER.BLK
  6465.       INCLUDE rin:TUPLEA.BLK
  6466.       INCLUDE rin:FILES.BLK
  6467.       INCLUDE rin:BUFFER.BLK
  6468.       INCLUDE rin:WHCOM.BLK
  6469.       INCLUDE rin:MISC.BLK
  6470. C
  6471.       INTEGER PTABLE
  6472.       LOGICAL EQ
  6473.       LOGICAL NE
  6474.       LOGICAL EQKEYW
  6475.       INCLUDE rin:DCLAR1.BLK
  6476.       INCLUDE rin:DCLAR3.BLK
  6477. C
  6478. C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
  6479. C
  6480.       CALL RMDBLK(DBNAME)
  6481.       IF(RMSTAT.EQ.0) GO TO 50
  6482.       CALL WARN(RMSTAT,DBNAME,0)
  6483.       GO TO 9999
  6484. C
  6485. C  LOCAL ARRAYS AND VARIABLES :
  6486. C
  6487. C  PTABLE (MATRIX 10) USED TO CONTROL POINTERS
  6488. C        ROWS1,2 -- ATTRIBUTE NAME
  6489. C        ROW3 -- ATTRIBUTE LOCATION IN RELATION 1
  6490. C        ROW4 -- ATTRIBUTE LOCATION IN RELATION 2
  6491. C        ROW5 -- ATTRIBUTE LOCATION IN RELATION 3
  6492. C        ROW6 -- LENGTH IN WORDS
  6493. C        ROW7 -- ATTRIBUTE TYPE
  6494. C
  6495. C  EDIT COMMAND SYNTAX
  6496. C
  6497.    50 CONTINUE
  6498.       CALL BLKCLN
  6499.       NS = 0
  6500.       IF(.NOT.EQKEYW(3,KWWITH,4)) GO TO 9900
  6501.       IF(.NOT.EQKEYW(5,KWFORM,7)) GO TO 9900
  6502.       ITEMS = LXITEM(IDUMMY)
  6503.       IF(ITEMS.GT.6 .AND. .NOT.EQKEYW(7,KWUSIN,5)) GO TO 9900
  6504. C
  6505. C  KEYWORD SYNTAX OKAY
  6506. C
  6507.       RNAME1 = BLANK
  6508.       CALL LXSREC(2,1,8,RNAME1,1)
  6509.       I = LOCREL(RNAME1)
  6510.       IF(I.EQ.0) GO TO 100
  6511. C
  6512. C  MISSING FIRST RELATION.
  6513. C
  6514.       CALL WARN(1,RNAME1,0)
  6515.       GO TO 9999
  6516.   100 CONTINUE
  6517. C
  6518. C  SAVE DATA ABOUT RELATION 1
  6519. C
  6520.       I1 = LOCPRM(RNAME1,1)
  6521.       IF(I1.EQ.0) GO TO 110
  6522.       CALL WARN(9,RNAME1,0)
  6523.       GO TO 9999
  6524.   110 CONTINUE
  6525.       NCOL1 = NCOL
  6526.       NATT1 = NATT
  6527.       RPW1 = RPW
  6528.       MPW1 = MPW
  6529.       RNAME2 = BLANK
  6530.       CALL LXSREC(4,1,8,RNAME2,1)
  6531.       I = LOCREL(RNAME2)
  6532.       IF(I.EQ.0) GO TO 200
  6533. C
  6534. C  MISSING SECOND RELATION.
  6535. C
  6536.       CALL WARN(1,RNAME2,0)
  6537.       GO TO 9999
  6538.   200 CONTINUE
  6539. C
  6540. C  SAVE DATA ABOUT RELATION 2
  6541. C
  6542.       I2 = LOCPRM(RNAME2,1)
  6543.       IF(I2.EQ.0) GO TO 210
  6544.       CALL WARN(9,RNAME2,0)
  6545.       GO TO 9999
  6546.   210 CONTINUE
  6547.       NCOL2 = NCOL
  6548.       NATT2 = NATT
  6549.       RPW2 = RPW
  6550.       MPW2 = MPW
  6551. C
  6552. C  CHECK FOR LEGAL RNAME3
  6553. C
  6554.       IF((LXLENC(6).GE.1).AND.(LXLENC(6).LE.8)) GO TO 250
  6555.       CALL WARN(7,KWRELA,BLANK)
  6556.       GO TO 9999
  6557.   250 CONTINUE
  6558. C
  6559. C  CHECK FOR DUPLICATE RELATION 3
  6560. C
  6561.       RNAME3 = BLANK
  6562.       CALL LXSREC(6,1,8,RNAME3,1)
  6563.       I = LOCREL(RNAME3)
  6564.       IF(I.NE.0) GO TO 300
  6565. C
  6566. C  ERROR
  6567. C
  6568.     if(nout.eq.6)goto 3140
  6569.       WRITE(NOUT,9000)
  6570.  9000 FORMAT(55H -ERROR- Resultant Relation Does Not Have A Unique Name)
  6571.       GO TO 9999
  6572. 3140    continue
  6573.     write(c128wk,9000)
  6574.     call atxto
  6575.     goto 9999
  6576. C
  6577. C  CHECK USER READ SECURITY
  6578. C
  6579.   300 CONTINUE
  6580.       IF((I1.NE.0).OR.(I2.NE.0)) GO TO 9999
  6581. C
  6582. C  RELATION NAMES OKAY -- CHECK THE ATTRIBUTES
  6583. C
  6584. C  SET UP PTABLE IN MATRIX POSITION 10
  6585. C
  6586.       CALL BLKDEF(10,7,NATT1+NATT2)
  6587.       PTABLE = BLKLOC(10)
  6588.       NATT3 = 0
  6589.       IF(ITEMS.EQ.6) GO TO 500
  6590. C
  6591. C  INTERSECT ON SOME OF THE ATTRIBUTES
  6592. C
  6593.       IF(ITEMS-7.LE.NATT1+NATT2) GO TO 350
  6594.     if(nout.eq.6)goto 3141
  6595.       WRITE(NOUT,9001)
  6596.  9001 FORMAT(38H -ERROR- Too Many Attributes Specified)
  6597.       GO TO 9999
  6598. 3141    continue
  6599.     write(c128wk,9001)
  6600.     call atxto
  6601.     goto 9999
  6602.   350 CONTINUE
  6603.       IJ = 1
  6604.       DO 400 I=8,ITEMS
  6605. C
  6606. C  RETRIEVE ATTRIBUTE LENGTH FOR OLD ATTRIBUTE
  6607. C
  6608. C
  6609. C  SEE IF IT FROM RELATION 1.
  6610. C
  6611.       ANAME = BLANK
  6612.       CALL LXSREC(I,1,8,ANAME,1)
  6613.       ICHK1 = LOCATT(ANAME,RNAME1)
  6614. C
  6615. C  SEE IF IT IS FROM RELATION 2.
  6616. C
  6617.       ICHK2 = LOCATT(ANAME,RNAME2)
  6618.       IF((ICHK1.NE.0).AND.(ICHK2.NE.0)) GO TO 450
  6619. C
  6620. C  ATTRIBUTE IS OKAY -- SET UP PTABLE
  6621. C
  6622.       IF(ICHK1.EQ.0) ICHK1 = LOCATT(ANAME,RNAME1)
  6623.       IF(ICHK2.EQ.0) ICHK2 = LOCATT(ANAME,RNAME2)
  6624.       CALL ATTGET(ISTAT)
  6625.       NATT3 = NATT3 + 1
  6626.       BUFFER(PTABLE) = LXWREC(I,1)
  6627.       BUFFER(PTABLE+1) = LXWREC(I,2)
  6628.       IF(ICHK2.EQ.0) BUFFER(PTABLE+3) = ATTCOL
  6629.       BUFFER(PTABLE+4) = IJ
  6630.       NWORDS = ATTWDS
  6631.       BUFFER(PTABLE+5) = ATTLEN
  6632.       IF(NWORDS.EQ.0) NWORDS = 1
  6633.       IJ = IJ + NWORDS
  6634.       BUFFER(PTABLE+6) = ATTYPE
  6635.       IF(ICHK1.NE.0) GO TO 360
  6636.       ICHK1 = LOCATT(ANAME,RNAME1)
  6637.       CALL ATTGET(ISTAT)
  6638.       BUFFER(PTABLE+2) = ATTCOL
  6639.   360 CONTINUE
  6640.       PTABLE = PTABLE + 7
  6641. C
  6642.   400 CONTINUE
  6643.       ICT = IJ - 1
  6644.       GO TO 555
  6645. C
  6646. C  ATTRIBUTE WAS NOT IN EITHER RELATION.
  6647. C
  6648.   450 CONTINUE
  6649.     if(nout.eq.6)goto 3143
  6650.       WRITE(NOUT,9002) ANAME
  6651.  9002 FORMAT(9H -ERROR- ,A8,33H Is Not Common To Either Relation)
  6652.       GO TO 9999
  6653. 3143    continue
  6654.     write(c128wk,9002) aname
  6655.     call atxto
  6656.     goto 9999
  6657. C
  6658. C  INTERSECT IS ON ALL ATTRIBUTES
  6659. C
  6660.   500 CONTINUE
  6661.       ICT = 1
  6662. C
  6663. C  STORE DATA FROM RELATION 1 IN PTABLE
  6664. C
  6665.       I = LOCATT(BLANK,RNAME1)
  6666.       DO 515 I=1,NATT1
  6667.       CALL ATTGET(ISTAT)
  6668.       IF(ISTAT.NE.0) GO TO 515
  6669.       NATT3 = NATT3 + 1
  6670.       BUFFER(PTABLE) = IBLANK
  6671.       CALL STRMOV(ATTNAM,1,8,BUFFER(PTABLE),1)
  6672.       BUFFER(PTABLE+2) = ATTCOL
  6673.       BUFFER(PTABLE+4) = ICT
  6674.       NWORDS = ATTWDS
  6675.       BUFFER(PTABLE+5) = ATTLEN
  6676.       IF(NWORDS.EQ.0) NWORDS = 1
  6677.       ICT = ICT + NWORDS
  6678.       BUFFER(PTABLE+6) = ATTYPE
  6679.       PTABLE = PTABLE + 7
  6680.   515 CONTINUE
  6681. C
  6682. C  STORE DATA FROM RELATION 2 IN PTABLE
  6683. C
  6684.       KATT3 = NATT3
  6685.       I = LOCATT(BLANK,RNAME2)
  6686.       DO 550 I=1,NATT2
  6687.       CALL ATTGET(ISTAT)
  6688.       IF(ISTAT.NE.0) GO TO 550
  6689. C
  6690. C  FIRST CHECK TO SEE IF ATTRIBUTE IS ALREADY IN PTABLE.
  6691. C
  6692.       KQ1 = BLKLOC(10) - 7
  6693.       DO 520 J=1,KATT3
  6694.       KQ1 = KQ1 + 7
  6695.       IF(BUFFER(KQ1+3).NE.0) GO TO 520
  6696.       IF(EQ(BUFFER(KQ1),ATTNAM)) GO TO 530
  6697.   520 CONTINUE
  6698. C
  6699. C  NOT THERE -- PUT IT IN.
  6700. C
  6701.       NATT3 = NATT3 + 1
  6702.       BUFFER(PTABLE) = IBLANK
  6703.       CALL STRMOV(ATTNAM,1,8,BUFFER(PTABLE),1)
  6704.       BUFFER(PTABLE+3) = ATTCOL
  6705.       BUFFER(PTABLE+4) = ICT
  6706.       NWORDS = ATTWDS
  6707.       BUFFER(PTABLE+5) = ATTLEN
  6708.       IF(NWORDS.EQ.0) NWORDS = 1
  6709.       ICT = ICT + NWORDS
  6710.       BUFFER(PTABLE+6) = ATTYPE
  6711.       PTABLE = PTABLE + 7
  6712.       GO TO 550
  6713. C
  6714. C  ALREADY THERE -- CHANGE THE 2ND POINTER
  6715. C
  6716.   530 CONTINUE
  6717.       BUFFER(KQ1+3) = ATTCOL
  6718.   550 CONTINUE
  6719.       ICT = ICT - 1
  6720. C
  6721. C  DONE LOADING PTABLE
  6722. C
  6723. C  SEE IF THERE ARE ANY COMMON ATTRIBUTES.
  6724. C
  6725.   555 CONTINUE
  6726.       PTABLE = BLKLOC(10)
  6727.       DO 570 I = 1,NATT3
  6728.       IF((BUFFER(PTABLE+2).NE.0).AND.(BUFFER(PTABLE+3).NE.0)) GO TO 600
  6729.       PTABLE = PTABLE + 7
  6730.   570 CONTINUE
  6731. C
  6732. C  NO COMMON ATTRIBUTES
  6733. C
  6734.     if(nout.eq.6)goto 3144
  6735.       WRITE(NOUT,9003) RNAME1,RNAME2
  6736.  9003 FORMAT(19H -ERROR- Relations ,A8,5H AND ,A8,
  6737.      X26H Have No Common Attributes)
  6738.       GO TO 9999
  6739. 3144    continue
  6740.     write(c128wk,9003) rname1,rname2
  6741.     call atxto
  6742.     goto 9999
  6743. C
  6744. C  PTABLE IS CONSTRUCTED
  6745. C
  6746. C  NOW CREATE ATTRIBUTE AND RELATION TABLES AND THE RELATION
  6747. C
  6748.   600 CONTINUE
  6749.       IF(ICT.GT.MAXCOL) GO TO 9800
  6750. C
  6751. C  SET UP THE WHERE CLAUSE FOR THE INTERSECT.
  6752. C  THIS IS A DUMMY WHERE CLAUSE USED ONLY BY THE KEY PROCESSING
  6753. C
  6754.       KEYCOL = BUFFER(PTABLE+3)
  6755.       KEYTYP = BUFFER(PTABLE+6)
  6756.       NBOO = -1
  6757.       KATTL(1) = BUFFER(PTABLE+5)
  6758.       KATTY(1) = KEYTYP
  6759.       IF(KEYTYP.EQ.KZIVEC) KATTY(1) = KZINT
  6760.       IF(KEYTYP.EQ.KZRVEC) KATTY(1) = KZREAL
  6761.       IF(KEYTYP.EQ.KZDVEC) KATTY(1) = KZDOUB
  6762.       IF(KEYTYP.EQ.KZIMAT) KATTY(1) = KZINT
  6763.       IF(KEYTYP.EQ.KZRMAT) KATTY(1) = KZREAL
  6764.       IF(KEYTYP.EQ.KZDMAT) KATTY(1) = KZDOUB
  6765.       KOMPOS(1) = 1
  6766.       KSTRT = 0
  6767.       MAXTU = ALL9S
  6768.       LIMTU = ALL9S
  6769. C
  6770. C  SET UP RELATION TABLE.
  6771. C
  6772.       NAME = RNAME3
  6773.       CALL RMDATE(RDATE)
  6774.       NCOL = ICT
  6775.       NCOL3 = ICT
  6776.       NATT = NATT3
  6777.       NTUPLE = 0
  6778.       RSTART = 0
  6779.       REND = 0
  6780.       RPW = RPW1
  6781.       MPW = MPW1
  6782.       IF(EQ(RPW,NONE).AND.NE(RPW2,NONE)) RPW = RPW2
  6783.       IF(EQ(MPW,NONE).AND.NE(MPW2,NONE)) MPW = MPW2
  6784.       CALL RELADD
  6785. C
  6786.       CALL ATTNEW(NAME,NATT)
  6787.       PTABLE = BLKLOC(10)
  6788.       DO 700 K=1,NATT3
  6789.       ATTNAM = BLANK
  6790.       CALL STRMOV(BUFFER(PTABLE),1,8,ATTNAM,1)
  6791.       RELNAM = NAME
  6792.       ATTCOL = BUFFER(PTABLE+4)
  6793.       ATTLEN = BUFFER(PTABLE+5)
  6794.       ATTYPE = BUFFER(PTABLE+6)
  6795.       ATTKEY = 0
  6796.       CALL ATTADD
  6797.       PTABLE = PTABLE + 7
  6798.   700 CONTINUE
  6799. C
  6800. C  SEE IF WE CAN DO KEY PROCESSING.
  6801. C
  6802.       PTABLE = BLKLOC(10) - 7
  6803.       DO 800 K=1,NATT3
  6804.       PTABLE = PTABLE + 7
  6805.       IF(BUFFER(PTABLE+2).EQ.0) GO TO 800
  6806.       IF(BUFFER(PTABLE+3).EQ.0) GO TO 800
  6807.       J = LOCATT(BUFFER(PTABLE),RNAME1)
  6808.       IF(J.NE.0) GO TO 800
  6809.       CALL ATTGET(ISTAT)
  6810.       IF(ATTKEY.EQ.0) GO TO 800
  6811. C
  6812. C  WE FOUND A KEY ELEMENT IN MATN1 WHICH IS COMMON.
  6813. C
  6814.       KSTRT = ATTKEY
  6815.       NS = 2
  6816.       KATTL(1) = BUFFER(PTABLE+5)
  6817.       KATTY(1) = BUFFER(PTABLE+6)
  6818.       KEYCOL = BUFFER(PTABLE+3)
  6819.       GO TO 900
  6820.   800 CONTINUE
  6821.   900 CONTINUE
  6822. C
  6823. C  CALL ISECT TO CONSTRUCT MATN3
  6824. C
  6825.       CALL BLKDEF(11,MAXCOL,1)
  6826.       KQ3 = BLKLOC(11)
  6827.       PTABLE = BLKLOC(10)
  6828.       I = LOCREL(RNAME2)
  6829.       CALL ISECT(RNAME1,RNAME3,BUFFER(KQ3),NCOL3,NATT3,BUFFER(PTABLE),
  6830.      XKEYCOL,KEYTYP)
  6831.       GO TO 9999
  6832. C
  6833. C  TUPLE LENGTH EXCEEDS MAXCOL
  6834. C
  6835.  9800 CONTINUE
  6836.     if(nout.eq.6)goto 3416
  6837.       WRITE(NOUT,9810) MAXCOL
  6838.  9810 FORMAT(36H -ERROR- Relation Row Length Exceeds,I5)
  6839.       GO TO 9999
  6840. 3416    continue
  6841.     write(c128wk,9810)maxcol
  6842.     call atxto
  6843.     goto 9999
  6844. C
  6845. C  SYNTAX ERROR IN INTERSECT COMMAND
  6846. C
  6847.  9900 CONTINUE
  6848.       CALL WARN(4,0,0)
  6849. C
  6850. C
  6851. C  DONE WITH INTERSECT
  6852. C
  6853.  9999 CONTINUE
  6854.       CALL BLKCLR(10)
  6855.       CALL BLKCLR(11)
  6856.       RETURN
  6857.       END
  6858.       SUBROUTINE ITOC(STRING,CHAR1,NUMC,INT,IERR)
  6859.       INCLUDE rin:TEXT.BLK
  6860. C
  6861. C     THIS ROUTINE CONVERTS AN INTEGER TO TEXT AND PUTS
  6862. C     THE TEXT IN STRING.  IF THE INTEGER WILL NOT FIT, STRING IS
  6863. C     BLANKED OUT AND IERR IS RETURNED NON-ZERO.
  6864. C
  6865. C     STRING....REPOSITORY FOR TEXT OF INT
  6866. C     CHAR1.....1'ST CHARACTER POSITION IN STRING TO USE
  6867. C     NUMC......NUMBER OF CHARACTERS ALLOWED FOR INT
  6868. C               AT MOST 14 CHARACTERS WILL BE USED
  6869. C     INT.......INTEGER TO CONVERT.
  6870. C     IERR......0 IF INT FITS, 1 OTHERWISE
  6871. C
  6872.       INCLUDE rin:CONST4.BLK
  6873.       INCLUDE rin:MISC.BLK
  6874.       INTEGER STRING(*),CHAR1
  6875.       INTEGER DIGITS(10),C(14)
  6876.       EQUIVALENCE (DIGITS(1),K40)
  6877. C
  6878. C     BLANK OUT STRING
  6879. C
  6880.       IC = CHAR1 - 1
  6881.       DO 10 I=1,NUMC
  6882.       IC = IC + 1
  6883.       CALL PUTT(STRING,IC,BLANK)
  6884.    10 CONTINUE
  6885. C
  6886. C     SEE IF INT FITS
  6887. C
  6888.       NUM = NUMC
  6889.       IF(NUM.GT.9) NUM = 9
  6890.       IN = IABS(INT)
  6891.       IF(INT.LT.0) NUM = NUM - 1
  6892.       IERR = 1
  6893.       IF(IN.GE.10**NUM) GO TO 1000
  6894. C
  6895. C     FITS - BUILD STRING OF CHARACTERS IN C
  6896. C
  6897.       NC = 0
  6898.       IERR = 0
  6899.    20 CONTINUE
  6900.       IN1 = IN/10
  6901.       IC = IN - 10*IN1
  6902.       NC = NC + 1
  6903.       C(NC) = DIGITS(IC+1)
  6904.       IN = IN1
  6905.       IF(IN.GT.0) GO TO 20
  6906. C
  6907. C     NOW BUILD STRING
  6908. C
  6909.       ISTART = CHAR1 + NUMC - NC - 1
  6910.       IF(INT.GE.0) GO TO 40
  6911. C
  6912. C     NEGATIVE - ADD SIGN
  6913. C
  6914.       CALL PUTT(STRING,ISTART,K4MNUS)
  6915.    40 CONTINUE
  6916. C
  6917. C     MOVE IN STRING
  6918. C
  6919.       DO 60 I=1,NC
  6920.       ISTART = ISTART + 1
  6921.       CALL PUTT(STRING,ISTART,C(NC-I+1))
  6922.    60 CONTINUE
  6923.  1000 CONTINUE
  6924.       RETURN
  6925.       END
  6926.       SUBROUTINE ITOH(I,J,K)
  6927.       INCLUDE rin:TEXT.BLK
  6928. C
  6929. C  PURPOSE:   UNPACK I AND J FROM K
  6930. C
  6931. C  I WAS MULTIPLIED BY 100000.
  6932. C
  6933.       I = K / 100000
  6934.       J = K - (100000 * I)
  6935.       RETURN
  6936.       END
  6937.       SUBROUTINE JOIN(RNAME1,RNAME3,MATN3,NCOL3,NATT3,PTABLE,
  6938.      XKEYCOL,KEYTYP)
  6939.       INCLUDE rin:TEXT.BLK
  6940. C
  6941. C  THIS ROUTINE PERFORMS THE ACTUAL JOIN BETWEEN
  6942. C  RELATION 1 AND 2 FORMING 3
  6943. C
  6944. C  PARAMETERS:
  6945. C         NAME1---NAME OF THE FIRST RELATION
  6946. C         MATN3---DATA TUPLE FOR RELATION 3
  6947. C         NCOL3---NUMBER OF FIXED LENGTH COLUMNS IN MATN3
  6948. C         NATT3---NUMBER OF ATTRIBUTES IN MATN3
  6949. C         PTABLE--POINTER TABLE FOR THIS INTERSECT
  6950. C         KEYCOL--COLUMN OF MATN2 USED FOR SUPPLYING KEY VALUES
  6951. C         KEYTYP--ATTRIBUTE TYPE OF MATN1 USED FOR KEY VALUES
  6952.       INCLUDE rin:MISC.BLK
  6953.       INCLUDE rin:FILES.BLK
  6954.       INCLUDE rin:TUPLER.BLK
  6955.       INCLUDE rin:RIMPTR.BLK
  6956.       INCLUDE rin:RIMCOM.BLK
  6957.       INCLUDE rin:BUFFER.BLK
  6958.       INCLUDE rin:WHCOM.BLK
  6959.       INCLUDE rin:DCLAR1.BLK
  6960.       DIMENSION MATN3(*)
  6961.       INTEGER PTABLE(7,*)
  6962.       INTEGER ATTLEN
  6963.       INTEGER ENDCOL
  6964. C
  6965. C  INITIALIZE THE MATRIX POINTERS.
  6966. C
  6967.       IERR = 0
  6968.       IDST = 0
  6969.       IDNEW = 0
  6970.       IDCUR = NID
  6971. C
  6972. C  GET THE PARAMETERS FOR THE FIRST MATRIX.
  6973. C
  6974.       I = LOCREL(RNAME1)
  6975.       IDM1 = NID
  6976.       NSP = 0
  6977.       IF(KSTRT.NE.0) NSP = 2
  6978.       NTUP3 = 0
  6979.       ICROW = 0
  6980.       NUMWAR = 0
  6981. C
  6982. C  SEQUENCE THROUGH MATN2.
  6983. C
  6984.   100 CONTINUE
  6985.       IF(IDCUR.EQ.0) GO TO 1000
  6986.       CALL ITOH(N1,N2,IDCUR)
  6987.       IF(N2.EQ.0) GO TO 1000
  6988.       CALL GETDAT(2,IDCUR,MATN2,NCOL2)
  6989.       IF(IDCUR.LT.0) GO TO 1000
  6990.       ICROW = ICROW + 1
  6991. C
  6992. C  MOVE THE COMPARISON VALUE INTO THE WHCOM ARRAYS.
  6993. C
  6994.       CALL ITOH(NCHAR,NWORDS,KATTL(1))
  6995.       IP = MATN2 + KEYCOL - 1
  6996.       IF(NWORDS.NE.0) GO TO 110
  6997. C
  6998. C  SPECIAL GYRATIONS FOR VARIABLE LENGTH STUFF.
  6999. C
  7000.       IP2 = BUFFER(IP)
  7001.       IP = MATN2 + IP2 - 1
  7002.       NWORDS = BUFFER(IP)
  7003.       IF(NWORDS.LE.300) GO TO 105
  7004.       NUMWAR = NUMWAR + 1
  7005.     if(numwar.ge.100)goto 100
  7006.     if(nout.eq.6)goto 2
  7007.        WRITE (NOUT,103)ICROW
  7008.   103 FORMAT(15H -WARNING- ROW ,I6,
  7009.      X       35H IGNORED Because Attribute Too Long)
  7010.       GO TO 100
  7011. 2    continue
  7012.     write(c128wk,103)icrow
  7013.     call atxto
  7014.     goto 100
  7015.   105 CONTINUE
  7016.       IP = IP + 2
  7017.       NCHAR = BUFFER(IP-1)
  7018.   110 CONTINUE
  7019.       CALL HTOI(NCHAR,NWORDS,WHRLEN(1))
  7020.       CALL BLKMOV(WHRVAL(1),BUFFER(IP),NWORDS)
  7021.       NID = IDM1
  7022.       NS = NSP
  7023.   200 CONTINUE
  7024.       CALL RMLOOK(MATN1,1,1,NCOL1)
  7025.       IF(RMSTAT.NE.0) GO TO 100
  7026. C
  7027. C  OKAY -- NOW LOAD THE DATA.
  7028. C
  7029.   400 CONTINUE
  7030.       ENDCOL = NCOL3
  7031.       DO 900 KLM=1,NATT3
  7032.       KOL1 = PTABLE(3,KLM)
  7033.       KOL2 = PTABLE(4,KLM)
  7034.       KOL3 = PTABLE(5,KLM)
  7035.       ATTLEN = PTABLE(6,KLM)
  7036.       CALL ITOH(NCHAR,NWORDS,ATTLEN)
  7037.       IF(NWORDS.EQ.0) GO TO 700
  7038.       DO 600 I=1,NWORDS
  7039.       IF(KOL1.EQ.0) GO TO 500
  7040. C
  7041. C  LOAD THE ATTRIBUTE FROM MATN1.
  7042. C
  7043.       I1 = MATN1 + KOL1 - 1
  7044.       MATN3(KOL3) = BUFFER(I1)
  7045.       KOL3 = KOL3 + 1
  7046.       KOL1 = KOL1 + 1
  7047.       GO TO 600
  7048.   500 CONTINUE
  7049. C
  7050. C  LOAD THE ATTRIBUTE FROM MATN2.
  7051. C
  7052.       I2 = MATN2 + KOL2 - 1
  7053.       MATN3(KOL3) = BUFFER(I2)
  7054.       KOL3 = KOL3 + 1
  7055.       KOL2 = KOL2 + 1
  7056.   600 CONTINUE
  7057.       GO TO 900
  7058.   700 CONTINUE
  7059.       ENDCOL = ENDCOL + 1
  7060.       MATN3(KOL3) = ENDCOL
  7061.       IF(KOL1.EQ.0) GO TO 710
  7062. C
  7063. C  USE POINTERS FROM MATN1.
  7064. C
  7065.       I1 = MATN1 + KOL1 - 1
  7066.       KOL1 = BUFFER(I1)
  7067.       I2 = MATN1 + KOL1 - 1
  7068.       NWORDS = BUFFER(I2)
  7069.       GO TO 720
  7070.   710 CONTINUE
  7071. C
  7072. C  USE POINTERS FROM MATN2.
  7073. C
  7074.       I2 = MATN2 + KOL2 - 1
  7075.       KOL2 = BUFFER(I2)
  7076.       I2 = MATN2 + KOL2 - 1
  7077.       NWORDS = BUFFER(I2)
  7078.   720 CONTINUE
  7079. C
  7080. C  LOAD UP THE VALUES.
  7081. C
  7082.       IF((ENDCOL+NWORDS+1).GT.MAXCOL) GO TO 950
  7083.       MATN3(ENDCOL) = NWORDS
  7084.       NWORDS = NWORDS + 1
  7085.       DO 800 I=1,NWORDS
  7086.       ENDCOL = ENDCOL + 1
  7087.       I2 = I2 + 1
  7088.       MATN3(ENDCOL) = BUFFER(I2)
  7089.   800 CONTINUE
  7090.   900 CONTINUE
  7091.       CALL ADDDAT(3,IDNEW,MATN3,ENDCOL)
  7092.       IF(IDST.EQ.0) IDST = IDNEW
  7093.       NTUP3 = NTUP3 + 1
  7094. C
  7095. C  LOOK FOR MORE IN MATN1.
  7096. C
  7097.       GO TO 200
  7098. C
  7099. C  TUPLE LENGTH EXCEEDS MAXCOL
  7100. C
  7101.   950 CONTINUE
  7102.       IERR = 1
  7103.     if(nout.eq.6)goto 3
  7104.       WRITE(NOUT,960) MAXCOL
  7105.   960 FORMAT(36H -ERROR- Relation Row Length Exceeds,I5)
  7106.     goto 1000
  7107. 3    continue
  7108.     write(c128wk,960)maxcol
  7109.     call atxto
  7110. C
  7111. C  ALL DONE.
  7112. C
  7113.  1000 CONTINUE
  7114.       I = LOCREL(RNAME3)
  7115.       CALL RELGET(ISTAT)
  7116.       RSTART = IDST
  7117.       REND = IDNEW
  7118.       NTUPLE = NTUP3
  7119.       CALL RELPUT
  7120.       NUM = NTUP3
  7121.     if(ierr.ne.0)return
  7122.     if(nout.eq.6)goto 4
  7123.        WRITE(NOUT,9000) NUM
  7124.  9000 FORMAT(27H Successful JOIN Operation ,
  7125.      XI6,15H Rows Generated)
  7126. C
  7127. C  RETURN
  7128. C
  7129.       RETURN
  7130. 4    continue
  7131.     write(c128wk,9000)num
  7132.     call atxto
  7133.     return
  7134.       END
  7135.       SUBROUTINE JOIREL
  7136.       INCLUDE rin:TEXT.BLK
  7137. C
  7138. C  THIS ROUTINE FINDS THE JOIN OF TWO RELATIONS BASED UPON JOINING
  7139. C  TWO ATTRIBUTES.  THE RESULT FROM THIS PROCESS IS A PHYSICAL
  7140. C  RELATION WHICH HAS TUPLES CONTRUCTED FROM BOTH RELATIONS
  7141. C  WHERE THE SPECIFIED ATTRIBUTES MATCH AS REQUESTED.
  7142. C
  7143. C  THE SYNTAX FOR THE JOIN COMMAND IS:
  7144. C
  7145. C  JOIN REL1 USING ATT1 WITH REL2 USING ATT2 FORMING REL3 WHERE EQ
  7146. C
  7147.       INCLUDE rin:RMATTS.BLK
  7148.       INCLUDE rin:RMKEYW.BLK
  7149.       INCLUDE rin:CONST4.BLK
  7150.       INCLUDE rin:FLAGS.BLK
  7151.       INCLUDE rin:RIMCOM.BLK
  7152.       INCLUDE rin:TUPLER.BLK
  7153.       INCLUDE rin:TUPLEA.BLK
  7154.       INCLUDE rin:FILES.BLK
  7155.       INCLUDE rin:BUFFER.BLK
  7156.       INCLUDE rin:WHCOM.BLK
  7157.       INCLUDE rin:MISC.BLK
  7158. C
  7159.       INTEGER PTABLE
  7160.       LOGICAL EQ
  7161.       LOGICAL NE
  7162.       LOGICAL EQKEYW
  7163.       INCLUDE rin:DCLAR1.BLK
  7164.       INCLUDE rin:DCLAR3.BLK
  7165. C
  7166. C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
  7167. C
  7168.       CALL RMDBLK(DBNAME)
  7169.       IF(RMSTAT.EQ.0) GO TO 40
  7170.       CALL WARN(RMSTAT,DBNAME,0)
  7171.       GO TO 9999
  7172. C
  7173. C  LOCAL ARRAYS AND VARIABLES :
  7174. C
  7175. C  PTABLE (MATRIX 10) USED TO CONTROL POINTERS
  7176. C        ROWS1,2 -- ATTRIBUTE NAME
  7177. C        ROW3 -- ATTRIBUTE LOCATION IN RELATION 1
  7178. C        ROW4 -- ATTRIBUTE LOCATION IN RELATION 2
  7179. C        ROW5 -- ATTRIBUTE LOCATION IN RELATION 3
  7180. C        ROW6 -- LENGTH IN WORDS
  7181. C        ROW7 -- ATTRIBUTE TYPE
  7182. C
  7183. C  EDIT COMMAND SYNTAX
  7184. C
  7185.    40 CONTINUE
  7186.       CALL BLKCLN
  7187.       IF(.NOT.EQKEYW(3,KWUSIN,5)) GO TO 9900
  7188.       IF(.NOT.EQKEYW(5,KWWITH,4)) GO TO 9900
  7189.       IF(.NOT.EQKEYW(7,KWUSIN,5)) GO TO 9900
  7190.       IF(.NOT.EQKEYW(9,KWFORM,7)) GO TO 9900
  7191.       ITEMS = LXITEM(IDUMMY)
  7192. C
  7193. C  SET DEFAULT WHERE CONDITION (EQ OR NK = 2)
  7194. C
  7195.       NK = 2
  7196.       IF(ITEMS.LE.10) GO TO 50
  7197. C
  7198. C  CHECK WHERE COMPARISON.
  7199. C
  7200.       IF(.NOT.EQKEYW(11,KWWHER,5)) GO TO 9900
  7201.       NK = LOCBOO(LXWREC(12,1))
  7202.       IF(NK.EQ.0) GO TO 9900
  7203.       IF(NK.EQ.1) GO TO 9900
  7204.    50 CONTINUE
  7205. C
  7206. C  KEYWORD SYNTAX OKAY
  7207. C
  7208.       RNAME1 = BLANK
  7209.       CALL LXSREC(2,1,8,RNAME1,1)
  7210.       I = LOCREL(RNAME1)
  7211.       IF(I.EQ.0) GO TO 100
  7212. C
  7213. C  MISSING FIRST RELATION.
  7214. C
  7215.       CALL WARN(1,RNAME1,0)
  7216.       GO TO 9999
  7217.   100 CONTINUE
  7218. C
  7219. C  SAVE DATA ABOUT RELATION 1
  7220. C
  7221.       I1 = LOCPRM(RNAME1,1)
  7222.       IF(I1.EQ.0) GO TO 110
  7223.       CALL WARN(9,RNAME1,0)
  7224.       GO TO 9999
  7225.   110 CONTINUE
  7226.       NCOL1 = NCOL
  7227.       NATT1 = NATT
  7228.       RPW1 = RPW
  7229.       MPW1 = MPW
  7230. C
  7231. C  CHECK THE COMPARISON ATTRIBUTE.
  7232. C
  7233.       ANAME1 = BLANK
  7234.       CALL LXSREC(4,1,8,ANAME1,1)
  7235.       I = LOCATT(ANAME1,RNAME1)
  7236.       IF(I.NE.0) CALL WARN(3,ANAME1,RNAME1)
  7237.       IF(I.NE.0) GO TO 9999
  7238.       RNAME2 = BLANK
  7239.       CALL LXSREC(6,1,8,RNAME2,1)
  7240.       I = LOCREL(RNAME2)
  7241.       IF(I.EQ.0) GO TO 200
  7242. C
  7243. C  MISSING SECOND RELATION.
  7244. C
  7245.       CALL WARN(1,RNAME2,0)
  7246.       GO TO 9999
  7247.   200 CONTINUE
  7248. C
  7249. C  SAVE DATA ABOUT RELATION 2
  7250. C
  7251.       I2 = LOCPRM(RNAME2,1)
  7252.       IF(I2.EQ.0) GO TO 210
  7253.       CALL WARN(9,RNAME2,0)
  7254.       GO TO 9999
  7255.   210 CONTINUE
  7256.       NCOL2 = NCOL
  7257.       NATT2 = NATT
  7258.       RPW2 = RPW
  7259.       MPW2 = MPW
  7260. C
  7261. C  CHECK THE COMPARISON ATTRIBUTE.
  7262. C
  7263.       ANAME2 = BLANK
  7264.       CALL LXSREC(8,1,8,ANAME2,1)
  7265.       I = LOCATT(ANAME2,RNAME2)
  7266.       IF(I.NE.0) CALL WARN(3,ANAME2,RNAME2)
  7267.       IF(I.NE.0) GO TO 9999
  7268. C
  7269. C  CHECK FOR LEGAL RNAME3
  7270. C
  7271.       IF((LXLENC(10).GE.1).AND.(LXLENC(10).LE.8)) GO TO 250
  7272.       CALL WARN(7,KWRELA,BLANK)
  7273.       GO TO 9999
  7274.   250 CONTINUE
  7275. C
  7276. C  CHECK FOR DUPLICATE RELATION 3
  7277. C
  7278.       RNAME3 = BLANK
  7279.       CALL LXSREC(10,1,8,RNAME3,1)
  7280.       I = LOCREL(RNAME3)
  7281.       IF(I.NE.0) GO TO 300
  7282. C
  7283. C  ERROR
  7284. C
  7285.     if(nout.eq.6)goto 1
  7286.       WRITE(NOUT,9000)
  7287.  9000 FORMAT(55H -ERROR- Resultant Relation Does Not Have A Unique Name)
  7288.       GO TO 9999
  7289. 1    continue
  7290.     write(c128wk,9000)
  7291.     call atxto
  7292.     goto 9999
  7293. C
  7294. C  CHECK USER READ SECURITY
  7295. C
  7296.   300 CONTINUE
  7297.       IF((I1.NE.0).OR.(I2.NE.0)) GO TO 9999
  7298. C
  7299. C  RELATION NAMES OKAY -- CHECK THE ATTRIBUTES
  7300. C
  7301. C  SET UP PTABLE IN MATRIX POSITION 10
  7302. C
  7303.       CALL BLKDEF(10,7,NATT1+NATT2)
  7304.       PTABLE = BLKLOC(10)
  7305.       NATT3 = 0
  7306.       ICT = 1
  7307. C
  7308. C  STORE DATA FROM RELATION 1 IN PTABLE
  7309. C
  7310.       I = LOCATT(BLANK,RNAME1)
  7311.       DO 500 I=1,NATT1
  7312.       CALL ATTGET(ISTAT)
  7313.       IF(ISTAT.NE.0) GO TO 500
  7314.       NATT3 = NATT3 + 1
  7315.       BUFFER(PTABLE) = IBLANK
  7316.       CALL STRMOV(ATTNAM,1,8,BUFFER(PTABLE),1)
  7317.       BUFFER(PTABLE+2) = ATTCOL
  7318.       BUFFER(PTABLE+4) = ICT
  7319.       NWORDS = ATTWDS
  7320.       BUFFER(PTABLE+5) = ATTLEN
  7321.       IF(NWORDS.EQ.0) NWORDS = 1
  7322.       ICT = ICT + NWORDS
  7323.       BUFFER(PTABLE+6) = ATTYPE
  7324.       PTABLE = PTABLE + 7
  7325.   500 CONTINUE
  7326. C
  7327. C  STORE DATA FROM RELATION 2 IN PTABLE
  7328. C
  7329.       KATT3 = NATT3
  7330.       I = LOCATT(BLANK,RNAME2)
  7331.       DO 550 I=1,NATT2
  7332.       CALL ATTGET(ISTAT)
  7333.       IF(ISTAT.NE.0) GO TO 550
  7334. C
  7335. C  FIRST CHECK TO SEE IF ATTRIBUTE IS ALREADY IN PTABLE.
  7336. C
  7337.       KQ1 = BLKLOC(10) - 7
  7338.       DO 520 J=1,KATT3
  7339.       KQ1 = KQ1 + 7
  7340.       IF(BUFFER(KQ1+3).NE.0) GO TO 520
  7341.       IF(NE(BUFFER(KQ1),ATTNAM)) GO TO 520
  7342.     if(nout.eq.6)goto 3
  7343.       WRITE(NOUT,9003) ATTNAM
  7344.  9003 FORMAT(11H -WARNING- ,A8,30H is a DUPLICATE attribute name)
  7345.       WRITE(NOUT,9004)
  7346.  9004 FORMAT(53H You should rename it before doing queries or updates)
  7347.       GO TO 530
  7348. 3    continue
  7349.       WRITE(c128wk,9003) ATTNAM
  7350.     call atxto
  7351.       WRITE(c128wk,9004)
  7352.     call atxto
  7353.     goto 530
  7354.   520 CONTINUE
  7355.   530 CONTINUE
  7356. C
  7357. C  ADD THE DATA TO PTABLE.
  7358. C
  7359.       NATT3 = NATT3 + 1
  7360.       BUFFER(PTABLE) = IBLANK
  7361.       CALL STRMOV(ATTNAM,1,8,BUFFER(PTABLE),1)
  7362.       BUFFER(PTABLE+3) = ATTCOL
  7363.       BUFFER(PTABLE+4) = ICT
  7364.       NWORDS = ATTWDS
  7365.       BUFFER(PTABLE+5) = ATTLEN
  7366.       IF(NWORDS.EQ.0) NWORDS = 1
  7367.       ICT = ICT + NWORDS
  7368.       BUFFER(PTABLE+6) = ATTYPE
  7369.       PTABLE = PTABLE + 7
  7370.   550 CONTINUE
  7371.       ICT = ICT - 1
  7372. C
  7373. C  PTABLE IS CONSTRUCTED
  7374. C
  7375. C  NOW CREATE ATTRIBUTE AND RELATION TABLES AND THE RELATION
  7376. C
  7377.       IF(ICT.GT.MAXCOL) GO TO 9850
  7378. C
  7379. C  SET UP THE WHERE CLAUSE FOR THE JOIN.
  7380. C
  7381.       I = LOCATT(ANAME2,RNAME2)
  7382.       CALL ATTGET(ISTAT)
  7383.       IF(ATTWDS.GT.300) GO TO 9870
  7384.       KEYCOL = ATTCOL
  7385.       KEYTYP = ATTYPE
  7386.       KEYLEN = ATTLEN
  7387.       NBOO = 1
  7388.       BOO(1) = K4AND
  7389.       I = LOCATT(ANAME1,RNAME1)
  7390.       CALL ATTGET(ISTAT)
  7391.       KATTP(1) = ATTCOL
  7392.       KATTL(1) = ATTLEN
  7393. C
  7394. C  MAKE SURE THE ATTRIBUTE TYPES MATCH.
  7395. C
  7396.       IF(KEYTYP.NE.ATTYPE) GO TO 9800
  7397.       IF(KEYLEN.NE.ATTLEN) GO TO 9700
  7398.       KATTY(1) = ATTYPE
  7399.       IF(KEYTYP.EQ.KZIVEC) KATTY(1) = KZINT
  7400.       IF(KEYTYP.EQ.KZRVEC) KATTY(1) = KZREAL
  7401.       IF(KEYTYP.EQ.KZDVEC) KATTY(1) = KZDOUB
  7402.       IF(KEYTYP.EQ.KZIMAT) KATTY(1) = KZINT
  7403.       IF(KEYTYP.EQ.KZRMAT) KATTY(1) = KZREAL
  7404.       IF(KEYTYP.EQ.KZDMAT) KATTY(1) = KZDOUB
  7405.       KOMTYP(1) = NK
  7406.       KOMPOS(1) = 1
  7407.       KOMLEN(1) = 1
  7408.       KOMPOT(1) = 1
  7409.       KSTRT = ATTKEY
  7410.       IF(NK.NE.2) KSTRT = 0
  7411.       MAXTU = ALL9S
  7412.       LIMTU = ALL9S
  7413. C
  7414. C  SET UP RELATION TABLE.
  7415. C
  7416.       NAME = RNAME3
  7417.       CALL RMDATE(RDATE)
  7418.       NCOL = ICT
  7419.       NCOL3 = ICT
  7420.       NATT = NATT3
  7421.       NTUPLE = 0
  7422.       RSTART = 0
  7423.       REND = 0
  7424.       RPW = RPW1
  7425.       MPW = MPW1
  7426.       IF(EQ(RPW,NONE).AND.NE(RPW2,NONE)) RPW = RPW2
  7427.       IF(EQ(MPW,NONE).AND.NE(MPW2,NONE)) MPW = MPW2
  7428.       CALL RELADD
  7429. C
  7430.       CALL ATTNEW(NAME,NATT)
  7431.       PTABLE = BLKLOC(10)
  7432.       DO 700 K=1,NATT3
  7433.       ATTNAM = BLANK
  7434.       CALL STRMOV(BUFFER(PTABLE),1,8,ATTNAM,1)
  7435.       RELNAM = NAME
  7436.       ATTCOL = BUFFER(PTABLE+4)
  7437.       ATTLEN = BUFFER(PTABLE+5)
  7438.       ATTYPE = BUFFER(PTABLE+6)
  7439.       ATTKEY = 0
  7440.       CALL ATTADD
  7441.       PTABLE = PTABLE + 7
  7442.   700 CONTINUE
  7443. C
  7444. C  CALL JOIN TO CONSTRUCT MATN3
  7445. C
  7446.       CALL BLKDEF(11,MAXCOL,1)
  7447.       KQ3 = BLKLOC(11)
  7448.       PTABLE = BLKLOC(10)
  7449.       I = LOCREL(RNAME2)
  7450.       CALL JOIN(RNAME1,RNAME3,BUFFER(KQ3),NCOL3,NATT3,BUFFER(PTABLE),
  7451.      XKEYCOL,KEYTYP)
  7452.       GO TO 9999
  7453. C
  7454. C  MISMATCHED DATA TYPES.
  7455. C
  7456.  9700 CONTINUE
  7457.     if(nout.eq.6)goto 4
  7458.       WRITE(NOUT,9006)
  7459.  9006 FORMAT(46H -ERROR- JOIN attributes are different lengths )
  7460.       GO TO 9999
  7461. 4    continue
  7462.     write(c128wk,9006)
  7463.     call atxto
  7464.     goto 9999
  7465.  9800 CONTINUE
  7466.     if(nout.eq.6)goto 5
  7467.       WRITE(NOUT,9005)
  7468.  9005 FORMAT(44H -ERROR- JOIN attributes are different types)
  7469.       GO TO 9999
  7470. 5    continue
  7471.     write(c128wk,9005)
  7472.     call atxto
  7473.     goto 9999
  7474. C
  7475. C  TUPLE LENGTH EXCEEDS MAXCOL
  7476. C
  7477.  9850 CONTINUE
  7478.     if (nout.eq.6)goto 6
  7479.       WRITE(NOUT,9860) MAXCOL
  7480.  9860 FORMAT(36H -ERROR- Relation ROW LENGTH Exceeds,I5)
  7481.       GO TO 9999
  7482. 6    continue
  7483.     write(c128wk,9860)maxcol
  7484.     call atxto
  7485.     goto 9999
  7486.  9870 CONTINUE
  7487.     if(nout.eq.6)goto 7
  7488.       WRITE (NOUT,9880)
  7489.  9880 FORMAT(32H -ERROR- JOIN attribute too long )
  7490.       GO TO 9999
  7491. 7    continue
  7492.     write(c128wk,9880)
  7493.     call atxto
  7494.     goto 9999
  7495. C
  7496. C  SYNTAX ERROR IN JOIN COMMAND
  7497. C
  7498.  9900 CONTINUE
  7499.       CALL WARN(4,0,0)
  7500. C
  7501. C
  7502. C  DONE WITH INTERSECT
  7503. C
  7504.  9999 CONTINUE
  7505.       CALL BLKCLR(10)
  7506.       CALL BLKCLR(11)
  7507.       RETURN
  7508.       END
  7509.       SUBROUTINE KMPARD(VALUE1,VALUE2,LEN,NK,OK)
  7510.       INCLUDE rin:TEXT.BLK
  7511. C
  7512. C  THIS ROUTINE COMPARES VALUE1 AND VALUE2 TO SEE IF THEY MEET THE
  7513. C  DESIRED CONDITIONS.
  7514. C
  7515. C  PARAMETERS
  7516. C         VALUE1--FIRST VALUE
  7517. C         VALUE2--SECOND VALUE
  7518. C         LEN-----VALUE LENGTHS
  7519. C         NK------NUMBER FOR COMPARISON TYPE
  7520. C         OK------.FALSE. COMING IN, .TRUE. GOING OUT IF THE CONDITIONS
  7521. C                 ARE MET
  7522. C
  7523.       INCLUDE rin:FLAGS.BLK
  7524.       DOUBLE PRECISION TOLL
  7525.       DOUBLE PRECISION VALUE1(*),VALUE2(*)
  7526.       LOGICAL OK
  7527.       TOLL = TOL
  7528. C
  7529. C  BRANCH ON THE VALUE OF NK.
  7530. C
  7531.       IF(NK.NE.2) GO TO 30
  7532. C  EQ.
  7533.       IF(TOL.NE.0.) GO TO 26
  7534.       DO 25 I=1,LEN
  7535.       IF(VALUE1(I).NE.VALUE2(I)) GO TO 999
  7536.    25 CONTINUE
  7537.       GO TO 900
  7538.    26 CONTINUE
  7539.       IF(PCENT) GO TO 28
  7540.       DO 27 I=1,LEN
  7541.       IF(VALUE1(I).LT.(VALUE2(I)-TOLL)) GO TO 999
  7542.       IF(VALUE1(I).GT.(VALUE2(I)+TOLL)) GO TO 999
  7543.    27 CONTINUE
  7544.       GO TO 900
  7545.    28 CONTINUE
  7546.       DO 29 I=1,LEN
  7547.       IF(VALUE1(I).LT.(VALUE2(I)*(1.-TOLL))) GO TO 999
  7548.       IF(VALUE1(I).GT.(VALUE2(I)*(1.+TOLL))) GO TO 999
  7549.    29 CONTINUE
  7550.       GO TO 900
  7551.    30 IF(NK.NE.3) GO TO 40
  7552. C  NE.
  7553.       IF(TOL.NE.0.) GO TO 36
  7554.       DO 35 I=1,LEN
  7555.       IF(VALUE1(I).NE.VALUE2(I)) GO TO 900
  7556.    35 CONTINUE
  7557.       GO TO 999
  7558.    36 CONTINUE
  7559.       IF(PCENT) GO TO 38
  7560.       DO 37 I=1,LEN
  7561.       IF(VALUE1(I).LT.(VALUE2(I)-TOLL)) GO TO 900
  7562.       IF(VALUE1(I).GT.(VALUE2(I)+TOLL)) GO TO 900
  7563.    37 CONTINUE
  7564.       GO TO 999
  7565.    38 CONTINUE
  7566.       DO 39 I=1,LEN
  7567.       IF(VALUE1(I).LT.(VALUE2(I)*(1.-TOLL))) GO TO 900
  7568.       IF(VALUE1(I).GT.(VALUE2(I)*(1.+TOLL))) GO TO 900
  7569.    39 CONTINUE
  7570.       GO TO 999
  7571.    40 IF((NK.NE.4).AND.(NK.NE.5)) GO TO 60
  7572. C  GT AND GE.
  7573.       DO 45 I=1,LEN
  7574.       IF(VALUE1(I).GT.VALUE2(I)) GO TO 900
  7575.       IF(VALUE1(I).LT.VALUE2(I)) GO TO 999
  7576.    45 CONTINUE
  7577.       IF(NK.EQ.5) GO TO 900
  7578.       GO TO 999
  7579.    60 IF((NK.NE.6).AND.(NK.NE.7)) GO TO 80
  7580. C  LT AND LE.
  7581.       DO 65 I=1,LEN
  7582.       IF(VALUE1(I).LT.VALUE2(I)) GO TO 900
  7583.       IF(VALUE1(I).GT.VALUE2(I)) GO TO 999
  7584.    65 CONTINUE
  7585.       IF(NK.EQ.7) GO TO 900
  7586.       GO TO 999
  7587.    80 CONTINUE
  7588.       GO TO 999
  7589.   900 OK = .TRUE.
  7590.   999 RETURN
  7591.       END
  7592.       SUBROUTINE KMPARI(VALUE1,VALUE2,LEN,NK,OK)
  7593.       INCLUDE rin:TEXT.BLK
  7594. C
  7595. C  THIS ROUTINE COMPARES VALUE1 AND VALUE2 TO SEE IF THEY MEET THE
  7596. C  DESIRED CONDITIONS.
  7597. C
  7598. C  PARAMETERS
  7599. C         VALUE1--FIRST VALUE
  7600. C         VALUE2--SECOND VALUE
  7601. C         LEN-----VALUE LENGTHS
  7602. C         NK------NUMBER FOR COMPARISON TYPE
  7603. C         OK------.FALSE. COMING IN, .TRUE. GOING OUT IF THE CONDITIONS
  7604. C                 ARE MET
  7605. C
  7606.       INTEGER VALUE1(*),VALUE2(*)
  7607.       LOGICAL OK
  7608. C
  7609. C  BRANCH ON THE VALUE OF NK.
  7610. C
  7611.       IF(NK.NE.2) GO TO 30
  7612. C  EQ.
  7613.       DO 25 I=1,LEN
  7614.       IF(VALUE1(I).NE.VALUE2(I)) GO TO 999
  7615.    25 CONTINUE
  7616.       GO TO 900
  7617.    30 IF(NK.NE.3) GO TO 40
  7618. C  NE.
  7619.       DO 35 I=1,LEN
  7620.       IF(VALUE1(I).NE.VALUE2(I)) GO TO 900
  7621.    35 CONTINUE
  7622.       GO TO 999
  7623.    40 IF((NK.NE.4).AND.(NK.NE.5)) GO TO 60
  7624. C  GT AND GE.
  7625.       DO 45 I=1,LEN
  7626.       IF(VALUE1(I).GT.VALUE2(I)) GO TO 900
  7627.       IF(VALUE1(I).LT.VALUE2(I)) GO TO 999
  7628.    45 CONTINUE
  7629.       IF(NK.EQ.5) GO TO 900
  7630.       GO TO 999
  7631.    60 IF((NK.NE.6).AND.(NK.NE.7)) GO TO 80
  7632. C  LT AND LE.
  7633.       DO 65 I=1,LEN
  7634.       IF(VALUE1(I).LT.VALUE2(I)) GO TO 900
  7635.       IF(VALUE1(I).GT.VALUE2(I)) GO TO 999
  7636.    65 CONTINUE
  7637.       IF(NK.EQ.7) GO TO 900
  7638.       GO TO 999
  7639.    80 CONTINUE
  7640.       GO TO 999
  7641.   900 OK = .TRUE.
  7642.   999 RETURN
  7643.       END
  7644.       SUBROUTINE KMPARR(VALUE1,VALUE2,LEN,NK,OK)
  7645.       INCLUDE rin:TEXT.BLK
  7646. C
  7647. C  THIS ROUTINE COMPARES VALUE1 AND VALUE2 TO SEE IF THEY MEET THE
  7648. C  DESIRED CONDITIONS.
  7649. C
  7650. C  PARAMETERS
  7651. C         VALUE1--FIRST VALUE
  7652. C         VALUE2--SECOND VALUE
  7653. C         LEN-----VALUE LENGTHS
  7654. C         NK------NUMBER FOR COMPARISON TYPE
  7655. C         OK------.FALSE. COMING IN, .TRUE. GOING OUT IF THE CONDITIONS
  7656. C                 ARE MET
  7657. C
  7658.       INCLUDE rin:FLAGS.BLK
  7659.       REAL VALUE1(*),VALUE2(*)
  7660.       LOGICAL OK
  7661. C
  7662. C  BRANCH ON THE VALUE OF NK.
  7663. C
  7664.       IF(NK.NE.2) GO TO 30
  7665. C  EQ.
  7666.       IF(TOL.NE.0.) GO TO 26
  7667.       DO 25 I=1,LEN
  7668.       IF(VALUE1(I).NE.VALUE2(I)) GO TO 999
  7669.    25 CONTINUE
  7670.       GO TO 900
  7671.    26 CONTINUE
  7672.       IF(PCENT) GO TO 28
  7673.       DO 27 I=1,LEN
  7674.       IF(VALUE1(I).LT.(VALUE2(I)-TOL)) GO TO 999
  7675.       IF(VALUE1(I).GT.(VALUE2(I)+TOL)) GO TO 999
  7676.    27 CONTINUE
  7677.       GO TO 900
  7678.    28 CONTINUE
  7679.       DO 29 I=1,LEN
  7680.       IF(VALUE1(I).LT.(VALUE2(I)*(1.-TOL))) GO TO 999
  7681.       IF(VALUE1(I).GT.(VALUE2(I)*(1.+TOL))) GO TO 999
  7682.    29 CONTINUE
  7683.       GO TO 900
  7684.    30 IF(NK.NE.3) GO TO 40
  7685. C  NE.
  7686.       IF(TOL.NE.0.) GO TO 36
  7687.       DO 35 I=1,LEN
  7688.       IF(VALUE1(I).NE.VALUE2(I)) GO TO 900
  7689.    35 CONTINUE
  7690.       GO TO 999
  7691.    36 CONTINUE
  7692.       IF(PCENT) GO TO 38
  7693.       DO 37 I=1,LEN
  7694.       IF(VALUE1(I).LT.(VALUE2(I)-TOL)) GO TO 900
  7695.       IF(VALUE1(I).GT.(VALUE2(I)+TOL)) GO TO 900
  7696.    37 CONTINUE
  7697.       GO TO 999
  7698.    38 CONTINUE
  7699.       DO 39 I=1,LEN
  7700.       IF(VALUE1(I).LT.(VALUE2(I)*(1.-TOL))) GO TO 900
  7701.       IF(VALUE1(I).GT.(VALUE2(I)*(1.+TOL))) GO TO 900
  7702.    39 CONTINUE
  7703.       GO TO 999
  7704.    40 IF((NK.NE.4).AND.(NK.NE.5)) GO TO 60
  7705. C  GT AND GE.
  7706.       DO 45 I=1,LEN
  7707.       IF(VALUE1(I).GT.VALUE2(I)) GO TO 900
  7708.       IF(VALUE1(I).LT.VALUE2(I)) GO TO 999
  7709.    45 CONTINUE
  7710.       IF(NK.EQ.5) GO TO 900
  7711.       GO TO 999
  7712.    60 IF((NK.NE.6).AND.(NK.NE.7)) GO TO 80
  7713. C  LT AND LE.
  7714.       DO 65 I=1,LEN
  7715.       IF(VALUE1(I).LT.VALUE2(I)) GO TO 900
  7716.       IF(VALUE1(I).GT.VALUE2(I)) GO TO 999
  7717.    65 CONTINUE
  7718.       IF(NK.EQ.7) GO TO 900
  7719.       GO TO 999
  7720.    80 CONTINUE
  7721.       GO TO 999
  7722.   900 OK = .TRUE.
  7723.   999 RETURN
  7724.       END
  7725.       SUBROUTINE KMPART(VALUE1,VALUE2,LEN,NK,OK)
  7726.       INCLUDE rin:TEXT.BLK
  7727. C
  7728. C     THIS ROUTINE COMPARES LEN'S WORTH OF TEXT WORDS TO
  7729. C     SEE IF THEY MEET THE SPECIFIED CONDITION.
  7730. C     THE ROUTINE SWITCP IS USED TO ACTUALLY COMPARE
  7731. C     TWO WORDS.
  7732. C
  7733. C     PARAMETERS
  7734. C       VALUE1....LIST OF WORDS OF TEXT
  7735. C       VALUE2....LIST OF WORDS OF TEXT
  7736. C       LEN.......LENGTH OF VALUE1,VALUE2
  7737. C       NK........VALUE1 NK'S VALUE2
  7738. C                 NK IS AN INTEGER WITH THE FOLLOWING VALUES
  7739. C                 NK=2   EQ
  7740. C                    3   NE
  7741. C                    4   GT
  7742. C                    5   GE
  7743. C                    6   LT
  7744. C                    7   LE
  7745. C
  7746. C       OK........ .FALSE. COMING IN, .TRUE. GOING OUT IF
  7747. C                 CONDITION IS SATISFIED.
  7748. C
  7749.       INTEGER VALUE1(LEN),VALUE2(LEN)
  7750.       INTEGER SWITCP
  7751.       LOGICAL OK
  7752.       IF(NK.LT.2) GO TO 999
  7753.       IF(NK.GT.7) GO TO 999
  7754. C
  7755. C     LOOP ON VALUES TO COMPARE
  7756. C
  7757.       DO 100 I=1,LEN
  7758. C
  7759. C  COMPARE TWO VALUES 0=EQ  -1=GT  1=LT
  7760. C
  7761.       J = SWITCP(VALUE1(I),VALUE2(I))
  7762.       IF(J.EQ.0) GO TO 100
  7763.       IF(NK.EQ.2) GO TO 999
  7764.       K = 5 - J
  7765.       IF(NK.EQ.K) GO TO 999
  7766.       IF(NK.EQ.K+1) GO TO 999
  7767.       GO TO 200
  7768.   100 CONTINUE
  7769. C
  7770. C     EQUAL
  7771. C
  7772.       IF(NK.EQ.3) GO TO 999
  7773.       IF(NK.EQ.4) GO TO 999
  7774.       IF(NK.EQ.6) GO TO 999
  7775.   200 CONTINUE
  7776.       OK = .TRUE.
  7777.   999 CONTINUE
  7778.       RETURN
  7779.       END
  7780.       SUBROUTINE KOMPXX(VALUE1,VALUE2,LEN,NK,OK,TYPE)
  7781.       INCLUDE rin:TEXT.BLK
  7782. C
  7783. C  THIS ROUTINE COMPARES VALUE1 AND VALUE2 TO SEE IF THEY MEET THE
  7784. C  DESIRED CONDITIONS.
  7785. C
  7786. C  PARAMETERS
  7787. C         VALUE1--FIRST VALUE
  7788. C         VALUE2--SECOND VALUE
  7789. C         LEN-----VALUE LENGTHS
  7790. C         NK------NUMBER FOR COMPARISON TYPE
  7791. C         OK------.FALSE. COMING IN, .TRUE. GOING OUT IF THE CONDITIONS
  7792. C                 ARE MET
  7793. C         TYPE----TYPE OF VALUES BEING COMPARED
  7794. C
  7795.       INCLUDE rin:RMATTS.BLK
  7796.       INCLUDE rin:MISC.BLK
  7797. C
  7798.       INTEGER VALUE1(*)
  7799.       INTEGER VALUE2(*)
  7800.       INTEGER TYPE
  7801.       LOGICAL OK
  7802.       IF(NK.NE.-1) GO TO 10
  7803. C  FAILS.
  7804.       IF(VALUE1(1).EQ.NULL) OK = .TRUE.
  7805.       GO TO 999
  7806.    10 CONTINUE
  7807.       IF(VALUE1(1).EQ.NULL) GO TO 999
  7808.       IF(NK.NE.1) GO TO 20
  7809. C  EXISTS
  7810.       OK = .TRUE.
  7811.       GO TO 999
  7812.    20 CONTINUE
  7813.       IF(TYPE.EQ.KZINT)
  7814.      X CALL KMPARI(VALUE1,VALUE2,LEN,NK,OK)
  7815.       IF(TYPE.EQ.KZREAL)
  7816.      X CALL KMPARR(VALUE1,VALUE2,LEN,NK,OK)
  7817.       IF(TYPE.EQ.KZDOUB)
  7818.      X CALL KMPARD(VALUE1,VALUE2,LEN/2,NK,OK)
  7819.       IF(TYPE.EQ.KZTEXT)
  7820.      X CALL KMPART(VALUE1,VALUE2,LEN,NK,OK)
  7821.   999 CONTINUE
  7822.       RETURN
  7823.       END
  7824.       INTEGER FUNCTION LFIND(ITEM1,NUM,KEY,NCHAR)
  7825.       INCLUDE rin:TEXT.BLK
  7826. C
  7827. C     THIS ROUTINE LOOKS FOR A KEYWORD IN THE LXLREC
  7828. C     RECORD.  IT RETURNS 0 IF NOT FOUND AND THE ITEM
  7829. C     NUMBER IF FOUND.
  7830. C
  7831.       LOGICAL EQKEYW
  7832.       INTEGER KEY(*)
  7833.       NEND = ITEM1 + NUM - 1
  7834.       DO 10 J=ITEM1,NEND
  7835.       IF(EQKEYW(J,KEY,NCHAR)) GO TO 20
  7836.    10 CONTINUE
  7837.       J = 0
  7838.    20 CONTINUE
  7839.       LFIND = J
  7840.       RETURN
  7841.       END
  7842.       SUBROUTINE LOADIT(MAT)
  7843.       INCLUDE rin:TEXT.BLK
  7844. C
  7845. C  THIS ROUTINE IS THE FORTRAN ROUTINE FOR LOADING DATA VALUES IN THE
  7846. C  RIM DATA BASE.
  7847. C
  7848. C  PARAMETERS:
  7849. C         MAT-----SCRATCH ARRAY FOR BUILDING TUPLES
  7850. C
  7851.       INCLUDE rin:CONST4.BLK
  7852.       INCLUDE rin:RMKEYW.BLK
  7853.       INCLUDE rin:FILES.BLK
  7854.       INCLUDE rin:RULCOM.BLK
  7855.       INCLUDE rin:START.BLK
  7856.       INCLUDE rin:TUPLEA.BLK
  7857.       INCLUDE rin:TUPLER.BLK
  7858.       INCLUDE rin:MISC.BLK
  7859.       INCLUDE rin:FLAGS.BLK
  7860. C
  7861. C  DIMENSION STATEMENTS.
  7862.       INTEGER COLUMN
  7863.       LOGICAL EQKEYW
  7864.       DOUBLE PRECISION DTEMP
  7865.       REAL TEMP(2)
  7866.       INTEGER ITEMP(2)
  7867.       EQUIVALENCE (DTEMP,TEMP(1))
  7868.       EQUIVALENCE (TEMP(1),ITEMP(1))
  7869.       INTEGER ENDCOL
  7870.       INTEGER MAT(*)
  7871. C
  7872. C  READ A CARD.
  7873. C
  7874.   100 CONTINUE
  7875.       CALL LODREC
  7876.       LSTCMD = K4LOA
  7877.       ITEMS = LXITEM(IDUMMY)
  7878.       IF(ITEMS.GT.2) GO TO 160
  7879.       IF(EQKEYW(1,KWLOAD,4)) GO TO 5000
  7880.       IF(ITEMS.GT.1) GO TO 160
  7881.       IF(EQKEYW(1,KWCHEC,5)) GO TO 3000
  7882.       IF(EQKEYW(1,KWNOCH,7)) GO TO 4000
  7883.       IF(EQKEYW(1,KWEND,3)) GO TO 5000
  7884.   160 CONTINUE
  7885. C
  7886. C  ASSUME THIS IS A DATA CARD.
  7887. C
  7888. C  ZERO OUT THE TUPLE.
  7889. C
  7890.       CALL ZEROIT(MAT,MAXCOL)
  7891. C
  7892. C  CHECK EACH ATTRIBUTE AND MOVE IT TO THE TUPLE FROM INPUT.
  7893. C
  7894.       NUMKEY = 0
  7895.       I = LOCATT(BLANK,NAME)
  7896.       IF(I.NE.0) GO TO 5000
  7897.       J = 1
  7898.       ENDCOL = NCOL + 1
  7899.       DO 1000 I=1,NATT
  7900.       CALL ATTGET(ISTAT)
  7901.       IF(ISTAT.NE.0) GO TO 2300
  7902.       COLUMN = ATTCOL
  7903.       IF(ATTKEY.NE.0) NUMKEY = NUMKEY + 1
  7904. C
  7905. C     CALL PARVAL TO CRACH VALUE STRING
  7906. C
  7907.       IF(ATTWDS.EQ.0) GO TO 200
  7908. C
  7909. C     FIXED ATTRIBUTE
  7910. C
  7911.       CALL PARVAL(J,MAT(COLUMN),ATTYPE,ATTWDS,ATTCHA,0,IERR)
  7912.       IF(IERR.NE.0) GO TO 100
  7913.       GO TO 1000
  7914.   200 CONTINUE
  7915. C
  7916. C     VARIABLE ATTRIBUTE
  7917. C
  7918.       MAT(COLUMN) = ENDCOL
  7919.       NCOLT = ENDCOL + 1
  7920.       CALL PARVAL(J,MAT(ENDCOL+2),ATTYPE,ATTWDS,ATTCHA,NCOLT,IERR)
  7921.       IF(IERR.NE.0) GO TO 100
  7922.       MAT(ENDCOL) = ATTWDS
  7923.       MAT(ENDCOL+1) = ATTCHA
  7924.       ENDCOL = ENDCOL + ATTWDS + 2
  7925.  1000 CONTINUE
  7926.       ENDCOL = ENDCOL - 1
  7927.       IF(J.LE.ITEMS) GO TO 2400
  7928. C
  7929. C  SEE IF ALL APPLICABLE RULES ARE SATISFIED.
  7930. C
  7931.       IF(.NOT.RUCK) GO TO 1100
  7932.       IF(.NOT.RULES) GO TO 1100
  7933.       CALL CHKTUP(MAT,ISTAT)
  7934.       IF(ISTAT.EQ.0) GO TO 1100
  7935.       IF(ISTAT.LT.0) GO TO 1050
  7936.     if(nout.eq.6)goto 1
  7937.       WRITE(NOUT,1010)
  7938.  1010 FORMAT(54H -ERROR- The Data Fails To Satisfy The Following Rule:)
  7939.     goto 2
  7940. 1    continue
  7941.     write(c128wk,1010)
  7942.     call atxto
  7943. 2    continue
  7944.       ISNOUT = NOUTR
  7945.       NOUTR = NOUT
  7946.       CALL PRULE(ISTAT)
  7947.       NOUTR = ISNOUT
  7948.       GO TO 100
  7949.  1050 CONTINUE
  7950.       ISTAT = -ISTAT
  7951.     if(nout.eq.6)goto 3
  7952.       WRITE(NOUT,1060) ISTAT
  7953.  1060 FORMAT(32H -ERROR- Unable To Process RULE ,I4)
  7954.       GO TO 100
  7955. 3    continue
  7956.     write(c128wk,1060)istat
  7957.     call atxto
  7958.     goto 100
  7959.  1100 CONTINUE
  7960.       NTUPLE = NTUPLE + 1
  7961.       CALL ADDDAT(1,REND,MAT,ENDCOL)
  7962.       IF(RSTART.EQ.0) RSTART = REND
  7963.       CALL RELPUT
  7964. C
  7965. C  PROCESS ANY KEY ATTRIBUTES.
  7966. C
  7967.       IF(NUMKEY.EQ.0) GO TO 100
  7968.       I = LOCATT(BLANK,NAME)
  7969.       DO 1500 I=1,NATT
  7970.       CALL ATTGET(ISTAT)
  7971.       IF(ISTAT.NE.0) GO TO 2300
  7972.       IF(ATTKEY.EQ.0) GO TO 1500
  7973.       START = ATTKEY
  7974.       KSTART = ATTKEY
  7975.       COLUMN = ATTCOL
  7976.       IF(ATTWDS.NE.0) GO TO 1400
  7977.       COLUMN = MAT(ATTCOL) + 2
  7978.  1400 CONTINUE
  7979.       IF(MAT(COLUMN).EQ.NULL) GO TO 1500
  7980.       CALL BTADD(MAT(COLUMN),REND,ATTYPE)
  7981.       IF(START.EQ.KSTART) GO TO 1500
  7982.       ATTKEY = START
  7983.       CALL ATTPUT(ISTAT)
  7984.  1500 CONTINUE
  7985.       GO TO 100
  7986. C
  7987. C  ATTGET RAN OUT OF ATTRIBUTES TOO SOON.
  7988. C
  7989.  2300 CONTINUE
  7990.     if(nout.eq.6)goto 7
  7991.       WRITE(NOUT,9004)
  7992.  9004 FORMAT(34H -ERROR- Attribute Table Too Short)
  7993.       GO TO 100
  7994. 7    continue
  7995.     write(c128wk,9004)
  7996.     call atxto
  7997.     goto 100
  7998.  2400 CONTINUE
  7999. C
  8000. C     TOO MANY ITEMS
  8001. C
  8002.     if(nout.eq.6)goto 8
  8003.       WRITE (NOUT,2450)
  8004.  2450 FORMAT(33H -ERROR- Too Many Items On Record )
  8005.       GO TO 100
  8006. 8    continue
  8007.     write(c128wk,2450)
  8008.     call atxto
  8009.     goto 100
  8010. C
  8011. C  CHECK ON.
  8012. C
  8013.  3000 CONTINUE
  8014.       RUCK = .TRUE.
  8015.       GO TO 100
  8016. C
  8017. C  CHECK OFF.
  8018. C
  8019.  4000 CONTINUE
  8020.       RUCK = .FALSE.
  8021.       GO TO 100
  8022. C
  8023. C  ALL DONE.
  8024. C
  8025.  5000 CONTINUE
  8026.       RETURN
  8027.       END
  8028.       FUNCTION LOCATT(ANAME,RNAME)
  8029.       INCLUDE rin:TEXT.BLK
  8030. C
  8031. C  PURPOSE:   LOOK FOR ATTRIBUTES AND RELATIONS IN THE ATTRIBUTE
  8032. C             RELATION
  8033. C
  8034. C  PARAMETERS:
  8035. C         ANAME---NAME OF ATTRIBUTE OR BLANKS
  8036. C         RNAME---NAME OF RELATION OR BLANKS
  8037. C         LOCATT--STATUS VARIABLE - 0 MEANS OK, 1 MEANS NO WAY
  8038.       INCLUDE rin:ATTBLE.BLK
  8039.       INCLUDE rin:START.BLK
  8040.       INCLUDE rin:MISC.BLK
  8041.       LOGICAL EQ
  8042.       LOGICAL NE
  8043.       INCLUDE rin:DCLAR1.BLK
  8044.       INCLUDE rin:DATA1.BLK
  8045.       LOCATT = 0
  8046. C
  8047. C  SEE WHAT THE CALLER WANTS.
  8048. C
  8049.       IF(EQ(RNAME,BLANK)) GO TO 1000
  8050. C
  8051. C  RNAME IS SPECIFIED.
  8052. C
  8053. C
  8054. C  FIND THE START FOR THIS RELATION.
  8055. C
  8056. C
  8057. C  GET THE PAGE WITH THE DATA FOR THIS RELATION.
  8058. C
  8059.   100 CONTINUE
  8060.       CRNAME = RNAME
  8061.       MRSTRT = MSTRTP
  8062.   200 CONTINUE
  8063.       CALL ATTPAG(MRSTRT)
  8064. C
  8065. C  LOOK FOR THE ATTRIBUTE IN THIS RELATION.
  8066. C
  8067.       I = MRSTRT
  8068.   300 CONTINUE
  8069.       IF(I.GT.APBUF) GO TO 400
  8070.       IF(ATTBLE(1,I).LT.0) GO TO 350
  8071.       IF(NE(ATTBLE(4,I),RNAME)) GO TO 350
  8072.       IF(ANAME.EQ.BLANK) GO TO 500
  8073.       IF(EQ(ATTBLE(2,I),ANAME)) GO TO 500
  8074.   350 CONTINUE
  8075.       I = I + 1
  8076.       GO TO 300
  8077. C
  8078. C  GET THE NEXT PAGE.
  8079. C
  8080.   400 CONTINUE
  8081.       MRSTRT = ATTBUF(1)
  8082.       IF(MRSTRT.EQ.0) GO TO 9000
  8083.       GO TO 200
  8084. C
  8085. C  WE FOUND THE ROW WE ARE LOOKING FOR.
  8086. C
  8087.   500 CONTINUE
  8088.       CANAME = ANAME
  8089.       CROW = I
  8090.       LROW = 0
  8091.       GO TO 9999
  8092. C
  8093. C  SCAN FOR ATTRIBUTE WITHOUT RELATION SPECIFIED.
  8094. C
  8095.  1000 CONTINUE
  8096.       IF(EQ(ANAME,BLANK)) GO TO 9000
  8097.       MRSTRT = MSTRTP
  8098.  1100 CONTINUE
  8099.       CALL ATTPAG(MRSTRT)
  8100.       I = MRSTRT
  8101.  1200 CONTINUE
  8102.       IF(I.GT.APBUF) GO TO 1400
  8103.       IF(ATTBLE(1,I).LT.0) GO TO 1300
  8104.       IF(EQ(ATTBLE(2,I),ANAME)) GO TO 1500
  8105.  1300 CONTINUE
  8106.       I = I + 1
  8107.       GO TO 1200
  8108. C
  8109. C  GET THE NEXT PAGE.
  8110. C
  8111.  1400 CONTINUE
  8112.       MRSTRT = ATTBUF(1)
  8113.       IF(MRSTRT.EQ.0) GO TO 9000
  8114.       GO TO 1100
  8115. C
  8116. C  FOUND IT.
  8117. C
  8118.  1500 CONTINUE
  8119.       CRNAME = BLANK
  8120.       CANAME = ANAME
  8121.       CROW = I
  8122.       LROW = 0
  8123.       GO TO 9999
  8124. C
  8125. C  UNABLE TO FIND WHAT WE ARE LOOKING FOR.
  8126. C
  8127.  9000 CONTINUE
  8128.       CRNAME = 0
  8129.       CANAME = 0
  8130.       LOCATT = 1
  8131.       CROW = 0
  8132.       LROW = 0
  8133.  9999 CONTINUE
  8134.       RETURN
  8135.       END
  8136.       FUNCTION LOCBOO(KOMPAR)
  8137.       INCLUDE rin:TEXT.BLK
  8138. C
  8139. C  FIND THE TYPE OF BOOLEAN COMPARISON THAT KOMPAR IS.
  8140. C  JUST CHECK THE FIRST 3 CHARACTERS
  8141. C
  8142. C  PARAMETERS:
  8143. C         KOMPAR--BOOLEAN OPERATOR
  8144. C         LOCBOO--CORRESPONDING NUMBER
  8145. C
  8146.       INCLUDE rin:CONST4.BLK
  8147.       INCLUDE rin:MISC.BLK
  8148.       INTEGER BOOL(17)
  8149.       EQUIVALENCE (BOOL(1),K4BOOL(1))
  8150.       CALL FILCH(KOM,1,CHPWD,BLANK)
  8151.       CALL STRMOV(KOMPAR,1,3,KOM,1)
  8152.       DO 100 I=1,17
  8153.       IF(KOM.EQ.BOOL(I)) GO TO 200
  8154.   100 CONTINUE
  8155.       I = 0
  8156.       IF(KOM.EQ.K4CON) I = 9
  8157.   200 LOCBOO = I
  8158.       IF(I.EQ.8) LOCBOO = -1
  8159.       RETURN
  8160.       END
  8161.       FUNCTION LOCPRM(RNAME,JCODE)
  8162.       INCLUDE rin:TEXT.BLK
  8163. C
  8164. C  CHECK PERMISSION FOR A USERID AGAINST A RELATION.
  8165. C
  8166. C  PARAMETERS:
  8167. C         RNAME---RELATION NAME
  8168. C         JCODE---READ/MODIFY CODE
  8169. C                 1 FOR READ
  8170. C                 2 FOR MODIFY
  8171. C         LOCPRM--O FOR OK, 1 FOR NO-WAY
  8172.       INCLUDE rin:FLAGS.BLK
  8173.       INCLUDE rin:RIMCOM.BLK
  8174.       INCLUDE rin:TUPLER.BLK
  8175.       INCLUDE rin:MISC.BLK
  8176.       LOGICAL EQ
  8177.       INCLUDE rin:DCLAR1.BLK
  8178. C
  8179. C  RETRIEVE THE PASSWORDS.
  8180. C
  8181.       IF(EQ(RNAME,NAME)) GO TO 100
  8182.       GO TO 1500
  8183.   100 CONTINUE
  8184. C
  8185. C  COMPARE THE PASSWORDS.
  8186. C
  8187.       IF(JCODE.NE.1) GO TO 500
  8188. C
  8189. C  READ.
  8190. C
  8191.       IF(EQ(RPW,NONE)) GO TO 1000
  8192.       IF(EQ(RPW,USERID)) GO TO 1000
  8193.       IF(EQ(MPW,USERID)) GO TO 1000
  8194.       IF(EQ(OWNER,USERID)) GO TO 1000
  8195.       GO TO 1500
  8196.   500 CONTINUE
  8197.       IF(JCODE.NE.2) GO TO 1500
  8198. C
  8199. C  MODIFY.
  8200. C
  8201.       IF(EQ(MPW,NONE)) GO TO 1000
  8202.       IF(EQ(MPW,USERID)) GO TO 1000
  8203.       IF(EQ(OWNER,USERID)) GO TO 1000
  8204.       GO TO 1500
  8205. C
  8206. C  OK.
  8207. C
  8208.  1000 LOCPRM = 0
  8209.       RMSTAT = 0
  8210.       RETURN
  8211. C
  8212. C  NO WAY.
  8213. C
  8214.  1500 CONTINUE
  8215.       LOCPRM = 1
  8216.       RMSTAT = 90
  8217.       RETURN
  8218.       END
  8219.       FUNCTION LOCREL(RNAME)
  8220.       INCLUDE rin:TEXT.BLK
  8221. C
  8222. C  PURPOSE:   LOOK FOR A RELATION IN THE RELTBL RELATION
  8223. C
  8224. C  PARAMETERS:
  8225. C         RNAME---NAME OF RELATION OR BLANK
  8226. C         LOCREL--STATUS VARIABLE - 0 MEANS OK, 1 MEANS NO WAY
  8227.       INCLUDE rin:RELTBL.BLK
  8228.       INCLUDE rin:TUPLER.BLK
  8229.       INCLUDE rin:MISC.BLK
  8230.       INCLUDE rin:RIMPTR.BLK
  8231.       LOGICAL EQ
  8232.       INCLUDE rin:DCLAR1.BLK
  8233.       INCLUDE rin:DATA2.BLK
  8234.       LOCREL = 0
  8235. C
  8236. C  SCAN FOR THIS RELATION.
  8237. C
  8238.       MRSTRT = MSTRTP
  8239.   100 CONTINUE
  8240.       CALL RELPAG(MRSTRT)
  8241.       I = MRSTRT
  8242.   200 CONTINUE
  8243.       IF(I.GT.RPBUF) GO TO 400
  8244.       IF(RELTBL(1,I).EQ.0) GO TO 9000
  8245.       IF(RELTBL(1,I).LT.0) GO TO 300
  8246.       IF(EQ(RNAME,BLANK)) GO TO 500
  8247.       IF(EQ(RELTBL(2,I),RNAME)) GO TO 500
  8248.   300 CONTINUE
  8249.       I = I + 1
  8250.       GO TO 200
  8251. C
  8252. C  GET THE NEXT PAGE.
  8253. C
  8254.   400 CONTINUE
  8255.       MRSTRT = RELBUF(1)
  8256.       IF(MRSTRT.EQ.0) GO TO 9000
  8257.       GO TO 100
  8258. C
  8259. C  FOUND IT.
  8260. C
  8261.   500 CONTINUE
  8262.       LRROW = I - 1
  8263.       CALL BLKMOV(NAME,RELTBL(2,I),2)
  8264.       CALL BLKMOV(RDATE,RELTBL(4,I),2)
  8265.       NCOL = RELTBL(6,I)
  8266.       NATT = RELTBL(7,I)
  8267.       NTUPLE = RELTBL(8,I)
  8268.       RSTART = RELTBL(9,I)
  8269.       REND = RELTBL(10,I)
  8270.       CALL BLKMOV(RPW,RELTBL(11,I),2)
  8271.       CALL BLKMOV(MPW,RELTBL(13,I),2)
  8272.       CNAME = RNAME
  8273. C
  8274. C  ALSO SET THE VALUES IN THE RIMPTR COMMON BLOCK.
  8275. C
  8276.       IVAL = 0
  8277.       LIMVAL = 0
  8278.       CID = RSTART
  8279.       NID = CID
  8280.       NS = 0
  8281.       MID = 0
  8282.       GO TO 9999
  8283. C
  8284. C  UNABLE TO FIND WHAT WE ARE LOOKING FOR.
  8285. C
  8286.  9000 CONTINUE
  8287.       LOCREL = 1
  8288.       LRROW = 0
  8289.  9999 CONTINUE
  8290.       RETURN
  8291.       END
  8292.       SUBROUTINE LODELE(NUMELE,ERROR)
  8293.       INCLUDE rin:TEXT.BLK
  8294. C
  8295. C  THIS ROUTINE LOADS THE ELEMENT DATA INTO THE SCRATCH RELATION.
  8296. C
  8297. C  PARAMETERS:
  8298. C         NUMELE--NUMBER OF NEWLY DEFINED ATTRIBUTES
  8299. C         ERROR---COUNT OF CRUMMY INPUT COMMANDS
  8300. C
  8301.       INCLUDE rin:RMATTS.BLK
  8302.       INCLUDE rin:RMKEYW.BLK
  8303.       INCLUDE rin:BUFFER.BLK
  8304.       INCLUDE rin:FILES.BLK
  8305.       INCLUDE rin:MISC.BLK
  8306.       INCLUDE rin:CONST4.BLK
  8307. C
  8308.       LOGICAL EQKEYW
  8309.       INTEGER ERROR
  8310.       INTEGER ROWS
  8311.       INTEGER COLUMN
  8312. C
  8313. C  READ AN ELEMENT RECORD.
  8314. C
  8315.   100 CONTINUE
  8316.       CALL LODREC
  8317.       IF(LXITEM(IDUMMY).GT.1) GO TO 200
  8318.       IF(EQKEYW(1,KWELEM,8)) GO TO 999
  8319.       IF(EQKEYW(1,KWATTR,10)) GO TO 999
  8320.       IF(EQKEYW(1,KWRELA,9)) GO TO 999
  8321.       IF(EQKEYW(1,KWPASS,9)) GO TO 999
  8322.       IF(EQKEYW(1,KWRULS,5)) GO TO 999
  8323.       IF(EQKEYW(1,KWEND,3)) GO TO 999
  8324. C
  8325. C  UNRECOGNIZED GARBAGE.
  8326. C
  8327.       CALL WARN(4,0,0)
  8328.       ERROR = ERROR + 1
  8329.       GO TO 100
  8330. C
  8331. C  EDIT ELEMENT INPUT.
  8332. C
  8333.   200 CONTINUE
  8334.       IATTV = 0
  8335.       IF(EQKEYW(2,KWREAL,4)) IATTV = KZREAL
  8336.       IF(EQKEYW(2,KWTEXT,4)) IATTV = KZTEXT
  8337.       IF(EQKEYW(2,KWINT ,7)) IATTV = KZINT
  8338.       IF(EQKEYW(2,KWDOUB,6)) IATTV = KZDOUB
  8339.       IF(EQKEYW(2,KWRVEC,4)) IATTV = KZRVEC
  8340.       IF(EQKEYW(2,KWIVEC,4)) IATTV = KZIVEC
  8341.       IF(EQKEYW(2,KWDVEC,4)) IATTV = KZDVEC
  8342.       IF(EQKEYW(2,KWRMAT,4)) IATTV = KZRMAT
  8343.       IF(EQKEYW(2,KWIMAT,4)) IATTV = KZIMAT
  8344.       IF(EQKEYW(2,KWDMAT,4)) IATTV = KZDMAT
  8345.       IF(IATTV.NE.0) GO TO 300
  8346.     if(nout.eq.6)goto 1
  8347.       WRITE(NOUT,9000)
  8348.  9000 FORMAT(36H -ERROR- Illegal Data Type Specified)
  8349.       ERROR = ERROR + 1
  8350.       GO TO 100
  8351. 1    continue
  8352.     write(c128wk,9000)
  8353.     call atxto
  8354.     error=error+1
  8355.     goto 100
  8356.   300 CONTINUE
  8357. C
  8358. C  MAKE SURE THAT THE ATTRIBUTE NAME IS TEXT.
  8359. C
  8360.       IF(LXID(1).EQ.KZTEXT) GO TO 400
  8361.     if(nout.eq.6)goto 2
  8362.       WRITE(NOUT,9001)
  8363.  9001 FORMAT(37H -ERROR- Attribute Names Must Be TEXT)
  8364.       ERROR = ERROR + 1
  8365.       GO TO 100
  8366. 2    continue
  8367.     error=error+1
  8368.     write(c128wk,9001)
  8369.     call atxto
  8370.     goto 100
  8371.   400 CONTINUE
  8372.       IF(LXLENC(1).LE.8) GO TO 450
  8373.       CALL WARN(7,KWATTR,K4E)
  8374.       ERROR = ERROR + 1
  8375.       GO TO 100
  8376.   450 CONTINUE
  8377. C
  8378. C  LXITEM(IDUMMY) = 2, 3, 4, OR 5 ?
  8379. C
  8380.       LENGTH = 1
  8381.       IF(EQKEYW(2,KWTEXT,4)) LENGTH = 8
  8382.       ROWS = 1
  8383.       COLUMN = 1
  8384.       KEY = 0
  8385.       IF(LXITEM(IDUMMY).EQ.2) GO TO 700
  8386.       IF(LXITEM(IDUMMY).EQ.3) GO TO 500
  8387.       IF(LXITEM(IDUMMY).EQ.4) GO TO 600
  8388.       IF(LXITEM(IDUMMY).EQ.5) GO TO 600
  8389.       CALL WARN(4,0,0)
  8390.       ERROR = ERROR + 1
  8391.       GO TO 100
  8392. C
  8393. C  LXITEM(IDUMMY) = 3.
  8394. C
  8395.   500 CONTINUE
  8396.       IF(EQKEYW(3,KWKEY,3)) GO TO 540
  8397.       IF((LXIREC(3).GT.0).AND.(LXIREC(3).LE.MAXCOL)) GO TO 530
  8398.       IF(EQKEYW(3,KWVAR,3)) GO TO 550
  8399.     if(nout.eq.6)goto 3
  8400.       WRITE(NOUT,9002) MAXCOL
  8401.  9002 FORMAT(42H -ERROR- Length Must Be A Positive Integer,
  8402.      X       18H in the Range 1 to,I5)
  8403.     goto 4
  8404. 3    continue
  8405.     write(c128wk,9002)maxcol
  8406.     call atxto
  8407. 4    continue
  8408.       ERROR = ERROR + 1
  8409. C
  8410.   530 CONTINUE
  8411.       LENGTH = LXIREC(3)
  8412.       ROWS = LENGTH
  8413.       GO TO 700
  8414. C
  8415.   540 CONTINUE
  8416.       KEY = 1
  8417.       GO TO 700
  8418. C
  8419.   550 CONTINUE
  8420.       LENGTH = 0
  8421.       ROWS = 0
  8422.       COLUMN = 0
  8423.       GO TO 700
  8424. C
  8425. C  LXITEM(IDUMMY) = 4 OR 5.
  8426. C
  8427.   600 CONTINUE
  8428.       IF((LXID(3).EQ.KZINT).AND.(LXIREC(3).GT.0)) GO TO 620
  8429.       IF(EQKEYW(3,KWVAR,3)) GO TO 610
  8430.     if(nout.eq.6)goto 5
  8431.       WRITE(NOUT,9002) MAXCOL
  8432.       ERROR = ERROR + 1
  8433.       GO TO 100
  8434. 5    continue
  8435.     error=error+1
  8436.     write(c128wk,9002)maxcol
  8437.     call atxto
  8438. C
  8439.   610 CONTINUE
  8440.       LENGTH = 0
  8441.       ROWS = 0
  8442.       GO TO 630
  8443. C
  8444.   620 CONTINUE
  8445.       LENGTH = LXIREC(3)
  8446.       ROWS = LENGTH
  8447.       IF((LXID(4).EQ.KZINT).AND.(LXIREC(4).GT.0)) GO TO 650
  8448.   630 CONTINUE
  8449.       IF(EQKEYW(4,KWKEY,3)) GO TO 640
  8450.       IF(EQKEYW(4,KWVAR,3)) GO TO 660
  8451.       CALL WARN(4,0,0)
  8452.       ERROR = ERROR + 1
  8453.       GO TO 100
  8454. C
  8455.   640 CONTINUE
  8456.       KEY = 1
  8457.       GO TO 700
  8458. C
  8459.   650 CONTINUE
  8460.       COLUMN = LXIREC(4)
  8461.       GO TO 670
  8462.   660 CONTINUE
  8463.       COLUMN = 0
  8464.   670 CONTINUE
  8465.       IF(EQKEYW(2,KWRMAT,4)) GO TO 680
  8466.       IF(EQKEYW(2,KWIMAT,4)) GO TO 680
  8467.       IF(EQKEYW(2,KWDMAT,4)) GO TO 680
  8468.     if(nout.eq.6)goto 8
  8469.       WRITE(NOUT,9003)
  8470.  9003 FORMAT(56H -ERROR- MATRIX Data Type Required With Rows And Columns
  8471.      X)
  8472.       ERROR = ERROR + 1
  8473.       GO TO 100
  8474. 8    continue
  8475.       ERROR = ERROR + 1
  8476.     write(c128wk,9003)
  8477.     call atxto
  8478.     goto 100
  8479. C
  8480.   680 CONTINUE
  8481.       IF(LXITEM(IDUMMY).EQ.4) GO TO 700
  8482.       IF(EQKEYW(5,KWKEY,3)) GO TO 640
  8483.       CALL WARN(4,0,0)
  8484.       ERROR = ERROR + 1
  8485.       GO TO 100
  8486. C
  8487. C  STORE THE ELEMENT IN JUNK.
  8488. C
  8489.   700 CONTINUE
  8490.       NUMELE = NUMELE + 1
  8491.       CALL BLKCHG(10,5,NUMELE)
  8492.       KQ1 = BLKLOC(10)
  8493.       KQ1 = KQ1 + (5*(NUMELE-1))
  8494.       BUFFER(KQ1) = IBLANK
  8495.       CALL LXSREC(1,1,8,BUFFER(KQ1),1)
  8496.       BUFFER(KQ1+2) = IATTV
  8497.       IF(EQKEYW(2,KWDOUB,6)) LENGTH = LENGTH * 2
  8498.       BUFFER(KQ1+3) = LENGTH
  8499.       BUFFER(KQ1+4) = KEY
  8500. C
  8501. C  GET MORE DATA.
  8502. C
  8503.       IF(BUFFER(KQ1+2).NE.KZTEXT) GO TO 750
  8504. C
  8505. C  SPECIAL PACKING FOR TEXT ATTRIBUTES.
  8506. C
  8507.       NWORDS = ((LENGTH - 1) / CHPWD) + 1
  8508.       IF(LENGTH.EQ.0) NWORDS = 0
  8509.       CALL HTOI(LENGTH,NWORDS,BUFFER(KQ1+3))
  8510.       GO TO 100
  8511. C
  8512.   750 CONTINUE
  8513.       IF(BUFFER(KQ1+2).EQ.KZINT ) GO TO 100
  8514.       IF(BUFFER(KQ1+2).EQ.KZREAL) GO TO 100
  8515.       IF(BUFFER(KQ1+2).EQ.KZDOUB) GO TO 100
  8516. C
  8517. C  PROCESS VECTOR AND MATRIX ITEMS.
  8518. C
  8519.       IF(BUFFER(KQ1+2).NE.KZDVEC) GO TO 760
  8520.       COLUMN = 2
  8521.       GO TO 770
  8522.   760 CONTINUE
  8523.       IF(BUFFER(KQ1+2).NE.KZDMAT) GO TO 770
  8524.       COLUMN = COLUMN * 2
  8525.   770 CONTINUE
  8526.       CALL HTOI(ROWS,ROWS*COLUMN,BUFFER(KQ1+3))
  8527.       GO TO 100
  8528. C
  8529. C  DONE.
  8530. C
  8531.   999 CONTINUE
  8532.       RETURN
  8533.       END
  8534.       SUBROUTINE LODPAS(ERROR)
  8535.       INCLUDE rin:TEXT.BLK
  8536. C
  8537. C  THIS ROUTINE PROCESS THE PASSWORDS FOR RELATIONS WHEN DEFINING
  8538. C  A RIM SCHEMA.  PASSWORD COMMANDS MAY BE ABBREVIATED OR
  8539. C  INPUT IN A LONG FORM.  LOADPAS PERFORMS THE EDITING OF THE
  8540. C  USER INPUT.
  8541. C
  8542.       INCLUDE rin:TUPLER.BLK
  8543.       INCLUDE rin:RMKEYW.BLK
  8544.       INCLUDE rin:FILES.BLK
  8545.       INCLUDE rin:MISC.BLK
  8546.       INTEGER ERROR
  8547.       LOGICAL EQKEYW
  8548.       INCLUDE rin:DCLAR1.BLK
  8549.       INCLUDE rin:DCLAR3.BLK
  8550. C
  8551. C  READ A PASSWORD.
  8552. C
  8553.   100 CONTINUE
  8554.       CALL LODREC
  8555.       IF(EQKEYW(1,KWELEM,8)) GO TO 999
  8556.       IF(EQKEYW(1,KWATTR,10)) GO TO 999
  8557.       IF(EQKEYW(1,KWRELA,9)) GO TO 999
  8558.       IF(EQKEYW(1,KWPASS,9)) GO TO 100
  8559.       IF(EQKEYW(1,KWRULS,5)) GO TO 999
  8560.       IF(EQKEYW(1,KWEND,3)) GO TO 999
  8561.       ITEMS = LXITEM(IDUMMY)
  8562.       IF(ITEMS.EQ.5) GO TO 200
  8563.       IF(ITEMS.EQ.6) GO TO 300
  8564.       CALL WARN(4,0,0)
  8565.       ERROR = ERROR + 1
  8566.       GO TO 100
  8567. C
  8568. C  ABBREVIATED FORMAT FOR PASSWORD COMMAND.
  8569. C
  8570.   200 CONTINUE
  8571.       ICODE = 1
  8572.       IF(EQKEYW(1,KWRPW,3)) ICODE = 2
  8573.       IF(EQKEYW(1,KWMPW,3)) ICODE = 3
  8574.       IF(ICODE.NE.1) GO TO 220
  8575. C
  8576. C  ERROR IN PASSWORD SYNTAX.
  8577. C
  8578.   215 CONTINUE
  8579.       CALL WARN(4,0,0)
  8580.       ERROR = ERROR + 1
  8581.       GO TO 100
  8582. C
  8583.   220 CONTINUE
  8584.       IF(EQKEYW(2,KWFOR,3)) GO TO 230
  8585.       CALL WARN(4,0,0)
  8586.       ERROR = ERROR + 1
  8587.       GO TO 100
  8588. C
  8589.   230 CONTINUE
  8590.       RNAME = BLANK
  8591.       IF(.NOT.EQKEYW(3,KWALL,3)) CALL LXSREC(3,1,8,RNAME,1)
  8592.       I = LOCREL(RNAME)
  8593.       IF(I.EQ.0) GO TO 240
  8594.       CALL WARN(1,RNAME,0)
  8595.       ERROR = ERROR + 1
  8596.       GO TO 100
  8597. C
  8598.   240 CONTINUE
  8599.       IF(EQKEYW(4,KWIS,2)) GO TO 400
  8600.       CALL WARN(4,0,0)
  8601.       ERROR = ERROR + 1
  8602.       GO TO 100
  8603. C
  8604. C  LONG VERSION FOR PASSWORD COMMAND.
  8605. C
  8606.   300 CONTINUE
  8607.       ICODE = 1
  8608.       IF(EQKEYW(1,KWREAD,4)) ICODE = 2
  8609.       IF(EQKEYW(1,KWMODI,6)) ICODE = 3
  8610.       IF(ICODE.NE.1) GO TO 330
  8611. C
  8612.   320 CONTINUE
  8613.       CALL WARN(4,0,0)
  8614.       ERROR = ERROR + 1
  8615.       GO TO 100
  8616. C
  8617.   330 CONTINUE
  8618.       IF(EQKEYW(2,KWPASS,8)) GO TO 340
  8619.       CALL WARN(4,0,0)
  8620.       ERROR = ERROR + 1
  8621.       GO TO 100
  8622. C
  8623.   340 CONTINUE
  8624.       IF(EQKEYW(3,KWFOR,3)) GO TO 350
  8625.       CALL WARN(4,0,0)
  8626.       ERROR = ERROR + 1
  8627.       GO TO 100
  8628. C
  8629.   350 CONTINUE
  8630.       RNAME = BLANK
  8631.       IF(.NOT.EQKEYW(4,KWALL,3)) CALL LXSREC(4,1,8,RNAME,1)
  8632.       I = LOCREL(RNAME)
  8633.       IF(I.EQ.0) GO TO 360
  8634.       CALL WARN(1,RNAME,0)
  8635.       ERROR = ERROR + 1
  8636.       GO TO 100
  8637. C
  8638.   360 CONTINUE
  8639.       IF(EQKEYW(5,KWIS,2)) GO TO 400
  8640.       CALL WARN(4,0,0)
  8641.       ERROR = ERROR + 1
  8642.       GO TO 100
  8643. C
  8644. C  STORE THE PASSWORD.
  8645. C
  8646.   400 CONTINUE
  8647.       IF(ICODE.EQ.1) GO TO 100
  8648.   500 CONTINUE
  8649.       CALL RELGET(ISTAT)
  8650.       IF(ISTAT.NE.0) GO TO 100
  8651.       IF((LXLENC(ITEMS).GE.1).AND.(LXLENC(ITEMS).LE.8)) GO TO 600
  8652.     if(nout.eq.6)goto 1
  8653.       WRITE(NOUT,550)
  8654.   550 FORMAT(44H -ERROR- PASSWORDS Must Be 1-8 Alphanumeric ,
  8655.      X       10HCharacters)
  8656.       ERROR = ERROR + 1
  8657.       GO TO 100
  8658. 1    continue
  8659.     write(c128wk,550)
  8660.     call atxto
  8661.       ERROR = ERROR + 1
  8662.       GO TO 100
  8663.   600 CONTINUE
  8664.       RPW1 = BLANK
  8665.       CALL LXSREC(ITEMS,1,8,RPW1,1)
  8666.       IF(ICODE.EQ.2) RPW= RPW1
  8667.       IF(ICODE.EQ.3) MPW = RPW1
  8668.       CALL RELPUT
  8669. C
  8670. C  LOOK FOR MORE RELATIONS.
  8671. C
  8672.       GO TO 500
  8673. C
  8674. C  END PASSWORD PROCESSING.
  8675. C
  8676.   999 CONTINUE
  8677.       RETURN
  8678.       END
  8679.       SUBROUTINE LODREC
  8680.       INCLUDE rin:TEXT.BLK
  8681. C
  8682. C     COVER ROUTINE FOR LXLREC WHICH HANDLES END-OF-FILES.
  8683. C
  8684.       INCLUDE rin:LXGEN.BLK
  8685.       INCLUDE rin:RMATTS.BLK
  8686.       INCLUDE rin:RMKEYW.BLK
  8687.       INCLUDE rin:CONST4.BLK
  8688.       INCLUDE rin:CONST8.BLK
  8689.       INCLUDE rin:FLAGS.BLK
  8690.       INCLUDE rin:FILES.BLK
  8691.       INCLUDE rin:RIMCOM.BLK
  8692.       INCLUDE rin:MISC.BLK
  8693.       LOGICAL EQKEYW
  8694.       INCLUDE rin:DCLAR4.BLK
  8695.       IF(RMSTAT.GT.1000) GO TO 800
  8696.       NUMEOF = 0
  8697.     if(noutr.eq.6)goto 25
  8698.       IF(ECHO.AND.(NUMREP.EQ.0)) WRITE(NOUTR,10)
  8699.     goto 26
  8700. 25    continue
  8701.     if(.not.echo.or.(numrep.ne.0))goto 26
  8702.     write(c128wk,10)
  8703.     call atxto
  8704. 26    continue
  8705.    10 FORMAT(1X)
  8706.     1 CONTINUE
  8707.       IF(NUMEOF.GT.10) GO TO 820
  8708.       LENREC = 0
  8709.       CALL LXLREC(DUM,LENREC,DUM)
  8710.       IF(LXID(1).NE.K4EOF) GO TO 100
  8711.       NUMEOF = NUMEOF + 1
  8712.       IF(BATCH) GO TO 900
  8713.       IF(CONNI) GO TO 1
  8714.       CALL SETIN(K8IN)
  8715.       GO TO 1
  8716.   100 CONTINUE
  8717.       ITEMS = LXITEM(DUM)
  8718.       ISAVE = LSTCMD
  8719.       CALL LXSREC(1,1,3,LSTCMD,1)
  8720.       IF(ITEMS.GT.3) GO TO 1000
  8721.       IF(EQKEYW(1,KWHELP,4)) GO TO 200
  8722.       IF(ITEMS.GT.2) GO TO 1000
  8723.       IF(EQKEYW(1,KWECHO,4)) GO TO 300
  8724.       IF(EQKEYW(1,KWNOEC,6)) GO TO 400
  8725.       IF(EQKEYW(1,KWINPU,5)) GO TO 500
  8726.       IF(EQKEYW(1,KWOUTP,6)) GO TO 600
  8727.       IF(EQKEYW(1,KWQUIT,4)) GO TO 700
  8728.       GO TO 1000
  8729.   200 CONTINUE
  8730. C
  8731. C     HELP
  8732. C
  8733.       IF((ITEMS.GE.2).AND.(LXID(2).NE.KZTEXT)) GO TO 1000
  8734.       IF((ITEMS.GE.3).AND.(LXID(3).NE.KZTEXT)) GO TO 1000
  8735.       LSTCMD = ISAVE
  8736.       CALL RMHELP
  8737.       GO TO 1
  8738.   300 CONTINUE
  8739. C
  8740. C     ECHO
  8741. C
  8742.       IF(ITEMS.EQ.2) GO TO 1000
  8743.       ECHO = .TRUE.
  8744.       CALL LXSET(KWECHO,K4ON)
  8745.       GO TO 1
  8746.   400 CONTINUE
  8747. C
  8748. C     NOECHO
  8749. C
  8750.       IF(ITEMS.EQ.2) GO TO 1000
  8751.       ECHO = .FALSE.
  8752.       CALL LXSET(KWECHO,K4OFF)
  8753.       GO TO 1
  8754.   500 CONTINUE
  8755. C
  8756. C     INPUT
  8757. C
  8758.       IF(ITEMS.NE.2) GO TO 1000
  8759.       IF(LXID(2).NE.KZTEXT) GO TO 1000
  8760.       IFILE = BLANK
  8761.       CALL LXSREC(2,1,7,IFILE,1)
  8762.       IF(EQKEYW(2,KWTERM,8))IFILE = K8IN
  8763.       CALL SETIN(IFILE)
  8764.       GO TO 1
  8765.   600 CONTINUE
  8766. C
  8767. C     OUTPUT
  8768. C
  8769.       IF(ITEMS.NE.2) GO TO 1000
  8770.       IF(LXID(2).NE.KZTEXT) GO TO 1000
  8771.       IFILE = BLANK
  8772.       CALL LXSREC(2,1,7,IFILE,1)
  8773.       IF(EQKEYW(2,KWTERM,8))IFILE = K8OUT
  8774.       CALL SETOUT(IFILE)
  8775.       GO TO 1
  8776.   700 CONTINUE
  8777. C
  8778. C     QUIT
  8779. C
  8780.       IF(ITEMS.EQ.2) GO TO 1000
  8781.       CALL RMCLOS
  8782.       GO TO 999
  8783. C
  8784. C  SYSTEM TYPE FILE/BUFFER ERRORS -- HELP???????????
  8785. C
  8786.   800 CONTINUE
  8787.     if(nout.eq.6)goto 3240
  8788.       WRITE(NOUT,810) RMSTAT
  8789.   810 FORMAT(13H SYSTEM Error,I5)
  8790.       GO TO 900
  8791. 3240    continue
  8792.     write(c128wk,810)rmstat
  8793.     call atxto
  8794.     goto 900
  8795.   820 CONTINUE
  8796. C
  8797. C     TOO MANY END-OF-FILES ENCOUNTERED
  8798. C
  8799.     if(nout.eq.6)goto 3241
  8800.       WRITE (NOUT,830)
  8801.   830 FORMAT(45H -WARNING- End-Of-File Encountered On "INPUT",
  8802.      X       11X,28HThe Database Files Are Local)
  8803.       GO TO 900
  8804. 3241    continue
  8805.     write(c128wk,830)
  8806.     call atxto
  8807.   900 CONTINUE
  8808.       CALL RMCLOS
  8809.   999 CONTINUE
  8810. C was STOP here
  8811.       return
  8812.  1000 CONTINUE
  8813.       RETURN
  8814.       END
  8815.       SUBROUTINE LODREL(NUMELE,ERROR)
  8816.       INCLUDE rin:TEXT.BLK
  8817. C
  8818. C  THIS ROUTINE LOADS THE RELATION DESCRIPTION FROM USER DIRECTIVES
  8819. C  IN THE APPROPRIATE RIM TABLES BASED ON THE CSC SCHEMA DEFINITION.
  8820. C  A ROUTINE (CHEQLST) DOES THE ACTUAL DATA TRANSFER
  8821. C  WITH THIS ROUTINE PERFORMING THE MAJORITY OF THE EDITING.
  8822. C
  8823.       INCLUDE rin:RMATTS.BLK
  8824.       INCLUDE rin:RMKEYW.BLK
  8825.       INCLUDE rin:BUFFER.BLK
  8826.       INCLUDE rin:FILES.BLK
  8827.       INCLUDE rin:MISC.BLK
  8828. C
  8829.       LOGICAL EQKEYW
  8830.       INTEGER ERROR
  8831.       INCLUDE rin:DCLAR1.BLK
  8832. C
  8833. C  READ RELATION DATA.
  8834. C
  8835.   100 CONTINUE
  8836.       CALL LODREC
  8837.       IF(LXITEM(IDUMMY).GT.1) GO TO 150
  8838.       IF(EQKEYW(1,KWELEM,8)) GO TO 999
  8839.       IF(EQKEYW(1,KWATTR,10)) GO TO 999
  8840.       IF(EQKEYW(1,KWRELA,9)) GO TO 999
  8841.       IF(EQKEYW(1,KWPASS,9)) GO TO 999
  8842.       IF(EQKEYW(1,KWRULS,5)) GO TO 999
  8843.       IF(EQKEYW(1,KWEND,3)) GO TO 999
  8844.   150 CONTINUE
  8845.       IF(LXITEM(IDUMMY).GE.3) GO TO 200
  8846. C
  8847. C  UNRECOGNIZED GARBAGE.
  8848. C
  8849.       CALL WARN(4,0,0)
  8850.       ERROR = ERROR + 1
  8851.       GO TO 100
  8852. C
  8853. C  CHECK FOR VALID RELATION NAME.
  8854. C
  8855.   200 CONTINUE
  8856.       IF(LXID(1).EQ.KZTEXT) GO TO 300
  8857.       if(nout.eq.6)goto 1
  8858.       WRITE(NOUT,9000)
  8859.  9000 FORMAT(36H -ERROR- Relation Names Must Be TEXT)
  8860.       ERROR = ERROR + 1
  8861.       GO TO 100
  8862. 1    continue
  8863.     write(c128wk,9000)
  8864.     call atxto
  8865. 2    error=error+1
  8866.     goto 100
  8867.   300 CONTINUE
  8868.       IF(LXLENC(1).LE.8) GO TO 400
  8869.       CALL WARN(7,KWRELA,BLANK)
  8870.       ERROR = ERROR + 1
  8871.       GO TO 100
  8872.   400 CONTINUE
  8873.       RNAME = BLANK
  8874.       CALL LXSREC(1,1,8,RNAME,1)
  8875.       I = LOCREL(RNAME)
  8876.       IF(I.NE.0) GO TO 500
  8877.     if(nout.eq.6)goto 3
  8878.       WRITE(NOUT,9001)
  8879.  9001 FORMAT(44H -ERROR- Duplicate Relation Name Encountered)
  8880.       ERROR = ERROR + 1
  8881.       GO TO 100
  8882. 3    continue
  8883.     write(c128wk,9001)
  8884.     call atxto
  8885.     goto 2
  8886. C
  8887. C  CHECK ATTRIBUTE NAMES.
  8888. C
  8889.   500 CONTINUE
  8890.       JUNK = 1
  8891.       IF(NUMELE.GT.0) JUNK = BLKLOC(10)
  8892.       CALL CHKATT(BUFFER(JUNK),NUMELE,ERROR)
  8893.       GO TO 100
  8894. C
  8895. C  END RELATION PROCESSING.
  8896. C
  8897.   999 CONTINUE
  8898.       RETURN
  8899.       END
  8900.       SUBROUTINE LODRUL
  8901.       INCLUDE rin:TEXT.BLK
  8902. C
  8903. C  THIS ROUTINE PROCESSES THE RULES OF A RIM SCHEMA.  THE
  8904. C  ACTUAL PARSING OF THE RULES IS DONE IN THIS ROUTINE.  THE
  8905. C  ROUTINE SETRUL SETS UP THE APPROPRIATE RELATIONS TO STORE THE
  8906. C  RULES.
  8907. C
  8908.       INCLUDE rin:RMATTS.BLK
  8909.       INCLUDE rin:RMKEYW.BLK
  8910.       INCLUDE rin:CONST4.BLK
  8911.       INCLUDE rin:RIMCOM.BLK
  8912.       INCLUDE rin:RIMPTR.BLK
  8913.       INCLUDE rin:WHCOM.BLK
  8914.       INCLUDE rin:CONST8.BLK
  8915.       INCLUDE rin:TUPLER.BLK
  8916.       INCLUDE rin:RULCOM.BLK
  8917.       INCLUDE rin:TUPLEA.BLK
  8918.       INCLUDE rin:MISC.BLK
  8919.       INCLUDE rin:BUFFER.BLK
  8920.       INCLUDE rin:FILES.BLK
  8921.       INCLUDE rin:DCLAR1.BLK
  8922.       INTEGER RTBL(24)
  8923.       INTEGER ITEM
  8924.       INTEGER VALUE(10)
  8925.       REAL RVALUE(10)
  8926.       EQUIVALENCE (RVALUE(1),VALUE(1))
  8927.       EQUIVALENCE (RTBL(2),ANAME)
  8928.       EQUIVALENCE (RTBL(4),ANAME1)
  8929.       EQUIVALENCE (RTBL(6),RNAME1)
  8930.       EQUIVALENCE (RTBL(8),IBOO)
  8931.       EQUIVALENCE (RTBL(10),ITEM)
  8932.       EQUIVALENCE (RTBL(11),ANAME2)
  8933.       EQUIVALENCE (RTBL(13),RNAME2)
  8934.       EQUIVALENCE (RTBL(15),VALUE(1))
  8935.       INTEGER RRC(3)
  8936.       LOGICAL EQKEYW
  8937.       LOGICAL EQ
  8938.       LOGICAL NE
  8939.       NERROR = 0
  8940. C
  8941. C  LOOK FOR EXISTING RULES.
  8942. C
  8943.       I = LOCREL(RIMRRC)
  8944.       IF(I.NE.0) GO TO 50
  8945.       NUMRUL = 0
  8946.       IF(NTUPLE.EQ.0) GO TO 40
  8947.       ID = REND
  8948.       CALL GETDAT(1,ID,LOC,LENGTH)
  8949.       NUMRUL = BUFFER(LOC+2)
  8950.    40 CONTINUE
  8951.       I = LOCREL(RIMRDT)
  8952.       IF(I.EQ.0) GO TO 100
  8953.    50 CONTINUE
  8954. C
  8955. C  SET UP RIMRRC AND RIMRDT FOR THE FIRST TIME.
  8956. C
  8957.       CALL SETRUL
  8958.       NUMRUL = 0
  8959. C
  8960. C  READ THE RULES.
  8961. C
  8962.   100 CONTINUE
  8963. C
  8964. C  DELETE RULE IF THERE WAS AN ERROR
  8965. C
  8966.       RNAME = RIMRRC
  8967.  2000 CONTINUE
  8968.       IF(NERROR.LE.0) GO TO 2050
  8969. C
  8970. C  LOCATE RELATION AND SET UP THE WHERE CLAUSE FOR RULE NUMBER
  8971. C
  8972.       I = LOCREL(RNAME)
  8973.       I = LOCATT(K8NUM,RNAME)
  8974.       CALL ATTGET(I)
  8975.       NBOO = 1
  8976.       BOO(1) = K4AND
  8977.       KATTP(1) = ATTCOL
  8978.       KATTL(1) = ATTLEN
  8979.       KATTY(1) = ATTYPE
  8980.       KOMTYP(1) = 2
  8981.       KOMPOS(1) = 1
  8982.       KOMLEN(1) = 1
  8983.       KOMPOT(1) = 1
  8984.       KSTRT = 0
  8985.       MAXTU = ALL9S
  8986.       LIMTU = ALL9S
  8987.       WHRVAL(1) = NUMRUL
  8988.       WHRLEN(1) = 1
  8989.       NS = 0
  8990.       IF(NTUPLE.LE.0) GO TO 2030
  8991.       IID = CID
  8992.       ND = 0
  8993. C
  8994. C  LOCATE AND DE-LINK THE EFFECTED TUPLES
  8995. C
  8996.  2010 CONTINUE
  8997.       CALL RMLOOK(MAT,1,1,LENGTH)
  8998.       IF(RMSTAT.NE.0) GO TO 2020
  8999.       ND = ND + 1
  9000.       CALL DELDAT(1,CID)
  9001.       IF(CID.EQ.IID) IID = NID
  9002.       GO TO 2010
  9003.  2020 CONTINUE
  9004.       IF(ND.EQ.0) GO TO 2030
  9005.       CALL RELGET(LENGTH)
  9006.       RSTART = IID
  9007.       NTUPLE = NTUPLE - ND
  9008.       CALL RELPUT
  9009.  2030 RMSTAT = 0
  9010.       RNAME = RIMRDT
  9011.       NERROR = NERROR - 1
  9012.       IF(NERROR.EQ.1) GO TO 2000
  9013.       NUMRUL = NUMRUL - 1
  9014.  2050 CONTINUE
  9015.       CALL LODREC
  9016.       ITEMS = LXITEM(I)
  9017.       IF(EQKEYW(1,KWELEM,8)) GO TO 999
  9018.       IF(EQKEYW(1,KWRELA,9)) GO TO 999
  9019.       IF(EQKEYW(1,KWATTR,10)) GO TO 999
  9020.       IF(EQKEYW(1,KWPASS,9)) GO TO 999
  9021.       IF(EQKEYW(1,KWRULS,5)) GO TO 999
  9022.       IF(EQKEYW(1,KWEND,3)) GO TO 999
  9023. C
  9024. C  PROCESS THIS RULE.
  9025. C
  9026.   110 CONTINUE
  9027.       ANAME = K8AND
  9028.       J = 1
  9029.       IFLAG = 0
  9030.       NUMRUL = NUMRUL + 1
  9031.       ANAME1 = BLANK
  9032.       CALL LXSREC(1,1,8,ANAME1,1)
  9033.       RNAME1 = BLANK
  9034.       IF(.NOT.EQKEYW(2,KWIN,2)) GO TO 200
  9035. C
  9036. C  RELATION NAME IS SPECIFIED.
  9037. C
  9038.       CALL LXSREC(3,1,8,RNAME1,1)
  9039.       RNAME = RNAME1
  9040.       I = LOCATT(ANAME1,RNAME1)
  9041.       IF(I.NE.0) GO TO 150
  9042.       CALL ATTGET(ISTAT)
  9043.       GO TO 400
  9044.   150 CONTINUE
  9045.       CALL WARN(3,ANAME1,RNAME1)
  9046.       NUMRUL = NUMRUL - 1
  9047.       GO TO 100
  9048.   200 CONTINUE
  9049. C
  9050. C  ANY RELATION WITH THIS ATTRIBUTE.
  9051. C
  9052.       I = LOCATT(ANAME1,RNAME1)
  9053.       IF(I.NE.0) GO TO 150
  9054.   300 CONTINUE
  9055.       IF(EQKEYW(2,KWIN,2)) GO TO 100
  9056.       CALL ATTGET(ISTAT)
  9057.       IF(ISTAT.NE.0) GO TO 100
  9058.       RNAME = RELNAM
  9059.       IFLAG = IFLAG + 1
  9060.   400 CONTINUE
  9061. C
  9062. C  MAKE AN ADDITION TO RIMRRC.
  9063. C
  9064.       RRC(1) = IBLANK
  9065.       RRC(2) = IBLANK
  9066.       CALL STRMOV(RNAME,1,8,RRC,1)
  9067.       RRC(3) = NUMRUL
  9068.       I = LOCREL(RIMRRC)
  9069.       CALL RELGET(ISTAT)
  9070.       CALL ADDDAT(1,REND,RRC,3)
  9071.       IF(RSTART.EQ.0) RSTART = REND
  9072.       CALL RMDATE(RDATE)
  9073.       NTUPLE = NTUPLE + 1
  9074.       CALL RELPUT
  9075. C
  9076. C  PROCESS THE RULE.
  9077. C
  9078.   500 CONTINUE
  9079.       IF(J.GT.ITEMS) GO TO 300
  9080.       ANAME1 = BLANK
  9081.       CALL LXSREC(J,1,8,ANAME1,1)
  9082.       RNAME3 = BLANK
  9083.       IF(.NOT.EQKEYW(J+1,KWIN,2)) GO TO 510
  9084.       J = J + 2
  9085.       CALL LXSREC(J,1,8,RNAME3,1)
  9086.   510 CONTINUE
  9087.       IF(RNAME1.EQ.RNAME3) GO TO 530
  9088.     if(nout.eq.6)goto 2
  9089.       WRITE(NOUT,520)
  9090.   520 FORMAT(43H -ERROR- Rule Components Must Apply To The ,
  9091.      X   13HSame Relation )
  9092.     goto 3
  9093. 2    continue
  9094.     write(c128wk,520)
  9095.     call atxto
  9096. 3    continue
  9097.       NERROR = 2
  9098.       GO TO 100
  9099.   530 CONTINUE
  9100.       I = LOCATT(ANAME1,RNAME)
  9101.       IF(I.EQ.0) GO TO 600
  9102.       CALL WARN(3,ANAME1,RNAME)
  9103.       NERROR = 2
  9104.       GO TO 100
  9105.   600 CONTINUE
  9106.       CALL ATTGET(ISTAT)
  9107.       J = J + 1
  9108.       IBOO = IBLANK
  9109.       CALL LXSREC(J,1,4,IBOO,1)
  9110.       I = LOCBOO(IBOO)
  9111.       IF(I.NE.0) GO TO 700
  9112.     if(nout.eq.6)goto 4
  9113.       WRITE(NOUT,9000)
  9114.  9000 FORMAT(41H -ERROR- Unrecognized Boolean Comparision )
  9115.     goto 5
  9116. 4    continue
  9117.     write(c128wk,9000)
  9118.     call atxto
  9119. 5    continue
  9120.       NERROR = 2
  9121.       GO TO 100
  9122.   700 CONTINUE
  9123.       J = J + 1
  9124.       ANAME2 = BLANK
  9125.       RNAME2 = BLANK
  9126.       IF(I.LT.10) GO TO 750
  9127. C
  9128. C  ATTRIBUTE COMPARISION.
  9129. C
  9130.       CALL HTOI(0,3,ITEM)
  9131.       CALL LXSREC(J,1,8,ANAME2,1)
  9132.       IF(.NOT.EQKEYW(J+1,KWIN,2)) GO TO 1000
  9133.       IF(.NOT.EQKEYW(2,KWIN,2)) GO TO 1000
  9134.       CALL LXSREC(J+2,1,8,RNAME2,1)
  9135.       LTYPE = ATTYPE
  9136.       LLEN = ATTLEN
  9137.       DO 705 K=1,10
  9138.       VALUE(K) = IBLANK
  9139.   705 CONTINUE
  9140.       J = J + 2
  9141.       I = LOCATT(ANAME2,RNAME2)
  9142.       IF(I.NE.0) GO TO 740
  9143.       CALL ATTGET(ISTAT)
  9144.       IF((LTYPE.NE.KZTEXT).AND.(LLEN.GT.1)) GO TO 720
  9145.       IF((LTYPE.EQ.ATTYPE) .AND. (LLEN.EQ.ATTLEN)) GO TO 800
  9146.     if(nout.eq.6)goto 6
  9147.       WRITE (NOUT,710)
  9148.   710 FORMAT(51H -ERROR- Attributes Must Be Of The Same Type/Length)
  9149.     goto 7
  9150. 6    continue
  9151.     write(c128wk,710)
  9152.     call atxto
  9153. 7    continue
  9154.       NERROR = 2
  9155.       GO TO 100
  9156.   720 CONTINUE
  9157.     if(nout.eq.6)goto 8
  9158.       WRITE(NOUT,730)
  9159.   730 FORMAT(48H -ERROR- Non-TEXT Attributes Must Be Of Length 1)
  9160.     goto 10
  9161. 8    continue
  9162.     write(c128wk,730)
  9163.     call atxto
  9164. 10    continue
  9165.       NERROR = 2
  9166.       GO TO 100
  9167.   740 CONTINUE
  9168.       CALL WARN(3,ANAME2,RNAME2)
  9169.       NERROR = 2
  9170.       GO TO 100
  9171. C
  9172. C  VALUE COMPARISION.
  9173. C
  9174.   750 CONTINUE
  9175.       IF(LXID(J).EQ.KZTEXT) K = 0
  9176.       IF(LXID(J).EQ.KZINT) K = 1
  9177.       IF(LXID(J).EQ.KZREAL) K = 2
  9178.       I = 0
  9179.       IF(K.EQ.0) I = LXLENC(J)
  9180. C
  9181. C  CHECK APPROPRIENESS OF VALUES
  9182. C
  9183.       LOP = (40-1)/CHPWD + 1
  9184.       IF(K.NE.0) GO TO 770
  9185. C
  9186. C  TEXT
  9187. C
  9188.       IF(ATTYPE.NE.KZTEXT) GO TO 790
  9189.       IF(I.LE.40) GO TO 764
  9190.       I = 40
  9191.     if(nout.eq.6)goto 11
  9192.       WRITE(NOUT,762)
  9193.     goto 764
  9194. 11    continue
  9195.     write(c128wk,762)
  9196.     call atxto
  9197.   762 FORMAT(50H -WARNING- RULE "VALUE" Truncated To 40 Characters )
  9198.   764 CONTINUE
  9199.       CALL HTOI(I,K,ITEM)
  9200.       CALL LXSREC(J,1,40,VALUE,1)
  9201.       GO TO 800
  9202. C
  9203. C  INTEGER
  9204. C
  9205.   770 CONTINUE
  9206.       IF(K.NE.1) GO TO 780
  9207.       IF(ATTYPE.NE.KZINT) GO TO 790
  9208.       IF(ATTLEN.NE.1) GO TO 790
  9209.       ITEM = K
  9210.       DO 772 KK=2,LOP
  9211.   772 VALUE(KK) = 0
  9212.       VALUE(1) = LXIREC(J)
  9213.       GO TO 800
  9214. C
  9215. C  REAL/DOUBLE
  9216. C
  9217.   780 CONTINUE
  9218.       IF((ATTYPE.NE.KZREAL).AND.(ATTYPE.NE.KZDOUB)) GO TO 790
  9219.       IF((ATTYPE.EQ.KZREAL).AND.(ATTLEN.NE.1)) GO TO 790
  9220.       IF((ATTYPE.EQ.KZDOUB).AND.(ATTLEN.NE.2)) GO TO 790
  9221.       ITEM = K
  9222.       DO 782 KK=2,LOP
  9223.   782 RVALUE(KK) = 0.
  9224.       RVALUE(1) = RXREC(J)
  9225.       GO TO 800
  9226. C
  9227. C  INCOMPATABLE VALUE/ATTRIBUTE
  9228. C
  9229.   790 CONTINUE
  9230.     if(nout.eq.6)goto 12
  9231.       WRITE(NOUT,792)
  9232.     goto 13
  9233. 12    continue
  9234.     write(c128wk,792)
  9235.     call atxto
  9236. 13    continue
  9237.   792 FORMAT(29H -ERROR- Illegal RULE "VALUE" )
  9238.       NERROR = 2
  9239.       GO TO 100
  9240.   800 CONTINUE
  9241.       IF((.NOT.EQKEYW(2,KWIN,2)).AND.(IFLAG.NE.1)) GO TO 500
  9242. C
  9243. C  LOAD THIS RULE.
  9244. C
  9245.       RTBL(1) = NUMRUL
  9246.       I = LOCREL(RIMRDT)
  9247.       CALL RELGET(ISTAT)
  9248.       I = 14 + ((40-1)/CHPWD + 1)
  9249.       CALL ADDDAT(1,REND,RTBL,I)
  9250.       IF(RSTART.EQ.0) RSTART = REND
  9251.       CALL RMDATE(RDATE)
  9252.       NTUPLE = NTUPLE + 1
  9253.       CALL RELPUT
  9254.       IF(J+1.GT.ITEMS) GO TO 900
  9255.       CALL LXSREC(J+1,1,8,ANAME,1)
  9256.       IF(EQ(ANAME,K8AND)) GO TO 900
  9257.       IF(EQ(ANAME,K8OR)) GO TO 900
  9258.     if(nout.eq.6)goto 14
  9259.       WRITE(NOUT,9001)
  9260.  9001 FORMAT(55H -ERROR- RULES Must Be JOINED With Either "AND" or "OR")
  9261.     goto 15
  9262. 14    continue
  9263.     write(c128wk,9001)
  9264.     call atxto
  9265. 15    continue
  9266.       NERROR = 2
  9267.       GO TO 100
  9268.   900 CONTINUE
  9269.       J = J + 2
  9270.       GO TO 500
  9271. C
  9272. C  SYNTAX ERRORS.
  9273. C
  9274.  1000 CONTINUE
  9275.     if(nout.eq.6)goto 16
  9276.       WRITE(NOUT,9002)
  9277.  9002 FORMAT(48H -ERROR- Relation Must Be Specified In This RULE)
  9278.     goto 17
  9279. 16    continue
  9280.     write(C128wk,9002)
  9281.     call atxto
  9282. 17    continue
  9283.       NERROR = 2
  9284.       GO TO 100
  9285. C
  9286. C  DONE SETTING UP RULES.
  9287. C
  9288.   999 CONTINUE
  9289. C
  9290. C  MAKE SURE THE USER ENTERED A KEYWORD - IF ITEMS GT 1 ASSUME A RULE
  9291. C
  9292.       IF(ITEMS.NE.1) GO TO 110
  9293.       RETURN
  9294.       END
  9295.       SUBROUTINE LSTREL
  9296.       INCLUDE rin:TEXT.BLK
  9297. C
  9298. C  THIS ROUTINE SUMMARIZES THE USERS DEFINITION OF A RELATION
  9299. C
  9300. C
  9301.       INCLUDE rin:RMATTS.BLK
  9302.       INCLUDE rin:RMKEYW.BLK
  9303.       INCLUDE rin:CONST4.BLK
  9304.       INCLUDE rin:CONST8.BLK
  9305.       INCLUDE rin:FLAGS.BLK
  9306.       INCLUDE rin:MISC.BLK
  9307.       INCLUDE rin:TUPLER.BLK
  9308.       INCLUDE rin:TUPLEA.BLK
  9309.       INCLUDE rin:FILES.BLK
  9310.       INTEGER STATUS
  9311.       LOGICAL EQ
  9312.       LOGICAL NE
  9313.       LOGICAL EQKEYW
  9314.       INTEGER IRPW
  9315.       INTEGER IMPW
  9316.       INCLUDE rin:DCLAR1.BLK
  9317.       INCLUDE rin:DCLAR6.BLK
  9318.       ITEMS = LXITEM(DUM)
  9319.       CALL RMDATE(IDAY)
  9320.       CALL RMTIME(ITIME)
  9321.       I = LOCREL(BLANK)
  9322.       NP = 0
  9323.       IF(I.EQ.0) GO TO 100
  9324.     if(nout.eq.6)goto 1
  9325.       WRITE(NOUT,2220)
  9326.  2220 FORMAT(32H -WARNING- Relation Tables Empty )
  9327.       GO TO 9999
  9328. 1    continue
  9329.     write(c128wk,2220)
  9330.     call atxto
  9331.     goto 9999
  9332.   100 CONTINUE
  9333.       IF(ITEMS.GT.2) GO TO 8200
  9334.       IF(ITEMS.EQ.2) GO TO 1000
  9335. C
  9336. C   LISTREL (WITH NO RELATION SPECIFIED)
  9337. C
  9338.       CALL RELGET(STATUS)
  9339.       IF(STATUS.NE.0) GO TO 900
  9340. C
  9341. C     DONT LISTREL RULE RELATIONS
  9342. C
  9343.       IF(EQ(NAME,K8RDT)) GO TO 100
  9344.       IF(EQ(NAME,K8RRC)) GO TO 100
  9345. C
  9346. C   VALIDATE USER
  9347. C
  9348.       IF(EQ(USERID,OWNER)) GO TO 150
  9349.       IF(EQ(RPW,NONE)) GO TO 150
  9350.       IF(EQ(RPW,USERID)) GO TO 150
  9351.       IF(EQ(MPW,USERID)) GO TO 150
  9352.       GO TO 100
  9353.   150 CONTINUE
  9354.       IF(NP.EQ.1) GO TO 200
  9355. C
  9356. C     WRITE OUT HEADER
  9357. C
  9358.     if(noutr.eq.6)goto 3
  9359.       WRITE(NOUTR,160) IDAY,ITIME
  9360.     goto 4
  9361. 3    continue
  9362.     write(c128wk,160)iday,itime
  9363. 4    continue
  9364.   160 FORMAT(10X,25HExisting Relations as of ,A8,3X,A8)
  9365.       NP = 1
  9366.   200 CONTINUE
  9367.     if(noutr.eq.6)goto 5
  9368.       WRITE(NOUTR,220) NAME
  9369.   220 FORMAT(20X,A8)
  9370.       GO TO 100
  9371. 5    continue
  9372.     write(c128wk,220) name
  9373.     call atxto
  9374.     goto 100
  9375.   900 CONTINUE
  9376.     if(np.ne.0)goto 9999
  9377.     if(nout.eq.6)goto 6
  9378.        WRITE(NOUT,1260)
  9379.       GO TO 9999
  9380. 6    continue
  9381.     write(C128WK,1260)
  9382.     call atxto
  9383.     goto 9999
  9384.  1000 CONTINUE
  9385. C
  9386. C   LISTREL RELATION
  9387. C
  9388.       IF(.NOT.EQKEYW(2,KWALL,3)) GO TO 1050
  9389.       I = LOCREL(BLANK)
  9390.       IF(I.NE.0) GO TO 8000
  9391.       NREL = 0
  9392.       GO TO 1100
  9393.  1050 CONTINUE
  9394.       RNAME = BLANK
  9395.       CALL LXSREC(2,1,8,RNAME,1)
  9396.       I = LOCREL(RNAME)
  9397.       IF(I.EQ.0) GO TO 1100
  9398. C
  9399. C  REQUESTED RELATION DOES NOT EXIST
  9400. C
  9401.       CALL WARN(1,RNAME,0)
  9402.       GO TO 9999
  9403.  1100 CONTINUE
  9404.       IF(.NOT.EQKEYW(2,KWALL,3)) GO TO 1200
  9405.       CALL RELGET(STATUS)
  9406.       IF((NREL.EQ.0).AND.(STATUS.NE.0)) GO TO 8100
  9407.       IF(STATUS.NE.0) GO TO 9999
  9408.  1200 CONTINUE
  9409. C
  9410. C     DONT LISTREL RULE RELATIONS
  9411. C
  9412.       IF(EQ(NAME,K8RDT)) GO TO 1250
  9413.       IF(EQ(NAME,K8RRC)) GO TO 1250
  9414. C
  9415. C   CHECK PERMISSION
  9416. C
  9417.       IF(EQ(USERID,OWNER)) GO TO 1300
  9418.       IF(EQ(RPW,NONE)) GO TO 1300
  9419.       IF(EQ(RPW,USERID)) GO TO 1300
  9420.       IF(EQ(MPW,USERID)) GO TO 1300
  9421.  1250 CONTINUE
  9422.       IF(EQKEYW(2,KWALL,3)) GO TO 1100
  9423.     if(nout.eq.6)goto 10
  9424.       WRITE(NOUT,1260)
  9425.  1260 FORMAT(40H -ERROR- Unauthorized Access To Relation ,
  9426.      X       20H Data Not Permitted. )
  9427.       GO TO 9999
  9428. 10    continue
  9429.     write(c128wk,1260)
  9430.     call atxto
  9431.     goto 9999
  9432.  1300 CONTINUE
  9433. C
  9434. C  PRINT HEADER.
  9435. C
  9436.       NREL = NREL + 1
  9437.       IRPW = K4NONE
  9438.       IMPW = K4NONE
  9439.       IF(NE(RPW,NONE)) IRPW = K4YES
  9440.       IF(NE(MPW,NONE)) IMPW = K4YES
  9441. C
  9442.     if(noutr.eq.6)goto 11
  9443.       WRITE(NOUTR,1320) NAME
  9444.  1320 FORMAT(20X,11HRELATION : ,A8)
  9445.       WRITE(NOUTR,1340) RDATE,IRPW
  9446.  1340 FORMAT(5X,11HLAST MOD : ,A10,9X,16HREAD PASSWORD : ,A4)
  9447.       WRITE(NOUTR,1360) DBNAME,IMPW
  9448.  1360 FORMAT(5X,9HSCHEMA : ,A10,10X,19H MODIFY PASSWORD : ,A4)
  9449. C
  9450.       WRITE(NOUTR,1380)
  9451.  1380 FORMAT(7X,4HNAME,10X,4HTYPE,10X,6HLENGTH,10X,3HKEY)
  9452.     goto 12
  9453. 11    continue
  9454.       WRITE(c128wk,1320) NAME
  9455.     call atxto
  9456.       WRITE(c128wk,1340) RDATE,IRPW
  9457.     call atxto
  9458.       WRITE(c128wk,1360) DBNAME,IMPW
  9459.     call atxto
  9460. C
  9461.       WRITE(NOUTR,1380)
  9462. 12    continue
  9463. C
  9464. C  FIND AND PRINT ATTRIBUTE DESCRIPTIONS
  9465. C
  9466.       I = LOCATT(BLANK,NAME)
  9467.       IF(I.EQ.0) GO TO 1500
  9468.     if(nout.eq.6)goto 13
  9469.       WRITE(NOUT,1400) NAME
  9470.  1400 FORMAT(20H -WARNING- Relation ,A8,
  9471.      X       26H Has No Attributes Defined )
  9472.       GO TO 9999
  9473. 13    continue
  9474.     write(c128wk,1400)name
  9475.     call atxto
  9476.     goto 9999
  9477.  1500 CONTINUE
  9478.       CALL ATTGET(STATUS)
  9479.       IF(STATUS.NE.0) GO TO 1600
  9480.       CALL FILCH(KEY,1,CHPWD,BLANK)
  9481.       IF(ATTKEY.NE.0) KEY = K4YES
  9482. C
  9483. C  RETRIEVE LENGTH OF ATTRIBUTE.
  9484. C
  9485.       NCHAR = ATTCHA
  9486.       NWORDS = ATTWDS
  9487.       IF(ATTYPE.EQ.KZDOUB) NWORDS = NWORDS / 2
  9488.       IF(ATTYPE.EQ.KZDVEC) NWORDS = NWORDS / 2
  9489.       IF(ATTYPE.EQ.KZDMAT) NWORDS = NWORDS / 2
  9490.       IF(ATTYPE.NE.KZTEXT) GO TO 1510
  9491.     if(noutr.eq.6)goto 14
  9492.       IF(NCHAR.NE.0) WRITE(NOUTR,1501) ATTNAM,ATTYPE,NCHAR,KEY
  9493.  1501 FORMAT(7X,A8,6X,A4,6X,I5,11H CHARACTERS,4X,A3)
  9494.       IF(NCHAR.EQ.0) WRITE(NOUTR,1502) ATTNAM,ATTYPE,KEY
  9495.  1502 FORMAT(7X,A8,6X,A4,10X,8HVARIABLE,8X,A3)
  9496.       GO TO 1500
  9497. 14    continue
  9498.       IF(NCHAR.NE.0) WRITE(c128wk,1501) ATTNAM,ATTYPE,NCHAR,KEY
  9499.     call atxto
  9500.       IF(NCHAR.EQ.0) WRITE(c128wk,1502) ATTNAM,ATTYPE,KEY
  9501.     call atxto
  9502.     goto 1500
  9503.  1510 CONTINUE
  9504.       IF(ATTYPE.EQ.KZIMAT) GO TO 1520
  9505.       IF(ATTYPE.EQ.KZRMAT) GO TO 1520
  9506.       IF(ATTYPE.EQ.KZDMAT) GO TO 1520
  9507.     if(noutr.eq.6)goto 15
  9508.       IF(NWORDS.EQ.0) WRITE(NOUTR,1502) ATTNAM,ATTYPE,KEY
  9509.       IF(NWORDS.NE.0) WRITE(NOUTR,1503) ATTNAM,ATTYPE,NWORDS,KEY
  9510.  1503 FORMAT(7X,A8,6X,A4,10X,I4,12X,A3)
  9511.       GO TO 1500
  9512. 15    continue
  9513.       IF(NWORDS.EQ.0) WRITE(c128wk,1502) ATTNAM,ATTYPE,KEY
  9514.       IF(NWORDS.NE.0) WRITE(c128wk,1503) ATTNAM,ATTYPE,NWORDS,KEY
  9515.     call atxto
  9516.     goto 1500
  9517.  1520 CONTINUE
  9518.       IF(NWORDS.EQ.0) GO TO 1530
  9519.       NC = NWORDS / NCHAR
  9520.     if(noutr.eq.6)goto 16
  9521.       WRITE(NOUTR,1504) ATTNAM,ATTYPE,NCHAR,NC,KEY
  9522.  1504 FORMAT(7X,A8,6X,A4,8X,I4,4H BY ,I4,6X,A3)
  9523.       GO TO 1500
  9524. 16    continue
  9525.     write(c128wk,1504)attnam,attype,nchar,nc,key
  9526.     call atxto
  9527.     goto 1500
  9528.  1530 CONTINUE
  9529.       IF(NCHAR.EQ.0) GO TO 1540
  9530.     if(noutr.eq.6)goto 17
  9531.       WRITE(NOUTR,1505) ATTNAM,ATTYPE,NCHAR,KEY
  9532.  1505 FORMAT(7X,A8,6X,A4,8X,I4,12H BY VARIABLE,2X,A3)
  9533.       GO TO 1500
  9534. 17    continue
  9535.       WRITE(c128wk,1505) ATTNAM,ATTYPE,NCHAR,KEY
  9536.     call atxto
  9537.     goto 1500
  9538.  1540 CONTINUE
  9539.     if(noutr.eq.6)goto 18
  9540.       WRITE(NOUTR,1506) ATTNAM,ATTYPE,KEY
  9541.  1506 FORMAT(7X,A8,6X,A4,4X,20HVARIABLE BY VARIABLE,2X,A3)
  9542.       GO TO 1500
  9543. 18    continue
  9544.       WRITE(c128wk,1506) ATTNAM,ATTYPE,KEY
  9545.     call atxto
  9546.       GO TO 1500
  9547. C
  9548.  1600 CONTINUE
  9549. C
  9550. C
  9551.     if(noutr.eq.6)goto 19
  9552.       WRITE(NOUTR,1620) NTUPLE
  9553.  1620 FORMAT(10X,25HCURRENT NUMBER OF ROWS = ,I8)
  9554.     goto 20
  9555. 19    continue
  9556.     write(c128wk,1620) ntuple
  9557.     call atxto
  9558. 20    continue
  9559.       IF(EQKEYW(2,KWALL,3)) GO TO 1100
  9560.       GO TO 9999
  9561.  8000 CONTINUE
  9562. C
  9563. C     NO RELATIONS DEFINED - ALL SPECIFICATION
  9564. C
  9565.     if(nout.eq.6)goto 21
  9566.       WRITE (NOUT,2220)
  9567.       GO TO 9999
  9568. 21    continue
  9569.     write(c128wk,2220)
  9570.     call atxto
  9571.     goto 9999
  9572.  8100 CONTINUE
  9573. C
  9574. C     NO RELATIONS PERMITTED - ALL SPECIFICATION
  9575. C
  9576.     if(nout.eq.6)goto 22
  9577.       WRITE (NOUT,1260)
  9578.       GO TO 9999
  9579. 22    continue
  9580.     write(c128wk,1260)
  9581.     call atxto
  9582.     goto 9999
  9583.  8200 CONTINUE
  9584.     if(nout.eq.6)goto 23
  9585.       WRITE(NOUT,8210)
  9586.  8210 FORMAT(35H -ERROR- Too Many Items For Listrel )
  9587.       GO TO 9999
  9588. 23    continue
  9589.     write(c128wk,8210)
  9590.     call atxto
  9591. C
  9592. C  ALL DONE.
  9593. C
  9594.  9999 RETURN
  9595.       END
  9596.       INTEGER FUNCTION LSTRNG(STR1,IC1,LC1,STR2,IC2,LC2)
  9597.       INCLUDE rin:TEXT.BLK
  9598. C
  9599. C  PURPOSE:   LOCATE ONE STRING OF CHARACTERS IN ANOTHER
  9600. C
  9601. C  PARAMETERS:
  9602. C     STR1----FIRST HOLLERITH STRING
  9603. C     IC1-----STARTING CHARACTER IN STR1 TO START THE SCAN
  9604. C     LC1-----LENGTH OF STR1
  9605. C     STR2----SECOND HOLLERITH STRING
  9606. C     IC2-----STARTING CHARACTER IN STR2
  9607. C     LC2-----LENGTH OF STR2
  9608. C     LSTRNG--CHARACTER POSITION IN STR1 WHERE STR2 WAS FOUND
  9609. C             0 IF IT CANNOT FIND IT
  9610. C
  9611.       Character*1 STR1(*)
  9612.       Character*1 STR2(*)
  9613. C
  9614. C  CHECK THAT THE PARAMETERS ARE GOOD.
  9615. C
  9616.       L2 = LC2 - 1
  9617.       IF(LC2.GT.LC1) GO TO 9000
  9618.       I1 = IC1 - 1
  9619.       DO 300 I=1,LC1
  9620.       I1 = I1 + 1
  9621.       IF(STR1(I1).NE.STR2(IC2)) GO TO 300
  9622. C
  9623. C  MATCHING FIRST CHARACTERS. SCAN THE REST.
  9624. C
  9625.       IF(L2.EQ.0) GO TO 200
  9626.       DO 100 J=1,L2
  9627.       IF(STR1(I1+J).NE.STR2(IC2+J)) GO TO 300
  9628.   100 CONTINUE
  9629. C
  9630. C  WE FOUND A MATCH.
  9631. C
  9632.   200 CONTINUE
  9633.       LSTRNG = I1
  9634.       RETURN
  9635. C
  9636. C  KEEP LOOKING.
  9637. C
  9638.   300 CONTINUE
  9639. C
  9640. C  NOT THERE.
  9641. C
  9642.  9000 CONTINUE
  9643.       LSTRNG = 0
  9644.       RETURN
  9645.       END
  9646.       SUBROUTINE LXCONS
  9647.       INCLUDE rin:TEXT.BLK
  9648. C
  9649. C  PURPOSE: THIS ROUTINE INITIALIZES THE HOLLERITH CONSTANTS USED
  9650. C           BY THE LXLREC ROUTINES. THE CODE IS MACHINE DEPENDENT.
  9651. C
  9652.       INCLUDE rin:LXGEN.BLK
  9653.       INCLUDE rin:LXCON.BLK
  9654.       INCLUDE rin:LXCARD.BLK
  9655.       INCLUDE rin:LXWRDS.BLK
  9656. C
  9657. C  VARIABLES USED BY THE LXCON AND LXCARD COMMON BLOCKS
  9658. C
  9659.       DATA JL0 /1H0/
  9660.       DATA JL1 /1H1/
  9661.       DATA JL2 /1H2/
  9662.       DATA JL3 /1H3/
  9663.       DATA JL4 /1H4/
  9664.       DATA JL5 /1H5/
  9665.       DATA JL6 /1H6/
  9666.       DATA JL7 /1H7/
  9667.       DATA JL8 /1H8/
  9668.       DATA JL9 /1H9/
  9669.       DATA JLMNUS /1H-/
  9670.       DATA JLPLUS /1H+/
  9671.       DATA JLDOT /1H./
  9672.       DATA JLDOL /1H$/
  9673.       DATA JLSEMI /1H;/
  9674.       DATA JLSTAR /1H*/
  9675.       DATA JLLPAR /1H(/
  9676.       DATA JLRPAR /1H)/
  9677.       DATA JLQUOT /1H"/
  9678.       DATA JLBLNK /1H /
  9679.       DATA JLTEXT /4HTEXT/
  9680.       DATA JLREAL /4HREAL/
  9681.       DATA JLINT /3HINT/
  9682.       DATA JLSAME /2H*N/
  9683.       DATA JLASAM /2H**/
  9684.       DATA JLREPT /3H*=N/
  9685.       DATA JLGENR /3H*+N/
  9686.       DATA JLEQS /1H=/
  9687.       DATA JLCOMA /1H,/
  9688.       DATA JLE /1HE/
  9689.       DATA JLNULL /3H-0-/
  9690.       DATA JLSLSH /1H//
  9691. C
  9692. C  VARIABLES USED BY THE LXWRDS COMMON BLOCK
  9693. C
  9694.       DATA JYA /1HA/
  9695.       DATA JYB /1HB/
  9696.       DATA JYC /1HC/
  9697.       DATA JYD /1HD/
  9698.       DATA JYE /1HE/
  9699.       DATA JYF /1HF/
  9700.       DATA JYH /1HH/
  9701.       DATA JYI /1HI/
  9702.       DATA JYK /1HK/
  9703.       DATA JYL /1HL/
  9704.       DATA JYM /1HM/
  9705.       DATA JYN /1HN/
  9706.       DATA JYO /1HO/
  9707.       DATA JYP /1HP/
  9708.       DATA JYQ /1HQ/
  9709.       DATA JYR /1HR/
  9710.       DATA JYS /1HS/
  9711.       DATA JYT /1HT/
  9712.       DATA JYU /1HU/
  9713.       DATA JYON /2HON/
  9714.       DATA JYOFF /3HOFF/
  9715.       DATA JYEOF /3HEOF/
  9716.       DATA JYECHO /4HECHO/
  9717.       DATA JYPROM /4HPROM/
  9718.       DATA JYINPT /4HINPT/
  9719.       DATA JYOTPT /4HOTPT/
  9720.       DATA JYDOLL /4HDOLL/
  9721.       DATA JYSEMI /4HSEMI/
  9722.       DATA JYCOMM /4HCOMM/
  9723.       DATA JYBLAN /4HBLAN/
  9724.       DATA JYPLUS /4HPLUS/
  9725.       DATA JYQUOT /4HQUOT/
  9726.       DATA JYPRES /4HPRES/
  9727.       DATA JYBLNK /1H /
  9728. C
  9729. C  SET THE LXGEN VARIABLES
  9730. C
  9731.       NUMREP= 0
  9732. C
  9733. C  MACHINE DEPENDENT VARIABLES USED BY THE LXCON COMMON BLOCK
  9734. C
  9735.       NWORD = 290
  9736.       MCHAR = 1160
  9737.       NCPW = 4
  9738. C
  9739. C  SET THE LXCON AND LXCARD VARIABLES
  9740. C
  9741.       MITEM = 100
  9742.       NIN = 5
  9743.       NOUT = 6
  9744.       NEXT = 1
  9745.       NEWN = 0
  9746.       OLDN = 0
  9747.       ECHO = .TRUE.
  9748.       DIGITS(1) = JL0
  9749.       DIGITS(2) = JL1
  9750.       DIGITS(3) = JL2
  9751.       DIGITS(4) = JL3
  9752.       DIGITS(5) = JL4
  9753.       DIGITS(6) = JL5
  9754.       DIGITS(7) = JL6
  9755.       DIGITS(8) = JL7
  9756.       DIGITS(9) = JL8
  9757.       DIGITS(10) = JL9
  9758.       MINUS = JLMNUS
  9759.       PLUS = JLPLUS
  9760.       CONT = JLPLUS
  9761.       POINT = JLDOT
  9762.       DOLLAR = JLDOL
  9763.       SEMI = JLSEMI
  9764.       STAR = JLSTAR
  9765.       LPAREN = JLLPAR
  9766.       RPAREN = JLRPAR
  9767.       QUOTES = JLQUOT
  9768.       BLANK = JLBLNK
  9769.       BLANKS = JLBLNK
  9770.       TEXT = JLTEXT
  9771.       REAL = JLREAL
  9772.       INTGER = JLINT
  9773.       SAME = JLSAME
  9774.       ALLSAM =JLASAM
  9775.       REPEAT = JLREPT
  9776.       GENRAT = JLGENR
  9777.       EQUALS = JLEQS
  9778.       COMMA = JLCOMA
  9779.       E = JLE
  9780.       NULL = JLNULL
  9781.       SLASH = JLSLSH
  9782. C
  9783. C  SET THE LXWRDS VARIABLES
  9784. C
  9785.       KYA    = JYA
  9786.       KYB    = JYB
  9787.       KYC    = JYC
  9788.       KYD    = JYD
  9789.       KYE    = JYE
  9790.       KYF    = JYF
  9791.       KYH    = JYH
  9792.       KYI    = JYI
  9793.       KYK    = JYK
  9794.       KYL    = JYL
  9795.       KYM    = JYM
  9796.       KYN    = JYN
  9797.       KYO    = JYO
  9798.       KYP    = JYP
  9799.       KYQ    = JYQ
  9800.       KYR    = JYR
  9801.       KYS    = JYS
  9802.       KYT    = JYT
  9803.       KYU    = JYU
  9804.       KYON   = JYON
  9805.       KYOFF  = JYOFF
  9806.       KYEOF  = JYEOF
  9807.       KYECHO = JYECHO
  9808.       KYPROM = JYPROM
  9809.       KYINPT = JYINPT
  9810.       KYOTPT = JYOTPT
  9811.       KYDOLL = JYDOLL
  9812.       KYSEMI = JYSEMI
  9813.       KYCOMM = JYCOMM
  9814.       KYBLAN = JYBLAN
  9815.       KYPLUS = JYPLUS
  9816.       KYQUOT = JYQUOT
  9817.       KYPRES = JYPRES
  9818.       KYBLNK = JYBLNK
  9819.       RETURN
  9820.       END
  9821.       FUNCTION LXCREC(I,J)
  9822.       INCLUDE rin:TEXT.BLK
  9823. C
  9824. C     THIS FUNCTION RETURNS THE JTH CHARACTER OF THE ITH ITEM
  9825. C     LEFT ADJUST BLANK FILL IF POSSIBLE AND ALL BLANKS OTHERWISE.
  9826. C
  9827.       INCLUDE rin:LXCARD.BLK
  9828.       INCLUDE rin:LXCON.BLK
  9829.       LXCREC = BLANKS
  9830.       IF(I.LT.1) RETURN
  9831.       IF(I.GT.NEWN) RETURN
  9832.       IF(J.LT.1) RETURN
  9833.       IF(TYPE(I).NE.TEXT) RETURN
  9834.       LEN = INT(RVAL(I))
  9835.       IF(J.GT.LEN) RETURN
  9836.       K = INTVAL(I)
  9837.       CALL GETT(NEWREC(K),J,LXCREC)
  9838.       RETURN
  9839.       END
  9840.       SUBROUTINE LXEND(LINE,LEN,LOC,MORE,NEWLEN)
  9841.       INCLUDE rin:TEXT.BLK
  9842. C
  9843. C     THIS ROUTINE LOOKS FOR DOLLAR,SEMI OR PLUS AS A NEW
  9844. C     END OF LINE.  NOTE - DOLLAR, SEMI OR PLUS ARE NOT NOTED
  9845. C     IF IN A QUOTED TEXT OR A COMMENT UNLESS NO END OF QUOTE
  9846. C     OR COMMENT IS ENCOUNTERED.
  9847. C
  9848. C     INPUT  - LINE.....ONE CHARACTER PER WORD
  9849. C              LEN......LENGTH OF LINE
  9850. C     OUTPUT - LOC......LOCATION OF DOLLAR OR SEMI ELSE 0.
  9851. C              MORE......TRUE. IFF PLUS IS END
  9852. C              NEWLEN....CHARACTER BEFORE DOLLAR, SEMI OR PLUS ELSE LEN
  9853. C
  9854.       INCLUDE rin:LXCON.BLK
  9855.       DIMENSION LINE(*)
  9856.       LOGICAL MORE
  9857. C
  9858. C     AN IF LOOP ON NUMBER OF CHARACTERS
  9859. C
  9860.       IC = 0
  9861.       IF(LEN.LE.0) GO TO 300
  9862.    10 CONTINUE
  9863.       IC = IC + 1
  9864.       IF(LINE(IC).EQ.DOLLAR) GO TO 100
  9865.       IF(LINE(IC).EQ.SEMI) GO TO 100
  9866.       IF(LINE(IC).EQ.QUOTES) GO TO 20
  9867.       IF(LINE(IC).EQ.STAR) GO TO 50
  9868.       IF(IC.GE.LEN) GO TO 300
  9869.       GO TO 10
  9870.    20 CONTINUE
  9871. C
  9872. C     POSSIBLE QUOTE - IGNORE IF SO
  9873. C
  9874.       IF(IC.EQ.LEN) GO TO 300
  9875.       IF(IC.EQ.1) GO TO 25
  9876.       IF(LINE(IC-1).EQ.BLANK) GO TO 25
  9877.       IF(LINE(IC-1).NE.COMMA) GO TO 10
  9878.    25 CONTINUE
  9879.       ICQ = IC
  9880.    30 CONTINUE
  9881.       ICQ = ICQ + 1
  9882.       IF(ICQ.GE.LEN) GO TO 10
  9883.       IF(LINE(ICQ).NE.QUOTES) GO TO 30
  9884.       IF(ICQ.EQ.LEN) GO TO 300
  9885.       IF(LINE(ICQ+1).NE.QUOTES)IC = ICQ +1
  9886.       IF(LINE(ICQ+1).NE.QUOTES) GO TO 10
  9887.       ICQ = ICQ + 1
  9888.       GO TO 30
  9889.    50 CONTINUE
  9890. C
  9891. C     STAR - POSSIBLE COMMENT
  9892. C
  9893.       IF(IC.EQ.LEN) GO TO 300
  9894.       ENDCOM = NULL
  9895.       IF(LINE(IC+1).EQ.LPAREN) ENDCOM = RPAREN
  9896.       IF(LINE(IC+1).EQ.SLASH) ENDCOM = SLASH
  9897.       IF(ENDCOM.EQ.NULL) GO TO 10
  9898. C
  9899. C     LOOK FOR END OF COMMENT
  9900. C
  9901.       ISTART = IC + 2
  9902.       IF(ISTART.GT.LEN) GO TO 300
  9903.       DO 60 I=ISTART,LEN
  9904.       IF(LINE(1).NE.ENDCOM) GO TO 60
  9905.       IC = I
  9906.       GO TO 10
  9907.    60 CONTINUE
  9908.       IC = IC + 1
  9909.       GO TO 10
  9910.   100 CONTINUE
  9911. C
  9912. C     FOUND A DOLLAR - USED TO BE WORTH SOMETHING
  9913. C
  9914.       LOC = IC
  9915.       MORE = .FALSE.
  9916.       NEWLEN = IC - 1
  9917.       GO TO 1000
  9918.   300 CONTINUE
  9919. C
  9920. C     MADE IT TO THE END
  9921. C
  9922.       NEWLEN = LEN
  9923.       LOC = 0
  9924.       MORE = .FALSE.
  9925.       IF(LEN.LE.0) GO TO 1000
  9926.       IF(LINE(NEWLEN).NE.CONT) GO TO 1000
  9927.       NEWLEN = NEWLEN - 1
  9928.       MORE = .TRUE.
  9929.  1000 CONTINUE
  9930.       RETURN
  9931.       END
  9932.       SUBROUTINE LXGENR
  9933.       INCLUDE rin:TEXT.BLK
  9934. C
  9935. C     THIS SUBROUTINE INCREMENTS REAL AND INTEGER VALUES BY THE
  9936. C     INCREMENTS STORED IN LXGEN FOR GENERATION RECORDS.
  9937. C
  9938.       INCLUDE rin:LXCARD.BLK
  9939.       INCLUDE rin:LXGEN.BLK
  9940.       INCLUDE rin:LXCON.BLK
  9941.       DO 10 I=1,NEWN
  9942.       IF(TYPE(I).EQ.INTGER) INTVAL(I) = INTVAL(I) + INTINC(I)
  9943.       IF(TYPE(I).EQ.REAL) RVAL(I) = RVAL(I) + RINC(I)
  9944.    10 CONTINUE
  9945.       NUMREP = NUMREP - 1
  9946.       RETURN
  9947.       END
  9948.       SUBROUTINE LXGENS(RECORD,LENREC,NUML,LINE,LEN,NEWLEN,
  9949.      X                  MORE,LOC,IERR)
  9950.       INCLUDE rin:TEXT.BLK
  9951. C
  9952. C     THIS ROUTINE CRACKS A GENERATION RECORD INTO INTINC,RINC AND NUMRE
  9953. C
  9954. C     I/O      - RECORD....STRING FROM CALLING PROGRAM
  9955. C                LENREC....LENGTH OF RECORD
  9956. C                NUML......NUMBER OF READS THIS RECORD
  9957. C                LINE......HOLDER FOR USER INPUT
  9958. C                LEN.......NUMBER OF CHARACTERS IN LINE
  9959. C                NEWLEN....NUMBER CHARACTERS IN LINE THIS RECORD
  9960. C                MORE.......TRUE. IFF THIS IS PLUS RECORD
  9961. C                LOC.......LOCATION OF EOR
  9962. C     OUTPUT   - IERR......ERROR RETURN IF ANY
  9963. C
  9964.       INCLUDE rin:LXCARD.BLK
  9965.       INCLUDE rin:LXCON.BLK
  9966.       INCLUDE rin:LXGEN.BLK
  9967.       INCLUDE rin:LXCIT.BLK
  9968.       DIMENSION LINE(LEN)
  9969.       INTEGER RECORD(*)
  9970.       LOGICAL MORE
  9971.       INTEGER START
  9972.       IERR = 0
  9973.       NUMGEN = 0
  9974.       NUMREP = IVALUE
  9975. C
  9976. C     BIG LOOP ON ITEMS
  9977. C
  9978.    10 CONTINUE
  9979.       START = LAST + 1
  9980.       CALL LXNEXI(LINE,START,NEWLEN)
  9981.       IF(FIRST.NE.0) GO TO 100
  9982. C
  9983. C     OUT OF ITEMS
  9984. C
  9985.       IF((.NOT.MORE) .AND. (NUMGEN.EQ.OLDN)) GO TO 1000
  9986.       IF((.NOT.MORE).AND.(NUMGEN.GT.OLDN)) GO TO 8010
  9987. C
  9988. C     IF NO MORE - DEFAULT LAST ITEM TO **
  9989. C
  9990.       IF(.NOT.MORE)TYP = ALLSAM
  9991.       IF(.NOT.MORE) GO TO 200
  9992. C
  9993. C     GET ANOTHER LINE
  9994. C
  9995.       CALL LXLINE(RECORD,LENREC,NUML,LINE,LEN,LOC)
  9996.       IF(LXEOF) GO TO 1000
  9997.       CALL LXEND(LINE,LEN,LOC,MORE,NEWLEN)
  9998.       LAST = 0
  9999.       GO TO 10
  10000.   100 CONTINUE
  10001. C
  10002. C     PARSE THE ITEM
  10003. C
  10004.       IF(TYP.EQ.COMMA) GO TO 10
  10005.       IF(TYP.NE.INTGER) GO TO 150
  10006. C
  10007. C     INTEGER
  10008. C
  10009.       NUMGEN = NUMGEN + 1
  10010.       IF(NUMGEN.GT.OLDN) GO TO 8010
  10011.       IF(TYPE(NUMGEN).EQ.INTGER) GO TO 110
  10012.       IF(TYPE(NUMGEN).EQ.REAL) GO TO 8020
  10013.       IF(IVALUE.NE.0) GO TO 8020
  10014.   110 CONTINUE
  10015.       RINC(NUMGEN) = 0.
  10016.       INTINC(NUMGEN) = IVALUE
  10017.       GO TO 10
  10018.   150 CONTINUE
  10019.       IF(TYP.NE.REAL) GO TO 200
  10020. C
  10021. C     REAL
  10022. C
  10023.       NUMGEN = NUMGEN + 1
  10024.       IF(NUMGEN.GT.OLDN) GO TO 8010
  10025.       IF(TYPE(NUMGEN).NE.REAL) GO TO 8020
  10026.       INTINC(NUMGEN) = 0
  10027.       RINC(NUMGEN) = RVALUE
  10028.       GO TO 10
  10029.   200 CONTINUE
  10030.       IF((TYP.NE.SAME) .AND. (TYP.NE.ALLSAM)) GO TO 250
  10031. C
  10032. C     *N OR **
  10033. C
  10034.       NUMI = IVALUE
  10035.       IF(TYP.EQ.ALLSAM) NUMI = OLDN - NUMGEN
  10036.       IF((NUMGEN+NUMI).GT.OLDN) GO TO 8010
  10037.       DO 220 I=1,NUMI
  10038.       NUMGEN = NUMGEN + 1
  10039.       RINC(NUMGEN) = 0.
  10040.       INTINC(NUMGEN) = 0
  10041.   220 CONTINUE
  10042.       IF(FIRST.EQ.0) GO TO 1000
  10043.       GO TO 10
  10044.   250 CONTINUE
  10045.       IF(TYP.NE.REPEAT) GO TO 8050
  10046. C
  10047. C     *=N+STEP
  10048. C
  10049.       NUMI = IVALUE
  10050.       IF(NUMI.LE.0) GO TO 8030
  10051.       IF(NUMGEN.LE.0) GO TO 8040
  10052.       IF((NUMI+NUMGEN).GT.OLDN) GO TO 8010
  10053.       ICHECK = NULL
  10054.       IF(RINC(NUMGEN).NE.0.) ICHECK = REAL
  10055.       IF(INTINC(NUMGEN).NE.0) ICHECK = INTGER
  10056.       IF((ICHECK.NE.NULL).AND.(ICHECK.NE.TGEN)) GO TO 8020
  10057.       IF(TGEN.EQ.NULL) IGEN = 0
  10058.       IF(TGEN.EQ.NULL) RGEN = 0.
  10059.       IF(TGEN.EQ.REAL) ICHECK = REAL
  10060.       IF(IGEN.NE.0) ICHECK = INTGER
  10061.       RR = RINC(NUMGEN)
  10062.       II = INTINC(NUMGEN)
  10063.       DO 270 I=1,NUMI
  10064.       NUMGEN = NUMGEN + 1
  10065.       IF(ICHECK.EQ.NULL) GO TO 260
  10066.       IF(ICHECK.NE.TYPE(NUMGEN)) GO TO 8020
  10067.   260 CONTINUE
  10068.       II = II + IGEN
  10069.       RR = RR + RGEN
  10070.       RINC(NUMGEN) = RR
  10071.       INTINC(NUMGEN) = II
  10072.   270 CONTINUE
  10073.       GO TO 10
  10074.  1000 CONTINUE
  10075.       RETURN
  10076. C
  10077. C     ERROR MESSAGES
  10078. C
  10079.  8010 CONTINUE
  10080. C
  10081. C     TOO MANY ITEMS IN GENERATION RECORD
  10082. C
  10083.       IERR = 21
  10084.       IF(LENREC.NE.0) GO TO 1000
  10085.       IF(NOUT.EQ.0) GO TO 1000
  10086.     if(nout.eq.6)goto 3140
  10087.       WRITE (NOUT,8015)
  10088.  8015 FORMAT(17H *** ERROR *** - ,
  10089.      X       36HNumber Of Items In Generation Record,
  10090.      X 1X,27HMust Match Previous Record  )
  10091.       GO TO 1000
  10092. 3140    continue
  10093.     write(c128wk,8015)
  10094.     call atxto
  10095.     goto 1000
  10096.  8020 CONTINUE
  10097. C
  10098. C     TYPE DIFFERENCE
  10099. C
  10100.       IERR = 22
  10101.       IF(LENREC.NE.0) GO TO 1000
  10102.       IF(NOUT.EQ.0) GO TO 1000
  10103.     if(nout.eq.6)goto 3141
  10104.       WRITE(NOUT,8025)
  10105.  8025 FORMAT(17H *** ERROR *** - ,
  10106.      X       34HType Mismatch On Generation Record)
  10107.       GO TO 1000
  10108. 3141    continue
  10109.     write(c128wk,8025)
  10110.     call atxto
  10111.     goto 1000
  10112.  8030 CONTINUE
  10113. C
  10114. C     *=N WITH N .LE. 0
  10115. C
  10116.       IERR = 6
  10117.       GO TO 1000
  10118.  8040 CONTINUE
  10119. C
  10120. C     *=N FIRST ITEM
  10121. C
  10122.       IERR = 4
  10123.       GO TO 1000
  10124.  8050 CONTINUE
  10125. C
  10126. C     ILLEGAL TYPE ON GENERATION RECORDS
  10127. C
  10128.       IERR = 25
  10129.       IF(LENREC.NE.0) GO TO 1000
  10130.       IF(NOUT.EQ.0) GO TO 1000
  10131.     if(nout.eq.6)goto 3142
  10132.       WRITE (NOUT,8055)
  10133.  8055 FORMAT(17H *** ERROR *** - ,
  10134.      X       45HIllegal Text Or *+N ITEM In Generation Record )
  10135.       GO TO 1000
  10136. 3142    continue
  10137.     write(c128wk,8055)
  10138.     call atxto
  10139.     goto 1000
  10140.       END
  10141.       SUBROUTINE LXGETI(STRING,LEN,IFINT,VALUE)
  10142.       INCLUDE rin:TEXT.BLK
  10143. C
  10144. C     PURPOSE - INTERPRET A STRING OF CHARACTERS AS AN INTEGER.
  10145. C
  10146. C     INPUT  - STRING....ARRAY OF CHARACTERS ONE PER WORD
  10147. C              LEN.......NUMBER OF CHARACTERS IN STRING
  10148. C     OUTPUT - IFINT..... .TRUE. IFF STRING REPRESENTS AN INTEGER
  10149. C              VALUE.....THE ACTUAL VALUE OF THE INTEGER IN STRING.
  10150. C
  10151.       INCLUDE rin:LXCON.BLK
  10152.       INTEGER VALUE
  10153.       INTEGER STRING(LEN)
  10154.       LOGICAL IFINT
  10155.       NEW = 0
  10156.       VALUE = 0
  10157.       IFINT = .FALSE.
  10158.       IS = 1
  10159.       ISIGN = 1
  10160.       IF(STRING(1).NE.MINUS) GO TO 5
  10161.       ISIGN = -1
  10162.       IS = 2
  10163.     5 CONTINUE
  10164.       IF(STRING(1).NE.PLUS) GO TO 10
  10165.       IS = 2
  10166.    10 CONTINUE
  10167.       IF(IS.GT.LEN) GO TO 1000
  10168. C
  10169. C     LOOK AT EACH CHARACTER - IF INTEGER ADD IT IN
  10170. C
  10171.       DO 100 I=IS,LEN
  10172.       DO 20 J=1,10
  10173.       IF(STRING(I).EQ.DIGITS(J)) GO TO 30
  10174.    20 CONTINUE
  10175. C
  10176. C     NOT INTEGER
  10177. C
  10178.       GO TO 1000
  10179.    30 CONTINUE
  10180.       NEW = 10 * NEW + J - 1
  10181.   100 CONTINUE
  10182.       VALUE = ISIGN*NEW
  10183.       IFINT = .TRUE.
  10184.  1000 CONTINUE
  10185.       RETURN
  10186.       END
  10187.       SUBROUTINE LXGETR(STRING,LEN,IFREAL,VALUE)
  10188.       INCLUDE rin:TEXT.BLK
  10189. C
  10190. C     PURPOSE - PARSE A REAL NUMBER - DEFINED AS  ?I1.I2E?I3 WHERE
  10191. C               ? STANDS FOR EITHER + OR - AND I1,I2,I3 ARE INTEGERS.
  10192. C               EITHER THE POINT OR THE "E" MUST BE PRESENT AND THERE
  10193. C               MUST BE AT LEAST TWO CHARACTERS.
  10194. C               IN ADDITION THERE MUST BE AT LEAST ONE DIGIT.
  10195. C
  10196. C     INPUT  - STRING...REAL NUMBER ONE CHARACTER PER WORD.
  10197. C              LEN......LENGTH OF STRING
  10198. C     OUTPUT - IFREAL...TRUE IFF STRING REPRESENTS A REAL NUMBER
  10199. C              VALUE....THE REAL REAL NUMBER
  10200. C
  10201. C     METHOD - I1,I2 AND I3 ARE IDENTIFIED AS SUBSTRINGS AND LXGETI
  10202. C              TURNS THEM INTO INTEGERS WHICH ARE FLOATED AND TURNED
  10203. C              INTO THE REAL REAL VALUE.
  10204. C
  10205.       INCLUDE rin:LXCON.BLK
  10206.       INTEGER STRING(LEN)
  10207.       INTEGER START(3),LENI(3),IN(3)
  10208.       REAL R(3)
  10209.       LOGICAL IFREAL,IFINT,DOT,EXP
  10210.       VALUE = 0.
  10211.       IFREAL = .FALSE.
  10212.       SIGN1 = 1.
  10213.       SIGN2 = 1.
  10214.       DO 5 I=1,3
  10215.       LENI(I) = 0
  10216.       START(I) = 0
  10217.       IN(I) = 0
  10218.       R(I) = 0.
  10219.     5 CONTINUE
  10220.       DOT = .FALSE.
  10221.       EXP = .TRUE.
  10222. C
  10223. C     FIND START AND LENGTHS OF THE THREE INTEGERS (MAY BE EMPTY)
  10224. C
  10225.       IF(LEN.LT.2) GO TO 1000
  10226.       START(1) = 1
  10227.       IF(STRING(1).EQ.PLUS) START(1) = 2
  10228.       IF(STRING(1).EQ.MINUS) START(1) = 2
  10229.       IF(STRING(1).EQ.MINUS) SIGN1 = -1.
  10230. C
  10231. C     LOOK FOR POINT
  10232. C
  10233.       IS = START(1)
  10234.       DO 10 I=IS,LEN
  10235.       IF(STRING(I).EQ.POINT) GO TO 20
  10236.       IF(STRING(I).EQ.E) GO TO 15
  10237.    10 CONTINUE
  10238.    15 CONTINUE
  10239.       LENI(1) = 0
  10240.       START(2) = START(1)
  10241.       GO TO 30
  10242.    20 CONTINUE
  10243.       DOT = .TRUE.
  10244.       LENI(1) = I - START(1)
  10245.       START(2) = I + 1
  10246.    30 CONTINUE
  10247.       IS = START(2)
  10248.       IF(IS.GT.LEN) GO TO 200
  10249. C
  10250. C     LOOK FOR E
  10251. C
  10252.       DO 40 I=IS,LEN
  10253.       IF(STRING(I).EQ.E) GO TO 50
  10254.       IF(DOT.AND.(STRING(I).EQ.PLUS)) GO TO 50
  10255.       IF(DOT.AND.(STRING(I).EQ.MINUS)) GO TO 50
  10256.    40 CONTINUE
  10257.       I = LEN + 1
  10258.       EXP = .FALSE.
  10259.    50 CONTINUE
  10260.       LENI(2) = I - START(2)
  10261.       START(3) = I + 1
  10262.       IF(START(3).GT.LEN) GO TO 200
  10263.       IS = START(3)
  10264.       IF(STRING(IS).EQ.MINUS) SIGN2 = -1.
  10265.       IF(STRING(IS).EQ.MINUS) START(3) = IS + 1
  10266.       IF(STRING(IS).EQ.PLUS) START(3) = IS + 1
  10267.       LENI(3) = LEN - START(3) + 1
  10268.   200 CONTINUE
  10269. C
  10270. C     IF NO EXPONENT OR DECIMAL POINT THEN NOT REAL
  10271. C
  10272.       IF( (.NOT. DOT) .AND. (.NOT. EXP) ) GO TO 1000
  10273. C
  10274. C     IF NO NUMBERS THEN NOT REAL
  10275. C
  10276.       NUM = LENI(1) + LENI(2) + LENI(3)
  10277.       IF(NUM.EQ.0) GO TO 1000
  10278. C
  10279. C  IF NO INTEGER PRECEEDING THE E - ITEM IS TEXT
  10280. C
  10281.       IF((LENI(1)+LENI(2)).EQ.0) GO TO 1000
  10282. C
  10283. C      SWITCH I1 AND I2 IF NO DECIMAL POINT FOUND
  10284. C
  10285.       IF(DOT) GO TO 210
  10286.       LENI(1) = LENI(2)
  10287.       START(1) = START(2)
  10288.       LENI(2) = 0
  10289.   210 CONTINUE
  10290. C
  10291. C     NOW MAKE I1,I2, AND I3 INTO INTEGERS
  10292. C
  10293.       DO 250 I=1,3
  10294.       IF(LENI(I) .EQ. 0) GO TO 250
  10295.       IS = START(I)
  10296.       CALL LXGETI(STRING(IS),LENI(I),IFINT,IN(I))
  10297.       IF(.NOT.IFINT) GO TO 1000
  10298.       R(I) = FLOAT(IN(I))
  10299.   250 CONTINUE
  10300. C
  10301. C     NOW MAKE THE REAL REAL NUMBER
  10302. C
  10303.       LEN2 = LENI(2)
  10304.       R(2) = R(2) / (10.**LEN2)
  10305.       R(1) = SIGN1 * ( R(1) + R(2) )
  10306.       IF( (LENI(1)+LENI(2)) .EQ. 0 ) R(1) = SIGN1
  10307.       I3 = IN(3)
  10308. C
  10309. C  CHECK THE THE EXPONENT IS LEGAL E-38 TO E+38
  10310. C
  10311.       LENX = LENI(1) - 1
  10312.       IF(LENX.LT.0) LENX = 0
  10313.       IF((LENX+I3).GT.38) GO TO 1000
  10314.       R(3) = 10.**I3
  10315.       IF(SIGN2.EQ.-1.) R(3) = 1./R(3)
  10316.       VALUE = R(1) * R(3)
  10317.       IFREAL = .TRUE.
  10318.  1000 CONTINUE
  10319.       RETURN
  10320.       END
  10321.       FUNCTION LXID(I)
  10322.       INCLUDE rin:TEXT.BLK
  10323. C
  10324. C     THIS FUNCTION RETURNS THE ID OF THE ITH ITEM IN THE LAST
  10325. C      LXLREC RECORD.
  10326. C     ID'S MAY BE 4HTEXT,3HINT,4HREAL, OR 3HEOF
  10327. C
  10328.       INCLUDE rin:LXCARD.BLK
  10329.       INCLUDE rin:LXCON.BLK
  10330.       LXID = BLANKS
  10331.       IF((I.GT.0) .AND. (I.LE.NEWN)) LXID = TYPE(I)
  10332.       RETURN
  10333.       END
  10334.       FUNCTION LXIREC(I)
  10335.       INCLUDE rin:TEXT.BLK
  10336. C
  10337. C     THIS FUNCTION RETURNS THE INTEGER VALUE OF THE ITH ITEM.
  10338. C     LXIREC IS RETURNED 0 IF I IS NOT VALID INTEGER ITEM.
  10339. C
  10340.       INCLUDE rin:LXCARD.BLK
  10341.       INCLUDE rin:LXCON.BLK
  10342.       LXIREC = 0
  10343.       IF(I.LT.1) RETURN
  10344.       IF(I.GT.NEWN) RETURN
  10345.       IF(TYPE(I).NE.INTGER) RETURN
  10346.       LXIREC = INTVAL(I)
  10347.       RETURN
  10348.       END
  10349.       FUNCTION LXITEM(NUM)
  10350.       INCLUDE rin:TEXT.BLK
  10351. C
  10352. C     THIS FUNCTION RETURNS THE NUMBER OF ITEMS READ IN THE LAST
  10353. C      LXLREC RECORD.
  10354. C
  10355.       INCLUDE rin:LXCARD.BLK
  10356.       NUM = NEWN
  10357.       LXITEM = NEWN
  10358.       RETURN
  10359.       END
  10360.       FUNCTION LXLENC(I)
  10361.       INCLUDE rin:TEXT.BLK
  10362. C
  10363. C     THIS FUNCTION RETURNS THE LENGTH IN CHARACTERS OF THE ITH ITEM.
  10364. C     LXLENC IS RETURNED AS ZERO IF I IS NOT VALID TEXT ITEM.
  10365. C
  10366.       INCLUDE rin:LXCARD.BLK
  10367.       INCLUDE rin:LXCON.BLK
  10368.       LXLENC = 0
  10369.       IF(I.LT.1) RETURN
  10370.       IF(I.GT.NEWN) RETURN
  10371.       IF(TYPE(I).EQ.INTGER) RETURN
  10372.       IF(TYPE(I).EQ.REAL) RETURN
  10373.       LXLENC = INT(RVAL(I))
  10374.       RETURN
  10375.       END
  10376.       FUNCTION LXLENW(I)
  10377.       INCLUDE rin:TEXT.BLK
  10378. C
  10379. C     THIS FUNCTION RETURNS THE LENGTH IN WORDS OF THE ITH ITEM.
  10380. C     IF I IS NOT A VALID TEXT ITEM LXLENW IS RETURNED ZERO.
  10381. C     WORDS HERE REFERS TO A FORTRAN INTEGER ITEM.
  10382. C     (E.G. 10 CHARACTERS ON CYBERS,8 CHARACTERS ON CRAY...)
  10383. C
  10384.       INCLUDE rin:LXCARD.BLK
  10385.       INCLUDE rin:LXCON.BLK
  10386.       LXLENW = 0
  10387.       IF(I.LT.1) RETURN
  10388.       IF(I.GT.NEWN) RETURN
  10389.       LXLENW = 1
  10390.       IF(TYPE(I).EQ.INTGER) RETURN
  10391.       IF(TYPE(I).EQ.REAL) RETURN
  10392.       LEN = INT(RVAL(I))
  10393.       LXLENW = ((LEN-1)/NCPW) + 1
  10394.       RETURN
  10395.       END
  10396.       SUBROUTINE LXLINE(RECORD,LENREC,NUML,LINE,LEN,LOC)
  10397.       INCLUDE rin:TEXT.BLK
  10398. C
  10399. C     THIS ROUTINE GETS THE NEXT LINE FOR LXLREC TO PARSE.  IF LENREC
  10400. C     IS ZERO, FILE NIN IS READ, ELSE THE LINE IS EXTRACTED FROM RECORD.
  10401. C     IF LOC IS NOT ZERO NEW LINE IS ALREADY IN LINE, SIMPLY
  10402. C     MOVE THE DATA TO THE FRONT OF LINE.
  10403. C
  10404.       INCLUDE rin:LXCARD.BLK
  10405.       INCLUDE rin:PROM.BLK
  10406.       INCLUDE rin:LXCON.BLK
  10407.       character*208 c128wk,c128rd
  10408.     integer*4 nc128,mc128
  10409.     common/accmd/c128wk,c128rd,nc128,mc128
  10410. c above 3 lines taken from FILES.BLK
  10411.       DIMENSION LINE(80)
  10412. C following needed on big endian machines
  10413.     integer*4 lineel
  10414.     character*1 lel(4)
  10415.     equivalence(lineel,lel(1))
  10416. cc    character*2 cpromq
  10417. cc    integer*2 cprom
  10418. cc    equivalence(cprom,cpromq)
  10419.       INTEGER RECORD(*)
  10420.       IF(LOC.NE.0) GO TO 200
  10421.       NUML = NUML + 1
  10422.       IF(LENREC.NE.0) GO TO 100
  10423. C
  10424. C     FROM FILE NIN
  10425. C
  10426.       LEN = 80
  10427. C
  10428. 7001    CONTINUE
  10429. C analyticalc change...use vwrt to emit the prompt without crlf
  10430. cc    cprom=prom
  10431.       IF(NIN.EQ.5) call vwrt(prom,2)
  10432. cc      IF(NIN.EQ.5) call vwrt(cpromq,2)
  10433. c      IF(NIN.EQ.5) WRITE(6,5) PROM
  10434.     5 FORMAT(1X,A2,$)
  10435.     if(nin.eq.5)goto 3340
  10436.       READ (NIN,10,END=13) LINE
  10437.     goto 3341
  10438. 3340    continue
  10439.     call atxti
  10440.     read(c128rd,10)line
  10441.       if(nin.eq.5)call uvt100(1,1,1)
  10442.     if(nin.eq.5)call uvt100(11,0,0)
  10443.     lineel=line(1)
  10444.     if(ichar(lel(1)).eq.26)goto 13
  10445. C explicitly, if we see control-Z treat it as eof.
  10446. 3341    continue
  10447.    10 FORMAT(80A1)
  10448.       LXEOF = .FALSE.
  10449. C FORCE CHARS FROM TERMINALS TO BE UPPER CASE
  10450.     IF(NIN.NE.5)GOTO 14
  10451. C ONLY CHANGE CHARS FROM A TTY
  10452. C ALSO STOP CHANGING IF WE GET TO A " CHARACTER
  10453. C IF 1ST CHAR IS } THEN DO COMMAND...
  10454. C system dependent .. commented out code is for small endian
  10455. C machines...
  10456. c    IF(MOD(LINE(1),256).NE.125)GOTO 12
  10457. c    CALL USRCMD(LINE(2))
  10458. c    GOTO 7001
  10459. c12    CONTINUE
  10460. d    DO 11 N=1,80
  10461. c    NN=MOD(LINE(N),256)
  10462. c    IF(NN.EQ.34)GOTO 14
  10463. C 34 IS " CHARACTER IN ASCII
  10464. C REPLACE a-z BY A-Z AND LEAVE ALL ELSE ALONE.
  10465. C TRY TO LEAVE HIGH PARTS OF INTEGER ALONE.
  10466. c    IF(NN.GE.97.AND.NN.LE.122)LINE(N)=(LINE(N)/256)*256+(NN-32)
  10467. c11    CONTINUE
  10468. C
  10469. C Following code for big-endian machines...probably will work on any.
  10470.     lineel=line(1)
  10471.     if(lel(1).ne.'}')goto 12
  10472.     Call usrcmd(line(2))
  10473.     goto 7001
  10474. 12    Continue
  10475.     do 11 n=1,80
  10476.     lineel=line(n)
  10477.     kkk=ichar(lel(1))
  10478.     if(kkk.ge.97.and.kkk.le.122)lel(1)=char(kkk-32)
  10479.         if(kkk.eq.0)lel(1)=' '
  10480.     line(n)=lineel
  10481. 11    continue
  10482.       GO TO 14
  10483.    13 CONTINUE
  10484.       LXEOF = .TRUE.
  10485.    14 CONTINUE
  10486. C
  10487.       IF(LXEOF) GO TO 1000
  10488.       IF(NOUT.EQ.0) GO TO 1000
  10489.       IF(.NOT.ECHO) GO TO 1000
  10490.     if(nout.eq.6)goto 3140
  10491.       WRITE(NOUT,20) LINE
  10492.    20 FORMAT(16H Input Line ... ,80A1)
  10493.       GO TO 1000
  10494. 3140    continue
  10495.     write(c128wk,20)line
  10496.     call atxto
  10497.     goto 1000
  10498.   100 CONTINUE
  10499. C
  10500. C     GET LINE FROM RECORD
  10501. C
  10502.       LEN = 0
  10503.       I1 = 80*(NUML-1) + 1
  10504.       I2 = 80*NUML
  10505.       IF(I1.GT.LENREC) GO TO 1000
  10506.       IF(I2.GT.LENREC) I2 = LENREC
  10507.       DO 150 I=I1,I2
  10508.       LEN = LEN + 1
  10509.       CALL GETT(RECORD,I,LINE(LEN))
  10510.   150 CONTINUE
  10511.       GO TO 1000
  10512.   200 CONTINUE
  10513.       NEWLEN = LEN - LOC
  10514.       IF(NEWLEN.LE.0) GO TO 230
  10515.       DO 220 I=1,NEWLEN
  10516.       LOC = LOC + 1
  10517.       LINE(I) = LINE(LOC)
  10518.   220 CONTINUE
  10519.   230 CONTINUE
  10520.       LEN = NEWLEN
  10521.       LOC = 0
  10522.  1000 CONTINUE
  10523.       IF(LEN.LE.0) RETURN
  10524. C
  10525. C     IGNORE TRAILING BLANKS
  10526. C
  10527.       ICHECK = LEN + 1
  10528.       DO 1100 I=1,LEN
  10529.       ICHECK = ICHECK - 1
  10530.       IF(LINE(ICHECK).NE.BLANKS) GO TO 1200
  10531.  1100 CONTINUE
  10532.       ICHECK = 1
  10533.  1200 CONTINUE
  10534.       LEN = ICHECK
  10535.       RETURN
  10536.       END
  10537.       SUBROUTINE LXLREC(RECORD,LENREC,IERR)
  10538.       INCLUDE rin:TEXT.BLK
  10539. C
  10540. C     LXLREC BREAKS INPUT STRINGS INTO TEXT,REAL OR INTEGER ITEMS.
  10541. C
  10542. C     INPUT  - RECORD....ONE RECORD IN A HOLLERITH STRING IN 80
  10543. C                        CHARACTER CHUNKS.  IF MORE THAN 80 CHARACTERS
  10544. C                        ARE NEEDED ALL BUT THE LAST CHUNK SHOULD END
  10545. C                        WITH A PLUS.  THE LAST CHUNK NEED NOT BE A FULL
  10546. C                        80 CHARACTERS.
  10547. C              LENREC....LENGTH OF RECORD IN CHARS.
  10548. C                        IF 0 READ INPUT FROM INPUT
  10549. C     OUTPUT - IERR......ERROR RETURN IF LENREC IS NOT ZERO.
  10550. C
  10551. C
  10552. C     LXLREC ERROR RETURNS
  10553. C
  10554. C     NUMBER         MEANING
  10555. C     ------    ---------------------------------------------------
  10556. C        1 ..... *N EXTENDS PAST PREVIOUS RECORD
  10557. C        2 ..... *N OR ** OPTION REQUESTS LESS THAN ONE ITEM
  10558. C        3 ..... TOO MANY ITEMS
  10559. C        4 ..... *=N WAS FIRST ITEM
  10560. C        5 ..... *+N WAS NOT FIRST ITEM
  10561. C        6 ..... *=N WHERE N WAS NOT POSITIVE
  10562. C        7 ..... TOO MANY TEXT CHARACTERS
  10563. C        8 ..... *=N+STEP DOES NOT AGREE IN TYPE WITH PREVIOUS ITEM
  10564. C       21 ..... NUMBER OF ITEMS IN GENERATION RECORD FAILS TO
  10565. C                MATCH PREVIOUS RECORD.
  10566. C       22 ..... TYPE MISMATCH ON GENERATION RECORD.
  10567. C       25 ..... ILLEGAL TEXT OR *+N ITEM ON GENERATION RECORD.
  10568. C
  10569.       INCLUDE rin:LXCARD.BLK
  10570.       INCLUDE rin:LXCON.BLK
  10571.       INCLUDE rin:LXCIT.BLK
  10572.       INCLUDE rin:LXGEN.BLK
  10573.       INCLUDE rin:LXWRDS.BLK
  10574.       INTEGER RECORD(*),LINE(80),START
  10575.       LOGICAL MORE,TTY,IFSET
  10576.       DATA LOC /0/
  10577. C
  10578. C     BRANCH IF GENERATION
  10579. C
  10580.       IF(NUMREP.NE.0) GO TO 900
  10581.     5 CONTINUE
  10582. C
  10583. C     MOVE CURRENT TO OLD
  10584. C
  10585.       DO 10 I=1,NWORD
  10586.       OLDREC(I) = NEWREC(I)
  10587.       NEWREC(I) = BLANKS
  10588.    10 CONTINUE
  10589.       OLDN = NEWN
  10590.       NEWN = 0
  10591.       NEXT = 1
  10592. C
  10593. C     GET 1ST LINE OF INFORMATION
  10594. C
  10595.       IERR = 0
  10596.       NUML = 0
  10597.    15 CONTINUE
  10598.       CALL LXLINE(RECORD,LENREC,NUML,LINE,LEN,LOC)
  10599.       IF(LXEOF) GO TO 7000
  10600. C
  10601. C     CHECK FOR *(SET KEYWORD=NEWVALUE) RECORD
  10602. C
  10603.       CALL LXUSET(LINE,LEN,IFSET)
  10604.       IF(IFSET) GO TO 15
  10605. C
  10606. C     FIND END OF LINE
  10607. C
  10608.       CALL LXEND(LINE,LEN,LOC,MORE,NEWLEN)
  10609. C
  10610. C     GET 1ST ITEM
  10611. C
  10612.       START = 1
  10613.       CALL LXNEXI(LINE,START,NEWLEN)
  10614.       IF(FIRST.NE.0) GO TO 20
  10615. C
  10616. C     NO ITEMS IN LINE 1
  10617. C
  10618.       IF(.NOT.MORE) NOEND = .FALSE.
  10619.       MORE = .TRUE.
  10620.       GO TO 110
  10621.    20 CONTINUE
  10622. C
  10623. C     CHECK FOR GENERATION RECORD
  10624. C
  10625.       IF(TYP.EQ.GENRAT) GO TO 800
  10626. C
  10627. C     BUILD A STRAIGHTFORWARD RECORD
  10628. C
  10629.    30 CONTINUE
  10630.       IF((TYP.NE.SAME) .AND. (TYP.NE.ALLSAM)) GO TO 50
  10631. C
  10632. C     *N OR **
  10633. C
  10634.       NUMI = IVALUE
  10635.       IF(TYP.EQ.ALLSAM) NUMI = OLDN - NEWN
  10636.       IF((NUMI+NEWN).GT.OLDN) GO TO 8010
  10637.       IF(NUMI.LE.0) GO TO 8020
  10638.       IF((NUMI+NEWN).GT.MITEM) GO TO 8030
  10639.       L = NEWN
  10640.       DO 40 J=1,NUMI
  10641.       I = L + J
  10642.       LA = INT(RVAL(I))
  10643.       LB = INTVAL(I)
  10644.       IF(TYPE(I).EQ.TEXT) GO TO 35
  10645.       LA = 1
  10646.       LB = 1
  10647.    35 CONTINUE
  10648.       CALL LXSTOR(TYPE(I),INTVAL(I),RVAL(I),OLDREC(LB),1,LA,.TRUE.)
  10649.       IF(NEWN.GT.MITEM) GO TO 8030
  10650.       IF(NEXT.GT.MCHAR) GO TO 8070
  10651.    40 CONTINUE
  10652.       GO TO 100
  10653.    50 CONTINUE
  10654.       IF(TYP.NE.REPEAT) GO TO 70
  10655. C
  10656. C     *=N
  10657. C
  10658.       NUMI = IVALUE
  10659.       IF(NUMI.LE.0) GO TO 8060
  10660.       IF(NEWN.LE.0) GO TO 8040
  10661.       L = NEWN
  10662.       IF(TGEN.EQ.NULL)IGEN = 0
  10663.       IF(TGEN.EQ.NULL)RGEN = 0.
  10664.       IF((TGEN.NE.NULL).AND.(TGEN.NE.TYPE(L))) GO TO 8080
  10665.       IF((NEWN+NUMI).GT.MITEM) GO TO 8030
  10666.       LA = INT(RVAL(L))
  10667.       LB = INTVAL(L)
  10668.       IF(TYPE(L).EQ.TEXT) GO TO 55
  10669.       LA = 1
  10670.       LB = 1
  10671.    55 CONTINUE
  10672.       RR = RVAL(L)
  10673.       II = INTVAL(L)
  10674.       DO 60 I=1,NUMI
  10675.       RR = RR + RGEN
  10676.       II = II + IGEN
  10677.       CALL LXSTOR(TYPE(L),II,RR,NEWREC(LB),1,LA,.TRUE.)
  10678.       IF(NEWN.GT.MITEM) GO TO 8030
  10679.       IF(NEXT.GT.MCHAR) GO TO 8070
  10680.    60 CONTINUE
  10681.       GO TO 100
  10682.    70 CONTINUE
  10683.       IF(TYP.NE.COMMA) GO TO 80
  10684. C
  10685. C     TYP = COMMA      GENERATE -NULL- TEXT ITEM
  10686. C
  10687.       CALL LXSTOR(TEXT,0,0.,NULL,1,3,.TRUE.)
  10688.       GO TO 100
  10689.    80 CONTINUE
  10690.       IF(TYP.EQ.GENRAT) GO TO 8050
  10691.       CALL LXSTOR(TYP,IVALUE,RVALUE,LINE,FIRST,LAST,.FALSE.)
  10692.       IF(NEWN.GT.MITEM) GO TO 8030
  10693.       IF(NEXT.GT.MCHAR) GO TO 8070
  10694.   100 CONTINUE
  10695.       START = LAST + 1
  10696.       IF(START.GT.NEWLEN) GO TO 110
  10697.       CALL LXNEXI(LINE,START,NEWLEN)
  10698.       IF(FIRST.NE.0) GO TO 30
  10699.   110 CONTINUE
  10700.       IF((.NOT.MORE) .AND. (NEWN.NE.0)) GO TO 1000
  10701. C
  10702. C     GET ANOTHER LINES WORTH
  10703. C
  10704.       CALL LXLINE(RECORD,LENREC,NUML,LINE,LEN,LOC)
  10705.       IF(LXEOF) GO TO 7000
  10706.       CALL LXEND(LINE,LEN,LOC,MORE,NEWLEN)
  10707.       START = 1
  10708.       IF(NOEND) GO TO 120
  10709.       CALL LXNEXI(LINE,START,NEWLEN)
  10710.       IF(FIRST.NE.0) GO TO 30
  10711.       GO TO 110
  10712.   120 CONTINUE
  10713. C
  10714. C     WE EITHER HAVE TO STORE TO THE END OF A QUOTE OR
  10715. C     SKIP TO THE END OF A COMMENT.
  10716. C
  10717.       IF(NEWLEN.LE.0) GO TO 110
  10718.       NOEND = .FALSE.
  10719.       IF(FIRST.NE.0) GO TO 140
  10720. C
  10721. C     COMMENT
  10722. C
  10723.       DO 130 I=1,NEWLEN
  10724.       LAST = I
  10725.       IF(LINE(I).EQ.ENDCOM) GO TO 100
  10726.   130 CONTINUE
  10727.       IF(MORE) NOEND = .TRUE.
  10728.       GO TO 110
  10729.   140 CONTINUE
  10730. C
  10731. C     CONTINUED QUOTE
  10732. C
  10733.       NEXT = INTVAL(NEWN)*NCPW - NCPW + 1 + IFIX(RVAL(NEWN))
  10734.       I = 1
  10735.   150 CONTINUE
  10736.       IF(I.GT.NEWLEN) GO TO 170
  10737.       IF(LINE(I).NE.QUOTES) GO TO 160
  10738.       IF(I.EQ.NEWLEN) GO TO 170
  10739.       IF(LINE(I+1).NE.QUOTES) GO TO 170
  10740.       I = I + 1
  10741.   160 CONTINUE
  10742.       CALL PUTT(NEWREC,NEXT,LINE(I))
  10743.       I = I + 1
  10744.       NEXT = NEXT + 1
  10745.        GO TO 150
  10746.   170 CONTINUE
  10747.       N = NEXT - INTVAL(NEWN)*NCPW + NCPW - 1
  10748.       RVAL(NEWN) = FLOAT(N)
  10749.       LAST = I
  10750.       NEXT = 1 + NCPW*(1+(NEXT-2)/NCPW)
  10751.       IF(MORE.AND.(LAST.GE.NEWLEN)) NOEND = .TRUE.
  10752.       IF(LINE(LAST).EQ.QUOTES) NOEND = .FALSE.
  10753.       GO TO 100
  10754.   800 CONTINUE
  10755. C
  10756. C     PARSE GENERATION RECORD
  10757. C
  10758.       NEWN = OLDN
  10759.       DO 810 I=1,NWORD
  10760.       NEWREC(I) = OLDREC(I)
  10761.   810 CONTINUE
  10762.       CALL LXGENS(RECORD,LENREC,NUML,LINE,LEN,NEWLEN,
  10763.      X         MORE,LOC,IERR)
  10764.       IF(LXEOF) GO TO 7000
  10765.       IF(IERR.EQ.0) GO TO 900
  10766.       NUMREP = 0
  10767.       IF(IERR.EQ.4) GO TO 8040
  10768.       IF(IERR.EQ.6) GO TO 8060
  10769.       IF(LENREC.NE.0) GO TO 1000
  10770.       GO TO 9000
  10771.   900 CONTINUE
  10772. C
  10773. C     STUFF GENERATION RECORD
  10774. C
  10775.       CALL LXGENR
  10776.  1000 CONTINUE
  10777.       RETURN
  10778.  7000 CONTINUE
  10779. C
  10780. C     END OF FILE ENCOUNTERED
  10781. C     RETURN ONE ITEM OF TYPE 3HEOF
  10782. C
  10783.       NEWN = 1
  10784.       TYPE(1) = KYEOF
  10785.       GO TO 1000
  10786.  8000 CONTINUE
  10787. C
  10788. C     ERROR MESSAGES
  10789. C
  10790.  8010 CONTINUE
  10791. C
  10792. C     *N PAST PREVIOUS RECORD
  10793. C
  10794.       IERR = 1
  10795.       IF(LENREC.NE.0) GO TO 1000
  10796.       IF(NOUT.EQ.0) GO TO 9000
  10797.     if(nout.eq.6)goto 3143
  10798.       WRITE (NOUT,8015)
  10799.  8015 FORMAT(17H *** ERROR *** - ,31H*N Extends Past Previous Record)
  10800.       GO TO 9000
  10801. 3143    continue
  10802.     write(c128wk,8015)
  10803.     call atxto
  10804.     goto 9000
  10805.  8020 CONTINUE
  10806. C
  10807. C     *N OR ** OPTION REQUESTS ZERO OR FEWER ITEMS
  10808. C
  10809.       IERR = 2
  10810.       IF(LENREC.NE.0) GO TO 1000
  10811.       IF(NOUT.EQ.0) GO TO 9000
  10812.     if(nout.eq.6)goto 3144
  10813.       WRITE (NOUT,8025)
  10814.  8025 FORMAT(17H *** ERROR *** -
  10815.      X       ,43H*N or ** Option Requests Less Than One Item)
  10816.       GO TO 9000
  10817. 3144    continue
  10818.     write(c128wk,8025)
  10819.     call atxto
  10820.     goto 9000
  10821.  8030 CONTINUE
  10822. C
  10823. C     MORE THAN MITEM RECORDS
  10824. C
  10825.       IERR = 3
  10826.       IF(LENREC.NE.0) GO TO 1000
  10827.       IF(NOUT.EQ.0) GO TO 9000
  10828.     if(nout.eq.6)goto 3145
  10829.       WRITE (NOUT,8035)MITEM
  10830.  8035 FORMAT(17H *** ERROR *** - ,7HMax Of ,I3,15H Items Exceeded)
  10831.       GO TO 9000
  10832. 3145    continue
  10833.     write(c128wk,8035)mitem
  10834.     call atxto
  10835.     goto 9000
  10836.  8040 CONTINUE
  10837. C
  10838. C     *=N FIRST ITEM
  10839. C
  10840.       IERR = 4
  10841.       IF(LENREC.NE.0) GO TO 1000
  10842.       IF(NOUT.EQ.0) GO TO 9000
  10843.     if(nout.eq.6)goto 3146
  10844.       WRITE (NOUT,8045)
  10845.  8045 FORMAT(17H *** ERROR *** - ,25H*=N May Not Be First Item)
  10846.       GO TO 9000
  10847. 3146    continue
  10848.     write(c128wk,8045)
  10849.     call atxto
  10850.     goto 9000
  10851.  8050 CONTINUE
  10852. C
  10853. C     *+N NOT FIRST ITEM IN RECORD
  10854. C
  10855.       IERR = 5
  10856.       IF(LENREC.NE.0) GO TO 1000
  10857.       IF(NOUT.EQ.0) GO TO 9000
  10858.     if(nout.eq.6)goto 3147
  10859.       WRITE (NOUT,8055)
  10860.  8055 FORMAT(17H *** ERROR *** - ,32H*+N Must Be First Item In Record)
  10861.       GO TO 9000
  10862. 3147    continue
  10863.     write(c128wk,8055)
  10864.     call atxto
  10865.     goto 9000
  10866.  8060 CONTINUE
  10867. C
  10868. C     *=N WITH 0 OR NEGATIVE N
  10869. C
  10870.       IERR = 6
  10871.       IF(LENREC.NE.0) GO TO 1000
  10872.       IF(NOUT.EQ.0) GO TO 9000
  10873.     if(nout.eq.6)goto 3148
  10874.       WRITE (NOUT,8065)
  10875.  8065 FORMAT(17H *** ERROR *** - ,28HFOR *=N ITEM N Must Positive)
  10876.       GO TO 9000
  10877. 3148    continue
  10878.     write(c128wk,8065)
  10879.     call atxto
  10880.     goto 9000
  10881.  8070 CONTINUE
  10882. C
  10883. C     TOTAL TEXT CHARACTERS EXCEEDS MCHAR
  10884. C
  10885.       IERR = 7
  10886.       IF(LENREC.NE.0) GO TO 1000
  10887.       IF(NOUT.EQ.0) GO TO 9000
  10888.     if(nout.eq.6)goto 3149
  10889.       WRITE (NOUT,8075)MCHAR
  10890.  8075 FORMAT(17H *** ERROR *** -
  10891.      X        ,40HTotal Text Characters For Record Exceeds ,I4)
  10892.       GO TO 9000
  10893. 3149    continue
  10894.     write(c128wk,8075)mchar
  10895.     call atxto
  10896.     goto 9000
  10897.  8080 CONTINUE
  10898. C
  10899. C     *=N?VALUE DOES NOT AGREE IN TYPE WITH PREVIOUS ITEM.
  10900. C
  10901.       IERR = 8
  10902.       IF(LENREC.NE.0) GO TO 1000
  10903.       IF(NOUT.EQ.0) GO TO 9000
  10904.     if(nout.eq.6)goto 3150
  10905.       WRITE (NOUT,8085)
  10906.  8085 FORMAT(17H *** ERROR *** -
  10907.      X       ,51H*=N Value Does Not Agree In Type With Previous Item)
  10908.     goto 9000
  10909. 3150    continue
  10910.     write(c128wk,8085)
  10911.     call atxto
  10912.  9000 CONTINUE
  10913.       NEWN = 0
  10914.       IF(.NOT.MORE) GO TO 5
  10915.       IF(TTY(DUM)) GO TO 5
  10916.       CALL LXLINE(RECORD,LENREC,NUML,LINE,LEN,LOC)
  10917.       IF(LXEOF) GO TO 7000
  10918.       CALL LXEND(LINE,LEN,LOC,MORE,NEWLEN)
  10919.       GO TO 9000
  10920.       END
  10921.       FUNCTION LXMASK(NAMEIN)
  10922.       INCLUDE rin:TEXT.BLK
  10923.       DATA IBLANK /1H /
  10924.       NEW = 0
  10925.       DO 10 I=1,8
  10926.       CALL GETT(NAMEIN,I,L)
  10927.       IF(L.NE.IBLANK) CALL PUTT(NEW,I,L)
  10928.    10 CONTINUE
  10929.       LXMASK = NEW
  10930.       RETURN
  10931.       END
  10932.       SUBROUTINE LXNEXI(LINE,START,LEN)
  10933.       INCLUDE rin:TEXT.BLK
  10934. C
  10935. C     THIS ROUTINE PARSES THE INPUT LINE RETRIEVING THE NEXT ITEM, IF
  10936. C     ANY, AND DETERMINES THE TYPE AND A VALUE IF NOT A TEXT ITEM.
  10937. C     ITEMS ARE DELIMITED BY BLANKS OR COMMAS.
  10938. C
  10939. C     INPUT  - LINE.....HOLLERITH ARRAY, ONE CHARACTER/WORD.
  10940. C              START....STARTING POINT IN LINE
  10941. C              LEN......LENGTH OF LINE
  10942. C
  10943.       INCLUDE rin:LXCIT.BLK
  10944.       INCLUDE rin:LXCON.BLK
  10945.       DIMENSION LINE(*)
  10946.       LOGICAL IFINT,IFREAL
  10947.       INTEGER START
  10948. C
  10949. C     LOCATE 1ST CHARACTER
  10950. C
  10951.       NCOMMA = 0
  10952.       NOEND = .FALSE.
  10953.       FIRST = START - 1
  10954.       TYP = TEXT
  10955.    10 CONTINUE
  10956.       FIRST = FIRST + 1
  10957.       LAST = FIRST
  10958.       IF(FIRST.GT.LEN) GO TO 900
  10959.       IF(LINE(FIRST).EQ.BLANK) GO TO 10
  10960.       IF(LINE(FIRST).NE.COMMA) GO TO 12
  10961.       NCOMMA = NCOMMA + 1
  10962.       IF(NCOMMA.LE.1) GO TO 10
  10963.       FIRST = FIRST - 1
  10964.       LAST = FIRST
  10965.       TYP = COMMA
  10966.       GO TO 1000
  10967.    12 CONTINUE
  10968.       IF(LINE(FIRST).EQ.EQUALS) GO TO 1000
  10969.       IF(LINE(FIRST).EQ.LPAREN) GO TO 1000
  10970.       IF(LINE(FIRST).EQ.RPAREN) GO TO 1000
  10971.       IF(LINE(FIRST).NE.STAR) GO TO 20
  10972. C
  10973. C     MIGHT BE COMMENT
  10974. C
  10975.       IF(FIRST.EQ.LEN) GO TO 20
  10976.       ENDCOM = NULL
  10977.       IF(LINE(FIRST+1).EQ.LPAREN) ENDCOM = RPAREN
  10978.       IF(LINE(FIRST+1).EQ.SLASH) ENDCOM = SLASH
  10979.       IF(ENDCOM.EQ.NULL) GO TO 20
  10980. C
  10981. C     TIS - GO UNTIL ")"
  10982. C
  10983.       NOEND = .TRUE.
  10984.       FIRST = FIRST + 1
  10985.    15 CONTINUE
  10986.       FIRST = FIRST + 1
  10987.       IF(FIRST.GT.LEN) GO TO 900
  10988.       IF(LINE(FIRST).NE.ENDCOM) GO TO 15
  10989.       NOEND = .FALSE.
  10990.       GO TO 10
  10991.    20 CONTINUE
  10992. C
  10993. C     LOCATE LAST - 1ST CHECK IF QUOTED STRING
  10994. C
  10995.       IF(LINE(FIRST).EQ.QUOTES) GO TO 50
  10996.       LAST = FIRST
  10997.    30 CONTINUE
  10998. C
  10999. C     LOOK FOR BLANK OR COMMA
  11000. C
  11001.       LAST = LAST + 1
  11002.       IF(LAST.GT.LEN) GO TO 100
  11003.       IF(LINE(LAST).EQ.BLANK) GO TO 100
  11004.       IF(LINE(LAST).EQ.COMMA) GO TO 100
  11005.       IF(LINE(LAST).EQ.LPAREN) GO TO 100
  11006.       IF(LINE(LAST).EQ.RPAREN) GO TO 100
  11007.       IF(LINE(LAST).NE.EQUALS) GO TO 30
  11008. C
  11009. C     SPECIAL CASE *=
  11010. C
  11011.       IF(LAST.NE.(FIRST+1)) GO TO 100
  11012.       IF(LINE(FIRST).NE.STAR) GO TO 100
  11013.       GO TO 30
  11014.    50 CONTINUE
  11015. C
  11016. C     QUOTED STRING
  11017. C
  11018.       NOEND = .TRUE.
  11019.       TYP = TEXT
  11020.       LAST = FIRST
  11021.    60 CONTINUE
  11022.       IF(LAST.GE.LEN) GO TO 1000
  11023.       LAST = LAST + 1
  11024.       IF(LINE(LAST).NE.QUOTES) GO TO 60
  11025.       IF(LAST.EQ.LEN) GO TO 70
  11026.       IF(LINE(LAST+1).NE.QUOTES)GO TO 70
  11027.       LAST = LAST + 1
  11028.       GO TO 60
  11029.    70 CONTINUE
  11030.       NOEND = .FALSE.
  11031.       GO TO 1000
  11032.   100 CONTINUE
  11033. C
  11034. C     TEST FOR REAL OR INTEGER
  11035. C
  11036.       LAST = LAST -1
  11037.       TYP = INTGER
  11038.       CALL LXGETI(LINE(FIRST),LAST-FIRST+1,IFINT,IVALUE)
  11039.       IF(IFINT) GO TO 1000
  11040.       IVALUE = 0
  11041.       TYP = REAL
  11042.       CALL LXGETR(LINE(FIRST),LAST-FIRST+1,IFREAL,RVALUE)
  11043.       IF(IFREAL) GO TO 1000
  11044.       RVALUE = 0.
  11045. C
  11046. C     TRY FOR SPECIALTY TYPES
  11047. C
  11048.       TYP = TEXT
  11049.       IF(LINE(FIRST).NE.STAR) GO TO 1000
  11050.       IF(FIRST.NE.LAST) GO TO 105
  11051. C
  11052. C     SINGLE *
  11053. C
  11054.       TYP = SAME
  11055.       IVALUE = 1
  11056.       GO TO 1000
  11057.   105 CONTINUE
  11058.       IF(LINE(FIRST+1).NE.STAR) GO TO 110
  11059.       IF(LAST.NE.FIRST+1) GO TO 110
  11060. C
  11061. C     **, *=N, *+N THEN *N
  11062. C
  11063.       TYP = ALLSAM
  11064.       GO TO 1000
  11065.   110 CONTINUE
  11066.       IF((LAST-FIRST).LE.1) GO TO 130
  11067.       IF(LINE(FIRST+1).NE.EQUALS) GO TO 120
  11068. C
  11069. C     *=N - SEE IF *=N?VALUE
  11070. C
  11071.       TGEN = NULL
  11072.       IGEN = 0
  11073.       RGEN = 0.
  11074.       NUM = LAST - FIRST - 2
  11075.       IF(NUM.LE.0) GO TO 114
  11076.       LOOK = FIRST + 2
  11077.       DO 112 I=1,NUM
  11078.       LOOK = LOOK + 1
  11079.       IF(LINE(LOOK) .EQ. PLUS) GO TO 200
  11080.       IF(LINE(LOOK) .EQ. MINUS) GO TO 200
  11081.   112 CONTINUE
  11082.   114 CONTINUE
  11083. C
  11084. C     PLAIN *=N
  11085. C
  11086.       CALL LXGETI(LINE(FIRST+2),LAST-FIRST-1,IFINT,IVALUE)
  11087.       TYP = REPEAT
  11088.       IF(IFINT) GO TO 1000
  11089.       TYP = TEXT
  11090.       IVALUE = 0
  11091.       GO TO 1000
  11092.   120 CONTINUE
  11093.       IF(LINE(FIRST+1).NE.PLUS) GO TO 130
  11094.       CALL LXGETI(LINE(FIRST+2),LAST-FIRST-1,IFINT,IVALUE)
  11095.       TYP = GENRAT
  11096.       IF(IFINT) GO TO 1000
  11097.   130 CONTINUE
  11098. C
  11099. C     *N
  11100. C
  11101.       TYP = SAME
  11102.       CALL LXGETI(LINE(FIRST+1),LAST-FIRST,IFINT,IVALUE)
  11103.       IF(IFINT) GO TO 1000
  11104.       TYP = TEXT
  11105.       IVALUE = 0
  11106.       GO TO 1000
  11107.   200 CONTINUE
  11108. C
  11109. C     *=N?VALUE
  11110. C
  11111.       TYP = REPEAT
  11112.       CALL LXGETI(LINE(FIRST+2),LOOK-FIRST-2,IFINT,IVALUE)
  11113.       IF(.NOT.IFINT) GO TO 250
  11114.       TGEN = INTGER
  11115.       CALL LXGETI(LINE(LOOK),LAST-LOOK+1,IFINT,IGEN)
  11116.       IF(IFINT) GO TO 1000
  11117.       TGEN = REAL
  11118.       CALL LXGETR(LINE(LOOK),LAST-LOOK+1,IFREAL,RGEN)
  11119.       IF(IFREAL) GO TO 1000
  11120.   250 CONTINUE
  11121.       TYP = TEXT
  11122.       IVALUE = 0
  11123.       GO TO 1000
  11124.   900 CONTINUE
  11125. C
  11126. C     COULDNT FIND AN ITEM
  11127. C
  11128.       FIRST = 0
  11129.  1000 CONTINUE
  11130.       RETURN
  11131.       END
  11132.       SUBROUTINE LXSET(WHAT,NEWVAL)
  11133.       INCLUDE rin:TEXT.BLK
  11134. C
  11135. C     THIS ROUTINE IS USED TO RESET PARAMETERS FOR THE LXLREC
  11136. C     GROUP OF ROUTINES.
  11137. C
  11138. C     INPUT  - WHAT.....WHICH PARAMETER TO RESET
  11139. C              NEWVAL...NEW VALUE FOR PARAMETER
  11140. C
  11141. C     POSSIBLE VALUES FOR WHAT
  11142. C       WHAT                                      NEWVAL
  11143. C       ----                                      ------
  11144. C     4HECHO                                      2HON,3HOFF
  11145. C     4HPROM                                      PROMPT CHARACTERS
  11146. C     4HINPT                                      INFIL NAME/NUMBER
  11147. C     4HOTPT                                      OUTFILE NAME/NUMBER
  11148. C     4HDOLL (DOLLAR END-OF-RECORD)               SEE NOTE
  11149. C     4HCOMM (COMMA ITEM DELIMETER)               SEE NOTE
  11150. C     4HSEMI (SEMI-COLON END-OF-RECORD)           SEE NOTE
  11151. C     4HBLAN (BLANK ITEM DELIMITER)               SEE NOTE
  11152. C     4HPLUS (PLUS CONTINUATION CHARACTER)        SEE NOTE
  11153. C     4HQUOT (TEXT ITEM DELIMETER)                SEE NOTE
  11154. C
  11155. C     NOTE - FOR CHARACTER PARAMETERS SUCH AS DOLLAR, THE CHARRACTER
  11156. C            PARAMETER WILL BE REPLACED WITH THE 1ST CHARACTER IN
  11157. C            NEWVAL UNLESS NEWVAL IS NULL.  IN THAT CASE, DOLLAR
  11158. C            WILL NOT BE AN END-OF-RECORD CHARACTER AND WILL NOT BE
  11159. C            REPLACED BY ANY OTHER CHARACTER.
  11160. C
  11161.       INCLUDE rin:LXCON.BLK
  11162.       INCLUDE rin:PROM.BLK
  11163.       INCLUDE rin:LXCARD.BLK
  11164.       INCLUDE rin:LXWRDS.BLK
  11165.       LOGICAL IFNULL
  11166.       INTEGER WHAT
  11167.       DATA ISAVPR /1/
  11168.       DATA JSAVPR /1/
  11169.       IF(WHAT.NE.KYECHO) GO TO 10
  11170. C
  11171. C     ECHO OPTION
  11172. C
  11173.       IF(NEWVAL.EQ.KYON) ECHO = .TRUE.
  11174.       IF(NEWVAL.EQ.KYOFF) ECHO = .FALSE.
  11175.       GO TO 1000
  11176.    10 CONTINUE
  11177.       IF(WHAT.NE.KYPROM) GO TO 15
  11178. C
  11179. C     PROMPT OPTION
  11180. C
  11181.       JSAVPR = ISAVPR
  11182.       ISAVPR = NEWVAL
  11183.       PROM = NEWVAL
  11184.       GO TO 1000
  11185.    15 CONTINUE
  11186.       IF(WHAT.NE.KYINPT) GO TO 20
  11187. C
  11188. C     INPUT FILE NAME
  11189. C
  11190.       NIN = NEWVAL
  11191.       GO TO 1000
  11192.    20 CONTINUE
  11193.       IF(WHAT.NE.KYOTPT) GO TO 30
  11194. C
  11195. C     OUTPUT FILE NAME
  11196. C
  11197.       NOUT = NEWVAL
  11198.       GO TO 1000
  11199.    30 CONTINUE
  11200.       IFNULL = .FALSE.
  11201.       IF(NEWVAL.EQ.NULL) IFNULL = .TRUE.
  11202.       CALL GETT(NEWVAL,1,ICHAR)
  11203.       IF(WHAT.NE.KYDOLL) GO TO 40
  11204. C
  11205. C     DOLLAR
  11206. C
  11207.       DOLLAR = ICHAR
  11208.       IF(IFNULL)DOLLAR = NULL
  11209.       GO TO 1000
  11210.    40 CONTINUE
  11211.       IF(WHAT.NE.KYSEMI) GO TO 50
  11212. C
  11213. C     SEMI-COLON
  11214. C
  11215.       SEMI = ICHAR
  11216.       IF(IFNULL)SEMI = NULL
  11217.       GO TO 1000
  11218.    50 CONTINUE
  11219.       IF(WHAT.NE.KYCOMM) GO TO 60
  11220. C
  11221. C     COMMA
  11222. C
  11223.       COMMA = ICHAR
  11224.       IF(IFNULL)COMMA = NULL
  11225.       GO TO 1000
  11226.    60 CONTINUE
  11227.       IF(WHAT.NE.KYBLAN) GO TO 70
  11228. C
  11229. C     BLANK
  11230. C
  11231.       BLANK = ICHAR
  11232.       IF(IFNULL)BLANK = NULL
  11233.       GO TO 1000
  11234.    70 CONTINUE
  11235.       IF(WHAT.NE.KYPLUS) GO TO 80
  11236. C
  11237. C     PLUS
  11238. C
  11239.       CONT = ICHAR
  11240.       IF(IFNULL)CONT = NULL
  11241.       GO TO 1000
  11242.    80 CONTINUE
  11243. C
  11244. C     QUOTES
  11245. C
  11246.       IF(WHAT.NE.KYQUOT) GO TO 90
  11247.       QUOTES = ICHAR
  11248.       IF(IFNULL) QUOTES = NULL
  11249.       GO TO 1000
  11250.    90 CONTINUE
  11251.       IF(WHAT.NE.KYPRES) GO TO 100
  11252.       IF(JSAVPR.EQ.1) GO TO 100
  11253.       PROM = JSAVPR
  11254.       ITEMP = JSAVPR
  11255.       JSAVPR = ISAVPR
  11256.       ISAVPR = ITEMP
  11257.       GO TO 1000
  11258.   100 CONTINUE
  11259.  1000 CONTINUE
  11260.       RETURN
  11261.       END
  11262.       SUBROUTINE LXSREC(I,CHAR1,NUMC,STRING,START)
  11263.       INCLUDE rin:TEXT.BLK
  11264. C
  11265. C     THIS SUBROUTINE PUTS NUMC CHARACTERS FROM THE I'TH
  11266. C     ITEM INTO STRING STARTING WITH CHAR1 IN ITEM AND
  11267. C     START IN STRING.  THE STRING IS BLANK FILLED IF
  11268. C     THERE IS NOT ENOUGH ITEM OR SET TO ALL BLANKS IF
  11269. C     ITEM IS NOT A VALID TEXT ITEM.
  11270. C
  11271.       INCLUDE rin:LXCON.BLK
  11272.       INCLUDE rin:LXCARD.BLK
  11273.       INTEGER CHAR1,START,STRING(*)
  11274.       NUMB = NUMC
  11275.       ISB = START
  11276.       IF(I.LT.1) GO TO 1000
  11277.       IF(I.GT.NEWN) GO TO 1000
  11278.       IF(CHAR1.LT.1) GO TO 100
  11279.       IF(START.LT.1) GO TO 100
  11280.       IF(TYPE(I).NE.TEXT) GO TO 1000
  11281.       LEN = INT(RVAL(I))
  11282.       IF(CHAR1.GT.LEN) GO TO 100
  11283.       ISC = INTVAL(I)
  11284.       NUM = LEN - CHAR1 + 1
  11285.       IF(NUMC.LT.NUM) NUM = NUMC
  11286.       NUMB = NUMC - NUM
  11287.       ISB = START + NUM
  11288.       CALL STRMOV(NEWREC(ISC),CHAR1,NUM,STRING,START)
  11289.   100 CONTINUE
  11290. C
  11291. C     BLANK FILL
  11292. C
  11293.       DO 110 II=1,NUMB
  11294.       CALL PUTT(STRING,ISB,BLANKS)
  11295.       ISB = ISB + 1
  11296.   110 CONTINUE
  11297.       RETURN
  11298.  1000 CONTINUE
  11299. C
  11300. C     PUT -0- IN TEXT STRING
  11301. C
  11302.       NUM = 3
  11303.       IF(NUMC.LT.NUM) NUM = NUMC
  11304.       CALL STRMOV(NULL,1,NUM,STRING,START)
  11305.       NUMB = NUMC - NUM
  11306.       ISB = START + NUM
  11307.       IF(NUMB.GT.0) GO TO 100
  11308.       RETURN
  11309.       END
  11310.       SUBROUTINE LXSTOR(TYP,I,R,LINE,FIRST,LAST,STRING)
  11311.       INCLUDE rin:TEXT.BLK
  11312. C
  11313. C     THIS ROUTINE STORES AN ITEM IN NEWREC.
  11314. C
  11315. C     INPUT - TYP.....ITEM TYP
  11316. C             I.......ITEM INTEGER VALUE IF INTGER
  11317. C             R.......ITEM REAL VALUE IF REAL
  11318. C             LINE....TEXT STRING
  11319. C             FIRST...FIRST CHARACTER OF TEXT IN LINE
  11320. C             LAST....LAST CHARACTER OF TEXT IN LINE
  11321. C             STRING..LOGICAL .TRUE. IF LINE IS PACKED.
  11322. C                             .FALSE. IF LINE IS ONE CHAR PER WORD.
  11323. C
  11324.       INCLUDE rin:LXCARD.BLK
  11325.       INCLUDE rin:LXCON.BLK
  11326.       LOGICAL STRING
  11327.       INTEGER TYP,FIRST,LAST
  11328.       DIMENSION LINE(*)
  11329.       NEWN = NEWN + 1
  11330.       IF(NEWN.GT.MITEM) GO TO 1000
  11331.       TYPE(NEWN) = TYP
  11332.       IF(TYP.NE.INTGER) GO TO 50
  11333. C
  11334. C     INTEGER
  11335. C
  11336.       INTVAL(NEWN) = I
  11337.       RVAL(NEWN) = 0.
  11338.       GO TO 1000
  11339.    50 CONTINUE
  11340.       IF(TYP.NE.REAL) GO TO 100
  11341. C
  11342. C     REAL
  11343. C
  11344.       RVAL(NEWN) = R
  11345.       INTVAL(NEWN) = 0
  11346.       GO TO 1000
  11347.   100 CONTINUE
  11348.       IF(TYP.NE.TEXT) GO TO 1000
  11349. C
  11350. C     TEXT - BRANCH IF STRING OR ONE CHAR. PER WORD
  11351. C
  11352.       IF(STRING) GO TO 200
  11353. C
  11354. C     CHECK FOR LEADING AND TRAILING QUOTES
  11355. C
  11356.       I1 = FIRST
  11357.       I2 = LAST
  11358.       IF(LINE(I1).EQ.QUOTES) I1 = I1 + 1
  11359.       IF(LINE(I2).EQ.QUOTES) I2 = I2 - 1
  11360.       INTVAL(NEWN) = 1 + NEXT/NCPW
  11361.       IF(I1.GT.I2) GO TO 150
  11362.       J = I1 - 1
  11363.   110 CONTINUE
  11364.       J = J + 1
  11365.       IF(J.EQ.I2) GO TO 120
  11366.       IF(LINE(J) .NE. QUOTES) GO TO 120
  11367.       IF(LINE(J+1) .NE. QUOTES) GO TO 120
  11368.       J = J + 1
  11369.   120 CONTINUE
  11370.       CALL PUTT(NEWREC,NEXT,LINE(J))
  11371.       NEXT = NEXT + 1
  11372.       IF(NEXT.GT.MCHAR) GO TO 1000
  11373.       IF(J.LT.I2) GO TO 110
  11374.   150 CONTINUE
  11375.       GO TO 270
  11376.   200 CONTINUE
  11377. C
  11378. C     STRING - JUST MOVE IT
  11379. C
  11380.       INTVAL(NEWN) = 1 + NEXT/NCPW
  11381.       DO 250 J=FIRST,LAST
  11382.       CALL GETT(LINE,J,IWORD)
  11383.       CALL PUTT(NEWREC,NEXT,IWORD)
  11384.       NEXT = NEXT + 1
  11385.       IF(NEXT.GT.MCHAR) GO TO 1000
  11386.   250 CONTINUE
  11387.   270 CONTINUE
  11388.       LEN = NEXT - INTVAL(NEWN)*NCPW + NCPW - 1
  11389.       RVAL(NEWN) = FLOAT(LEN)
  11390.       NEXT = 1 + NCPW*(1+(NEXT-2)/NCPW)
  11391.  1000 CONTINUE
  11392.       RETURN
  11393.       END
  11394.       SUBROUTINE LXUSET(LINE,LEN,IFSET)
  11395.       INCLUDE rin:TEXT.BLK
  11396. C
  11397. C     THSI ROUTINE CHECKS LINE FOR A USER SET COMMENT.  THESE COMMENTS
  11398. C     ARE OF THE FORM  *(SET KEYWORD=NEWVALUE)
  11399. C     WHERE KEYWORD CAN BE    DOLLAR
  11400. C                             SEMI
  11401. C                             QUOTES
  11402. C                             BLANK
  11403. C                             PLUS
  11404. C                             COMMA
  11405. C                             ECHO
  11406. C     NEWVALUE IS EITHER THE NEW CHARACTER OR THE WORD NULL EXCEPT
  11407. C     ECHO WHICH TAKES ON OR OFF.
  11408. C
  11409. C     INPUT  - LINE - ONE CHARACTER PER WORD
  11410. C              LEN  - LENGTH OF LINE
  11411. C     OUTPUT - IFSET- .TRUE. IF LEN IS BETWEEN 13 AND 18 AND
  11412. C                     THE LINE START *(SET  AND ENDS WITH ).
  11413. C
  11414.       INCLUDE rin:LXCON.BLK
  11415.       INCLUDE rin:LXCARD.BLK
  11416.       INCLUDE rin:LXWRDS.BLK
  11417.       LOGICAL IFSET
  11418.       DIMENSION LINE(LEN)
  11419.       IFSET = .FALSE.
  11420. C
  11421. C     ELIMINATE ANYTHING ELSE
  11422. C
  11423.       IF(LEN.LT.13) GO TO 1000
  11424.       IF(LEN.GT.18) GO TO 1000
  11425.       IF(LINE(1).NE.STAR) GO TO 1000
  11426.       IF(LINE(2).NE.LPAREN) GO TO 1000
  11427.       IF(LINE(3).NE.KYS) GO TO 1000
  11428.       IF(LINE(4).NE.E) GO TO 1000
  11429.       IF(LINE(5).NE.KYT) GO TO 1000
  11430.       IF(LINE(6).NE.BLANKS) GO TO 1000
  11431.       IF(LINE(LEN).NE.RPAREN) GO TO 1000
  11432. C
  11433. C     FOUND A SET COMMAND
  11434. C
  11435.       IFSET = .TRUE.
  11436. C
  11437. C     SEE IF ECHO COMMAND
  11438. C
  11439.       IF(LINE(7).NE.E) GO TO 5
  11440.       IF(LINE(8).NE.KYC) GO TO 5
  11441.       IF(LINE(9).NE.KYH) GO TO 5
  11442.       IF(LINE(10).EQ.KYO) GO TO 800
  11443.     5 CONTINUE
  11444. C
  11445. C     LOOK BETWEEN = AND END FOR NULL OR SINGLE CHARACTER
  11446. C
  11447.       IE = 10
  11448.       DO 10 I=1,3
  11449.       IE = IE + 1
  11450.       IF(LINE(IE).EQ.EQUALS) GO TO 20
  11451.    10 CONTINUE
  11452.       GO TO 900
  11453.    20 CONTINUE
  11454.       NUM = LEN - IE - 1
  11455.       NEWVAL = LINE(IE+1)
  11456.       IF(NUM.EQ.1) GO TO 50
  11457.       IF(NUM.NE.4) GO TO 900
  11458. C
  11459. C     CHECK FOR NULL
  11460. C
  11461.       NEWVAL = NULL
  11462.       IF(LINE(IE+1).NE.KYN) GO TO 900
  11463.       IF(LINE(IE+2).NE.KYU) GO TO 900
  11464.       IF(LINE(IE+3).NE.KYL) GO TO 900
  11465.       IF(LINE(IE+4).NE.KYL) GO TO 900
  11466.    50 CONTINUE
  11467.       IF(LINE(7).NE.KYC) GO TO 100
  11468. C
  11469. C     COMMA
  11470. C
  11471.       IF(LINE(8).NE.KYO) GO TO 900
  11472.       IF(LINE(9).NE.KYM) GO TO 900
  11473.       IF(LINE(10).NE.KYM) GO TO 900
  11474.       IF(LINE(11).NE.KYA) GO TO 900
  11475.       COMMA = NEWVAL
  11476.       GO TO 1000
  11477.   100 CONTINUE
  11478.       IF(LINE(7).NE.KYD) GO TO 150
  11479. C
  11480. C     DOLLAR
  11481. C
  11482.       IF(LINE(8).NE.KYO) GO TO 900
  11483.       IF(LINE(9).NE.KYL) GO TO 900
  11484.       IF(LINE(10).NE.KYL) GO TO 900
  11485.       IF(LINE(11).NE.KYA) GO TO 900
  11486.       IF(LINE(12).NE.KYR) GO TO 900
  11487.       DOLLAR = NEWVAL
  11488.       GO TO 1000
  11489.   150 CONTINUE
  11490.       IF(LINE(7).NE.KYB) GO TO 200
  11491. C
  11492. C     BLANK
  11493. C
  11494.       IF(LINE(8).NE.KYL) GO TO 900
  11495.       IF(LINE(9).NE.KYA) GO TO 900
  11496.       IF(LINE(10).NE.KYN) GO TO 900
  11497.       IF(LINE(11).NE.KYK) GO TO 900
  11498.       BLANK = NEWVAL
  11499.       GO TO 1000
  11500.   200 CONTINUE
  11501.       IF(LINE(7).NE.KYP) GO TO 250
  11502. C
  11503. C     PLUS
  11504. C
  11505.       IF(LINE(8).NE.KYL) GO TO 900
  11506.       IF(LINE(9).NE.KYU) GO TO 900
  11507.       IF(LINE(10).NE.KYS) GO TO 900
  11508.       PLUS = NEWVAL
  11509.       GO TO 1000
  11510.   250 CONTINUE
  11511.       IF(LINE(7).NE.KYQ) GO TO 300
  11512. C
  11513. C     QUOTES
  11514. C
  11515.       IF(LINE(8).NE.KYU) GO TO 900
  11516.       IF(LINE(9).NE.KYO) GO TO 900
  11517.       IF(LINE(10).NE.KYT) GO TO 900
  11518.       IF(LINE(11).NE.KYE) GO TO 900
  11519.       IF(LINE(12).NE.KYS) GO TO 900
  11520.       QUOTES = NEWVAL
  11521.       GO TO 1000
  11522.   300 CONTINUE
  11523. C
  11524. C     SEMI
  11525. C
  11526.       IF(LINE(7).NE.KYS) GO TO 900
  11527.       IF(LINE(8).NE.E) GO TO 900
  11528.       IF(LINE(9).NE.KYM) GO TO 900
  11529.       IF(LINE(10).NE.KYI) GO TO 900
  11530.       SEMI = NEWVAL
  11531.       GO TO 1000
  11532.   800 CONTINUE
  11533. C
  11534. C     ECHO
  11535. C
  11536.       IF(LINE(12).NE.KYO) GO TO 900
  11537.       IF(LINE(13).NE.KYF) GO TO 850
  11538. C
  11539. C     OFF
  11540. C
  11541.       IF(LEN.NE.15) GO TO 900
  11542.       IF(LINE(14).NE.KYF) GO TO 900
  11543.       ECHO = .FALSE.
  11544.       GO TO 1000
  11545.   850 CONTINUE
  11546. C
  11547. C     ON
  11548. C
  11549.       IF(LEN.NE.14) GO TO 900
  11550.       IF(LINE(13).NE.KYN) GO TO 900
  11551.       ECHO = .TRUE.
  11552.       GO TO 1000
  11553.   900 CONTINUE
  11554. C
  11555. C     UNRECOGNIZABLE SET COMMAND
  11556. C
  11557.     if(nout.eq.6)goto 3140
  11558.       IF(NOUT.NE.0)WRITE(NOUT,910)
  11559.   910 FORMAT(46H *** WARNING *** Did NOT Recognize SET Command)
  11560.  1000 CONTINUE
  11561.       RETURN
  11562. 3140    continue
  11563.     write(c128wk,910)
  11564.     call atxto
  11565.     return
  11566.       END
  11567.       FUNCTION LXWREC(I,J)
  11568.       INCLUDE rin:TEXT.BLK
  11569. C
  11570. C     THIS FUNCTION RETURNS THE JTH WORD OF ITEM I IF TEXT
  11571. C     IF I IS NOT A VALID TEXT ITEM BLANKS ARE RETURNED.
  11572. C
  11573.       INCLUDE rin:LXCARD.BLK
  11574.       INCLUDE rin:LXCON.BLK
  11575.       LXWREC = BLANKS
  11576.       IF(I.LT.1) RETURN
  11577.       IF(I.GT.NEWN) RETURN
  11578.       IF(J.LT.1) RETURN
  11579.       IF(TYPE(I).NE.TEXT) RETURN
  11580.       LEN = INT(RVAL(I))
  11581.       I1 = (J-1)*NCPW
  11582.       IF(I1.GE.LEN) RETURN
  11583.       K = INTVAL(I) + J - 1
  11584.       LXWREC = NEWREC(K)
  11585.       RETURN
  11586.       END
  11587.       SUBROUTINE MINMAX(MMVAL,MMTYP)
  11588.       INCLUDE rin:TEXT.BLK
  11589. C
  11590. C  PURPOSE:  PROCESS THE MIN/MAX REQUESTS
  11591. C
  11592. C  PARAMETERS: MMVAL--MIN/MAX VALUE
  11593. C              MMTYP--3HMIN OR 3HMAX (REQUEST TYPE)
  11594. C
  11595.       INCLUDE rin:RMATTS.BLK
  11596.       INCLUDE rin:CONST4.BLK
  11597.       INCLUDE rin:BTBUF.BLK
  11598.       INCLUDE rin:BUFFER.BLK
  11599.       INCLUDE rin:F3COM.BLK
  11600.       INCLUDE rin:TUPLEA.BLK
  11601.       INCLUDE rin:RIMCOM.BLK
  11602.       INCLUDE rin:MISC.BLK
  11603. C
  11604.       DIMENSION MMVAL(*)
  11605.       EQUIVALENCE (IMVAL,RMVAL)
  11606.       EQUIVALENCE (IV,RV)
  11607.       CALL TYPER(ATTYPE,MATVEC,ITYPE)
  11608.       MMVAL(1) = NULL
  11609. C
  11610. C  CHECK FOR A KEYED ATTRIBUTE
  11611. C
  11612.       IF(ATTKEY.NE.0) GO TO 300
  11613. C
  11614. C  NON-KEYED ATTRIBUTE -- PROCESS THE FUNCTION
  11615. C
  11616.   100 CALL RMLOOK(IP,1,1,LEN)
  11617.       IF(RMSTAT.NE.0) GO TO 998
  11618.       MMVAL(1) = BUFFER(IP+ATTCOL-1)
  11619.       MMVAL(2) = BUFFER(IP+ATTCOL)
  11620.       IF(MMVAL(1).EQ.NULL) GO TO 100
  11621.   200 CALL RMLOOK(IP,1,1,LEN)
  11622.       IF(RMSTAT.NE.0) GO TO 998
  11623.       IV = BUFFER(IP+ATTCOL-1)
  11624.       IF(IV.EQ.NULL) GO TO 200
  11625.       IF((ITYPE.EQ.KZDOUB).OR.(ITYPE.EQ.KZREAL)) GO TO 210
  11626.       IF((MMTYP.EQ.K4MIN).AND.(IV.GT.MMVAL(1))) GO TO 200
  11627.       IF((MMTYP.EQ.K4MAX).AND.(IV.LT.MMVAL(1))) GO TO 200
  11628.       GO TO 220
  11629.   210 CONTINUE
  11630.       IMVAL = MMVAL(1)
  11631.       IF((MMTYP.EQ.K4MIN).AND.(RV.GT.RMVAL)) GO TO 200
  11632.       IF((MMTYP.EQ.K4MAX).AND.(RV.LT.RMVAL)) GO TO 200
  11633.   220 CONTINUE
  11634.       MMVAL(1) = IV
  11635.       MMVAL(2) = BUFFER(IP+ATTCOL)
  11636.       GO TO 200
  11637. C
  11638. C  KEYED ATTRIBUTE -- PROCESS THE FUNCTION
  11639. C
  11640.   300 IF(MMTYP.EQ.K4MAX) GO TO 400
  11641. C
  11642. C  GET THE MIN VALUE FROM THE BTREE
  11643. C
  11644.       KSTART = ATTKEY
  11645.   310 CALL BTGET(KSTART,IN)
  11646.       IF(VALUE(2,IN).GE.0) GO TO 320
  11647. C
  11648. C  GET THE NEXT NODE
  11649. C
  11650.       KSTART = -VALUE(2,IN)
  11651.       GO TO 310
  11652. C
  11653. C  WE FOUND THE MINIMUM
  11654. C
  11655.   320 CONTINUE
  11656.       MMVAL(1) = VALUE(1,IN)
  11657.       IF(ATTYPE.NE.KZDOUB) GO TO 998
  11658.       CALL GETDAT(1,VALUE(2,IN),IP,LEN)
  11659.       MMVAL(1) = BUFFER(IP+ATTCOL-1)
  11660.       MMVAL(2) = BUFFER(IP+ATTCOL)
  11661.       GO TO 998
  11662. C
  11663. C  GET THE MAXIMUM VALUE FROM THE BTREE
  11664. C
  11665.   400 CONTINUE
  11666.       KSTART = ATTKEY
  11667.   410 CALL BTGET(KSTART,IN)
  11668.       KEND = IN + (LENBF3/3) - 1
  11669.       DO 420 J=IN,KEND
  11670.       IF(VALUE(1,J).EQ.ENDWRD) GO TO 430
  11671.   420 CONTINUE
  11672.       GO TO 998
  11673. C
  11674. C  CHECK IF WE REACHED THE BOTTOM NODE
  11675. C
  11676.   430 CONTINUE
  11677.       IF(VALUE(2,J).GE.0) GO TO 440
  11678. C
  11679. C  GET THE NEXT NODE
  11680. C
  11681.       KSTART = -VALUE(2,J)
  11682.       GO TO 410
  11683. C
  11684. C  FOUND THE MAXIMUM NODE
  11685. C
  11686.   440 CONTINUE
  11687.       MMVAL(1) = VALUE(1,J-1)
  11688.       IF(ATTYPE.NE.KZDOUB) GO TO 998
  11689.       CALL GETDAT(1,VALUE(2,J-1),IP,LEN)
  11690.       MMVAL(1) = BUFFER(IP+ATTCOL-1)
  11691.       MMVAL(2) = BUFFER(IP+ATTCOL)
  11692.       GO TO 998
  11693. C
  11694. C  CHECK THAT A VALUE WAS OBTAINED
  11695. C
  11696.   998 CONTINUE
  11697.       RMSTAT = 0
  11698.       IF(MMVAL(1).NE.NULL) GO TO 999
  11699. C
  11700. C  ERROR - NULL VALUE
  11701. C
  11702.       RMSTAT = 44
  11703.   999 CONTINUE
  11704.       RETURN
  11705.       END
  11706.       SUBROUTINE MODIFY
  11707.       INCLUDE rin:TEXT.BLK
  11708. C
  11709. C  THIS ROUTINE IS THE DRIVER FOR MODIFY OF THE RIM DATA BASE.
  11710. C
  11711.       INCLUDE rin:CONST8.BLK
  11712.       INCLUDE rin:RMKEYW.BLK
  11713.       INCLUDE rin:RIMCOM.BLK
  11714.       INCLUDE rin:TUPLEA.BLK
  11715.       INCLUDE rin:TUPLER.BLK
  11716.       INCLUDE rin:ATTBLE.BLK
  11717.       INCLUDE rin:FLAGS.BLK
  11718.       INCLUDE rin:BUFFER.BLK
  11719.       INCLUDE rin:FILES.BLK
  11720.       INCLUDE rin:MISC.BLK
  11721.       LOGICAL EQKEYW
  11722.       LOGICAL NE
  11723.       LOGICAL EQ
  11724.       INCLUDE rin:DCLAR1.BLK
  11725.       INCLUDE rin:DCLAR6.BLK
  11726.       NEXTOP = K8READ
  11727. C
  11728. C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
  11729. C
  11730.       CALL RMDBLK(DBNAME)
  11731.       IF(RMSTAT.EQ.0) GO TO 200
  11732.       CALL WARN(RMSTAT,DBNAME,0)
  11733.       GO TO 5000
  11734. C
  11735. C  READ A CARD
  11736. C
  11737.   100 CONTINUE
  11738.       CALL LODREC
  11739. C
  11740. C  SCAN A COMMAND.
  11741. C
  11742.   200 CONTINUE
  11743.       IFMOD = .TRUE.
  11744.       ITEMS = LXITEM(NUM)
  11745.       IF(EQKEYW(1,KWCHAN,6)) GO TO 400
  11746.       IF(EQKEYW(1,KWRENA,6)) GO TO 1000
  11747.       IF(EQKEYW(1,KWREMO,6)) GO TO 2000
  11748.       IF(EQKEYW(1,KWDELE,6)) GO TO 3000
  11749. C
  11750. C  UNRECOGNIZED COMMAND.
  11751. C
  11752.   300 CONTINUE
  11753.       NEXTOP = K8USE
  11754.       GO TO 5000
  11755. C
  11756. C  *************************
  11757. C  CHANGE COMMAND.
  11758. C  *************************
  11759. C
  11760.   400 CONTINUE
  11761.       IF(ITEMS.LT.4) GO TO 4000
  11762.       ITO = LFIND(1,ITEMS,KWTO,2)
  11763.       IF(ITO.LT.3) GO TO 4000
  11764.       IF(ITO.GT.7) GO TO 4000
  11765. C
  11766. C     LOOK FOR CHANGE OWNER
  11767. C
  11768.       IF(EQKEYW(2,KWOWNE,5)) GO TO 1005
  11769. C
  11770. C  SEE IF THIS IS A CHANGE FOR PASSWORDS.
  11771. C
  11772.       IF(EQKEYW(2,KWRPW,3)) GO TO 410
  11773.       IF(EQKEYW(2,KWMPW,3)) GO TO 410
  11774.       GO TO 450
  11775. C
  11776. C  CHANGE THE PASSWORDS.
  11777. C
  11778.   410 CONTINUE
  11779.       IF(ITO.NE.3) GO TO 4000
  11780.       IF(.NOT.EQKEYW(5,KWFOR,3)) GO TO 4000
  11781.       IF(ITEMS.NE.6) GO TO 4000
  11782.       RNAME = BLANK
  11783.       CALL LXSREC(6,1,8,RNAME,1)
  11784.       I = LOCREL(RNAME)
  11785.       IF(I.EQ.0) GO TO 420
  11786.       CALL WARN(1,RNAME,0)
  11787.       GO TO 100
  11788.   420 CONTINUE
  11789.       L = LOCPRM(RNAME,2)
  11790.       IF(L.NE.0) GO TO 4500
  11791.       IF((LXLENC(4).GE.1).AND.(LXLENC(4).LE.8)) GO TO 425
  11792.     if(nout.eq.6)goto 3140
  11793.       WRITE(NOUT,422)
  11794.   422 FORMAT(44H -ERROR- PASSWORDS Must Be 1-8 Alphanumeric ,
  11795.      X       10HCharacters)
  11796.       GO TO 100
  11797. 3140    continue
  11798.     write(c128wk,422)
  11799.     call atxto
  11800.     goto 100
  11801.   425 CONTINUE
  11802.       CALL RELGET(ISTAT)
  11803. C
  11804. C  CHANGE THE PASSWORD.
  11805. C
  11806.       IF(.NOT.EQKEYW(2,KWRPW,3)) GO TO 430
  11807.       RPW = BLANK
  11808.       CALL LXSREC(4,1,8,RPW,1)
  11809.       GO TO 440
  11810.   430 CONTINUE
  11811.       MPW = BLANK
  11812.       CALL LXSREC(4,1,8,MPW,1)
  11813.   440 CONTINUE
  11814.       CALL RELPUT
  11815.       GO TO 100
  11816.   450 CONTINUE
  11817. C
  11818. C  DEFINE THE BUFFERS FOR CHANGE
  11819. C
  11820.       CALL BLKDEF(10,MAXCOL,1)
  11821. C
  11822. C  USE HALF PAGE BUFFER FOR NEW ATTRIBUTE VALUE
  11823. C
  11824.       NCOLU = MAXCOL/2
  11825.       CALL BLKDEF(11,NCOLU,1)
  11826. C
  11827. C  SCAN FOR THE WORD FROM OR IN.
  11828. C
  11829.       IFLAG = 0
  11830.       J = LFIND(1,ITEMS,KWIN,2)
  11831.       RNAME = BLANK
  11832.       CALL LXSREC(J+1,1,8,RNAME,1)
  11833.       IF(J.NE.0) GO TO 460
  11834.       J = LFIND(1,ITEMS,KWFROM,4)
  11835.       RNAME = BLANK
  11836.       CALL LXSREC(J+1,1,8,RNAME,1)
  11837.       IF(J.NE.0) GO TO 460
  11838. C
  11839. C  ALL RELATIONS.
  11840. C
  11841.       IFLAG = 1
  11842.       RNAME = BLANK
  11843.   460 CONTINUE
  11844. C
  11845. C  SCAN THROUGH THE ATTRIBUTE TABLE LOOKING FOR THE ATTRIBUTE.
  11846. C
  11847.       NAC = 0
  11848.       NA = 0
  11849.       ANAME = BLANK
  11850.       CALL LXSREC(2,1,8,ANAME,1)
  11851.       I = LOCATT(ANAME,RNAME)
  11852.       IF(I.EQ.0) GO TO 500
  11853.       CALL WARN(3,ANAME,RNAME)
  11854.       GO TO 100
  11855.   500 CONTINUE
  11856.       NA = NA + 1
  11857.       I = LOCATT(ANAME,RNAME)
  11858.       DO 550 I=1,NA
  11859.       CALL ATTGET(ISTAT)
  11860.       IF(ISTAT.NE.0) GO TO 800
  11861.   550 CONTINUE
  11862. C
  11863. C  FIND THE RELATION NAME IN RELATION TABLE.
  11864. C
  11865.       I = LOCREL(RELNAM)
  11866.       IF(I.EQ.0) GO TO 600
  11867. C
  11868. C  UNRECOGNIZED RELATION NAME.
  11869. C
  11870.       CALL WARN(1,RELNAM,0)
  11871.       GO TO 100
  11872.   600 CONTINUE
  11873.       CALL RELGET(ISTAT)
  11874. C
  11875. C  CHECK FOR AUTHORIZATION.
  11876. C
  11877.       L = LOCPRM(RELNAM,2)
  11878.       IF(L.EQ.0) GO TO 700
  11879.       IF(IFLAG.EQ.1) GO TO 500
  11880.       GO TO 4500
  11881.   700 CONTINUE
  11882. C
  11883. C  CALL CHANGE TO FINISH PROCESSING THE COMMAND.
  11884. C
  11885.       KQ1 = BLKLOC(10)
  11886.       KQ11 = BLKLOC(11)
  11887.       CALL RMDATE(RDATE)
  11888.       NAC = NAC + 1
  11889.       CALL CHANGE(BUFFER(KQ1),BUFFER(KQ11))
  11890.       IF(IFLAG.EQ.0) GO TO 100
  11891.       GO TO 500
  11892.   800 CONTINUE
  11893.     if(nac.ne.0)goto 100
  11894.     if(nout.eq.6)goto 3141
  11895.        WRITE(NOUT,9001)
  11896.  9001 FORMAT(20H      0 ROWS CHANGED )
  11897.       GO TO 100
  11898. 3141    continue
  11899.     write(c128wk,9001)
  11900.     call atxto
  11901.     goto 100
  11902. C
  11903. C  *************************
  11904. C  RENAME COMMAND.
  11905. C  *************************
  11906. C
  11907.  1000 CONTINUE
  11908. C
  11909. C  CHECK RENAME SYNTAX
  11910. C
  11911.       IF(EQKEYW(2,KWRELA,8)) GO TO 1100
  11912.       IATT = 2
  11913.       IF(EQKEYW(2,KWATTR,9)) GO TO 1050
  11914.       IATT = 1
  11915.       GO TO 1050
  11916.  1005 CONTINUE
  11917. C
  11918. C  CHANGE THE OWNER.
  11919. C
  11920.       IF(NE(USERID,OWNER)) GO TO 1010
  11921.       IF(ITEMS.NE.4) GO TO 4000
  11922.       IF((LXLENC(4).GE.1).AND.(LXLENC(4).LE.8)) GO TO 1008
  11923.       CALL WARN(7,KWOWNE,BLANK)
  11924.       GO TO 100
  11925.  1008 CONTINUE
  11926.       OWNER = BLANK
  11927.       CALL LXSREC(4,1,8,OWNER,1)
  11928.       GO TO 100
  11929. C
  11930. C  UNABLE TO CHANGE THE OWNER.
  11931. C
  11932.  1010 CONTINUE
  11933.     if(nout.eq.6)goto 3142
  11934.       WRITE(NOUT,9002)
  11935.  9002 FORMAT(41H -ERROR- Unauthorized To Change The OWNER)
  11936.       GO TO 100
  11937. 3142    continue
  11938.     write(c128wk,9002)
  11939.     call atxto
  11940.     goto 100
  11941.  1050 CONTINUE
  11942. C
  11943. C     RENAME ATTRIBUTE
  11944. C
  11945.       CALL RNAMEA(IATT)
  11946.       GO TO 100
  11947.  1100 CONTINUE
  11948. C
  11949. C     RENAME RELATION
  11950. C
  11951.       CALL RNAMER
  11952.       GO TO 100
  11953. C+  MAKE SURE THAT THE RULES GET CHANGED AS NEEDED
  11954. C
  11955. C  *************************
  11956. C  REMOVE COMMAND.
  11957. C  *************************
  11958. C
  11959.  2000 CONTINUE
  11960.       RNAME = BLANK
  11961.       CALL LXSREC(2,1,8,RNAME,1)
  11962.       IF(ITEMS.NE.2) GO TO 4000
  11963. C
  11964. C  FIND THE RELATION NAME IN THE RELATION TABLE.
  11965. C
  11966.       I = LOCREL(RNAME)
  11967.       IF(I.EQ.0) GO TO 2200
  11968. C
  11969. C  UNRECOGNIZED RELATION NAME.
  11970. C
  11971.       CALL WARN(1,RNAME,0)
  11972.       GO TO 100
  11973.  2200 CONTINUE
  11974. C
  11975. C  CHECK FOR AUTHORIZATION.
  11976. C
  11977.       L = LOCPRM(RNAME,2)
  11978.       IF(L.NE.0) GO TO 4500
  11979. C
  11980. C  CHANGE THE RELATION TABLE.
  11981. C
  11982.       CALL RELGET(ISTAT)
  11983.       CALL RELDEL
  11984. C
  11985. C  CHANGE THE ATTRIBUTE TABLE.
  11986. C
  11987.       I = LOCATT(BLANK,RNAME)
  11988.       IF(I.NE.0) GO TO 100
  11989.  2300 CONTINUE
  11990.       CALL ATTGET(ISTAT)
  11991.       IF(ISTAT.NE.0) GO TO 100
  11992.       CALL ATTDEL(ISTAT)
  11993.       IF(ISTAT.NE.0) GO TO 100
  11994.       GO TO 2300
  11995. C
  11996. C  *************************
  11997. C  DELETE COMMAND.
  11998. C  *************************
  11999. C
  12000.  3000 CONTINUE
  12001.       IF(EQKEYW(2,KWKEY,3)) GO TO 3600
  12002.       IF(EQKEYW(2,KWRULE,4)) GO TO 3900
  12003. C
  12004. C   FIND THE WORD FROM OR IN
  12005. C
  12006.       J = LFIND(1,ITEMS,KWFROM,4)
  12007.       IF(J.NE.0) GO TO 3100
  12008.       J = LFIND(1,ITEMS,KWIN,2)
  12009.       IF(J.EQ.0) GO TO 4000
  12010.  3100 CONTINUE
  12011.       IF(EQKEYW(2,KWTUPL,6)) GO TO 3200
  12012.       IF(EQKEYW(2,KWROWS,4)) GO TO 3200
  12013.       IF(EQKEYW(2,KWDUPL,10)) GO TO 3200
  12014.       GO TO 4000
  12015.  3200 CONTINUE
  12016. C
  12017. C  FIND THE RELATION NAME IN THE RELATION TABLE.
  12018. C
  12019.       RNAME = BLANK
  12020.       CALL LXSREC(J+1,1,8,RNAME,1)
  12021.       I = LOCREL(RNAME)
  12022.       IF(I.EQ.0) GO TO 3300
  12023. C
  12024. C  UNRECOGNIZED RELATION NAME.
  12025. C
  12026.       CALL WARN(1,RNAME,0)
  12027.       GO TO 100
  12028.  3300 CONTINUE
  12029. C
  12030. C  CHECK FOR AUTHORIZATION.
  12031. C
  12032.       L = LOCPRM(RNAME,2)
  12033.       IF(L.NE.0) GO TO 4500
  12034.       IF(EQKEYW(2,KWDUPL,10)) GO TO 3500
  12035. C
  12036. C  CALL DELETE TO FINISH PROCESSING THE COMMAND.
  12037. C
  12038.       CALL BLKDEF(10,MAXCOL,1)
  12039.       KQ1 = BLKLOC(10)
  12040.       CALL DELETE(BUFFER(KQ1))
  12041.       CALL BLKCLR(10)
  12042.       GO TO 100
  12043. C
  12044. C  CALL DELDUP TO DELETE ALL DUPLICATES FROM THE RELATION.
  12045. C
  12046.  3500 CONTINUE
  12047.       CALL BLKDEF(10,MAXCOL,1)
  12048.       KQ1 = BLKLOC(10)
  12049.       CALL DELDUP(BUFFER(KQ1))
  12050.       CALL BLKCLR(10)
  12051.       GO TO 100
  12052. C
  12053. C  REMOVE THE KEY FOR AN ATTRIBUTE.
  12054. C
  12055.  3600 CONTINUE
  12056.       IF(ITEMS.GT.6) GO TO 4000
  12057.       RNAME = BLANK
  12058.       CALL LXSREC(6,1,8,RNAME,1)
  12059.       I = LOCREL(RNAME)
  12060.       IF(I.EQ.0) GO TO 3700
  12061. C
  12062. C  UNRECOGNIZED RELATION NAME.
  12063. C
  12064.       CALL WARN(1,RNAME,0)
  12065.       GO TO 100
  12066.  3700 CONTINUE
  12067. C
  12068. C  CHECK FOR AUTHORIZATION.
  12069. C
  12070.       L = LOCPRM(RNAME,2)
  12071.       IF(L.NE.0) GO TO 4500
  12072.       NAMOLD = BLANK
  12073.       CALL LXSREC(4,1,8,NAMOLD,1)
  12074.       I = LOCATT(NAMOLD,RNAME)
  12075.       IF(I.EQ.0) GO TO 3800
  12076.       CALL WARN(3,NAMOLD,RNAME)
  12077.       GO TO 100
  12078.  3800 CONTINUE
  12079. C
  12080. C  CHANGE THE KEY POINTER TO 0.
  12081. C
  12082.       CALL ATTGET(ISTAT)
  12083.       ATTKEY = 0
  12084.       CALL ATTPUT(ISTAT)
  12085.       GO TO 100
  12086. C
  12087. C  DELETE A RULE.
  12088. C
  12089.  3900 CONTINUE
  12090. C
  12091. C  CHECK FOR PERMISSION
  12092. C
  12093.       IF(EQ(USERID,OWNER)) GO TO 3950
  12094.     if(nout.eq.6)goto 3145
  12095.       WRITE(NOUT,3910)
  12096.  3910 FORMAT(41H -ERROR- Unauthorized Access To The RULES )
  12097.       GO TO 100
  12098. 3145    continue
  12099.     write(c128wk,3910)
  12100.     call atxto
  12101.     goto 100
  12102. C
  12103. C  GET THE RULE NUMBER AND CALL RULDEL
  12104. C
  12105.  3950 CONTINUE
  12106.       NUMRUL = LXIREC(3)
  12107.       RNAME = K8RRC
  12108.       CALL RULDEL(RNAME,NUMRUL)
  12109.       IF(RMSTAT.EQ.110) GO TO 100
  12110.       RNAME = K8RDT
  12111.       CALL RULDEL(RNAME,NUMRUL)
  12112.       GO TO 100
  12113. C
  12114. C  SYNTAX ERRORS.
  12115. C
  12116.  4000 CONTINUE
  12117.       CALL WARN(4,0,0)
  12118.       GO TO 100
  12119. C
  12120. C  ILLEGAL RELATION ACCESS - WRONG PASSWORD
  12121. C
  12122.  4500 CONTINUE
  12123.       CALL WARN(9,RNAME,0)
  12124.       RMSTAT = 0
  12125.       GO TO 100
  12126. C
  12127. C  FINAL PRINT.
  12128. C
  12129.  5000 CONTINUE
  12130.       CALL BLKCLR(10)
  12131.       CALL BLKCLR(11)
  12132.       RETURN
  12133.       END
  12134.       SUBROUTINE MOTSCN(MOTID,IPTR)
  12135.       INCLUDE rin:TEXT.BLK
  12136. C
  12137. C  PURPOSE:  SCAN THROUGH A MULTIPLE OCCURENCE TABLE (MOT)
  12138. C
  12139. C  PARAMETERS
  12140. C    INPUT:  MOTID---ID FOR THIS WORD
  12141. C    OUTPUT: MOTID---ID FOR MOT WORD NEXT TIME OR 0
  12142. C                    (0 IMPLIES THIS IS THE LAST VALUE)
  12143. C            IPTR----USER POINTER DESIRED
  12144. C
  12145. C  DECLARATIVES
  12146.       INCLUDE rin:BTBUF.BLK
  12147. C
  12148. C  CHECK FOR END OF MOT LIST.
  12149. C
  12150.   100 CONTINUE
  12151.       IF(MOTID.EQ.0) RETURN
  12152. C
  12153. C  GET THE MOT BLOCK THAT IS NEEDED.
  12154. C
  12155.       CALL ITOH(MOTIND,MOTIDP,MOTID)
  12156.       CALL BTGET(MOTIDP,IN)
  12157.       IND = 3 * IN - 3
  12158.       MOTIND = MOTIND + IND
  12159. C
  12160. C  RETRIEVE THE NEEDED WORD.
  12161. C
  12162.       MOTID = CORE(MOTIND)
  12163.       IPTR = CORE(MOTIND+1)
  12164.       IF(IPTR.EQ.0) GO TO 100
  12165. C
  12166. C  RETURN WITH THE VALUES.
  12167. C
  12168.       RETURN
  12169.       END
  12170.       LOGICAL FUNCTION NE(WORD1,WORD2)
  12171.       INCLUDE rin:TEXT.BLK
  12172. C
  12173. C  PURPOSE:   COMPARE WORD1 AND WORD2 FOR NE
  12174. C
  12175. C  PARAMETERS:
  12176. C         WORD1---A WORD OF TEXT
  12177. C         WORD2---ANOTHER WORD OF TEXT
  12178. C         NE------.TRUE. IF WORD1.NE.WORD2
  12179. C                 .FALSE. IF NOT NE
  12180.       INCLUDE rin:DCLAR6.BLK
  12181. C
  12182.       NE = WORD1.NE.WORD2
  12183.       RETURN
  12184.       END
  12185.       INTEGER FUNCTION NSCAN(STR1,IC1,LC1,STR2,IC2,LC2)
  12186.       INCLUDE rin:TEXT.BLK
  12187. C
  12188. C  PURPOSE:   LOCATE THE FIRST CHARACTER IN STR1 WHICH DOES
  12189. C             NOT MATCH THE CHARACTERS IN STR2
  12190. C
  12191. C  PARAMETERS:
  12192. C     STR1----FIRST HOLLERITH STRING
  12193. C     IC1-----STARTING CHARACTER IN STR1 TO START THE SCAN
  12194. C     LC1-----LENGTH OF STR1
  12195. C     STR2----SECOND HOLLERITH STRING
  12196. C     IC2-----STARTING CHARACTER IN STR2
  12197. C     LC2-----LENGTH OF STR2
  12198. C     NSCAN---CHARACTER POSITION IN STR1 OF FIRST MISMATCH
  12199. C             0 IF ALL MATCH
  12200. C
  12201.       Character*1 STR1(*)
  12202.       Character*1 STR2(*)
  12203. C
  12204. C  IF LC1 IS NEGATIVE THE SCAN IS RIGHT TO LEFT.
  12205. C
  12206.       INC = 1
  12207.       IF(LC1.LT.0) INC = -1
  12208.       LC = INC * LC1
  12209.       I1 = IC1
  12210. C
  12211. C  SCAN STR1.
  12212. C
  12213.       DO 200 I=1,LC
  12214.       I2 = IC2 - 1
  12215.       DO 100 J=1,LC2
  12216.       I2 = I2 + 1
  12217.       IF(STR1(I1).NE.STR2(I2)) GO TO 300
  12218.   100 CONTINUE
  12219.       I1 = I1 + INC
  12220.   200 CONTINUE
  12221. C
  12222. C  ALL CHARACTERS MATCH.
  12223. C
  12224.       NSCAN = 0
  12225.       RETURN
  12226. C
  12227. C  WE FOUND A NON-MATCHING CHARACTER.
  12228. C
  12229.   300 CONTINUE
  12230.       NSCAN = I1
  12231.       RETURN
  12232.       END
  12233.       SUBROUTINE PARVAL(ID,MAT,ATYPE,NWORDS,ROW,NCOLT,IERR)
  12234.       INCLUDE rin:TEXT.BLK
  12235. C
  12236. C     THIS ROUTINE PARSES A VALUE SPECIFICATION AND STORES THE
  12237. C     VALUE IN MAT.
  12238. C
  12239. C     PARAMETERS.......
  12240. C     ID.......INPUT - STARTING LXLREC ITEM NUMBER
  12241. C              OUTPUT- 1+ITEM NUMBER OF LAST ITEM IN VALUE
  12242. C     MAT......OUTPUT- ARRAY OF VALUES
  12243. C     ATYPE....INPUT - RVEC,IMAT,DOUB STUFF
  12244. C     NWORDS...INPUT - NWORDS PART OF ATTLEN
  12245. C              OUTPUT- ACTUAL NWORDS
  12246. C     ROW......INPUT - OTHER PART OF ATTLEN
  12247. C              OUTPUT- ACTUAL VALUE
  12248. C     IERR.....OUTPUT- ERROR FLAG
  12249. C                      0 MEANS OK
  12250. C                      1 IF TYPE MISMATCH
  12251. C                      2 IF COUNT MISMATCH
  12252. C                      3 IF PAREN MISMATCH
  12253. C
  12254.       INCLUDE rin:RMATTS.BLK
  12255.       INCLUDE rin:CONST4.BLK
  12256.       INCLUDE rin:FILES.BLK
  12257.       INCLUDE rin:MISC.BLK
  12258.       INTEGER ATYPE,VECMAT,TYPE,ROW
  12259.       EQUIVALENCE (IR,RR)
  12260.       DIMENSION MAT(*)
  12261.       IF(NCOLT.GT.MAXCOL) GO TO 8300
  12262.       ITEMS = LXITEM(IDUMMY)
  12263.       IERR = 0
  12264.       CALL TYPER(ATYPE,VECMAT,JTYPE)
  12265.       TYPE = JTYPE
  12266.       IF(TYPE.EQ.KZDOUB) TYPE = KZREAL
  12267.       IF(LXWREC(ID,1).EQ.NULL) GO TO 600
  12268.       NWORD = NWORDS
  12269.       IF(JTYPE.EQ.KZDOUB) NWORD = NWORDS/2
  12270.       IF(TYPE.NE.KZTEXT) GO TO 100
  12271. C
  12272. C     TEXT STUFF
  12273. C
  12274.       IF(LXID(ID).NE.KZTEXT) GO TO 8000
  12275.       NW = LXLENW(ID)
  12276.       IF(NWORD.EQ.0) GO TO 50
  12277. C
  12278. C     FIXED TEXT
  12279. C
  12280.       IF(LXLENC(ID).GT.ROW) GO TO 8100
  12281.       NW = NWORD
  12282.       GO TO 80
  12283.    50 CONTINUE
  12284. C
  12285. C     VARIABLE TEXT
  12286. C
  12287.       IF((NCOLT+NW).GT.MAXCOL) GO TO 8300
  12288.       NWORD = NW
  12289.       ROW = LXLENC(ID)
  12290.    80 CONTINUE
  12291.       DO 90 I=1,NW
  12292.       MAT(I) = LXWREC(ID,I)
  12293.    90 CONTINUE
  12294.       ID = ID + 1
  12295.       NWORDS = NWORD
  12296.       RETURN
  12297.   100 CONTINUE
  12298.       NUMI = ITEMS - ID + 1
  12299.       IF(NWORD.GT.NUMI) GO TO 8100
  12300. C
  12301. C     NON-TEXT STUFF
  12302. C
  12303.       IF(LXWREC(ID,1).NE.K4LPAR) GO TO 500
  12304. C
  12305. C     WE HAVE PARENS
  12306. C
  12307.       IF(VECMAT.EQ.KZMAT) GO TO 300
  12308. C
  12309. C     VECTOR
  12310. C
  12311.       IF(NWORD.EQ.0) GO TO 200
  12312. C
  12313. C     FIXED LENGTH VECTOR
  12314. C
  12315.       IF(LXWREC(ID+NWORD+1,1).NE.K4RPAR) GO TO 8100
  12316.       DO 150 I=1,NWORD
  12317.       IF(LXID(ID+I).NE.TYPE) GO TO 8000
  12318.   150 CONTINUE
  12319.       IS = ID + 1
  12320.       NW = NWORD
  12321.       ID = ID + NWORD + 2
  12322.       GO TO 1000
  12323.   200 CONTINUE
  12324. C
  12325. C     VARIABLE
  12326. C
  12327.       L = LFIND(ID,ITEMS-ID+1,K4RPAR,1)
  12328.       IF(L.EQ.0) GO TO 8200
  12329.       NW = L - ID - 1
  12330.       IF((NCOLT+NW).GT.MAXCOL) GO TO 8300
  12331.       NWORD = NW
  12332.       ROW = 1
  12333.       DO 250 I=1,NWORD
  12334.       IF(LXID(ID+I).NE.TYPE) GO TO 8000
  12335.   250 CONTINUE
  12336.       IS = ID + 1
  12337.       ID = L +  1
  12338.       GO TO 1000
  12339.   300 CONTINUE
  12340.       IF(NWORD.EQ.0) GO TO 400
  12341. C
  12342. C     FIXED MATRIX
  12343. C
  12344.       ISKIP = ROW + 2
  12345.       NCOLS = NWORD/ROW
  12346.       IP = ID + 1
  12347.       DO 320 I=1,NCOLS
  12348.       IF(LXWREC(IP,1).NE.K4LPAR) GO TO 8200
  12349.       DO 310 J=1,ROW
  12350.       IF(LXID(IP+J).NE.TYPE) GO TO 8000
  12351.   310 CONTINUE
  12352.       IF(LXWREC(IP+ROW+1,1).NE.K4RPAR) GO TO 8200
  12353.       IP = IP + ISKIP
  12354.   320 CONTINUE
  12355.       IF(LXWREC(IP-1,1).NE.K4RPAR) GO TO 8200
  12356.       IS = ID + 2
  12357.       NW = ISKIP*NCOLS
  12358.       ID = IS + NW
  12359.       GO TO 1000
  12360.   400 CONTINUE
  12361. C
  12362. C     VARIABLE MATRIX - SET NWORD AND ROW THEN USE FIXED CODE
  12363. C
  12364.       L = LFIND(ID,ITEMS-ID+1,K4RPAR,1)
  12365.       IF(L.EQ.0) GO TO 8200
  12366.       IROW = L - ID - 2
  12367.       IF(IROW.LE.0) GO TO 8100
  12368.       IF(ROW.EQ.0) ROW = IROW
  12369.       IF(IROW.NE.ROW) GO TO 8100
  12370.       ISKIP = ROW + 2
  12371.       IS = ID + 1
  12372.       NCOLS = 0
  12373.       DO 420 I=IS,ITEMS,ISKIP
  12374.       IF(LXWREC(I,1).EQ.K4RPAR) GO TO 450
  12375.       NCOLS = NCOLS + 1
  12376.   420 CONTINUE
  12377.       GO TO 8200
  12378.   450 CONTINUE
  12379.       NWX = ROW*NCOLS
  12380.       IF(JTYPE.EQ.KZDOUB) NWX = 2*NWX
  12381.       IF((NCOLT+NWX).GT.MAXCOL) GO TO 8300
  12382.       NWORD = ROW*NCOLS
  12383.       GO TO 300
  12384.   500 CONTINUE
  12385. C
  12386. C     NO PARENS
  12387. C
  12388.       IF(NWORD.EQ.0) GO TO 8200
  12389.       DO 550 I=1,NWORD
  12390.       IF(LXID(ID+I-1).NE.TYPE) GO TO 8000
  12391.   550 CONTINUE
  12392.       IS = ID
  12393.       NW = NWORD
  12394.       ID = ID + NWORD
  12395.       GO TO 1000
  12396.   600 CONTINUE
  12397. C
  12398. C     NULL VALUES
  12399. C
  12400.       ID = ID + 1
  12401.       IF(NWORDS .EQ.0) GO TO 650
  12402. C
  12403. C     FIXED NULL
  12404. C
  12405.       NW = NWORDS
  12406.       DO 620 I=1,NW
  12407.       MAT(I) = IBLANK
  12408.   620 CONTINUE
  12409.       MAT(1) = NULL
  12410.       GO TO 9999
  12411.   650 CONTINUE
  12412. C
  12413. C VARIABLE NULL
  12414. C
  12415.       IF((NCOLT+1).GT.MAXCOL) GO TO 8300
  12416.       MAT(1) = NULL
  12417.       NWORDS = 1
  12418.       ROW = 1
  12419.       IF(ATYPE.EQ.KZTEXT) ROW = 3
  12420.       IF(JTYPE.NE.KZDOUB) GO TO 9999
  12421.       IF((NCOLT+2).GT.MAXCOL) GO TO 8300
  12422.       NWORDS = 2
  12423.       MAT(2) = IBLANK
  12424.       GO TO 9999
  12425.  1000 CONTINUE
  12426. C
  12427. C     DUMP STUFF INTO MAT
  12428. C
  12429.       NW = NW + IS - 1
  12430.       MATIN = 1
  12431.       IF(JTYPE.EQ.KZDOUB) GO TO 1200
  12432.       IF(TYPE.EQ.KZINT) GO TO 1100
  12433. C
  12434. C     REAL AND SINGLE WORD DOUBLE
  12435. C
  12436.       DO 1050 I=IS,NW
  12437.       IF(LXID(I).EQ.KZTEXT) GO TO 1050
  12438.       RR = RXREC(I)
  12439.       MAT(MATIN) = IR
  12440.       MATIN = MATIN + 1
  12441.  1050 CONTINUE
  12442.       GO TO 9990
  12443.  1100 CONTINUE
  12444. C
  12445. C     INTEGER
  12446. C
  12447.       DO 1150 I=IS,NW
  12448.       IF(LXID(I).EQ.KZTEXT) GO TO 1150
  12449.       MAT(MATIN) = LXIREC(I)
  12450.       MATIN = MATIN + 1
  12451.  1150 CONTINUE
  12452.       GO TO 9990
  12453.  1200 CONTINUE
  12454. C
  12455. C     TWO WORD DOUBLE
  12456. C
  12457.       DO 1250 I=IS,NW
  12458.       IF(LXID(I).EQ.KZTEXT) GO TO 1250
  12459.       RR = RXREC(I)
  12460.       MAT(MATIN) = IR
  12461.       MAT(MATIN+1) = 0
  12462.       MATIN = MATIN + 2
  12463.  1250 CONTINUE
  12464.       GO TO 9990
  12465.  8000 CONTINUE
  12466.     if(nout.eq.6)goto 3140
  12467.       WRITE (NOUT,8010) ID
  12468.  8010 FORMAT(50H -ERROR- Type Mismatch For Value Starting At Item ,I3)
  12469.       IERR = 1
  12470.       GO TO 9999
  12471. 3140    write(c128wk,8010) ID
  12472.     call atxto
  12473.     ierr=1
  12474.     goto 9999
  12475.  8100 CONTINUE
  12476.     if(nout.eq.6)goto 3141
  12477.       WRITE (NOUT,8110)ID
  12478.  8110 FORMAT(
  12479.      X 53H -ERROR- Incorrect Length For Value Starting At Item ,I3)
  12480.       IERR = 2
  12481.       GO TO 9999
  12482. 3141    continue
  12483.     write(c128wk,8110)ID
  12484.     call atxto
  12485.     ierr=2
  12486.     goto 9999
  12487.  8200 CONTINUE
  12488.     if (nout.eq.6)goto 3142
  12489.       WRITE (NOUT,8210) ID
  12490.  8210 FORMAT(
  12491.      X 51H -ERROR- Paren Mismatch For Value Starting At Item ,I3)
  12492.       IERR = 3
  12493.       GO TO 9999
  12494. 3142    continue
  12495.     write(c128wk,8210)ID
  12496.     call atxto
  12497.     ierr=3
  12498.     goto 9999
  12499.  8300 CONTINUE
  12500.     if(nout.eq.6)goto 3143
  12501.       WRITE(NOUT,8310) MAXCOL
  12502.  8310 FORMAT(36H -ERROR- Relation Row Length Exceeds,I5)
  12503.       IERR = 2
  12504.       GO TO 9999
  12505. 3143    continue
  12506.     write(c128wk,8310)MAXCOL
  12507.     call atxto
  12508.     ierr=2
  12509.     goto 9999
  12510.  9990 CONTINUE
  12511. C
  12512. C     RESET NWORDS
  12513. C
  12514.       NWORDS = NWORD
  12515.       IF(JTYPE.EQ.KZDOUB) NWORDS = 2*NWORD
  12516.  9999 CONTINUE
  12517.       RETURN
  12518.       END
  12519.       SUBROUTINE PJECT
  12520.       INCLUDE rin:TEXT.BLK
  12521. C
  12522. C  THIS ROUTINE PERFORMS PHYSICAL PROJECTIONS ON EXISTING RELATIONS.
  12523. C  THE SYNTAX OF THE PROJECT COMMAND IS :
  12524. C
  12525. C     PROJECT RNAME2 FROM RNAME1 USING ATTR1 ATTR2...ATTRN
  12526. C     -------        ----        -----
  12527. C
  12528. C
  12529. C     INPUTS :
  12530. C        LODREC(1) = 'PROJECT'
  12531. C        LODREC(2) = NEW RELATION NAME
  12532. C        LODREC(3) = 'FROM'
  12533. C        LODREC(4) = OLD RELATION NAME
  12534. C        LODREC(5) = 'USING'
  12535. C        LODREC(6) = ATTRIBUTE 1
  12536. C        LODREC(7) = ATTRIBUTE 2
  12537. C           .             .
  12538. C           .             .
  12539. C        LODREC(N) = ATTRIBUTE N-5
  12540. C
  12541. C
  12542. C     OUTPUTS :
  12543. C        NEW RELATION TABLES AND DATA TABLES FOR RNAME2
  12544. C
  12545. C
  12546. C
  12547.       INCLUDE rin:RIMPTR.BLK
  12548.       INCLUDE rin:RMKEYW.BLK
  12549.       INCLUDE rin:WHCOM.BLK
  12550.       INCLUDE rin:TUPLER.BLK
  12551.       INCLUDE rin:TUPLEA.BLK
  12552.       INCLUDE rin:FILES.BLK
  12553.       INCLUDE rin:BUFFER.BLK
  12554.       INCLUDE rin:MISC.BLK
  12555.       INCLUDE rin:RIMCOM.BLK
  12556.       INCLUDE rin:FLAGS.BLK
  12557. C
  12558. C
  12559.       INTEGER STATUS
  12560.       LOGICAL EQKEYW
  12561.       INTEGER ATNCOL
  12562.       INCLUDE rin:DCLAR1.BLK
  12563. C
  12564. C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
  12565. C
  12566.       CALL RMDBLK(DBNAME)
  12567.       IF(RMSTAT.EQ.0) GO TO 1000
  12568.       CALL WARN(RMSTAT,DBNAME,0)
  12569.       GO TO 9999
  12570. C
  12571. C  KEYWORD SYNTAX IS OKAY - NOW CHECK RELATION NAMES
  12572. C
  12573.  1000 CONTINUE
  12574.       CALL BLKCLN
  12575.       IF(.NOT.EQKEYW(3,KWFROM,4)) GO TO 9900
  12576.       IF(.NOT.EQKEYW(5,KWUSIN,5)) GO TO 9900
  12577.       RNAME1 = BLANK
  12578.       CALL LXSREC(4,1,8,RNAME1,1)
  12579.       I = LOCREL(RNAME1)
  12580.       LENF = NCOL
  12581.       IF(I.EQ.0) GO TO 1100
  12582. C
  12583. C  RNAME1 DOES NOT EXIST
  12584. C
  12585.       CALL WARN(1,RNAME1,0)
  12586.       GO TO 9999
  12587. C
  12588. C
  12589.  1100 CONTINUE
  12590.       IF((LXLENC(2).GE.1).AND.(LXLENC(2).LE.8)) GO TO 1200
  12591.       CALL WARN(7,KWRELA,BLANK)
  12592.       GO TO 9999
  12593.  1200 CONTINUE
  12594.       RNAME2 = BLANK
  12595.       CALL LXSREC(2,1,8,RNAME2,1)
  12596.       I = LOCREL(RNAME2)
  12597.       IF(I.NE.0) GO TO 1400
  12598. C
  12599. C  DUPLICATE RELATION NAME ENCOUNTERED
  12600. C
  12601.     if(nout.eq.6)goto 3140
  12602.       WRITE (NOUT,1220)
  12603.  1220 FORMAT(
  12604.      X 55H -ERROR- Resultant Relation Does Not Have A Unique Name )
  12605.       GO TO 9999
  12606. 3140    continue
  12607.     write(c128wk,1220)
  12608.     call atxto
  12609.     goto 9999
  12610. C
  12611. C  CHECK USER READ SECURITY
  12612. C
  12613.  1400 CONTINUE
  12614.       I = LOCREL(RNAME1)
  12615.       I = LOCPRM(RNAME1,1)
  12616.       IF(I.EQ.0) GO TO 1410
  12617.       CALL WARN(9,RNAME1,0)
  12618.       GO TO 9999
  12619.  1410 CONTINUE
  12620.       NS = 0
  12621.       NID = RSTART
  12622. C
  12623. C  SET UP THE WHERE CLAUSE
  12624. C
  12625.       ITEMS = LXITEM(NUM)
  12626.       K = LFIND(1,ITEMS,KWWHER,5)
  12627.       NBOO = 0
  12628.       LIMTU = ALL9S
  12629.       RMSTAT = 0
  12630.       KKX = K
  12631.       IF(K.NE.0) CALL WHERE(KKX)
  12632.       IF(RMSTAT.NE.0) GO TO 9999
  12633. C
  12634. C  CHECK THE ATTRIBUTES AND BUILD POINTER ARRAY - POS. 10
  12635. C
  12636.       NOATTS = 0
  12637.       CALL BLKDEF(10,LENF,1)
  12638.       KQ10 = BLKLOC(10) - 1
  12639.       NOCOLS = 0
  12640.       II = ITEMS
  12641.       IF(K.NE.0) II = K - 1
  12642.       IFALL = 0
  12643.       IF(II.NE.6) GO TO 1450
  12644.       IF(.NOT.EQKEYW(6,KWALL,3)) GO TO 1450
  12645. C
  12646. C     ALL
  12647. C
  12648.       II = NATT + 5
  12649.       IFALL = 1
  12650.       GO TO 1470
  12651.  1450 CONTINUE
  12652. C
  12653. C  CHECK THAT ALL ATTRIBUTES ARE LEGAL
  12654. C
  12655.       IERR = 0
  12656.       DO 1460 I=6,II
  12657.       ANAME = BLANK
  12658.       CALL LXSREC(I,1,8,ANAME,1)
  12659.       IF(LOCATT(ANAME,NAME).EQ.0) GO TO 1460
  12660.       CALL WARN(3,ANAME,NAME)
  12661.       IERR = 1
  12662.  1460 CONTINUE
  12663.       IF(IERR.EQ.1) GO TO 9999
  12664.  1470 CONTINUE
  12665.       CALL ATTNEW(RNAME2,II-5)
  12666.       DO 1600 I=6,II
  12667.       IF(IFALL.EQ.0) GO TO 1490
  12668.       NUM = I - 5
  12669.       STATUS = LOCATT(BLANK,NAME)
  12670.       DO 1480 J=1,NUM
  12671.       CALL ATTGET(STATUS)
  12672.       IF(STATUS.NE.0) GO TO 1600
  12673.  1480 CONTINUE
  12674.       GO TO 1500
  12675.  1490 CONTINUE
  12676.       ANAME = BLANK
  12677.       CALL LXSREC(I,1,8,ANAME,1)
  12678.       IERR = LOCATT(ANAME,NAME)
  12679.  1500 CONTINUE
  12680.       IF(IFALL.EQ.0) CALL ATTGET(STATUS)
  12681.       NOATTS = NOATTS + 1
  12682.       ATNCOL = NOCOLS + 1
  12683.       IF(ATTWDS.LE.0) GO TO 1540
  12684. C
  12685. C     FIXED LENGTH
  12686. C
  12687.       KQ = KQ10 + ATTCOL
  12688.       DO 1520 KK=1,ATTWDS
  12689.       NOCOLS = NOCOLS + 1
  12690.       BUFFER(KQ) = NOCOLS
  12691.       KQ = KQ + 1
  12692.  1520 CONTINUE
  12693.       GO TO 1560
  12694.  1540 CONTINUE
  12695. C
  12696. C     VARIABLE LENGTH
  12697. C
  12698.       NOCOLS = NOCOLS + 1
  12699.       BUFFER(KQ10+ATTCOL) = -NOCOLS
  12700.  1560 CONTINUE
  12701.       RELNAM = RNAME2
  12702.       ATTCOL = ATNCOL
  12703.       ATTKEY = 0
  12704.       CALL ATTADD
  12705.  1600 CONTINUE
  12706. C
  12707. C  SET UP RELTBLE
  12708. C
  12709.       NAME = RNAME2
  12710.       CALL RMDATE(RDATE)
  12711.       NCOL = NOCOLS
  12712.       NATT = NOATTS
  12713.       NTUPLE = 0
  12714.       RSTART = 0
  12715.       REND = 0
  12716.       CALL RELADD
  12717. C
  12718. C     1 IS INPUT BUFFER, 2 IS OUTPUT BUFFER, 11 IS OUTPUT TUPLE
  12719. C
  12720.       LPAG = MAXCOL + 2
  12721.       CALL BLKDEF(11,LPAG,1)
  12722.       KQ11 = BLKLOC(11)
  12723. C
  12724. C     LOOP THRU THOSE TUPLES
  12725. C
  12726.       RMSTAT = 0
  12727.       I = LOCREL(RNAME1)
  12728.       KNEW = 0
  12729.       MSTART = 0
  12730.       MEND = 0
  12731.  1700 CONTINUE
  12732.       CALL RMLOOK(IPOINT,1,1,LENGTH)
  12733.       IF(RMSTAT.NE.0) GO TO 1800
  12734.       CALL PRJTUP(BUFFER(KQ10+1),LENF,NOCOLS,BUFFER(IPOINT),
  12735.      X            BUFFER(KQ11),LENT)
  12736.       CALL ADDDAT(2,MEND,BUFFER(KQ11),LENT)
  12737.       IF(MSTART.EQ.0)MSTART = MEND
  12738.       KNEW = KNEW + 1
  12739.       GO TO 1700
  12740.  1800 CONTINUE
  12741.       I = LOCREL(RNAME2)
  12742.       CALL RELGET(STATUS)
  12743.       NTUPLE = KNEW
  12744.       RSTART = MSTART
  12745.       REND = MEND
  12746.       CALL RELPUT
  12747.     if(nout.eq.6)goto 3144
  12748.       WRITE (NOUT,2180) KNEW
  12749.  2180 FORMAT(30H Successful PROJECT Operation ,I5,
  12750.      X       15H Rows Generated  )
  12751.       GO TO 9999
  12752. 3144    continue
  12753.     write(c128wk,2180) KNEW
  12754.     call atxto
  12755.     goto 9999
  12756. C
  12757. C
  12758.  9900 CONTINUE
  12759.       CALL WARN(4,0,0)
  12760. C
  12761.  9999 CONTINUE
  12762.       CALL BLKCLR(10)
  12763.       CALL BLKCLR(11)
  12764.       RETURN
  12765.       END
  12766.       SUBROUTINE PRJTUP(POINTS,LENP,LENNEW,OLDTUP,NEWTUP,LENT)
  12767.       INCLUDE rin:TEXT.BLK
  12768. C
  12769. C     THIS ROUTINE BUILDS A NEW TUPLE FROM AN OLD TUPLE USING
  12770. C     POINTS AS A GUIDING ARRAY.
  12771. C
  12772. C   INPUT
  12773. C     POINTS  - ARRAY THE LENGTH OF THE FIXED PORTION OF OLDREL.
  12774. C               EACH WORD CONTAINS A ZERO OR THE RECIEVING ADDRESS
  12775. C               IN NEW TUPLE (ZERO MEANS NOT IN NEW TUPLE)
  12776. C               IF ATTRIBUTE IS VARIABLE ADDRESS IS STORED AS NEGATIVE
  12777. C     LENP    - LENGTH OF POINTS
  12778. C     LENNEW  - LENGTH OF FIXED PORTION OF NEW TUPLE
  12779. C     OLDTUP  - OLD TUPLE
  12780. C   OUTPUT
  12781. C     NEWTUP  - NEW TUPLE
  12782. C     LENT    - LENGTH OF NEW TUPLE
  12783. C
  12784.       INTEGER POINTS(LENP),OLDTUP(LENP),NEWTUP(LENP)
  12785.       LENT = LENNEW
  12786.       DO 100 I=1,LENP
  12787.       IF(POINTS(I).EQ.0) GO TO 100
  12788.       IF(POINTS(I).GT.0) GO TO 50
  12789. C
  12790. C     VARIABLE ATTRIBUTE
  12791. C
  12792.       IADD = OLDTUP(I)
  12793.       NOCOLS = -POINTS(I)
  12794.       NEWTUP(NOCOLS) = LENT + 1
  12795.       LEN = OLDTUP(IADD) + 2
  12796.       DO 40 K=1,LEN
  12797.       LENT = LENT + 1
  12798.       NEWTUP(LENT) = OLDTUP(IADD)
  12799.       IADD = IADD + 1
  12800.    40 CONTINUE
  12801.       GO TO 100
  12802.    50 CONTINUE
  12803. C
  12804. C     FIXED ATTRIBUTE
  12805. C
  12806.       NUM = POINTS(I)
  12807.       NEWTUP(NUM) = OLDTUP(I)
  12808.   100 CONTINUE
  12809.       RETURN
  12810.       END
  12811.       SUBROUTINE PRULE(NUMRUL)
  12812.       INCLUDE rin:TEXT.BLK
  12813. C
  12814. C  THIS ROUTINE DUMPS OUT RULES ASSOCIATED WITH A RIM DATABASE
  12815. C
  12816. C  PARAMETERS:
  12817. C     NUMRUL--NUMBER OF THE RULE TO PRINT
  12818. C
  12819.       INCLUDE rin:CONST4.BLK
  12820.       INCLUDE rin:RMKEYW.BLK
  12821.       INCLUDE rin:CONST8.BLK
  12822.       INCLUDE rin:FILES.BLK
  12823.       INCLUDE rin:TUPLER.BLK
  12824.       INCLUDE rin:TUPLEA.BLK
  12825.       INCLUDE rin:WHCOM.BLK
  12826.       INCLUDE rin:RIMPTR.BLK
  12827.       INCLUDE rin:RIMCOM.BLK
  12828.       INCLUDE rin:MISC.BLK
  12829.       INCLUDE rin:RELTBL.BLK
  12830. C
  12831.       DIMENSION MAT(24)
  12832.       DIMENSION LINE(18)
  12833.       INTEGER SAVSCR(21)
  12834.       INTEGER SAVTUR(13)
  12835.       INTEGER ANDOR
  12836.       LOGICAL EQ
  12837. C
  12838. C  PRINT HEADING.
  12839. C
  12840.     if(noutr.eq.6)goto 3140
  12841.       WRITE(NOUTR,9000) NUMRUL
  12842.  9000 FORMAT(13H RULE NUMBER ,I5)
  12843.     goto 3141
  12844. 3140    continue
  12845.     write(c128wk,9000) NUMRUL
  12846.     call atxto
  12847. 3141    continue
  12848. C
  12849. C  PROCESS THIS RULE.
  12850. C
  12851.       MWDS = 5 + ((8-1)/CHPWD + 1)*4
  12852.       CALL BLKMOV(SAVTUR,NAME,MWDS)
  12853.       CALL BLKMOV(SAVSCR,IVAL,6)
  12854.       SAVSCR(7) = NBOO
  12855.       SAVSCR(8) = BOO(1)
  12856.       SAVSCR(9) = KATTP(1)
  12857.       SAVSCR(10) = KATTL(1)
  12858.       SAVSCR(11) = KATTY(1)
  12859.       SAVSCR(12) = KOMTYP(1)
  12860.       SAVSCR(13) = KOMPOS(1)
  12861.       SAVSCR(14) = KOMLEN(1)
  12862.       SAVSCR(15) = KOMPOT(1)
  12863.       SAVSCR(16) = KSTRT
  12864.       SAVSCR(17) = MAXTU
  12865.       SAVSCR(18) = LIMTU
  12866.       SAVSCR(19) = WHRVAL(1)
  12867.       SAVSCR(20) = WHRVAL(2)
  12868.       SAVSCR(21) = WHRLEN(1)
  12869. C
  12870. C  PREPARE TO CALL RMLOOK.
  12871. C
  12872.       I = LOCREL(K8RDT)
  12873.       IF(I.NE.0) GO TO 9999
  12874. C
  12875. C  SET UP A WHERE CLAUSE FOR THE ATTRIBUTE VALUE
  12876. C
  12877.       RMSTAT = 0
  12878.       NBOO = 0
  12879.       I = LOCATT(K8NUM,K8RDT)
  12880.       IF(I.NE.0) GO TO 9999
  12881.       CALL ATTGET(I)
  12882.       IF(I.NE.0) GO TO 9999
  12883.       NBOO = 1
  12884.       BOO(1) = K4AND
  12885.       KATTP(1) = ATTCOL
  12886.       KATTL(1) = ATTLEN
  12887.       KATTY(1) = ATTYPE
  12888.       KOMTYP(1) = 2
  12889.       KOMPOS(1) = 1
  12890.       KOMLEN(1) = 1
  12891.       KOMPOT(1) = 1
  12892.       WHRVAL(1) = NUMRUL
  12893.       WHRLEN(1) = 1
  12894.       KSTRT = 0
  12895.       MAXTU = ALL9S
  12896.       LIMTU = ALL9S
  12897.       CALL RMLOOK(MAT,2,0,LEN)
  12898.   100 CONTINUE
  12899.       IF(RMSTAT.NE.0) GO TO 9999
  12900. C
  12901. C  BLANK FILL THE LINE.
  12902. C
  12903.       CALL FILCH(LINE,1,72,BLANK)
  12904.       CALL STRMOV(MAT(4),1,8,LINE,2)
  12905.       IF(EQ(MAT(6),BLANK)) GO TO 300
  12906. C
  12907. C  THERE IS AN 'IN' CLAUSE.
  12908. C
  12909.       CALL STRMOV(BLANK,1,4,LINE,10)
  12910.       CALL STRMOV(KWIN,1,2,LINE,11)
  12911.       CALL STRMOV(MAT(6),1,8,LINE,14)
  12912.       GO TO 400
  12913. C
  12914. C  NO 'IN' CLAUSE.
  12915. C
  12916.   300 CONTINUE
  12917.       CALL STRMOV(BLANK,1,4,LINE,10)
  12918.       CALL STRMOV(BLANK,1,8,LINE,14)
  12919. C
  12920. C  IS RELNAME2 BLANK ?
  12921. C
  12922.   400 CONTINUE
  12923.       CALL STRMOV(BLANK,1,5,LINE,22)
  12924.       CALL STRMOV(MAT(8),1,3,LINE,23)
  12925.       CALL ITOH(NCHAR,ITYPE,MAT(10))
  12926.       IF(ITYPE.NE.3) GO TO 500
  12927. C
  12928. C  OBJECT IS AN ATTRIBUTE.
  12929. C
  12930.       CALL STRMOV(MAT(11),1,8,LINE,27)
  12931.       CALL STRMOV(BLANK,1,4,LINE,35)
  12932.       CALL STRMOV(KWIN,1,2,LINE,36)
  12933.       CALL STRMOV(MAT(13),1,8,LINE,39)
  12934.       GO TO 700
  12935. C
  12936. C  OBJECT IS A VALUE .
  12937. C
  12938.   500 CONTINUE
  12939.       IF(ITYPE.EQ.0) CALL STRMOV(MAT(15),1,NCHAR,LINE,27)
  12940.       IF(ITYPE.EQ.1) CALL ITOC(LINE,27,10,MAT(15),IERR)
  12941.       IF(ITYPE.EQ.2) CALL RTOC(LINE,27,10,MAT(15))
  12942. C
  12943.   700 CONTINUE
  12944.       CALL STRMOV(BLANK,1,4,ANDOR,1)
  12945.       CALL RMLOOK(MAT,2,0,LEN)
  12946.       IF(RMSTAT.EQ.0) ANDOR = MAT(2)
  12947. C
  12948. C  WRITE OUT THE ACTUAL RULE.
  12949. C
  12950.       LEN = 38
  12951.       IF(ITYPE.EQ.0) LEN = 68
  12952.       IF(ITYPE.EQ.3) LEN = 50
  12953.       CALL STRMOV(ANDOR,1,3,LINE,LEN)
  12954.       CALL SPOUT(LINE,70)
  12955.       GO TO 100
  12956. C
  12957. C  RESTORE THE POINTERS AND RETURN
  12958. C
  12959.  9999 CONTINUE
  12960.       CALL BLKMOV(NAME,SAVTUR,MWDS)
  12961.       I = LOCREL(NAME)
  12962.       LRROW = LRROW + 1
  12963.       CALL BLKMOV(IVAL,SAVSCR,6)
  12964.       NBOO = SAVSCR(7)
  12965.       BOO(1) = SAVSCR(8)
  12966.       KATTP(1) = SAVSCR(9)
  12967.       KATTL(1) = SAVSCR(10)
  12968.       KATTY(1) = SAVSCR(11)
  12969.       KOMTYP(1) = SAVSCR(12)
  12970.       KOMPOS(1) = SAVSCR(13)
  12971.       KOMLEN(1) = SAVSCR(14)
  12972.       KOMPOT(1) = SAVSCR(15)
  12973.       KSTRT = SAVSCR(16)
  12974.       MAXTU = SAVSCR(17)
  12975.       LIMTU = SAVSCR(18)
  12976.       WHRVAL(1) = SAVSCR(19)
  12977.       WHRVAL(2) = SAVSCR(20)
  12978.       WHRLEN(1) = SAVSCR(21)
  12979.       RETURN
  12980.       END
  12981.       SUBROUTINE PTRS(IP1,IP2,K,NATT3,PTABLE,LEN,ITYPE)
  12982.       INCLUDE rin:TEXT.BLK
  12983. C
  12984. C  THIS ROUTINE LOCATES THE PAIRS OF POINTERS TO COMMON
  12985. C  ATTRIBUTES FOR A SUBTRACT OR INTERSECT
  12986. C
  12987.       INTEGER PTABLE(7,*)
  12988. C
  12989.       IF(K.GT.NATT3) GO TO 500
  12990. C
  12991.   100 CONTINUE
  12992.       I = K
  12993.       IF(PTABLE(3,I).EQ.0) GO TO 200
  12994.       IF(PTABLE(4,I).EQ.0) GO TO 200
  12995.       IP1 = PTABLE(3,I)
  12996.       IP2 = PTABLE(4,I)
  12997.       CALL ITOH(IDUM,LEN,PTABLE(6,I))
  12998.       ITYPE = PTABLE(7,I)
  12999.       K = K + 1
  13000.       GO TO 9999
  13001.   200 CONTINUE
  13002.       K = K + 1
  13003.       IF(K.GT.NATT3) GO TO 500
  13004.       GO TO 100
  13005.   500 CONTINUE
  13006. C
  13007. C  DONE GOING THROUGH THE POINTERS.
  13008. C
  13009.       K = 0
  13010.       LEN = 0
  13011.  9999 RETURN
  13012.       END
  13013.       SUBROUTINE PUTDAT(INDEX,ID,ARRAY,LENGTH)
  13014.       INCLUDE rin:TEXT.BLK
  13015. C
  13016. C  PURPOSE:   REPLACE A TUPLE ON THE DATA FILE
  13017. C
  13018. C  PARAMETERS:
  13019. C         INDEX---BLOCK REFERENCE NUMBER
  13020. C         ID------PACKED ID WORD WITH OFFSET,IOBN
  13021. C         ARRAY---ARRAY TO RECEIVE THE TUPLE
  13022. C         LENGTH--LENGTH OF THE TUPLE
  13023.       INCLUDE rin:F2COM.BLK
  13024.       INCLUDE rin:RIMCOM.BLK
  13025.       INCLUDE rin:BUFFER.BLK
  13026.       INCLUDE rin:FLAGS.BLK
  13027. C
  13028.       INTEGER OFFSET
  13029.       INTEGER ARRAY(*)
  13030. C
  13031. C  UNPAC THE ID WORD.
  13032. C
  13033.       CALL ITOH(OFFSET,IOBN,ID)
  13034. C
  13035. C  SEE IF THE NEEDED BLOCK IS CURRENTLY IN CORE.
  13036. C
  13037.       NUMBLK = 0
  13038.       DO 200 I=1,3
  13039.       IF(IOBN.EQ.CURBLK(I)) NUMBLK = I
  13040.   200 CONTINUE
  13041.       IF(NUMBLK.NE.0) GO TO 400
  13042.       NUMBLK = INDEX
  13043. C
  13044. C  WE MUST DO PAGING.
  13045. C
  13046. C  SEE IF THE CURRENT BLOCK NEEDS WRITING.
  13047. C
  13048.       IF(MODFLG(NUMBLK).EQ.0) GO TO 300
  13049. C
  13050. C  WRITE OUT THE CURRENT BLOCK.
  13051. C
  13052.       KQ1 = BLKLOC(NUMBLK)
  13053.       CALL RIOOUT(FILE2,CURBLK(NUMBLK),BUFFER(KQ1),LENBF2,IOS)
  13054.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  13055.   300 CONTINUE
  13056. C
  13057. C  READ IN THE NEEDED BLOCK.
  13058. C
  13059.       CALL BLKCHG(NUMBLK,LENBF2,1)
  13060.       KQ1 = BLKLOC(NUMBLK)
  13061.       CALL RIOIN(FILE2,IOBN,BUFFER(KQ1),LENBF2,IOS)
  13062.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  13063.       CURBLK(NUMBLK) = IOBN
  13064.   400 CONTINUE
  13065.       MODFLG(NUMBLK) = 1
  13066.       IFMOD = .TRUE.
  13067. C
  13068. C  MOVE THE TUPLE TO THE PAGE.
  13069. C
  13070.       KQ0 = BLKLOC(NUMBLK) - 1
  13071.       LEN = BUFFER(KQ0 + OFFSET + 1)
  13072.       IF(LEN.NE.LENGTH) RMSTAT = 1002
  13073.       CALL BLKMOV(BUFFER(KQ0 + OFFSET + 2),ARRAY(1),LEN)
  13074. C
  13075. C  ALL DONE.
  13076. C
  13077.       RETURN
  13078.       END
  13079.       SUBROUTINE PUTT(STR1,IC1,WORD)
  13080.       INCLUDE rin:TEXT.BLK
  13081. C
  13082. C  PURPOSE:   PUT THE FIRST CHARACTER OF WORD IN STR1 AT IC1
  13083. C
  13084. C  PARAMETERS:
  13085. C     STR1----STRING OF CHARACTERS
  13086. C     IC1-----THE CHARACTER WANTED
  13087. C     WORD----WORD WITH THE CHARACTER (LEFT JUSTIFIED, BLANK FILL)
  13088. C
  13089.       Character*1 STR1(*)
  13090.       Character*1 WORD(*)
  13091.       STR1(IC1) = WORD(1)
  13092.       RETURN
  13093.       END
  13094.       SUBROUTINE QUERY
  13095.       INCLUDE rin:TEXT.BLK
  13096. C
  13097. C  THIS ROUTINE IS THE DRIVER FOR QUERY OF THE RIM DATA BASE.
  13098. C
  13099.       INCLUDE rin:RMATTS.BLK
  13100.       INCLUDE rin:RMKEYW.BLK
  13101.       INCLUDE rin:CONST4.BLK
  13102.       INCLUDE rin:CONST8.BLK
  13103.       INCLUDE rin:RIMCOM.BLK
  13104.       INCLUDE rin:RIMPTR.BLK
  13105.       INCLUDE rin:WHCOM.BLK
  13106.       INCLUDE rin:TUPLEA.BLK
  13107.       INCLUDE rin:TUPLER.BLK
  13108.       INCLUDE rin:FLAGS.BLK
  13109.       INCLUDE rin:FILES.BLK
  13110.       INCLUDE rin:MISC.BLK
  13111.       INCLUDE rin:SRTCOM.BLK
  13112.       LOGICAL EQKEYW
  13113.       LOGICAL SAORD
  13114.       INCLUDE rin:DCLAR1.BLK
  13115. C
  13116. C  READ A CARD
  13117. C
  13118.       NEXTOP = K8READ
  13119.       GO TO 200
  13120.   100 CONTINUE
  13121.       CALL LODREC
  13122. C
  13123. C  SCAN A COMMAND.
  13124. C
  13125.   200 CONTINUE
  13126.       ITEMS = LXITEM(IDUMMY)
  13127.       NS = 0
  13128.       IF(EQKEYW(1,KWSELE,6)) GO TO 400
  13129.       IF(EQKEYW(1,KWTALL,5)) GO TO 400
  13130.       IF(EQKEYW(1,KWCOMP,7)) GO TO 400
  13131.       IF(EQKEYW(1,KWNEWP,7)) GO TO 1600
  13132. C
  13133. C  UNRECOGNIZED COMMAND.
  13134. C
  13135.       NEXTOP = K8USE
  13136.       GO TO 2000
  13137. C
  13138. C  ERROR IN COMMAND.
  13139. C
  13140.   350 CONTINUE
  13141.       CALL WARN(4,0,0)
  13142.       GO TO 100
  13143. C
  13144. C  PRINT COMMAND.
  13145. C
  13146.   400 CONTINUE
  13147. C
  13148. C  SCAN FOR THE WORD FROM.
  13149. C
  13150.       J = LFIND(1,ITEMS,KWFROM,4)
  13151.       IF(J.EQ.0) GO TO 350
  13152.       IF(EQKEYW(1,KWSELE,6)) GO TO 410
  13153.       IF(EQKEYW(1,KWTALL,5)) GO TO 440
  13154.       IF(EQKEYW(1,KWCOMP,7)) GO TO 470
  13155. C
  13156. C  CHECK SELECT SYNTAX
  13157. C
  13158.   410 CONTINUE
  13159.       IF(J.LT.3) GO TO 350
  13160.       IF((EQKEYW(2,KWALL,3)).AND.(J.NE.3)) GO TO 350
  13161.       IF(J.EQ.ITEMS) GO TO 350
  13162.       JS = LFIND(1,ITEMS,KWSORT,6)
  13163.       JW = LFIND(1,ITEMS,KWWHER,5)
  13164.       IF(JS.EQ.0) GO TO 420
  13165.       IF((JS+1).GE.ITEMS) GO TO 350
  13166.       IF((JS-J).NE.2) GO TO 350
  13167.       IF(.NOT.EQKEYW(JS+1,KWBY,2)) GO TO 350
  13168.       IF(JW.EQ.0) GO TO 499
  13169.       IF((JW-JS).LT.3) GO TO 350
  13170.       GO TO 499
  13171.   420 IF(JW.EQ.0) GO TO 430
  13172.       IF((JW-J).NE.2) GO TO 350
  13173.       GO TO 499
  13174.   430 IF((J+1).NE.ITEMS) GO TO 350
  13175.       GO TO 499
  13176. C
  13177. C  CHECK TALLY SYNTAX
  13178. C
  13179.   440 CONTINUE
  13180.       IF((J.NE.3).AND.(J.NE.5)) GO TO 350
  13181.   450 JW = LFIND(1,ITEMS,KWWHER,5)
  13182.       IF(JW.NE.0) GO TO 460
  13183.       IF((J+1).NE.ITEMS) GO TO 350
  13184.       GO TO 499
  13185.   460 IF((JW-J).NE.2) GO TO 350
  13186.       GO TO 499
  13187. C
  13188. C  CHECK COMPUTE SYNTAX
  13189. C
  13190.   470 CONTINUE
  13191.       IF(J.NE.4) GO TO 350
  13192.       GO TO 450
  13193.   499 CONTINUE
  13194.       RNAME = BLANK
  13195.       CALL LXSREC(J+1,1,8,RNAME,1)
  13196. C
  13197. C  FIND THE RELATION NAME IN RELTBLE.
  13198. C
  13199.       I = LOCREL(RNAME)
  13200.       IF(I.EQ.0) GO TO 500
  13201. C
  13202. C  UNRECOGNIZED RELATION NAME.
  13203. C
  13204.       CALL WARN(1,RNAME,0)
  13205.       GO TO 100
  13206.   500 CONTINUE
  13207. C
  13208. C  CHECK FOR READ PERMISSION.
  13209. C
  13210.       L = LOCPRM(NAME,1)
  13211.       IF(L.EQ.0) GO TO 510
  13212.       CALL WARN(9,NAME,0)
  13213.       GO TO 100
  13214. C
  13215. C  GET THE RELATION DATA.
  13216. C
  13217. C
  13218. C  SEE IF ANY TUPLES EXIST.
  13219. C
  13220.   510 CONTINUE
  13221.       IF(NTUPLE.GT.0) GO TO 700
  13222.     if(nout.eq.6)goto 3240
  13223.       WRITE (NOUT,602)
  13224.   602 FORMAT(43H -WARNING- No Data Exists For This Relation )
  13225.       GO TO 100
  13226. 3240    continue
  13227.     write(c128wk,602)
  13228.     call atxto
  13229.     goto 100
  13230. C
  13231. C  SEE IF THERE IS A WHERE CLAUSE.
  13232. C
  13233.   700 CONTINUE
  13234.       K = LFIND(1,ITEMS,KWWHER,5)
  13235.       NBOO = 0
  13236.       LIMTU = ALL9S
  13237.       IF(K.EQ.0) GO TO 1000
  13238.       CALL WHERE(K)
  13239.       IF(RMSTAT.NE.0) GO TO 100
  13240. C
  13241. C  SEE IF ANY TUPLES SATISFY THE WHERE CLAUSE.
  13242. C
  13243.       CALL RMLOOK(IDUMMY,1,1,LENGTH)
  13244.       IF(RMSTAT.EQ.0) GO TO 900
  13245.     if(nout.eq.6)goto 3241
  13246.       WRITE (NOUT,720)
  13247.   720 FORMAT(43H -WARNING- No Rows Satisfy The WHERE Clause )
  13248.       GO TO 100
  13249. 3241    continue
  13250.     write(c128wk,720)
  13251.     call atxto
  13252.     goto 100
  13253.   900 CONTINUE
  13254.       NID = CID
  13255.       IVAL = IVAL - 1
  13256.       LIMVAL = 0
  13257.       IF(NS.EQ.3) NS = 2
  13258. C
  13259. C  SEE IF SORTING IS NEEDED OR ASKED FOR.
  13260. C
  13261.  1000 CONTINUE
  13262.       IF(EQKEYW(1,KWCOMP,7)) GO TO 1500
  13263.       IF(EQKEYW(1,KWTALL,5)) GO TO 1100
  13264.       IF(.NOT.EQKEYW(J+2,KWSORT,6)) GO TO 1300
  13265. C
  13266. C  SORTING IS NEEDED. NATT IS THE ATTRIBUTE NAME.
  13267. C
  13268. C  SEE HOW MANY ATTRIBUTES ARE SPECIFIED IN THE SORT.
  13269. C
  13270.       NKSORT = 1
  13271.       I = J + 3
  13272.       L = LFIND(I,ITEMS,KWWHER,5)
  13273.       IF(L.EQ.0) L = ITEMS + 1
  13274.       NUMV = L - I - 1
  13275.       GO TO 1150
  13276. C
  13277. C  TALLY SORT - SET VARIABLES
  13278. C
  13279.  1100 CONTINUE
  13280.       NKSORT = 2
  13281.       I = 1
  13282.       NUMV = J-2
  13283.  1150 CONTINUE
  13284. C
  13285. C  NUMV IS THE NUMBER OF SORT ITEMS WE HAVE.
  13286. C  I IS THE START OF ATTRIBUTE SORT LIST - 1
  13287. C
  13288.       NSOVAR = 0
  13289.       N = 0
  13290.  1155 N = N + 1
  13291.       SAORD = .TRUE.
  13292.       ANAME = BLANK
  13293.       CALL LXSREC(I+N,1,8,ANAME,1)
  13294. C
  13295. C  CHECK FOR ASCENDING OR DESCENDING SORT
  13296. C
  13297.       IEQ = IBLANK
  13298.       CALL LXSREC(I+N+1,1,1,IEQ,1)
  13299.       IF(IEQ.NE.K4EQS) GO TO 1158
  13300.       N = N + 2
  13301.       CALL LXSREC(I+N,1,1,IEQ,1)
  13302.       IF((IEQ.NE.K4A).AND.(IEQ.NE.K4D)) GO TO 350
  13303.       IF(IEQ.EQ.K4D) SAORD = .FALSE.
  13304. C
  13305. C  GET THE ATTRIBUTE DATA
  13306. C
  13307.  1158 CONTINUE
  13308.       K = LOCATT(ANAME,NAME)
  13309.       CALL ATTGET(K)
  13310.       IF(K.EQ.0) GO TO 1160
  13311.       CALL WARN(3,ANAME,NAME)
  13312.       GO TO 100
  13313. C
  13314. C  SET UP THE ATTRIBUTE SORT DATA
  13315. C
  13316.  1160 CONTINUE
  13317.       NUMCOL = ATTCOL - 1
  13318.       IF(NKSORT.EQ.2) NUMCOL = 0
  13319. C
  13320. C  CHECK FOR VARIABLE LENGTH - SORTING ON VARIABLE LENGTH
  13321. C  ATTRIBUTES IS CURRENTLY NOT ALLOWED
  13322. C
  13323.       IF(ATTWDS.NE.0) GO TO 1170
  13324.     if(nout.eq.6)goto 3242
  13325.       WRITE(NOUT,1165)
  13326.  1165 FORMAT(41H -WARNING- VARiable Length Attributes May,
  13327.      1       25H Not Be SORTed or TALLIED)
  13328.       GO TO 1200
  13329. 3242    continue
  13330.     write(C128wk,1165)
  13331.     call atxto
  13332.     goto 1200
  13333.  1170 CONTINUE
  13334. C
  13335. C  IF TEXT ATTRIBUTE DETERMINE THE NUMBER OF WORDS TO SORT ON - THIS
  13336. C  IS BASED ON THE NUMBER OF CHARACTERS (CURRENTLY 20) AND THE WORD
  13337. C  SIZE.
  13338. C     32 BIT WORDS - 20 CHARACTERS (5 WORDS)
  13339. C     60 BIT WORDS - 20 CHARACTERS (2 WORDS)
  13340. C     64 BIT WORDS - 16 CHARACTERS (2 WORDS)
  13341. C
  13342.       LSL = 1
  13343.       IF(ATTYPE.NE.KZTEXT) GO TO 1172
  13344. C
  13345. C  TEXT - DETERMINE SORT WORDS
  13346. C
  13347.       LSL = 20/CHPWD
  13348.       IF(ATTWDS.LT.LSL) LSL = ATTWDS
  13349. C
  13350. C  LOAD THE SORT ARRAYS
  13351. C
  13352.  1172 CONTINUE
  13353.       DO 1190 K=1,LSL
  13354.       NUMCOL = NUMCOL + 1
  13355.       NSOVAR = NSOVAR + 1
  13356. C
  13357. C  CHECK ON THE NUMBER OF SORT WORDS - CURRENTLY 10
  13358. C  THIS MAY WANT TO BE UPPER FOR THE SMALLER MACHINES
  13359. C
  13360.       IF(NSOVAR.LE.NSORTW) GO TO 1180
  13361.     if(nout.eq.6)goto 3243
  13362.       WRITE(NOUT,1175)
  13363.  1175 FORMAT(44H -ERROR- Illegal Number Of Sorted Attributes)
  13364.       GO TO 100
  13365. 3243    continue
  13366.     write(c128wk,1175)
  13367.     call atxto
  13368.     goto 100
  13369. C
  13370. C  LOAD ARRAYS
  13371. C
  13372.  1180 CONTINUE
  13373.       SORTYP(NSOVAR) = SAORD
  13374.       VARPOS(NSOVAR) = NUMCOL
  13375.       IF(ATTYPE.EQ.KZINT) L=1
  13376.       IF(ATTYPE.EQ.KZREAL) L=2
  13377.       IF(ATTYPE.EQ.KZDOUB) L=3
  13378.       IF(ATTYPE.EQ.KZTEXT) L=4
  13379.       IF(ATTYPE.EQ.KZIVEC) L=1
  13380.       IF(ATTYPE.EQ.KZRVEC) L=2
  13381.       IF(ATTYPE.EQ.KZDVEC) L=3
  13382.       IF(ATTYPE.EQ.KZIMAT) L=1
  13383.       IF(ATTYPE.EQ.KZRMAT) L=2
  13384.       IF(ATTYPE.EQ.KZDMAT) L=3
  13385.       VARTYP(NSOVAR) = L
  13386.  1190 CONTINUE
  13387.  1200 CONTINUE
  13388.       IF(N.LT.NUMV) GO TO 1155
  13389. C
  13390. C  DO THE SORT.
  13391. C
  13392.       IF(NSOVAR.EQ.0) GO TO 100
  13393.       CALL SORT(NKSORT,ierr)
  13394.     if(ierr.eq.0)goto 1299
  13395.     call warn(16)
  13396.     goto 100
  13397. 1299    continue
  13398.       NS = 1
  13399. C
  13400. C  CALL SELECT OR TALLY AS NEEDED.
  13401. C
  13402.  1300 CONTINUE
  13403.       IF(EQKEYW(1,KWTALL,5)) GO TO 1400
  13404.       CALL SELECT
  13405.       GO TO 100
  13406.  1400 CONTINUE
  13407.       CALL TALLY
  13408.       GO TO 100
  13409. C
  13410. C  CALL CMPUTE.
  13411. C
  13412.  1500 CONTINUE
  13413.       CALL CMPUTE
  13414.       GO TO 100
  13415. C
  13416. C  NEWPAGE COMMAND.
  13417. C
  13418.  1600 CONTINUE
  13419.       if(noutr.ne.6)WRITE(NOUTR,1610)
  13420.  1610 FORMAT(1H1)
  13421.       GO TO 100
  13422.  2000 CONTINUE
  13423.       RETURN
  13424.       END
  13425.       SUBROUTINE RELADD
  13426.       INCLUDE rin:TEXT.BLK
  13427. C
  13428. C  PURPOSE:   ADD A NEW TUPLE TO THE RELTBL RELATION
  13429. C
  13430.       INCLUDE rin:TUPLER.BLK
  13431.       INCLUDE rin:RELTBL.BLK
  13432.       INCLUDE rin:F1COM.BLK
  13433.       INCLUDE rin:FLAGS.BLK
  13434. C
  13435. C  GET THE PAGE FOR ADDING NEW TUPLES.
  13436. C
  13437.       MRSTRT = NRROW
  13438.       CALL RELPAG(MRSTRT)
  13439.       I = MRSTRT
  13440.       NRROW = NRROW + 1
  13441.       IF(I.EQ.RPBUF) NRROW = (RPBUF * LF1REC) + 1
  13442. C
  13443. C  MOVE THE DATA FROM THE TUPLE TO THE BUFFER.
  13444. C
  13445.       RELTBL(1,I) = NRROW
  13446.       CALL BLKMOV(RELTBL(2,I),NAME,2)
  13447.       CALL BLKMOV(RELTBL(4,I),RDATE,2)
  13448.       RELTBL(6,I) = NCOL
  13449.       RELTBL(7,I) = NATT
  13450.       RELTBL(8,I) = NTUPLE
  13451.       RELTBL(9,I) = RSTART
  13452.       RELTBL(10,I) = REND
  13453.       CALL BLKMOV(RELTBL(11,I),RPW,2)
  13454.       CALL BLKMOV(RELTBL(13,I),MPW,2)
  13455.       RELMOD = 1
  13456.       IFMOD = .TRUE.
  13457.       LRROW = 0
  13458.       IF(I.LT.RPBUF) RETURN
  13459. C
  13460. C  WE JUST FILLED A BUFFER. MAKE SURE RELTBL GETS THE NEXT ONE.
  13461. C
  13462.       RELBUF(1) = NRROW
  13463.       MRSTRT = NRROW
  13464.       CALL RELPAG(MRSTRT)
  13465.       RETURN
  13466.       END
  13467.       SUBROUTINE RELDEL
  13468.       INCLUDE rin:TEXT.BLK
  13469. C
  13470. C  PURPOSE:   DELETE THE CURRENT TUPLE FROM THE RELTBL RELATION
  13471. C             BASED ON CONDITIONS SET UP IN LOCREL
  13472. C
  13473.       INCLUDE rin:RELTBL.BLK
  13474.       IF(LRROW.EQ.0) GO TO 9999
  13475. C
  13476. C  CHANGE THE TUPLE STATUS FLAG TO DELETED.
  13477. C
  13478.       RELTBL(1,LRROW) = -RELTBL(1,LRROW)
  13479.       RELMOD = 1
  13480.  9999 CONTINUE
  13481.       RETURN
  13482.       END
  13483.       SUBROUTINE RELGET(STATUS)
  13484.       INCLUDE rin:TEXT.BLK
  13485. C
  13486. C  PURPOSE:   GET THE NEXT TUPLE IN THE RELTBL RELATION
  13487. C
  13488. C  PARAMETERS:
  13489. C         STATUS--STATUS VARIABLE - 0 MEANS OK, 1 MEANS NO WAY
  13490.       INCLUDE rin:RELTBL.BLK
  13491.       INCLUDE rin:TUPLER.BLK
  13492.       INCLUDE rin:MISC.BLK
  13493.       INTEGER STATUS
  13494.       LOGICAL EQ
  13495.       STATUS = 0
  13496. C
  13497. C  SCAN FOR THE NEXT RELATION.
  13498. C
  13499.       I = LRROW + 1
  13500.       GO TO 200
  13501.   100 CONTINUE
  13502.       CALL RELPAG(MRSTRT)
  13503.       I = MRSTRT
  13504.   200 CONTINUE
  13505.       IF(I.GT.RPBUF) GO TO 400
  13506.       IF(RELTBL(1,I).EQ.0) GO TO 9000
  13507.       IF(RELTBL(1,I).LT.0) GO TO 300
  13508.       IF(EQ(CNAME,BLANK)) GO TO 500
  13509.       IF(EQ(RELTBL(2,I),CNAME)) GO TO 500
  13510.   300 CONTINUE
  13511.       I = I + 1
  13512.       GO TO 200
  13513. C
  13514. C  GET THE NEXT PAGE.
  13515. C
  13516.   400 CONTINUE
  13517.       MRSTRT = RELBUF(1)
  13518.       IF(MRSTRT.EQ.0) GO TO 9000
  13519.       GO TO 100
  13520. C
  13521. C  FOUND IT.
  13522. C
  13523.   500 CONTINUE
  13524.       LRROW = I
  13525.       CALL BLKMOV(NAME,RELTBL(2,I),2)
  13526.       CALL BLKMOV(RDATE,RELTBL(4,I),2)
  13527.       NCOL = RELTBL(6,I)
  13528.       NATT = RELTBL(7,I)
  13529.       NTUPLE = RELTBL(8,I)
  13530.       RSTART = RELTBL(9,I)
  13531.       REND = RELTBL(10,I)
  13532.       CALL BLKMOV(RPW,RELTBL(11,I),2)
  13533.       CALL BLKMOV(MPW,RELTBL(13,I),2)
  13534.       GO TO 9999
  13535. C
  13536. C  UNABLE TO FIND WHAT WE ARE LOOKING FOR.
  13537. C
  13538.  9000 CONTINUE
  13539.       STATUS = 1
  13540.       LRROW = 0
  13541.  9999 CONTINUE
  13542.       RETURN
  13543.       END
  13544.       SUBROUTINE RELOAD
  13545.       INCLUDE rin:TEXT.BLK
  13546. C
  13547. C  PURPOSE:   RELOAD THE DATA BASE TO RECOVER LOST SPACE FROM
  13548. C             DELETIONS.
  13549. C
  13550.       INCLUDE rin:RMATTS.BLK
  13551.       INCLUDE rin:CONST4.BLK
  13552.       INCLUDE rin:CONST8.BLK
  13553.       INCLUDE rin:RIMPTR.BLK
  13554.       INCLUDE rin:TUPLEA.BLK
  13555.       INCLUDE rin:TUPLER.BLK
  13556.       INCLUDE rin:BUFFER.BLK
  13557.       INCLUDE rin:START.BLK
  13558.       INCLUDE rin:RIMCOM.BLK
  13559.       INCLUDE rin:FLAGS.BLK
  13560.       INCLUDE rin:MISC.BLK
  13561.       INCLUDE rin:SRTCOM.BLK
  13562.       INCLUDE rin:F2COM.BLK
  13563.       INCLUDE rin:F3COM.BLK
  13564.       INCLUDE rin:DCLAR1.BLK
  13565.       INCLUDE rin:DCLAR4.BLK
  13566. C
  13567. C  DIMENSION AND DATA
  13568. C
  13569.       INTEGER FILE4
  13570.       LOGICAL EQ
  13571.       INTEGER COLUMN
  13572.       INTEGER OFFSET
  13573.       integer lenbfb
  13574.       CHARACTER*8 FNAME
  13575. C
  13576. C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
  13577. C
  13578.       FILE = K8ZFIL
  13579.       IFMOD = .TRUE.
  13580.       CALL RMDBLK(DBNAME)
  13581.       IF(RMSTAT.EQ.0) GO TO 50
  13582.       CALL WARN(RMSTAT,DBNAME,0)
  13583.       GO TO 9999
  13584.    50 CONTINUE
  13585.       IFMOD = .TRUE.
  13586. C
  13587. C  SET UP THE NEW DATA FILE.
  13588. C
  13589. C
  13590. C  FORM THE NAMES FOR FILE2 AND FILE3.
  13591. C
  13592.       DO 10 I=1,7
  13593.       CALL GETT(DBNAME,I,IT)
  13594.       IF(IT.EQ.IBLANK) GO TO 20
  13595.    10 CONTINUE
  13596.       I = 7
  13597.    20 CONTINUE
  13598.       RIMDB2 = BLANK
  13599.       CALL STRMOV(DBNAME,1,I,RIMDB2,1)
  13600.       CALL PUTT(RIMDB2,I,K42)
  13601.       RIMDB3 = RIMDB2
  13602.       CALL PUTT(RIMDB3,I,K43)
  13603.       FILE = RIMDB2
  13604.       FILE4 = 34
  13605.       WRITE(FNAME,30) FILE
  13606.    30 FORMAT(A8)
  13607.       lenbfb=lenbf2*4
  13608. c buff length in bytes
  13609.     if(lenbfb.gt.1024)lenbfb=1024
  13610. c amiga fortran can't do over 10214 bytes/rec
  13611.       OPEN(UNIT=FILE4, FILE=FNAME, ACCESS='DIRECT',
  13612.      X     RECL=LENBFb,
  13613.      X     STATUS='NEW', IOSTAT=IOS)
  13614. C
  13615. C  INITIALIZE THIS FILE.
  13616. C
  13617.       CALL BLKCHG(4,LENBF2,1)
  13618.       KQ4 = BLKLOC(4)
  13619.       CALL ZEROIT(BUFFER(KQ4),LENBF2)
  13620.       CALL RIOOUT(FILE4,1,BUFFER(KQ4),LENBF2,IOS)
  13621.       KF4REC = 1
  13622.       IF(IOS.NE.0) RMSTAT = 2400 + IOS
  13623.       LF4REC = 1
  13624.       LF4WRD = 20
  13625. C
  13626. C  CYCLE THROUGH THE RELATIONS.
  13627. C
  13628.       I = LOCREL(BLANK)
  13629.       IF(I.NE.0) GO TO 9999
  13630.   100 CONTINUE
  13631.       CALL RELGET(ISTAT)
  13632.       IF(ISTAT.NE.0) GO TO 1000
  13633.       IF(NTUPLE.EQ.0) GO TO 100
  13634. C
  13635. C  START LOADING.
  13636. C
  13637.       NSTART = 0
  13638.       ID = NSTART
  13639.       NTUPLE = 0
  13640.       IDOLD = RSTART
  13641. C
  13642. C  GET A ROW FROM THE RELATION.
  13643. C
  13644.   200 CONTINUE
  13645.       IF(IDOLD.EQ.0) GO TO 600
  13646.       CALL ITOH(N1,N2,IDOLD)
  13647.       IF(N2.EQ.0) GO TO 600
  13648.       CALL GETDAT(1,IDOLD,LOCTUP,LENGTH)
  13649.       IF(IDOLD.LT.0) GO TO 200
  13650.       NTUPLE = NTUPLE + 1
  13651. C
  13652. C  UNPAC THE ID WORD.
  13653. C
  13654.       CALL ITOH(OFFSET,IOBN,ID)
  13655. C
  13656. C  CALCULATE THE NEW ID VALUE.
  13657. C
  13658.       IF(LF4WRD + LENGTH + 1 .LE. LENBF2) GO TO 300
  13659.       LF4REC = LF4REC + 1
  13660.       LF4WRD = 1
  13661.   300 CONTINUE
  13662.       CALL HTOI(LF4WRD,LF4REC,ID)
  13663.       IF(IOBN.EQ.0) GO TO 400
  13664. C
  13665. C  FIX UP THE ID POINTER SO IT POINTS TO THE NEXT TUPLE.
  13666. C
  13667.       KQ0 = BLKLOC(4) - 1
  13668.       ISIGN = 1
  13669.       BUFFER(KQ0 + OFFSET) = ISIGN * ID
  13670. C
  13671. C  NOW MOVE THE NEW TUPLE.
  13672. C
  13673.   400 CONTINUE
  13674.       CALL ITOH(OFFSET,IOBN,ID)
  13675. C
  13676.       IF(IOBN.EQ.KF4REC) GO TO 500
  13677. C
  13678. C  WE MUST DO PAGING.
  13679. C
  13680. C  WRITE OUT THE CURRENT BLOCK.
  13681. C
  13682.       KQ4 = BLKLOC(4)
  13683.       CALL RIOOUT(FILE4,KF4REC,BUFFER(KQ4),LENBF2,IOS)
  13684.       IF(IOS.NE.0) RMSTAT = 2400 + IOS
  13685. C
  13686. C  SET UP THE NEW BLOCK.
  13687. C
  13688.       CALL ZEROIT(BUFFER(KQ4),LENBF2)
  13689.       KF4REC = IOBN
  13690. C
  13691. C  WRITE OUT THE RECORD FOR THE FIRST TIME.
  13692. C
  13693.       CALL RIOOUT(FILE4,IOBN,BUFFER(KQ4),LENBF2,IOS)
  13694.       IF(IOS.NE.0) RMSTAT = 2400 + IOS
  13695.   500 CONTINUE
  13696. C
  13697. C  MOVE THE TUPLE TO THE PAGE.
  13698. C
  13699.       KQ0 = BLKLOC(4) - 1
  13700.       BUFFER(KQ0 + OFFSET) = 0
  13701.       BUFFER(KQ0 + OFFSET + 1) = LENGTH
  13702.       CALL BLKMOV(BUFFER(KQ0 + OFFSET + 2),BUFFER(LOCTUP),LENGTH)
  13703.       LF4WRD = LF4WRD + LENGTH + 2
  13704. C
  13705. C  ALL DONE RELOADING ONE TUPLE.
  13706. C
  13707.       IF(NSTART.EQ.0) NSTART = ID
  13708.       GO TO 200
  13709.   600 CONTINUE
  13710. C
  13711. C  RESET THE TUPLER VALUES.
  13712. C
  13713.       RSTART = NSTART
  13714.       REND = ID
  13715.       CALL RELPUT
  13716.       GO TO 100
  13717. C
  13718. C  DUMP THE LAST BUFFER FULL.
  13719. C
  13720.  1000 CONTINUE
  13721.       KQ4 = BLKLOC(4)
  13722.       CALL RIOOUT(FILE4,KF4REC,BUFFER(KQ4),LENBF2,IOS)
  13723.       CALL BLKCLR(4)
  13724. C
  13725. C  READ RECORD 1 BACK INTO INDEX BUFFER 1.
  13726. C
  13727.       CALL BLKCHG(1,LENBF2,1)
  13728.       KQ1 = BLKLOC(1)
  13729.       CALL RIOIN(FILE4,1,BUFFER(KQ1),LENBF2,IOS)
  13730. C
  13731. C  RESET THE OLD FLAGS IN F2COM.
  13732. C
  13733.       LF2REC = LF4REC
  13734.       LF2WRD = LF4WRD
  13735.       CURBLK(1) = 1
  13736.       CURBLK(2) = 0
  13737.       CURBLK(3) = 0
  13738.       MODFLG(1) = 1
  13739.       MODFLG(2) = 0
  13740.       MODFLG(3) = 0
  13741.       ITEMP = FILE2
  13742.       CLOSE(UNIT=FILE2,IOSTAT=IOS)
  13743.       FILE2 = FILE4
  13744.       CALL F2CLO
  13745.       CLOSE(UNIT=FILE4,IOSTAT=IOS)
  13746.       FILE2 = ITEMP
  13747.       CALL F2OPN(RIMDB2)
  13748. C
  13749. C  NOW REMAKE THE BTREE FILE.
  13750. C
  13751.       CLOSE(FILE3,STATUS='DELETE',IOSTAT=IOS)
  13752.       CALL F3OPN(RIMDB3)
  13753. C
  13754. C  CYCLE THROUGH THE RELATIONS.
  13755. C
  13756.       I = LOCREL(BLANK)
  13757. C
  13758. C  GET A RELATION.
  13759. C
  13760.  2000 CONTINUE
  13761.       CALL RELGET(ISTAT)
  13762.       IF(ISTAT.NE.0) GO TO 3100
  13763.       RNAME = NAME
  13764.       NID = RSTART
  13765.       IID = NID
  13766.       I = LOCATT(BLANK,RNAME)
  13767.       IF(I.NE.0) GO TO 2000
  13768.  2100 CONTINUE
  13769.       CALL ATTGET(ISTAT)
  13770.       IF(ISTAT.NE.0) GO TO 2000
  13771.       IF(ATTKEY.EQ.0) GO TO 2100
  13772.       ANAME = ATTNAM
  13773.       NID = IID
  13774. C
  13775. C  DETERMINE THE COLUMN TO BE USED FOR THIS ATTRIBUTE.
  13776. C
  13777.       COLUMN = ATTCOL
  13778. C
  13779. C  INITIALIZE THE BTREE FOR THIS ELEMENT.
  13780. C
  13781.       CALL BTINIT(ATTKEY)
  13782.       START = ATTKEY
  13783.       CALL ATTPUT(ISTAT)
  13784. C
  13785. C  SORT THE KEY VALUES IF THERE ARE MORE THAN 100 OF THEM
  13786. C
  13787.       IF(NTUPLE.GT.100) GO TO 2700
  13788. C
  13789. C   SCAN THROUGH ALL THE DATA FOR THIS RELATION.
  13790. C
  13791.  2500 CONTINUE
  13792.       IF(NID.EQ.0) GO TO 2900
  13793.       CALL ITOH(N1,N2,NID)
  13794.       IF(N2.EQ.0) GO TO 2900
  13795.       CID = NID
  13796.       CALL GETDAT(1,NID,ITUP,LENGTH)
  13797.       IF(NID.LT.0) GO TO 2900
  13798.       IP = ITUP + COLUMN - 1
  13799.       IF(ATTWDS.NE.0) GO TO 2600
  13800. C
  13801. C  ATTRIBUTE IS A VARIABLE LENGTH ATTRIBUTE.
  13802. C
  13803.       IP = BUFFER(IP) + ITUP + 1
  13804.  2600 CONTINUE
  13805.       IF(BUFFER(IP).EQ.NULL) GO TO 2500
  13806.       CALL BTADD(BUFFER(IP),CID,ATTYPE)
  13807.       GO TO 2500
  13808. C
  13809. C  SORT KEY VALUES BEFORE BUILDING THE B-TREE
  13810. C
  13811.  2700 CONTINUE
  13812.       LENGTH = 2
  13813.       NSOVAR = 1
  13814.       NKSORT = 3
  13815.       SORTYP(1) = .TRUE.
  13816.       VARPOS(1) = 1
  13817.       L = 2
  13818.       IF(ATTYPE.EQ.KZTEXT) L = 4
  13819.       IF(ATTYPE.EQ.KZINT ) L = 1
  13820.       IF(ATTYPE.EQ.KZIVEC) L = 1
  13821.       IF(ATTYPE.EQ.KZIMAT) L = 1
  13822.       VARTYP(1) = L
  13823.       CALL SORT(NKSORT)
  13824. C
  13825. C  READ THE SORTED KEY VALUES AND BUILD THE BTREE
  13826. C
  13827.       CALL GTSORT(IP,1,-1,LENGTH)
  13828.  2800 CONTINUE
  13829.       CALL GTSORT(IP,1,1,LENGTH)
  13830.       IF(RMSTAT.NE.0) GO TO 2900
  13831.       IF(BUFFER(IP).EQ.NULL) GO TO 2800
  13832.       CALL BTADD(BUFFER(IP),BUFFER(2),ATTYPE)
  13833.       GO TO 2800
  13834. C
  13835. C  ALL DONE.
  13836. C
  13837.  2900 CONTINUE
  13838. C
  13839. C  RESTORE THE START TO THE BTREE TABLE.
  13840. C
  13841.       I = LOCATT(ANAME,RNAME)
  13842.       CALL ATTGET(ISTAT)
  13843.       ATTKEY = START
  13844.       CALL ATTPUT(ISTAT)
  13845. C
  13846. C  RESET OUR LOCATION GOING THROUGH THE ATTRIBUTES FOR RNAME.
  13847. C
  13848.       I = LOCATT(BLANK,RNAME)
  13849.  3000 CONTINUE
  13850.       CALL ATTGET(ISTAT)
  13851.       IF(ISTAT.NE.0) GO TO 2000
  13852.       IF(EQ(ATTNAM,ANAME)) GO TO 2100
  13853.       GO TO 3000
  13854. C
  13855. C  COPY THE NEW BTREE FILE OVER THE OLD ONE.
  13856. C
  13857.  3100 CONTINUE
  13858. C
  13859. C  RETURN
  13860. C
  13861.  9999 CONTINUE
  13862.       RETURN
  13863.       END
  13864.       SUBROUTINE RELPAG(THEROW)
  13865.       INCLUDE rin:TEXT.BLK
  13866. C
  13867. C  PURPOSE:   DO PAGING AS NEEDED FOR THE RELTBL RELATION
  13868. C
  13869. C  PARAMETERS:
  13870. C         THEROW--INPUT - ROW WANTED
  13871. C                 OUTPUT - ACTUAL ROW TO USE IN THE BUFFER
  13872.       INCLUDE rin:RELTBL.BLK
  13873.       INCLUDE rin:RIMCOM.BLK
  13874.       INCLUDE rin:F1COM.BLK
  13875.       INTEGER THEROW
  13876. C
  13877. C  TURN THE REQUESTED ROW INTO A RECORD AND OFFSET.
  13878. C
  13879.       NNREC = ((THEROW - 1) / RPBUF) + 1
  13880.       NNROW = THEROW - ((NNREC - 1) * RPBUF)
  13881. C
  13882. C  SEE IF WE ALREADY HAVE THIS RECORD IN THE BUFFER.
  13883. C
  13884.       IF(NNREC.EQ.CRREC) GO TO 300
  13885. C
  13886. C  WE MUST DO PAGING.
  13887. C
  13888. C  SEE IF THE CURRENT RECORD IN THE BUFFER HAS BEEN MODIFIED.
  13889. C
  13890.       IF(RELMOD.EQ.0) GO TO 100
  13891. C
  13892. C  WRITE OUT THE CURRENT RECORD.
  13893. C
  13894.       CALL RIOOUT(FILE1,CRREC,RELBUF,LENBF1,IOS)
  13895.       IF(IOS.NE.0) RMSTAT = 2100 + IOS
  13896. C
  13897. C  READ IN THE NEEDED RECORD.
  13898. C
  13899.   100 CONTINUE
  13900.       RELMOD = 0
  13901.       IF(NNREC.GT.LF1REC) GO TO 150
  13902.       CALL RIOIN(FILE1,NNREC,RELBUF,LENBF1,IOS)
  13903.       IF(IOS.EQ.0) GO TO 200
  13904. C
  13905. C  THERE WAS NO DATA ON THE FILE - WRITE SOME.
  13906. C
  13907.   150 CONTINUE
  13908.       CALL ZEROIT(RELBUF,LENBF1)
  13909.       CALL RIOOUT(FILE1,NNREC,RELBUF,LENBF1,IOS)
  13910.       IF(IOS.NE.0) RMSTAT = 2100 + IOS
  13911.       LF1REC = LF1REC + 1
  13912.   200 CONTINUE
  13913.       CRREC = NNREC
  13914. C
  13915. C  SET THE POINTER TO THE ACTUAL ROW IN THE BUFFER.
  13916. C
  13917.   300 CONTINUE
  13918.       THEROW = NNROW
  13919.       RETURN
  13920.       END
  13921.       SUBROUTINE RELPUT
  13922.       INCLUDE rin:TEXT.BLK
  13923. C
  13924. C  PURPOSE:   REPLACE THE CURRENT TUPLE FROM THE RELTBL RELATION
  13925. C             BASED ON CONDITIONS SET UP IN LOCREL
  13926. C
  13927.       INCLUDE rin:FLAGS.BLK
  13928.       INCLUDE rin:TUPLER.BLK
  13929.       INCLUDE rin:RELTBL.BLK
  13930.       IF(LRROW.EQ.0) GO TO 9999
  13931. C
  13932. C  MOVE THE STUFF TO ROW LRROW.
  13933. C
  13934.       CALL BLKMOV(RELTBL(2,LRROW),NAME,2)
  13935.       CALL BLKMOV(RELTBL(4,LRROW),RDATE,2)
  13936.       RELTBL(6,LRROW) = NCOL
  13937.       RELTBL(7,LRROW) = NATT
  13938.       RELTBL(8,LRROW) = NTUPLE
  13939.       RELTBL(9,LRROW) = RSTART
  13940.       RELTBL(10,LRROW) = REND
  13941.       CALL BLKMOV(RELTBL(11,LRROW),RPW,2)
  13942.       CALL BLKMOV(RELTBL(13,LRROW),MPW,2)
  13943.       RELMOD = 1
  13944.       IFMOD = .TRUE.
  13945.  9999 CONTINUE
  13946.       RETURN
  13947.       END
  13948.       SUBROUTINE REUSE
  13949.       INCLUDE rin:TEXT.BLK
  13950. C
  13951. C  PURPOSE:    RESET THE USAGE FLAGS TO OFF IN THE ICORE FLAGS
  13952. C
  13953.       INCLUDE rin:F3COM.BLK
  13954.       DO 100 NUMB=1,NUMIC
  13955.       ICORE(1,NUMB) = 0
  13956.   100 CONTINUE
  13957.       RETURN
  13958.       END
  13959.       SUBROUTINE RIM
  13960.       INCLUDE rin:TEXT.BLK
  13961. C
  13962.       INCLUDE rin:RMATTS.BLK
  13963.       INCLUDE rin:RMKEYW.BLK
  13964.       INCLUDE rin:CONST4.BLK
  13965.       INCLUDE rin:CONST8.BLK
  13966.       INCLUDE rin:FLAGS.BLK
  13967.       INCLUDE rin:RIMCOM.BLK
  13968.       INCLUDE rin:FILES.BLK
  13969.       INCLUDE rin:MISC.BLK
  13970.       INCLUDE rin:SELCOM.BLK
  13971. C
  13972.       LOGICAL EQKEYW
  13973.       INTEGER IDT(2)
  13974.       INTEGER DBSTAT
  13975.       INCLUDE rin:DCLAR4.BLK
  13976. C
  13977. C  ACCEPT USER INPUT
  13978. C
  13979.       NEXTOP = K8READ
  13980.  1000 CONTINUE
  13981.       IF(NEXTOP.NE.K8READ) GO TO 1100
  13982.       CALL LODREC
  13983.  1100 CONTINUE
  13984.       NEXTOP = K8READ
  13985. C
  13986. C  CHECK COMMAND ON CARD
  13987. C
  13988.       IF(.NOT.EQKEYW(1,KWLIST,7)) GO TO 1300
  13989. C                                   LISTREL
  13990.       IF(.NOT.DFLAG) GO TO 1550
  13991.       CALL LSTREL
  13992.       GO TO 1000
  13993.  1300 CONTINUE
  13994.       IF(.NOT.EQKEYW(1,KWSELE,6)) GO TO 1305
  13995. C                                   SELECT
  13996.       IF(.NOT.DFLAG) GO TO 1550
  13997.       CALL QUERY
  13998.       GO TO 1000
  13999.  1305 CONTINUE
  14000.       IF(.NOT.EQKEYW(1,KWCHAN,6)) GO TO 1310
  14001. C                                   CHANGE
  14002.       IF(.NOT.DFLAG) GO TO 1550
  14003.       CALL MODIFY
  14004.       GO TO 1000
  14005.  1310 CONTINUE
  14006.       IF(.NOT.EQKEYW(1,KWCOMP,7)) GO TO 1315
  14007. C                                   COMPUTE
  14008.       IF(.NOT.DFLAG) GO TO 1550
  14009.       CALL QUERY
  14010.       GO TO 1000
  14011.  1315 CONTINUE
  14012.       IF(.NOT.EQKEYW(1,KWTALL,5)) GO TO 1320
  14013. C                                   TALLY
  14014.       IF(.NOT.DFLAG) GO TO 1550
  14015.       CALL QUERY
  14016.       GO TO 1000
  14017.  1320 CONTINUE
  14018.       IF(.NOT.EQKEYW(1,KWRETU,6)) GO TO 1322
  14019. C                                   return
  14020. C note one wants to use the RETURN command instead of EXIT where
  14021. C the database should be left open...
  14022.     NextOp=KWRetu
  14023.     RETURN
  14024.  1322 CONTINUE
  14025.       IF(.NOT.EQKEYW(1,KWEXIT,4)) GO TO 1325
  14026. C                                   EXIT
  14027.       GO TO 3000
  14028.  1325 CONTINUE
  14029.       IF(.NOT.EQKEYW(1,KWLOAD,4)) GO TO 1330
  14030. C                                   LOAD
  14031.       IF(.NOT.DFLAG) GO TO 1550
  14032.       NEXTOP = K8LOAD
  14033.       GO TO 5000
  14034.  1330 CONTINUE
  14035.       IF(.NOT.EQKEYW(1,KWOPEN,4)) GO TO 1335
  14036. C                                   OPEN
  14037.       IF(LXITEM(DBSTAT).LT.2) GO TO 1495
  14038.       IF((LXLENC(2).GE.1).AND.(LXLENC(2).LE.6)) GO TO 1334
  14039.     if(nout.eq.6)goto 3245
  14040.       WRITE (NOUT,1332)
  14041.  1332 FORMAT(39H -ERROR- The Database Name Must Be 1-6 ,
  14042.      X       23HAlphanumeric Characters)
  14043.       GO TO 1000
  14044. 3245    continue
  14045.     write(c128wk,1332)
  14046.     call atxto
  14047.     goto 1000
  14048.  1334 CONTINUE
  14049.       CALL RMCLOS
  14050.       DBNAME = BLANK
  14051.       CALL LXSREC(2,1,8,DBNAME,1)
  14052.       CALL RMDBGT(DBNAME,DBSTAT)
  14053.       IF(DBSTAT.NE.0) GO TO 1000
  14054.       CALL RMOPEN(DBNAME)
  14055.       IF(RMSTAT.NE.0) CALL WARN(RMSTAT,DBNAME,0)
  14056.       GO TO 1000
  14057.  1335 CONTINUE
  14058.       IF(.NOT.EQKEYW(1,KWEXHI,7)) GO TO 1345
  14059. C                                   EXHIBIT
  14060.       IF(.NOT.DFLAG) GO TO 1550
  14061.       CALL XHIBIT
  14062.       GO TO 1000
  14063.  1345 CONTINUE
  14064.       IF(.NOT.EQKEYW(1,KWDEFI,6)) GO TO 1350
  14065. C                                   DEFINE
  14066.       GO TO 2000
  14067.  1350 CONTINUE
  14068.       IF(.NOT.EQKEYW(1,KWECHO,4)) GO TO 1355
  14069. C                                   ECHO
  14070.       CALL LXSET(KWECHO,K4ON)
  14071.       ECHO = .TRUE.
  14072.       GO TO 1000
  14073.  1355 CONTINUE
  14074.       IF(.NOT.EQKEYW(1,KWNOEC,6)) GO TO 1360
  14075. C                                   NOECHO
  14076.       CALL LXSET(KWECHO,K4OFF)
  14077.       ECHO = .FALSE.
  14078.       GO TO 1000
  14079.  1360 CONTINUE
  14080.       IF(.NOT.EQKEYW(1,KWNEWP,7)) GO TO 1365
  14081. C                                   NEWPAGE
  14082.       If(noutr.ne.6)WRITE (NOUTR,1367)
  14083. c ignore newpage cmd for spreadsheet window
  14084.  1367 FORMAT(1H1)
  14085.       GO TO 1000
  14086.  1365 CONTINUE
  14087.       IF(.NOT.EQKEYW(1,KWUSER,4)) GO TO 1370
  14088. C                                   USER
  14089.       IF((LXLENC(2).GE.1).AND.(LXLENC(2).LE.8)) GO TO 1369
  14090.     if(nout.eq.6)goto 3246
  14091.       WRITE(NOUT,1368)
  14092.  1368 FORMAT(44H -ERROR- PASSWORDS Must Be 1-8 Alphanumeric ,
  14093.      X       10HCharacters)
  14094.       GO TO 1000
  14095. 3246    continue
  14096.     write(c128wk,1368)
  14097.     call atxto
  14098.     goto 1000
  14099.  1369 CONTINUE
  14100.       USERID = BLANK
  14101.       CALL LXSREC(2,1,8,USERID,1)
  14102.       GO TO 1000
  14103.  1370 CONTINUE
  14104.       IF(.NOT.EQKEYW(1,KWRENA,6)) GO TO 1375
  14105. C                                   RENAME
  14106.       IF(.NOT.DFLAG) GO TO 1550
  14107.       CALL MODIFY
  14108.       GO TO 1000
  14109.  1375 CONTINUE
  14110.       IF(.NOT.EQKEYW(1,KWDELE,6)) GO TO 1380
  14111. C                                   DELETE
  14112.       IF(.NOT.DFLAG) GO TO 1550
  14113.       CALL MODIFY
  14114.       GO TO 1000
  14115.  1380 CONTINUE
  14116.       IF(.NOT.EQKEYW(1,KWREMO,6)) GO TO 1385
  14117. C                                   REMOVE
  14118.       IF(.NOT.DFLAG) GO TO 1550
  14119.       CALL MODIFY
  14120.       GO TO 1000
  14121.  1385 CONTINUE
  14122.       IF(.NOT.EQKEYW(1,KWQUIT,4)) GO TO 1390
  14123. C                                   QUIT
  14124.       GO TO 3000
  14125.  1390 CONTINUE
  14126.       IF(.NOT.EQKEYW(1,KWCLOS,5)) GO TO 1395
  14127. C                                   CLOSE
  14128.       IF(.NOT.DFLAG) GO TO 1550
  14129.       CALL RMCLOS
  14130.       GO TO 1000
  14131.  1395 CONTINUE
  14132.       IF(.NOT.EQKEYW(1,KWPRIN,5)) GO TO 1400
  14133. C                                   PRINT
  14134.       IF(.NOT.DFLAG) GO TO 1550
  14135.       CALL RULES
  14136.       GO TO 1000
  14137.  1400 CONTINUE
  14138.       IF(.NOT.EQKEYW(1,KWINTS,9)) GO TO 1405
  14139. C                                   INTERSECT
  14140.       IF(.NOT.DFLAG) GO TO 1550
  14141.       CALL ISREL
  14142.       GO TO 1000
  14143.  1405 CONTINUE
  14144.       IF(.NOT.EQKEYW(1,KWPROJ,7)) GO TO 1410
  14145. C                                   PROJECT
  14146.       IF(.NOT.DFLAG) GO TO 1550
  14147.       CALL PJECT
  14148.       GO TO 1000
  14149.  1410 CONTINUE
  14150.       IF(.NOT.EQKEYW(1,KWSUBT,8)) GO TO 1415
  14151. C                                   SUBTRACT
  14152.       IF(.NOT.DFLAG) GO TO 1550
  14153.       CALL SUBREL
  14154.       GO TO 1000
  14155.  1415 CONTINUE
  14156.       IF(.NOT.EQKEYW(1,KWJOIN,4)) GO TO 1420
  14157. C                                   JOIN
  14158.       IF(.NOT.DFLAG) GO TO 1550
  14159.       CALL JOIREL
  14160.       GO TO 1000
  14161.  1420 CONTINUE
  14162.       IF(.NOT.EQKEYW(1,KWBUIL,5)) GO TO 1430
  14163. C                                   BUILD
  14164.       IF(.NOT.DFLAG) GO TO 1550
  14165.       CALL BUILD
  14166.       GO TO 1000
  14167.  1430 CONTINUE
  14168.       IF(.NOT.EQKEYW(1,KWRELO,6)) GO TO 1435
  14169. C                                   RELOAD
  14170.       IF(.NOT.DFLAG) GO TO 1550
  14171.       CALL RELOAD
  14172.       GO TO 1000
  14173.  1435 CONTINUE
  14174.       IF(.NOT.EQKEYW(1,KWINPU,5)) GO TO 1440
  14175. C                                   INPUT
  14176.       GO TO 1600
  14177.  1440 CONTINUE
  14178.       IF(.NOT.EQKEYW(1,KWOUTP,6)) GO TO 1445
  14179. C                                   OUTPUT
  14180.       GO TO 1700
  14181.  1445 CONTINUE
  14182.       IF(.NOT.EQKEYW(1,KWTITL,5)) GO TO 1450
  14183. C                                   TITLE
  14184.       GO TO 2100
  14185.  1450 CONTINUE
  14186.       IF(.NOT.EQKEYW(1,KWDATE,4)) GO TO 1455
  14187. C                                   DATE
  14188.       GO TO 2200
  14189.  1455 CONTINUE
  14190.       IF(.NOT.EQKEYW(1,KWBLAN,5)) GO TO 1460
  14191. C                                   BLANK
  14192.       GO TO 2300
  14193.  1460 CONTINUE
  14194.       IF(.NOT.EQKEYW(1,KWUNLO,6)) GO TO 1465
  14195. C                                   UNLOAD
  14196.       IF(.NOT.DFLAG) GO TO 1550
  14197.       CALL UNLOAD
  14198.       GO TO 1000
  14199.  1465 CONTINUE
  14200.       IF(.NOT.EQKEYW(1,KWLINE,5)) GO TO 1470
  14201. C                                   LINES
  14202.       IF(LXID(2).NE.KZINT) GO TO 2301
  14203.       ULPP = LXIREC(2)
  14204.       IF(ULPP.GE.0) GO TO 1000
  14205.       ULPP = 0
  14206.     if(nout.eq.6)goto 3247
  14207.       WRITE(NOUT,1466)
  14208.  1466 FORMAT(50H -WARNING- Lines Entered Is Out Of Range, Reset To,
  14209.      X        8H Default,/)
  14210.       GO TO 1000
  14211. 3247    continue
  14212.     write(c128wk,1466)
  14213.     call atxto
  14214.     goto 1000
  14215.  1470 CONTINUE
  14216.       IF(.NOT.EQKEYW(1,KWWIDT,5)) GO TO 1475
  14217. C                                   WIDTH
  14218.       IF(LXID(2).NE.KZINT) GO TO 2301
  14219.       UMCPL = LXIREC(2)
  14220.       IF(UMCPL.LT.0) UMCPL = 0
  14221.       IF(((UMCPL.GE.20).AND.(UMCPL.LE.132)).OR.(UMCPL.EQ.0)) GO TO 1000
  14222. C
  14223. C  ILLEGAL WIDTH SPECIFICATION
  14224. C
  14225.       IF(UMCPL.GT.132) UMCPL = 132
  14226.       IF(UMCPL.LT.20)  UMCPL = 20
  14227.     if(nout.eq.6)goto 3248
  14228.       WRITE(NOUT,1472) UMCPL
  14229.  1472 FORMAT(51H -WARNING- Width Entered Is Out Of Range, Reset To ,
  14230.      X    I4,/)
  14231.       GO TO 1000
  14232. 3248    continue
  14233.     write(c128wk,1472)UMCPL
  14234.     call atxto
  14235.     goto 1000
  14236.  1475 CONTINUE
  14237. C                                     MENU
  14238.       IF(.NOT.EQKEYW(1,KWMENU,4)) GO TO 1480
  14239.       NEXTOP = K8MENU
  14240.       IF(.NOT.BATCH) GO TO 3500
  14241.     if(nout.eq.6)goto 3249
  14242.       WRITE(NOUT,1476)
  14243.  1476 FORMAT(39H -ERROR- MENU Mode Not Allowed In BATCH )
  14244. 3249      NEXTOP = K8READ
  14245.       GO TO 1000
  14246.  1480 CONTINUE
  14247. C                                    TOLERANCE
  14248.       IF(.NOT.EQKEYW(1,KWTOLE,9)) GO TO 1485
  14249.       IF(LXID(2).NE.KZREAL) GO TO 1495
  14250.       TOL = RXREC(2)
  14251.       PCENT = .FALSE.
  14252.       IF(.NOT.EQKEYW(3,KWPERC,7)) GO TO 1000
  14253.       TOL = TOL/100.
  14254.       PCENT = .TRUE.
  14255.       GO TO 1000
  14256.  1485 CONTINUE
  14257. C                                    CHECK
  14258.       IF(.NOT.EQKEYW(1,KWCHEC,5)) GO TO 1490
  14259.       RUCK = .TRUE.
  14260.       GO TO 1000
  14261.  1490 CONTINUE
  14262. C                                    NOCHECK
  14263.       IF(.NOT.EQKEYW(1,KWNOCH,7)) GO TO 1495
  14264.       RUCK = .FALSE.
  14265.       GO TO 1000
  14266.  1495 CONTINUE
  14267. C
  14268. C     NOT IDENTIFIABLE COMMAND
  14269. C
  14270.     if(nout.eq.6)goto 3250
  14271.       WRITE (NOUT,1499)
  14272.  1499 FORMAT(37H -ERROR- Invalid Command - Retype It  )
  14273.  1500 CONTINUE
  14274.       GO TO 1000
  14275. 3250    continue
  14276.     write(c128wk,1499)
  14277.     call atxto
  14278.     goto 1000
  14279.  1550 CONTINUE
  14280. C
  14281. C     NO RELATIONS YET
  14282. C
  14283.     if(nout.eq.6)goto 3251
  14284.       WRITE (NOUT,1560)
  14285.  1560 FORMAT(53H -ERROR- No Relations Defined Yet For This Data Base )
  14286.       GO TO 1000
  14287. 3251    continue
  14288.     write(c128wk,1560)
  14289.     call atxto
  14290.     goto 1000
  14291. C
  14292. C     PROCESS THE INPUT COMMAND
  14293. C
  14294.  1600 CONTINUE
  14295.       IF((LXLENC(2).GE.1).AND.(LXLENC(2).LE.7)) GO TO 1610
  14296.     if(nout.eq.6)goto 3252
  14297.       WRITE(NOUT,1800)
  14298.       GO TO 1000
  14299. 3252    continue
  14300.     write(c128wk,1800)
  14301.     call atxto
  14302.     goto 1000
  14303.  1610 CONTINUE
  14304.       IFILE = BLANK
  14305.       CALL LXSREC(2,1,LXLENC(2),IFILE,1)
  14306.       CALL SETIN(IFILE)
  14307.       GO TO 1000
  14308. C
  14309. C     PROCESS THE OUTPUT COMMAND
  14310. C
  14311.  1700 CONTINUE
  14312.       IF((LXLENC(2).GE.1).AND.(LXLENC(2).LE.7)) GO TO 1710
  14313.     if(nout.eq.6)goto 3252
  14314.       WRITE(NOUT,1800)
  14315.       GO TO 1000
  14316.  1710 CONTINUE
  14317.       IFILE = BLANK
  14318.       CALL LXSREC(2,1,LXLENC(2),IFILE,1)
  14319.       CALL SETOUT(IFILE)
  14320.       GO TO 1000
  14321.  1800 FORMAT(45H -ERROR- File Names Must Be 1-7 Alphanumeric ,
  14322.      X       10HCharacters)
  14323. C
  14324. C  GO TO THE DEFINE MODULE.
  14325. C
  14326.  2000 CONTINUE
  14327.       NEXTOP = K8DEFI
  14328.       GO TO 3500
  14329. C
  14330. C  PROCESS THE TITLE COMMAND
  14331. C
  14332.  2100 CONTINUE
  14333.       KOL = 78
  14334.       IF(.NOT.CONNO) KOL = 132
  14335.       IF(UMCPL.NE.0) KOL = UMCPL
  14336.       KOLW = ((KOL-1)/CHPWD + 1)*CHPWD
  14337.       CALL FILCH(LINE,1,KOLW,BLANK)
  14338.       KCHAR = LXLENC(2)
  14339.       IF(KCHAR.LE.KOL) GOTO 2150
  14340.       KCHAR = KOL-2
  14341.     if(nout.eq.6)goto 3253
  14342.       WRITE(NOUT,100)
  14343.  100  FORMAT(53H -WARNING- Title Entered Was Too Long And Will Be Tru,
  14344.      X 6Hncated )
  14345. C
  14346.     goto 2150
  14347. 3253    continue
  14348.     write(c128wk,100)
  14349.     call atxto
  14350. c
  14351.  2150 CONTINUE
  14352.       KSTRT = (KOL-KCHAR)/2 + 1
  14353.       CALL LXSREC(2,1,KCHAR,LINE,KSTRT)
  14354.       CALL SPOUT(LINE,KOL)
  14355.       GO TO 1000
  14356. C
  14357. C  PROCESS THE DATE COMMAND
  14358. C
  14359.  2200 CONTINUE
  14360.       KOL = 78
  14361.       IF(.NOT.CONNO) KOL = 132
  14362.       IF(UMCPL.NE.0) KOL = UMCPL
  14363.       KOLW = ((KOL-1)/CHPWD + 1)*CHPWD
  14364.       CALL FILCH(LINE,1,KOLW,BLANK)
  14365.       KSTRT = KOL/2 - 4
  14366.       CALL RMDATE(IDT)
  14367.       CALL STRMOV(IDT,1,8,LINE,KSTRT)
  14368.       CALL SPOUT(LINE,KOL)
  14369.       GO TO 1000
  14370. C
  14371. C  PROCESS THE BLANK COMMAND
  14372. C
  14373.  2300 CONTINUE
  14374.       IF(LXITEM(ITEM).EQ.1) GO TO 2303
  14375.       IF(LXID(2).EQ.KZINT) GO TO 2303
  14376.  2301 CONTINUE
  14377.     if(nout.eq.6)goto 3254
  14378.       WRITE(NOUT,2302)
  14379.  2302 FORMAT(34H -ERROR- Item 2 Must Be An INTEGER)
  14380.       GO TO 1000
  14381. 3254    continue
  14382.     write(c128wk,2302)
  14383.     call atxto
  14384.     goto 1000
  14385.  2303 CONTINUE
  14386.       KOL = 1
  14387.       IF(LXITEM(ITEM).EQ.2) KOL = LXIREC(2)
  14388.       IF(KOL.LE.0) KOL = 1
  14389.       DO 2310 K=1,KOL
  14390. c ignore blank commandto screen too.
  14391.       if(noutr.ne.6)WRITE (NOUTR,2305)
  14392.  2305 FORMAT(1H )
  14393.  2310 CONTINUE
  14394.       GO TO 1000
  14395. C
  14396. C  CLOSE THE DATA BASE AND EXIT.
  14397. C
  14398.  3000 CONTINUE
  14399.       NEXTOP = K8EXIT
  14400.  3500 CONTINUE
  14401.       CALL RMCLOS
  14402.  5000 CONTINUE
  14403.       RETURN
  14404.       END
  14405.       SUBROUTINE RIOIN(FILE,RECORD,BUFFER,NWDS,IOS)
  14406.       INCLUDE rin:TEXT.BLK
  14407. C
  14408. C  PURPOSE:   COVER ROUTINE FOR RANDOM INPUT - VAX VERSION
  14409. C
  14410. C  PARAMETERS:
  14411. C         FILE----ARRAY WITH A FET
  14412. C         RECORD--RECORD NUMBER WANTED
  14413. C         BUFFER--BUFFER TO READ INTO
  14414. C         NWDS----NUMBER OF WORDS PER BUFFER
  14415. C         IOS-----STATUS VARIABLE - 0 MEANS SUCCESS, ELSE TILT
  14416. C
  14417.       INTEGER FILE
  14418.       INTEGER RECORD
  14419.     logical isitin
  14420.     integer filsiz,isz,lnbyt
  14421.       INTEGER BUFFER(*)
  14422. C handle new files that may be empty
  14423.     ios=1
  14424.     inquire(unit=file,exist=isitin,size=filsiz)
  14425.     if(.not.ISITIN)return
  14426.     isz=record*4*nwds
  14427.     if(filsiz.lt.isz)return
  14428. c this returns ios nonzero if the file hasn't got the data desired
  14429. C even if the file exists.
  14430.     ik=nwds/256
  14431. c amiga limit=1024 bytes/rec direct access
  14432.     if(ik.lt.1)ik=1
  14433.     irl=1+(record-1)*ik
  14434.     ibl=1
  14435.     ibh=min0(256,nwds)
  14436.     do 150 n150=1,ik
  14437.       READ(FILE,REC=irl,IOSTAT=IOS) (BUFFER(I),I=ibl,ibh)
  14438.     ibl=ibl+256
  14439.     ibh=ibh+256
  14440.     irl=irl+1
  14441. 150    continue
  14442.       RETURN
  14443.       END
  14444.       SUBROUTINE RIOOPN(FNAME,FILE,NWDS,IOS)
  14445.       INCLUDE rin:TEXT.BLK
  14446. C
  14447. C  PURPOSE:   COVER ROUTINE TO OPEN A RANDOM FILE
  14448. C
  14449. C  PARAMETERS:
  14450. C         FNAME---NAME OF THE FILE TO OPEN
  14451. C         FILE----ARRAY WITH A FET
  14452. C         NWDS----NUMBER OF WORDS PER RECORD
  14453. C         IOS-----STATUS VARIABLE - O MEANS SUCCESS, ELSE TILT
  14454. C
  14455.       INCLUDE rin:RIO.BLK
  14456.       REAL*8 FNAME
  14457.       integer reclb
  14458.       CHARACTER*8 NAME
  14459.       INTEGER FILE
  14460.       WRITE(NAME,100) FNAME
  14461.   100 FORMAT(A8)
  14462.       reclb=NWDS*4
  14463. C      OPEN(UNIT=FILE, FILE=NAME, ACCESS='DIRECT',
  14464. C     X     RECL=NWDS, ORGANIZATION='SEQUENTIAL',
  14465. C     X     STATUS='UNKNOWN',IOSTAT=IOS,SHARED)
  14466. C
  14467. C OPEN FOR EXCLUSIVE ACCESS, OMITTING THE "SHARED" KEYWORD
  14468.     if(reclb.gt.1024)reclb=1024
  14469. c amiga fortran limit is 1024 bytes/rec for direct access
  14470. c so read multiple records as needed
  14471.       OPEN(UNIT=FILE, FILE=NAME, ACCESS='DIRECT',
  14472.      X     RECL=reclb,
  14473.      X     STATUS='UNKNOWN',IOSTAT=IOS)
  14474.       IUN = FILE - 29
  14475.       IRECPS(IUN) = 0
  14476.       RETURN
  14477.       END
  14478.       SUBROUTINE RIOOUT(FILE,RECORD,BUFFER,NWDS,IOS)
  14479.       INCLUDE rin:TEXT.BLK
  14480. C
  14481. C  PURPOSE:   COVER ROUTINE FOR RANDOM OUTPUT - VAX VERSION
  14482. C
  14483. C  PARAMETERS:
  14484. C         FILE----ARRAY WITH A FET
  14485. C         RECORD--RECORD NUMBER WANTED
  14486. C         BUFFER--BUFFER TO WRITE FROM
  14487. C         NWDS----NUMBER OF WORDS PER BUFFER
  14488. C         IOS-----STATUS VARIABLE - 0 MEANS SUCCESS, ELSE TILT
  14489. C
  14490.       INCLUDE rin:RIO.BLK
  14491.       INTEGER FILE
  14492.       INTEGER RECORD
  14493.       INTEGER BUFFER(*)
  14494.       IUN = FILE - 29
  14495.       IRECPS(IUN) = IRECPS(IUN) + 1
  14496.     ik=nwds/256
  14497.     if(ik.lt.1)ik=1
  14498. c ik is count to read
  14499.     irl=1+(record-1)*ik
  14500.     ibl=1
  14501.     ibh=min0(256,nwds)
  14502.       IF(RECORD.EQ.0) GO TO 100
  14503.     do 130 n150=1,ik
  14504.       WRITE(FILE,REC=irl,IOSTAT=IOS) (BUFFER(I),I=ibl,ibh)
  14505.     ibl=ibl+256
  14506.     ibh=ibh+256
  14507.     irl=irl+1
  14508. 130    continue
  14509.       RETURN
  14510.   100 CONTINUE
  14511.       N = IRECPS(IUN)
  14512.     irl=1+(n-1)*ik
  14513.     do 150 n150=1,ik
  14514.       WRITE(FILE,REC=irl,IOSTAT=IOS) (BUFFER(I),I=ibl,ibh)
  14515.     ibl=ibl+256
  14516.     ibh=ibh+256
  14517.     irl=irl+1
  14518. 150    continue
  14519.       RETURN
  14520.       END
  14521.       SUBROUTINE RMCLOS
  14522.       INCLUDE rin:TEXT.BLK
  14523. C
  14524. C  PURPOSE:   CLOSE A RIM DATABASE.
  14525. C
  14526.       INCLUDE rin:RIMCOM.BLK
  14527.       INCLUDE rin:CONST8.BLK
  14528.       INCLUDE rin:FLAGS.BLK
  14529.       INCLUDE rin:DCLAR4.BLK
  14530. C
  14531. C  CLOSE THE MULTIPLE RMFIND SAVE FILE - ZZRIMZZ
  14532. C
  14533.       FILE = K8ZFIL
  14534.       CALL DROPF(FILE)
  14535. C
  14536. C  DO NOT CLOSE THE DATABASE IF THERE WERE NO MODIFICATIONS
  14537. C
  14538.       RMSTAT = 0
  14539.       IF(.NOT.DFLAG) RETURN
  14540.       DFLAG = .FALSE.
  14541.       IF(.NOT.IFMOD) RETURN
  14542. C
  14543. C  RESET THE DATABASE DATE AND TIME.
  14544. C
  14545.       CALL RMDATE(DBDATE)
  14546.       CALL RMTIME(DBTIME)
  14547. C
  14548. C  CLOSE THE THREE DATABASE FILES.
  14549. C
  14550.       CALL F1CLO
  14551.       CALL F2CLO
  14552.       CALL F3CLO
  14553.       DFLAG = .FALSE.
  14554.       IFMOD = .FALSE.
  14555.       RETURN
  14556.       END
  14557.       SUBROUTINE RMCONS
  14558.       INCLUDE rin:TEXT.BLK
  14559. C
  14560. C  PURPOSE:  THIS ROUTINE INITIALIZES THE HOLLERITH CONSTANTS USED
  14561. C            BY RIM. THE CODE IS MACHINE DEPENDENT.
  14562. C
  14563.       INCLUDE rin:FLAGS.BLK
  14564.       INCLUDE rin:MISC.BLK
  14565.       INCLUDE rin:CONST4.BLK
  14566.       INCLUDE rin:CONST8.BLK
  14567.       INCLUDE rin:RMATTS.BLK
  14568.       INCLUDE rin:RMKEYW.BLK
  14569.       REAL*8  J8RRC,J8RDT,J8NAM,J8NUM,J8AOR,J8AN1,
  14570.      X        J8RN1,J8OPR,J8TYP,J8AN2,J8RN2,J8VAL,J8XXX,J8AND,J8OR,
  14571.      X        J8ZFIL,J8HDB,J8COMM,J8SCH,J8RC,J8DBA,J8RMDT,J8RIM,
  14572.      X        J8BEGI,J8READ,J8USE,J8LOAD,J8DEFI,J8MENU,J8EXIT,J8IN,
  14573.      X        J8OUT,J8LIM,J8ROWS,J8DATA,J8ALL,J8ZZ98,J8ZZ99
  14574.       REAL*8  JWBY,JWEQ,JWIN,JWIS,JWTO,
  14575.      X        JWALL,JWEND,JWFOR,JWINT,JWKEY,JWMPW,JWRPW,JWVAR,JWZIP,
  14576.      X        JWDATE,JWDMAT,JWDVEC,JWECHO,JWEXIT,JWFROM,JWHELP,JWIMAT,
  14577.      X        JWIVEC,JWJOIN,JWLOAD,JWMENU,JWOPEN,JWQUIT,JWREAD,JWREAL,
  14578.      X        JWRMAT,JWROWS,JWRULE,JWRVEC,JWTEXT,JWUSER,JWWITH,JWBLAN,
  14579.      X        JWBUIL,JWCHEC,JWCLOS,JWCOUN,JWINPU,JWLIMI,JWLINE,JWOWNE,
  14580.      X        JWPRIN,JWRULS,JWTALL,JWTITL,JWUSIN,JWWHER,JWWIDT,JWCHAN,
  14581.      X        JWDEFI,JWDELE,JWDOUB,JWMODI,JWNOEC,JWOUTP,JWRELO,JWREMO,
  14582.      X        JWRENA,JWSELE,JWSORT,JWTUPL,JWUNLO,JWCOMP,JWEXHI,JWFORM,
  14583.      X        JWLIST,JWNEWP,JWNOCH,JWPERC,JWPROJ,JWATTR,JWDUPL,JWELEM,
  14584.      X        JWINTS,JWPASS,JWRELA,JWSUBT,JWTERM,JWTOLE,JWRETU
  14585.       REAL*8  J8CON1,J8CON2,J8CON3
  14586.       DIMENSION J4KOM(6),J4BOOL(17),J4HEAD(6)
  14587. C
  14588. C  VARIABLES USED BY THE FLAGS AND MISC COMMON BLOCKS
  14589. C
  14590.       DATA J8CON1 /4HNONE/
  14591.       DATA J8CON2 /1H /
  14592.       DATA J8CON3 /3H-0-/
  14593.       DATA J4CON1 /1H /
  14594.       DATA J4CON2 /3HRIM/
  14595.       DATA J4CON3 /3H-0-/
  14596.       DATA J4CON4 /4H*END/
  14597. C
  14598. C  VARIABLES USED BY THE CONST4 COMMON BLOCK
  14599. C
  14600.       DATA J4DP /2HD>/
  14601.       DATA J4RP /2HR>/
  14602.       DATA J4LP /2HL>/
  14603.       DATA J4HP /2HH>/
  14604.       DATA J4IS /2HIS/
  14605.       DATA J4EQ /2HEQ/
  14606.       DATA J4ON /2HON/
  14607.       DATA J4OR /2HOR/
  14608.       DATA J4OFF /3HOFF/
  14609.       DATA J4AND /3HAND/
  14610.       DATA J4MIN /3HMIN/
  14611.       DATA J4MAX /3HMAX/
  14612.       DATA J4AVE /3HAVE/
  14613.       DATA J4SUM /3HSUM/
  14614.       DATA J4END /3HEND/
  14615.       DATA J4DIM /3HDIM/
  14616.       DATA J4CRE /3HCRE/
  14617.       DATA J4UPD /3HUPD/
  14618.       DATA J4EOF /3HEOF/
  14619.       DATA J4LOD /3HLOD/
  14620.       DATA J4QUE /3HQUE/
  14621.       DATA J4COM /3HCOM/
  14622.       DATA J4CON /3HCON/
  14623.       DATA J4KEY /3HKEY/
  14624.       DATA J4YES /3HYES/
  14625.       DATA J4FOR /3HFOR/
  14626.       DATA J4LOA /3HLOA/
  14627.       DATA J4QUIT /4HQUIT/
  14628.       DATA J4EXIT /4HEXIT/
  14629.       DATA J4ECHO /4HECHO/
  14630.       DATA J4LOAD /4HLOAD/
  14631.       DATA J4DATA /4HDATA/
  14632.       DATA J4NONE /4HNONE/
  14633.       DATA J4PROM /4HPROM/
  14634.       DATA J4PRES /4HPRES/
  14635.       DATA J4INPT /4HINPT/
  14636.       DATA J4OTPT /4HOTPT/
  14637.       DATA J4WITH /4HWITH/
  14638.       DATA J4HASH /4HHASH/
  14639.       DATA J4A /1HA/
  14640.       DATA J4D /1HD/
  14641.       DATA J4Y /1HY/
  14642.       DATA J4N /1HN/
  14643.       DATA J4E /1HE/
  14644.       DATA J4M /1HM/
  14645.       DATA J40 /1H0/
  14646.       DATA J41 /1H1/
  14647.       DATA J42 /1H2/
  14648.       DATA J43 /1H3/
  14649.       DATA J44 /1H4/
  14650.       DATA J45 /1H5/
  14651.       DATA J46 /1H6/
  14652.       DATA J47 /1H7/
  14653.       DATA J48 /1H8/
  14654.       DATA J49 /1H9/
  14655.       DATA J4DOT /1H./
  14656.       DATA J4COL /1H:/
  14657.       DATA J4EQS /1H=/
  14658.       DATA J4STAR /1H*/
  14659.       DATA J4QUOT /1H"/
  14660.       DATA J4COMA /1H,/
  14661.       DATA J4LPAR /1H(/
  14662.       DATA J4RPAR /1H)/
  14663.       DATA J4PLUS /1H+/
  14664.       DATA J4MNUS /1H-/
  14665.       DATA J4KOM /2HEQ,2HEQ,2HGE,2HGT,2HLE,2HLT/
  14666.       DATA J4BOOL /3HEXI,2HEQ,2HNE,2HGT,2HGE,2HLT,2HLE,
  14667.      X             3HFAI,3HEQS,0,0,
  14668.      X             3HEQA,3HNEA,3HGTA,3HGEA,3HLTA,3HLEA/
  14669.       DATA J4HEAD /4HNUMB,4HER O,4HF OC,4HCURR,4HENCE,4HS   /
  14670. C
  14671. C  VARIABLES USED BY THE CONST8 COMMON BLOCK
  14672. C
  14673.       DATA J8RRC /8HRMRULRRC/
  14674.       DATA J8RDT /8HRMRULRDT/
  14675.       DATA J8NAM /8HRMRULNAM/
  14676.       DATA J8NUM /8HRMRULNUM/
  14677.       DATA J8AOR /8HRMRULAOR/
  14678.       DATA J8AN1 /8HRMRULAN1/
  14679.       DATA J8RN1 /8HRMRULRN1/
  14680.       DATA J8OPR /8HRMRULOPR/
  14681.       DATA J8TYP /8HRMRULTYP/
  14682.       DATA J8AN2 /8HRMRULAN2/
  14683.       DATA J8RN2 /8HRMRULRN2/
  14684.       DATA J8VAL /8HRMRULVAL/
  14685.       DATA J8XXX /8HASDFGHJK/
  14686.       DATA J8AND /3HAND/
  14687.       DATA J8OR   /2HOR/
  14688.       DATA J8ZFIL /7HZZRIMZZ/
  14689.       DATA J8HDB  /6HHELPDB/
  14690.       DATA J8COMM /7HCOMMAND/
  14691.       DATA J8SCH  /6HSCHEMA/
  14692.       DATA J8RC   /8H ROW COL/
  14693.       DATA J8DBA  /6HRIMDBA/
  14694.       DATA J8RMDT /7HRIMDATA/
  14695.       DATA J8RIM  /3HRIM/
  14696.       DATA J8BEGI /5HBEGIN/
  14697.       DATA J8READ /4HREAD/
  14698.       DATA J8USE  /3HUSE/
  14699.       DATA J8LOAD /4HLOAD/
  14700.       DATA J8DEFI /6HDEFINE/
  14701.       DATA J8MENU /4HMENU/
  14702.       DATA J8EXIT /4HEXIT/
  14703.       DATA J8IN   /5HINPUT/
  14704.       DATA J8OUT  /6HOUTPUT/
  14705.       DATA J8LIM  /5HLIMIT/
  14706.       DATA J8ROWS /4HROWS/
  14707.       DATA J8DATA /4HDATA/
  14708.       DATA J8ALL  /3HALL/
  14709.       DATA J8ZZ98 /4HZZ98/
  14710.       DATA J8ZZ99 /4HZZ99/
  14711. C
  14712. C  VARIABLES USED BY THE RMATTS COMMON BLOCK
  14713. C
  14714.       DATA JZVEC  /3HVEC/
  14715.       DATA JZMAT  /3HMAT/
  14716.       DATA JZVAR  /3HVAR/
  14717.       DATA JZINT  /3HINT/
  14718.       DATA JZREAL /4HREAL/
  14719.       DATA JZDOUB /4HDOUB/
  14720.       DATA JZTEXT /4HTEXT/
  14721.       DATA JZIVEC /4HIVEC/
  14722.       DATA JZRVEC /4HRVEC/
  14723.       DATA JZDVEC /4HDVEC/
  14724.       DATA JZIMAT /4HIMAT/
  14725.       DATA JZRMAT /4HRMAT/
  14726.       DATA JZDMAT /4HDMAT/
  14727. C
  14728. C  VARIABLES USED BY THE RMKEYW COMMON BLOCK
  14729. C
  14730.       DATA JWBY   / 2HBY       /
  14731.       DATA JWEQ   / 2HEQ     /
  14732.       DATA JWIN   / 2HIN       /
  14733.       DATA JWIS   / 2HIS       /
  14734.       DATA JWTO   / 2HTO       /
  14735.       DATA JWALL  / 3HALL      /
  14736.       DATA JWEND  / 3HEND      /
  14737.       DATA JWFOR  / 3HFOR      /
  14738.       DATA JWINT  / 7HINTEGER  /
  14739.       DATA JWKEY  / 3HKEY      /
  14740.       DATA JWMPW  / 3HMPW      /
  14741.       DATA JWRPW  / 3HRPW      /
  14742.       DATA JWVAR  / 3HVAR      /
  14743.       DATA JWZIP  / 3HZIP      /
  14744.       DATA JWDATE / 4HDATE     /
  14745.       DATA JWDMAT / 4HDMAT     /
  14746.       DATA JWDVEC / 4HDVEC     /
  14747.       DATA JWECHO / 4HECHO     /
  14748.       DATA JWEXIT / 4HEXIT     /
  14749.       DATA JWFROM / 4HFROM     /
  14750.       DATA JWHELP / 4HHELP     /
  14751.       DATA JWIMAT / 4HIMAT     /
  14752.       DATA JWIVEC / 4HIVEC     /
  14753.       DATA JWJOIN / 4HJOIN     /
  14754.       DATA JWLOAD / 4HLOAD     /
  14755.       DATA JWMENU / 4HMENU     /
  14756.       DATA JWOPEN / 4HOPEN     /
  14757.       DATA JWQUIT / 4HQUIT     /
  14758.       DATA JWREAD / 4HREAD     /
  14759.       DATA JWREAL / 4HREAL     /
  14760.       DATA JWRMAT / 4HRMAT     /
  14761.       DATA JWROWS / 4HROWS     /
  14762.       DATA JWRULE / 4HRULE     /
  14763.       DATA JWRVEC / 4HRVEC     /
  14764.       DATA JWTEXT / 4HTEXT     /
  14765.       DATA JWUSER / 4HUSER     /
  14766.       DATA JWWITH / 4HWITH     /
  14767.       DATA JWBLAN / 5HBLANK    /
  14768.       DATA JWBUIL / 5HBUILD    /
  14769.       DATA JWCHEC / 5HCHECK    /
  14770.       DATA JWCLOS / 5HCLOSE    /
  14771.       DATA JWCOUN / 5HCOUNT    /
  14772.       DATA JWINPU / 5HINPUT    /
  14773.       DATA JWLIMI / 5HLIMIT    /
  14774.       DATA JWLINE / 5HLINES    /
  14775.       DATA JWOWNE / 5HOWNER    /
  14776.       DATA JWPRIN / 5HPRINT    /
  14777.       DATA JWRULS / 5HRULES    /
  14778.       DATA JWTALL / 5HTALLY    /
  14779.       DATA JWTITL / 5HTITLE    /
  14780.       DATA JWUSIN / 5HUSING    /
  14781.       DATA JWWHER / 5HWHERE    /
  14782.       DATA JWWIDT / 5HWIDTH    /
  14783.       DATA JWCHAN / 6HCHANGE   /
  14784.       DATA JWRETU / 6HRETURN   /
  14785.       DATA JWDEFI / 6HDEFINE   /
  14786.       DATA JWDELE / 6HDELETE   /
  14787.       DATA JWDOUB / 6HDOUBLE   /
  14788.       DATA JWMODI / 6HMODIFY   /
  14789.       DATA JWNOEC / 6HNOECHO   /
  14790.       DATA JWOUTP / 6HOUTPUT   /
  14791.       DATA JWRELO / 6HRELOAD   /
  14792.       DATA JWREMO / 6HREMOVE   /
  14793.       DATA JWRENA / 6HRENAME   /
  14794.       DATA JWSELE / 6HSELECT   /
  14795.       DATA JWSORT / 6HSORTED   /
  14796.       DATA JWTUPL / 6HTUPLES   /
  14797.       DATA JWUNLO / 6HUNLOAD   /
  14798.       DATA JWCOMP / 7HCOMPUTE  /
  14799.       DATA JWEXHI / 7HEXHIBIT  /
  14800.       DATA JWFORM / 7HFORMING  /
  14801.       DATA JWLIST / 7HLISTREL  /
  14802.       DATA JWNEWP / 7HNEWPAGE  /
  14803.       DATA JWNOCH / 7HNOCHECK  /
  14804.       DATA JWPERC / 7HPERCENT  /
  14805.       DATA JWPROJ / 7HPROJECT  /
  14806.       DATA JWATTR / 8HATTRIBUT /
  14807.       DATA JWDUPL / 8HDUPLICAT /
  14808.       DATA JWELEM / 8HELEMENTS /
  14809.       DATA JWINTS / 8HINTERSEC /
  14810.       DATA JWPASS / 8HPASSWORD /
  14811.       DATA JWRELA / 8HRELATION /
  14812.       DATA JWSUBT / 8HSUBTRACT /
  14813.       DATA JWTERM / 8HTERMINAL /
  14814.       DATA JWTOLE / 8HTOLERANC /
  14815. C
  14816. C  SET THE FLAGS AND MISC VARIABLES
  14817. C
  14818.       USERID = J8CON1
  14819.       NONE = J8CON1
  14820.       BLANK = J8CON2
  14821.       DBNAME = J8CON3
  14822.       IBLANK = J4CON1
  14823.       LSTCMD = J4CON2
  14824.       NULL = J4CON3
  14825.       ENDWRD = J4CON4
  14826.       DFLAG = .FALSE.
  14827. C
  14828. C  SET THE CONST4 VARIABLES
  14829. C
  14830.       K4DP   = J4DP
  14831.       K4RP   = J4RP
  14832.       K4LP   = J4LP
  14833.       K4HP   = J4HP
  14834.       K4IS   = J4IS
  14835.       K4EQ   = J4EQ
  14836.       K4ON   = J4ON
  14837.       K4OR   = J4OR
  14838.       K4OFF  = J4OFF
  14839.       K4AND  = J4AND
  14840.       K4MIN  = J4MIN
  14841.       K4MAX  = J4MAX
  14842.       K4AVE  = J4AVE
  14843.       K4SUM  = J4SUM
  14844.       K4END  = J4END
  14845.       K4DIM  = J4DIM
  14846.       K4CRE  = J4CRE
  14847.       K4UPD  = J4UPD
  14848.       K4EOF  = J4EOF
  14849.       K4LOD  = J4LOD
  14850.       K4QUE  = J4QUE
  14851.       K4COM  = J4COM
  14852.       K4CON  = J4CON
  14853.       K4KEY  = J4KEY
  14854.       K4YES  = J4YES
  14855.       K4FOR  = J4FOR
  14856.       K4LOA  = J4LOA
  14857.       K4QUIT = J4QUIT
  14858.       K4EXIT = J4EXIT
  14859.       K4ECHO = J4ECHO
  14860.       K4LOAD = J4LOAD
  14861.       K4DATA = J4DATA
  14862.       K4NONE = J4NONE
  14863.       K4PROM = J4PROM
  14864.       K4PRES = J4PRES
  14865.       K4INPT = J4INPT
  14866.       K4OTPT = J4OTPT
  14867.       K4WITH = J4WITH
  14868.       K4HASH = J4HASH
  14869.       K4A    = J4A
  14870.       K4D    = J4D
  14871.       K4Y    = J4Y
  14872.       K4N    = J4N
  14873.       K4E    = J4E
  14874.       K4M    = J4M
  14875.       K40    = J40
  14876.       K41    = J41
  14877.       K42    = J42
  14878.       K43    = J43
  14879.       K44    = J44
  14880.       K45    = J45
  14881.       K46    = J46
  14882.       K47    = J47
  14883.       K48    = J48
  14884.       K49    = J49
  14885.       K4DOT  = J4DOT
  14886.       K4COL  = J4COL
  14887.       K4EQS  = J4EQS
  14888.       K4STAR = J4STAR
  14889.       K4QUOT = J4QUOT
  14890.       K4COMA = J4COMA
  14891.       K4LPAR = J4LPAR
  14892.       K4RPAR = J4RPAR
  14893.       K4PLUS = J4PLUS
  14894.       K4MNUS = J4MNUS
  14895.       DO 100 K = 1,6
  14896.       K4KOM(K) = J4KOM(K)
  14897.       K4HEAD(K) = J4HEAD(K)
  14898.   100 CONTINUE
  14899.       DO 200 K = 1,17
  14900.       K4BOOL(K) = J4BOOL(K)
  14901.   200 CONTINUE
  14902. C
  14903. C  SET THE CONST8 VARIABLES
  14904. C
  14905.       K8RRC  = J8RRC
  14906.       K8RDT  = J8RDT
  14907.       K8NAM  = J8NAM
  14908.       K8NUM  = J8NUM
  14909.       K8AOR  = J8AOR
  14910.       K8AN1  = J8AN1
  14911.       K8RN1  = J8RN1
  14912.       K8OPR  = J8OPR
  14913.       K8TYP  = J8TYP
  14914.       K8AN2  = J8AN2
  14915.       K8RN2  = J8RN2
  14916.       K8VAL  = J8VAL
  14917.       K8XXX  = J8XXX
  14918.       K8AND  = J8AND
  14919.       K8OR   = J8OR
  14920.       K8ZFIL = J8ZFIL
  14921.       K8HDB  = J8HDB
  14922.       K8COMM = J8COMM
  14923.       K8SCH  = J8SCH
  14924.       K8RC   = J8RC
  14925.       K8DBA  = J8DBA
  14926.       K8RMDT = J8RMDT
  14927.       K8RIM  = J8RIM
  14928.       K8BEGI = J8BEGI
  14929.       K8READ = J8READ
  14930.       K8USE  = J8USE
  14931.       K8LOAD = J8LOAD
  14932.       K8DEFI = J8DEFI
  14933.       K8MENU = J8MENU
  14934.       K8EXIT = J8EXIT
  14935.       K8IN   = J8IN
  14936.       K8OUT  = J8OUT
  14937.       K8LIM  = J8LIM
  14938.       K8ROWS = J8ROWS
  14939.       K8DATA = J8DATA
  14940.       K8ALL  = J8ALL
  14941.       K8ZZ98 = J8ZZ98
  14942.       K8ZZ99 = J8ZZ99
  14943. C
  14944. C  SET THE RMATTS VARIABLES
  14945. C
  14946.       KZVEC  = JZVEC
  14947.       KZMAT  = JZMAT
  14948.       KZVAR  = JZVAR
  14949.       KZINT  = JZINT
  14950.       KZREAL = JZREAL
  14951.       KZDOUB = JZDOUB
  14952.       KZTEXT = JZTEXT
  14953.       KZIVEC = JZIVEC
  14954.       KZRVEC = JZRVEC
  14955.       KZDVEC = JZDVEC
  14956.       KZIMAT = JZIMAT
  14957.       KZRMAT = JZRMAT
  14958.       KZDMAT = JZDMAT
  14959. C
  14960. C  SET THE RMKEYW VARIABLES
  14961. C
  14962.       KWBY   = JWBY
  14963.       KWEQ   = JWEQ
  14964.       KWIN   = JWIN
  14965.       KWIS   = JWIS
  14966.       KWTO   = JWTO
  14967.       KWALL  = JWALL
  14968.       KWEND  = JWEND
  14969.       KWFOR  = JWFOR
  14970.       KWINT  = JWINT
  14971.       KWKEY  = JWKEY
  14972.       KWMPW  = JWMPW
  14973.       KWRPW  = JWRPW
  14974.       KWVAR  = JWVAR
  14975.       KWZIP  = JWZIP
  14976.       KWDATE = JWDATE
  14977.       KWDMAT = JWDMAT
  14978.       KWDVEC = JWDVEC
  14979.       KWECHO = JWECHO
  14980.       KWEXIT = JWEXIT
  14981.       KWRETU = JWRETU
  14982.       KWFROM = JWFROM
  14983.       KWHELP = JWHELP
  14984.       KWIMAT = JWIMAT
  14985.       KWIVEC = JWIVEC
  14986.       KWJOIN = JWJOIN
  14987.       KWLOAD = JWLOAD
  14988.       KWMENU = JWMENU
  14989.       KWOPEN = JWOPEN
  14990.       KWQUIT = JWQUIT
  14991.       KWREAD = JWREAD
  14992.       KWREAL = JWREAL
  14993.       KWRMAT = JWRMAT
  14994.       KWROWS = JWROWS
  14995.       KWRULE = JWRULE
  14996.       KWRVEC = JWRVEC
  14997.       KWTEXT = JWTEXT
  14998.       KWUSER = JWUSER
  14999.       KWWITH = JWWITH
  15000.       KWBLAN = JWBLAN
  15001.       KWBUIL = JWBUIL
  15002.       KWCHEC = JWCHEC
  15003.       KWCLOS = JWCLOS
  15004.       KWCOUN = JWCOUN
  15005.       KWINPU = JWINPU
  15006.       KWLIMI = JWLIMI
  15007.       KWLINE = JWLINE
  15008.       KWOWNE = JWOWNE
  15009.       KWPRIN = JWPRIN
  15010.       KWRULS = JWRULS
  15011.       KWTALL = JWTALL
  15012.       KWTITL = JWTITL
  15013.       KWUSIN = JWUSIN
  15014.       KWWHER = JWWHER
  15015.       KWWIDT = JWWIDT
  15016.       KWCHAN = JWCHAN
  15017.       KWDEFI = JWDEFI
  15018.       KWDELE = JWDELE
  15019.       KWDOUB = JWDOUB
  15020.       KWMODI = JWMODI
  15021.       KWNOEC = JWNOEC
  15022.       KWOUTP = JWOUTP
  15023.       KWRELO = JWRELO
  15024.       KWREMO = JWREMO
  15025.       KWRENA = JWRENA
  15026.       KWSELE = JWSELE
  15027.       KWSORT = JWSORT
  15028.       KWTUPL = JWTUPL
  15029.       KWUNLO = JWUNLO
  15030.       KWCOMP = JWCOMP
  15031.       KWEXHI = JWEXHI
  15032.       KWFORM = JWFORM
  15033.       KWLIST = JWLIST
  15034.       KWNEWP = JWNEWP
  15035.       KWNOCH = JWNOCH
  15036.       KWPERC = JWPERC
  15037.       KWPROJ = JWPROJ
  15038.       KWATTR = JWATTR
  15039.       KWDUPL = JWDUPL
  15040.       KWELEM = JWELEM
  15041.       KWINTS = JWINTS
  15042.       KWPASS = JWPASS
  15043.       KWRELA = JWRELA
  15044.       KWSUBT = JWSUBT
  15045.       KWTERM = JWTERM
  15046.       KWTOLE = JWTOLE
  15047.       RETURN
  15048.       END
  15049.       SUBROUTINE RMDATE(IT)
  15050.       INCLUDE rin:TEXT.BLK
  15051. C
  15052. C  PURPOSE:   RETURN THE CURRENT DATE IN YY/MM/DD FORMAT
  15053. C
  15054. C  PARAMETERS:
  15055. C         IT------THE CURRENT DATE
  15056. C
  15057.       INCLUDE rin:MISC.BLK
  15058.       INTEGER MONTH,DAY,YEAR
  15059.       REAL*8 IT
  15060.       Character*1 SLASH
  15061.       DATA SLASH /1H//
  15062. c      CALL IDATE(DAY,MONTH,YEAR)
  15063.     CALL DATE(month,day,year)
  15064. c    call idate(month,day,year)
  15065.     if(year.gt.1900)year=year-1900
  15066. 100    if(year.gt.100)year=year-100
  15067.        if(year.gt.100)goto 100
  15068.       IF(MONTH.LT.10) MONTH = MONTH + 100
  15069.       IF(DAY.LT.10) DAY = DAY + 100
  15070.       CALL ITOC(IT,1,2,YEAR,IERR)
  15071.       CALL ITOC(IT,3,3,MONTH,IERR)
  15072.       CALL ITOC(IT,6,3,DAY,IERR)
  15073.       CALL PUTT(IT,3,SLASH)
  15074.       CALL PUTT(IT,6,SLASH)
  15075.       RETURN
  15076.       END
  15077.       SUBROUTINE RMDBGT(NAMDB,DBSTAT)
  15078.       INCLUDE rin:TEXT.BLK
  15079. C
  15080. C  PURPOSE: THIS ROUTINE WILL GET A RIM DATA BASE FROM PERMANENT
  15081. C           FILE. THE DATA BASE MAY BE DIRECT OR INDIRECT AND MAY
  15082. C           RESIDE ON AN ALTERNATE ACCOUNT. THIS ROUTINE HAS TWO
  15083. C           SECTIONS - AN MENU MODE SECTION WHERE THE DATA BASE
  15084. C           FILE DATA IS REQUESTED FROM THE USER, A COMMAND MODE SECTION
  15085. C           WHERE THE "OPEN DBNAME ....." COMMAND IS PROCESSED TO GET
  15086. C           THE FILE DATA.
  15087. C
  15088. C  SYSTEM: CDC CYBER (BOEING)
  15089. C
  15090. C  PARAMETERS: NAMDB -- DATABASE NAME IN H FORMAT (6HDBNAME)
  15091. C              DBSTAT - 0 IF SUCCESSFULL DATABASE RETRIEVAL
  15092. C                       1 IF UNSUCCESSFULL
  15093. C                       2 IF "QUIT"
  15094. C
  15095.       INTEGER DBSTAT
  15096.       DBSTAT = 0
  15097.       RETURN
  15098.       END
  15099.       SUBROUTINE RMDBLK(NAMDB)
  15100.       INCLUDE rin:TEXT.BLK
  15101. C
  15102. C  PURPOSE: THIS ROUTINE CHECKS FOR MODIFY PERMISSION ON A GIVEN
  15103. C           DATABASE FILE. CHECKS FOR WRITE MODE ON DIRECT ACCESS
  15104. C           AND CHECKS THE LOCKING FILE FOR INDIRQECT ACCESS FILES.
  15105. C
  15106. C  SYSTEM:  CDC CYBER (BOEING)
  15107. C
  15108. C  PARAMETERS: NAMDB -- DATABASE NAME IN H FORMAT
  15109. C
  15110.       INCLUDE rin:RIMCOM.BLK
  15111.       RMSTAT = 0
  15112.       RETURN
  15113.       END
  15114.       SUBROUTINE RMDBPT
  15115.       INCLUDE rin:TEXT.BLK
  15116. C
  15117. C  PURPOSE: THIS ROUTINE RETURNS THE RIM DATABASES THAT HAVE BEEN
  15118. C           MODIFIED. THE ROUTINE IS DUMMY FOR DIRECT ACCESS
  15119. C           DATABASES, USER MANAGED DATABASES AND DATABASES THAT
  15120. C           HAVE NOT BEEN MODIFIED. NEW DATABASE (DEFINE) MAY BE
  15121. C           SAVED AS INDIRECT OR DIRECT ACCESS FILES (PRIVATE).
  15122. C
  15123. C  SYSTEM: CDC CYBER (BOEING)
  15124. C
  15125. C  PARAMETERS: NONE
  15126. C
  15127.       RETURN
  15128.       END
  15129.       SUBROUTINE RMDEL(INDPTR)
  15130.       INCLUDE rin:TEXT.BLK
  15131. C
  15132. C  THIS ROUTINE DELETES THE CURRENT ROW.
  15133. C
  15134. C  PARAMETERS:
  15135. C         INDPTR--INDEX TO SAVE BLOCK (RANGE OF 0 TO 9)
  15136.       INCLUDE rin:KEYDAT.BLK
  15137.       INCLUDE rin:RIMCOM.BLK
  15138.       INCLUDE rin:MISC.BLK
  15139.       INCLUDE rin:FLAGS.BLK
  15140.       INCLUDE rin:TUPLER.BLK
  15141.       INCLUDE rin:TUPLEA.BLK
  15142.       INCLUDE rin:RIMPTR.BLK
  15143.       INCLUDE rin:BUFFER.BLK
  15144.       INCLUDE rin:START.BLK
  15145.       INTEGER COLUMN
  15146.       RMSTAT = 0
  15147. C
  15148. C         MAKE SURE DB IS DEFINED
  15149. C
  15150.       IF(DFLAG) GOTO 10
  15151.       RMSTAT = 16
  15152.       GOTO 9999
  15153. C
  15154.    10 CONTINUE
  15155. C
  15156. C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
  15157. C
  15158.       CALL RMDBLK(DBNAME)
  15159.       IF(RMSTAT.NE.0) GO TO 9999
  15160. C
  15161. C  RESTORE THE BLOCKS AS NEEDED.
  15162. C
  15163.       CALL RMRES(INDPTR)
  15164.       IF(RMSTAT.NE.0) GO TO 9999
  15165. C
  15166. C  CHECK FOR WRITE PERMISSION ON THIS RELATION.
  15167. C
  15168.       I = LOCPRM(NAME,2)
  15169.       IF(RMSTAT.NE.0) GO TO 9999
  15170. C
  15171. C  CHECK THAT RMGET WAS CALLED
  15172. C
  15173.       IF((IVAL.GT.0).AND.(IVAL.LT.ALL9S)) GO TO 200
  15174. C
  15175. C  RMGET WAS NOT CALLED BEFORE RMPUT
  15176. C
  15177.       RMSTAT = 60
  15178.       GO TO 9999
  15179. C
  15180. C  RETRIEVE THE CURRENT ROW IN A SCRATCH TUPLE.
  15181. C
  15182.   200 CONTINUE
  15183.       CALL BLKCHG(11,MAXCOL,1)
  15184.       KQ1 = BLKLOC(11)
  15185.       NID = CID
  15186.       INDEX = INDPTR
  15187.       IF(INDEX.EQ.0) INDEX = 1
  15188.       IF(INDEX.GT.3) INDEX = 3
  15189.       LNS = NS
  15190.       NS = 0
  15191.       CALL RMLOOK(BUFFER(KQ1),INDEX,0,KURLEN)
  15192.       IVAL = IVAL - 1
  15193.       NS = LNS
  15194.       IF(RMSTAT.EQ.0) GO TO 300
  15195. C
  15196. C  NO DATA AVAILABLE
  15197. C
  15198.       RMSTAT = 60
  15199.       GO TO 9999
  15200. C
  15201. C  DELETE THE CURRENT ROW OF THE RELATION.
  15202. C
  15203.   300 CONTINUE
  15204.       CALL DELDAT(INDEX,CID)
  15205.       RDATE = DBDATE
  15206.       NTUPLE = NTUPLE - 1
  15207.       CALL RELPUT
  15208. C
  15209. C  CHANGE THE POINTERS FOR ANY KEY ELEMENTS.
  15210. C
  15211.       IF(NUMKEY.EQ.0) GO TO 9999
  15212.       I = 0
  15213.       IF(NUMKEY.LE.5) GO TO 380
  15214.       I = LOCATT(BLANK,NAME)
  15215.   380 CONTINUE
  15216.       IF(NUMKEY.GT.5) GO TO 390
  15217.       I = I + 1
  15218.       IF(I.GT.NUMKEY) GO TO 9999
  15219.       START = KEYDAT(1,I)
  15220.       COLUMN = KEYDAT(2,I)
  15221.       ATTWDS = KEYDAT(3,I)
  15222.       ATTYPE = KEYDAT(4,I)
  15223.       GO TO 395
  15224.   390 CONTINUE
  15225.       CALL ATTGET(ISTAT)
  15226.       IF(ISTAT.NE.0) GO TO 9999
  15227.       IF(ATTKEY.EQ.0) GO TO 380
  15228.       START = ATTKEY
  15229.       COLUMN = ATTCOL
  15230.   395 CONTINUE
  15231.       IF(ATTWDS.NE.0) GO TO 400
  15232.       COLUMN = BUFFER(KQ1+COLUMN-1) + 2
  15233.   400 CONTINUE
  15234.       IF(BUFFER(KQ1+COLUMN-1).EQ.NULL) GO TO 380
  15235.       CALL BTREP(BUFFER(KQ1+COLUMN-1),0,CID,ATTYPE)
  15236.       GO TO 380
  15237.  9999 CONTINUE
  15238.       RETURN
  15239.       END
  15240.       SUBROUTINE RMFIND(INDPTR,RNAME)
  15241.       INCLUDE rin:TEXT.BLK
  15242. C
  15243. C  PURPOSE: LOCATE THE TUPLES FOR RELATION RNAME
  15244. C
  15245. C  PARAMETERS: INDPTR--MULTIPLE RELATION POSITION INDICATOR
  15246. C              RNAME---RELATION NAME
  15247. C
  15248.       INCLUDE rin:FLAGS.BLK
  15249.       INCLUDE rin:TUPLER.BLK
  15250.       INCLUDE rin:TUPLEA.BLK
  15251.       INCLUDE rin:VARDAT.BLK
  15252.       INCLUDE rin:KEYDAT.BLK
  15253.       INCLUDE rin:RIMCOM.BLK
  15254.       INCLUDE rin:RIMPTR.BLK
  15255.       INCLUDE rin:MISC.BLK
  15256.       INCLUDE rin:PTRCOM.BLK
  15257.       INCLUDE rin:RULCOM.BLK
  15258.       INCLUDE rin:WHCOM.BLK
  15259. C
  15260.       LOGICAL EQ
  15261.       INCLUDE rin:DCLAR1.BLK
  15262. C
  15263. C  INITIALIZE
  15264. C
  15265.       RMSTAT = 0
  15266. C         MAKE SURE DB IS DEFINED
  15267. C
  15268.       IF(DFLAG) GOTO 10
  15269.       RMSTAT = 16
  15270.       GOTO 999
  15271. C
  15272.    10 CONTINUE
  15273.       IF(INDCUR.NE.NULL) GO TO 50
  15274. C
  15275. C     FIRST TIME IN - CHECK INDPTR
  15276. C
  15277.       IF((INDPTR.GE.0).AND.(INDPTR.LE.9)) GO TO 100
  15278.       RMSTAT = 70
  15279.       GO TO 999
  15280.    50 CONTINUE
  15281. C
  15282. C  SAVE THE CURRENT POINTERS
  15283. C
  15284.       IF(INDCUR.NE.INDPTR) CALL RMSAV(INDCUR)
  15285.       IF(RMSTAT.NE.0) GO TO 999
  15286. C
  15287. C  CHECK FOR RULES FOR THIS RELATION
  15288. C
  15289.   100 RULES = .FALSE.
  15290.       I = LOCREL(RIMRRC)
  15291.       IF(I.NE.0) GO TO 140
  15292.       CALL CHKRUL(RNAME)
  15293.       IF(RMSTAT.GE.110) GO TO 999
  15294.       RMSTAT = 0
  15295. C
  15296. C  LOCATE THE RELATION
  15297. C
  15298.   140 CONTINUE
  15299.       I = LOCREL(RNAME)
  15300.       IF(I.NE.0) GO TO 150
  15301.       CALL RELGET(I)
  15302.       IF(I.EQ.0) GO TO 200
  15303.   150 CONTINUE
  15304.       RMSTAT = 20
  15305.       GO TO 999
  15306. C
  15307. C  SET CURRENT BLOCK AND CHECK READ PERMISSION
  15308. C
  15309.   200 INDCUR = INDPTR
  15310.       NS = 0
  15311.       IF(EQ(USERID,OWNER)) GO TO 300
  15312.       IF(EQ(RPW,NONE)) GO TO 300
  15313.       IF(EQ(RPW,USERID)) GO TO 300
  15314.       IF(EQ(MPW,USERID)) GO TO 300
  15315.       RMSTAT = 90
  15316.       GO TO 999
  15317.   300 CONTINUE
  15318. C
  15319. C  SET NUMBER OF WHERE CONDITIONS AND TUPLE LIMIT
  15320. C
  15321.       NBOO = 0
  15322.       LIMTU = ALL9S
  15323.       MAXGET(INDPTR+1) = NTUPLE
  15324. C
  15325. C  CHECK FOR VARIABLE LENGTH ATTRIBUTES
  15326. C
  15327.       NUMVAR = 0
  15328.       NUMKEY = 0
  15329.       I = LOCATT(BLANK,RNAME)
  15330.       DO 500 J=1,NATT
  15331.       CALL ATTGET(ISTATX)
  15332.       IF(ISTATX.NE.0) GO TO 999
  15333.       IF(ATTKEY.EQ.0) GO TO 400
  15334.       NUMKEY = NUMKEY + 1
  15335.       IF(NUMKEY.GT.5) GO TO 400
  15336.       KEYDAT(1,NUMKEY) = ATTKEY
  15337.       KEYDAT(2,NUMKEY) = ATTCOL
  15338.       KEYDAT(3,NUMKEY) = ATTWDS
  15339.       KEYDAT(4,NUMKEY) = ATTYPE
  15340.       CALL BLKMOV(KEYDAT(5,NUMKEY),ATTNAM,2)
  15341.   400 CONTINUE
  15342.       IF(ATTWDS.NE.0) GO TO 500
  15343.       NUMVAR = NUMVAR + 1
  15344.       IF(NUMVAR.GT.5) GO TO 500
  15345.       POSVAR(1,NUMVAR) = ATTCOL
  15346.       POSVAR(2,NUMVAR) = ATTYPE
  15347.   500 CONTINUE
  15348. C
  15349.   999 CONTINUE
  15350.       RETURN
  15351.       END
  15352.       SUBROUTINE RMGATT(ANAME,TYPE,MATVEC,VAR,LEN1,LEN2,COL,KEY)
  15353.       INCLUDE rin:TEXT.BLK
  15354. C
  15355. C  PURPOSE: THIS ROUTINE GETS THE DATA FOR THE CURRENT ATTRIBUTE
  15356. C           FOR THE CURRENT RELATION.
  15357. C           (FORTRAN INTERFACE COVER ROUTINE FOR GETATT)
  15358. C
  15359. C  PARAMETERS: ANAME---ATTRIBUTE NAME
  15360. C              TYPE----ATTRIBUTE TYPE - INT,REAL,TEXT,DOUB
  15361. C              MATVEC--ATTRIBUTE TYPE - MAT OR VEC (OTHERWISE BLANK)
  15362. C              VAR-----VARIABLE LENGTH ATTRIBUTE - .TRUE. OR .FALSE.
  15363. C              LEN1----ATTRIBUTE LENGTH DATA
  15364. C                      TEXT = NUMBER OF CHARACTERS
  15365. C                      INT,REAL,DOUBLE,VECTORS = NUMBER OF ITEMS
  15366. C                      MATRIX = ROW DIMENSION
  15367. C              LEN2----COLUMN DIMENSION OF MATRICES OR 0
  15368. C              COL-----ATTRIBUTE COLUMN IN THE RELATION
  15369. C              KEY-----KEYED ATTRIBUTE - .TRUE. OR .FALSE.
  15370. C
  15371.       INCLUDE rin:RIMPTR.BLK
  15372.       INCLUDE rin:RMATTS.BLK
  15373.       INCLUDE rin:RIMCOM.BLK
  15374.       INCLUDE rin:FLAGS.BLK
  15375.       INCLUDE rin:TUPLER.BLK
  15376.       INCLUDE rin:TUPLEA.BLK
  15377.       INCLUDE rin:MISC.BLK
  15378.       INTEGER STATUS
  15379.       LOGICAL EQ
  15380.       INTEGER TYPE
  15381.       INTEGER MATVEC
  15382.       INTEGER LEN1,LEN2
  15383.       INTEGER COL
  15384.       LOGICAL VAR
  15385.       LOGICAL KEY
  15386.       INCLUDE rin:DCLAR1.BLK
  15387. C
  15388.       RMSTAT = 0
  15389.       INDCUR = NULL
  15390. C
  15391. C         MAKE SURE DB IS DEFINED
  15392. C
  15393.       IF(DFLAG) GOTO 10
  15394.       RMSTAT = 16
  15395.       GOTO 999
  15396. C
  15397.    10 CONTINUE
  15398.       CALL ATTGET(STATUS)
  15399.       IF(STATUS.EQ.0) GO TO 200
  15400. C
  15401. C  NO MORE ATTRIBUTES
  15402. C
  15403.       RMSTAT = -1
  15404.       GO TO 999
  15405. C
  15406. C   VALIDATE USER
  15407. C
  15408.   200 CONTINUE
  15409.       IF(EQ(USERID,OWNER)) GO TO 300
  15410.       IF(EQ(RPW,NONE)) GO TO 300
  15411.       IF(EQ(RPW,USERID)) GO TO 300
  15412.       IF(EQ(MPW,USERID)) GO TO 300
  15413.       RMSTAT = 90
  15414.       GO TO 999
  15415. C
  15416. C  TRANSFER THE ATTRIBUTE DATA TO THE PROPER ARGUMENTS
  15417. C
  15418.   300 CONTINUE
  15419.       ANAME = ATTNAM
  15420.       CALL TYPER(ATTYPE,MATVEC,TYPE)
  15421.       LEN1 = ATTWDS
  15422.       LEN2 = 0
  15423.       IF(TYPE.EQ.KZTEXT) LEN1 = ATTCHA
  15424.       IF(TYPE.EQ.KZDOUB) LEN1 = LEN1/2
  15425.       IF(MATVEC.NE.KZMAT) GO TO 400
  15426.       LEN2 = LEN1/ATTCHA
  15427.       IF(LEN1.NE.0) LEN1 = ATTCHA
  15428.   400 CONTINUE
  15429.       VAR = .FALSE.
  15430.       IF(LEN1.EQ.0) VAR = .TRUE.
  15431.       KEY = .FALSE.
  15432.       IF(ATTKEY.NE.0) KEY = .TRUE.
  15433.       COL = ATTCOL
  15434.   999 RETURN
  15435.       END
  15436.       SUBROUTINE RMGET(INDPTR,TUPLE)
  15437.       INCLUDE rin:TEXT.BLK
  15438. C
  15439. C  THIS ROUTINE GETS THE NEXT ROW FROM A RELATION AND STORES
  15440. C  IT IN TUPLE.
  15441. C
  15442. C  PARAMETERS:
  15443. C         INDPTR--INDEX TO SAVE BLOCK (RANGE OF 0 TO 9)
  15444. C         TUPLE---USER ARRAY TO HOLD ONE COMPLETE TUPLE
  15445.       INCLUDE rin:RIMCOM.BLK
  15446.       INCLUDE rin:VARDAT.BLK
  15447.       INCLUDE rin:PTRCOM.BLK
  15448.       INCLUDE rin:RIMPTR.BLK
  15449.       INCLUDE rin:BUFFER.BLK
  15450.       INCLUDE rin:TUPLER.BLK
  15451.       INCLUDE rin:FLAGS.BLK
  15452.       INCLUDE rin:MISC.BLK
  15453. C
  15454.       INTEGER TUPLE(*)
  15455.       RMSTAT = 0
  15456. C         MAKE SURE DB IS DEFINED
  15457. C
  15458.       IF(DFLAG) GOTO 10
  15459.       RMSTAT = 16
  15460.       GOTO 9999
  15461. C
  15462.    10 CONTINUE
  15463. C
  15464. C  RESTORE THE BLOCKS AS NEEDED.
  15465. C
  15466.       CALL RMRES(INDPTR)
  15467.       IF(RMSTAT.NE.0) GO TO 9999
  15468. C
  15469. C  LOCATE THE NEXT ROW.
  15470. C
  15471.       INDEX = INDPTR
  15472.       IF(INDEX.EQ.0) INDEX = 1
  15473.       IF(INDEX.GT.3) INDEX = 3
  15474.       IF(NS.EQ.1) GO TO 50
  15475. C
  15476. C  UNSORTED RETRIEVAL
  15477. C
  15478.       CALL RMLOOK(MAT,INDEX,1,LENGTH)
  15479.       IF(IVAL.GT.MAXGET(INDPTR+1)) GO TO 75
  15480.       IF(RMSTAT.EQ.0) GO TO 100
  15481. C
  15482. C  END OF DATA.
  15483. C
  15484.       GO TO 75
  15485. C
  15486. C  SORTED RETRIEVAL
  15487. C
  15488.    50 CONTINUE
  15489.       LENGTH = NCOL + 1
  15490.       CALL RMGTSO(MAT,10,1,LENGTH,INDPTR)
  15491.       CID = BUFFER(MAT)
  15492.       MAT = MAT + 1
  15493.       LENGTH = LENGTH - 1
  15494.       IF(RMSTAT.EQ.0) GO TO 100
  15495. C
  15496. C  END OF DATA
  15497. C
  15498.    75 CONTINUE
  15499.       RMSTAT = -1
  15500.       IVAL = ALL9S
  15501.       GO TO 9999
  15502. C
  15503. C  MOVE THE DATA.
  15504. C
  15505.   100 CONTINUE
  15506.       CALL BLKMOV(TUPLE,BUFFER(MAT),LENGTH)
  15507.       IF(NUMVAR.EQ.0) GO TO 9999
  15508.       CALL RMVARC(-1,TUPLE)
  15509.  9999 CONTINUE
  15510.       RETURN
  15511.       END
  15512.       SUBROUTINE RMGREL(RNAME,LRPW,LMPW,LASTMD,NUMATT,NUMTUP)
  15513.       INCLUDE rin:TEXT.BLK
  15514. C
  15515. C  PURPOSE: THIS ROUTINE GETS THE DATA FOR THE CURRENT RELATION
  15516. C           (FORTRAN INTERFACE COVER ROUTINE FOR GETREL)
  15517. C
  15518. C  PARAMETERS: RNAME---RELATION NAME
  15519. C              RPW-----RELATION READ PASSWORD - .TRUE. OR .FALSE.
  15520. C              MPW-----RELATION MODIFY PASSWORD - .TRUE. OR .FALSE.
  15521. C              LASTMD--DATE OF LAST RELATION MODIFICATION
  15522. C              NUMATT--NUMBER OF ATTRIBUTES
  15523. C              NUMTUP--NUMBER OF CURRENTLY DEFINED TUPLES (ROWS)
  15524. C
  15525.       INCLUDE rin:RIMCOM.BLK
  15526.       INCLUDE rin:FLAGS.BLK
  15527.       INCLUDE rin:CONST8.BLK
  15528.       INCLUDE rin:RIMPTR.BLK
  15529.       INCLUDE rin:TUPLER.BLK
  15530.       INCLUDE rin:MISC.BLK
  15531.       INTEGER STATUS
  15532.       INTEGER NUMATT
  15533.       INTEGER NUMTUP
  15534.       LOGICAL LRPW
  15535.       LOGICAL LMPW
  15536.       LOGICAL EQ
  15537.       INCLUDE rin:DCLAR1.BLK
  15538.       INCLUDE rin:DCLAR6.BLK
  15539. C
  15540.       RMSTAT = 0
  15541.       INDCUR = NULL
  15542. C
  15543. C         MAKE SURE DB IS DEFINED
  15544. C
  15545.       IF(DFLAG) GOTO 10
  15546.       RMSTAT = 16
  15547.       GOTO 999
  15548. C
  15549.    10 CONTINUE
  15550.   100 CONTINUE
  15551.       CALL RELGET(STATUS)
  15552.       IF(STATUS.EQ.0) GO TO 200
  15553. C
  15554. C  NO MORE RELATIONS
  15555. C
  15556.       RMSTAT = -1
  15557.       GO TO 999
  15558. C
  15559. C   VALIDATE USER
  15560. C
  15561.   200 CONTINUE
  15562.       IF(EQ(NAME,K8RDT)) GO TO 100
  15563.       IF(EQ(NAME,K8RRC)) GO TO 100
  15564.       IF(EQ(USERID,OWNER)) GO TO 300
  15565.       IF(EQ(RPW,NONE)) GO TO 300
  15566.       IF(EQ(RPW,USERID)) GO TO 300
  15567.       IF(EQ(MPW,USERID)) GO TO 300
  15568.       GO TO 100
  15569. C
  15570. C  TRANSFER THE RELATION DATA TO THE PROPER ARGUMENTS
  15571. C
  15572.   300 CONTINUE
  15573.       RNAME = NAME
  15574.       LRPW =.TRUE.
  15575.       IF(EQ(RPW,NONE)) LRPW= .FALSE.
  15576.       LMPW = .TRUE.
  15577.       IF(EQ(MPW,NONE)) LMPW = .FALSE.
  15578.       LASTMD = RDATE
  15579.       NUMATT = NATT
  15580.       NUMTUP = NTUPLE
  15581.   999 RETURN
  15582.       END
  15583.       SUBROUTINE RMGTSO(MAT,INDEX,IFLAG,LENGTH,INDPTR)
  15584.       INCLUDE rin:TEXT.BLK
  15585. C
  15586. C  PURPOSE:  READ IN TUPLES FROM THE SORTED DATA FILE
  15587. C
  15588. C  PARAMETERS:
  15589. C            MAT-----ARRAY TO HOLD ONE TUPLE (IF IFLAG = 1)
  15590. C                    POINTER TO TUPLE IN BUFFER (IF IFLAG = 0)
  15591. C           INDEX---PAGE BUFFER TO USE
  15592. C            IFLAG---0 IF THE TUPLE IS RETURNED IN MAT
  15593. C                    1 IF THE BUFFER POINTER IS RETURNED IN MAT
  15594. C                   -1 OPEN THE SORT FILE AND INITIALIZE
  15595. C            LENGTH--LENGTH OF TUPLE IN WORDS
  15596. C            INDPTR--MULTIPLE RMHUNT INDEX - USED TO ASSIGN FILES
  15597. C
  15598.       INCLUDE rin:SRTCOM.BLK
  15599.       INCLUDE rin:WHCOM.BLK
  15600.       INCLUDE rin:RIMCOM.BLK
  15601.       INCLUDE rin:BUFFER.BLK
  15602.       INCLUDE rin:F2COM.BLK
  15603.       INCLUDE rin:MISC.BLK
  15604. C
  15605.       DIMENSION MAT(*)
  15606.       INFIL = 20 + INDPTR
  15607. C
  15608. C  IF IFLAG IS NOT -1 SKIP THE SORT FILE/BUFFER INITIALIZATION
  15609. C
  15610.       IF(IFLAG.NE.-1) GO TO 500
  15611. C
  15612. C  FIRST CALL -----
  15613. C
  15614. C  REWIND THE SORT FILE NEEDED
  15615. C
  15616.       REWIND INFIL
  15617. C
  15618. C  ESTABLISH THE BUFFER POINTER
  15619. C
  15620. C  SEE IF THE CURRENT BLOCK NEEDS WRITING
  15621. C
  15622.       IF(INDEX.GT.3) GO TO 200
  15623.       IF(MODFLG(INDEX).EQ.0) GO TO 100
  15624. C
  15625. C  WRITE OUT THE CURRENT BLOCK
  15626. C
  15627.       KQ1 = BLKLOC(INDEX)
  15628.       CALL RIOOUT(FILE2,CURBLK(INDEX),BUFFER(KQ1),LENBF2,IOS)
  15629.       IF(IOS.NE.0) RMSTAT = 2200 + IOS
  15630.   100 MODFLG(INDEX) = 0
  15631.       CURBLK(INDEX) = 0
  15632. C
  15633. C  ESTABLISH THE NEW BUFFER BLOCK
  15634. C
  15635.   200 CONTINUE
  15636.       CALL BLKCHG(INDEX,MAXCOL,1)
  15637. C
  15638. C  SET THE TUPLES READ COUNTED TO 0
  15639. C
  15640.       NREAD = 0
  15641. C
  15642. C  ALL INITIALIZATION COMPLETE -- RETURN
  15643. C
  15644.       RETURN
  15645. C
  15646. C  READ IN A TUPLE FROM THE SORT FILE
  15647. C
  15648.   500 CONTINUE
  15649.       CALL BLKCHG(INDEX,MAXCOL,1)
  15650.       KQ1 = BLKLOC(INDEX) - 1
  15651.       NREAD = NREAD + 1
  15652.       IF(NREAD.GT.LIMTU) GO TO 900
  15653.       IF(NREAD.GT.NSORT) GO TO 900
  15654.       IF(FIXLT) GO TO 600
  15655. C
  15656. C  VARIABLE LENGTH TUPLES
  15657. C
  15658. c      READ(INFIL) LENGTH,(BUFFER(KQ1+K),K=1,LENGTH)
  15659.       READ(INFIL) LENGTH
  15660.       READ(INFIL) (BUFFER(KQ1+K),K=1,LENGTH)
  15661.       GO TO 700
  15662. C
  15663. C  FIXED LENGTH TUPLES
  15664. C
  15665.   600 CONTINUE
  15666.       READ(INFIL) (BUFFER(KQ1+K),K=1,LENGTH)
  15667. C
  15668. C  TUPLE READ - SET MAT AND RMSTAT
  15669. C
  15670.   700 CONTINUE
  15671.       RMSTAT = 0
  15672.       MAT(1) = KQ1 + 1
  15673.       IF(IFLAG.NE.0) GO TO 999
  15674. C
  15675. C  LOAD TUPLE INTO MAT
  15676. C
  15677.       DO 800 K=1,LENGTH
  15678.       MAT(K) = BUFFER(KQ1+K)
  15679.   800 CONTINUE
  15680.       GO TO 999
  15681. C
  15682. C  ALL DONE - SET RMSTAT AND CLOSE THE FILE
  15683. C
  15684.   900 CONTINUE
  15685.       RMSTAT = -1
  15686.       CALL BLKCLR(INDEX)
  15687.       CLOSE(UNIT=INFIL,STATUS='DELETE')
  15688. C
  15689.   999 CONTINUE
  15690.       RETURN
  15691.       END
  15692.       SUBROUTINE RMHELP
  15693.       INCLUDE rin:TEXT.BLK
  15694. C
  15695. C     THIS ROUTINE PROCESSES THE RIM HELP
  15696. C     COMMAND.  THE HELP DATA BASE HAS 3 ATTRIBUTES -
  15697. C     KEY3    - A 3 CHARACTER FIELD FOR FINDING THE LAST COMMAND
  15698. C               DOES NOT ALLOW DISCRIMINATION BETWEEN DIFFERENT
  15699. C               RENAMES OR DELETES
  15700. C     VERBAGE - A VARIABLE TEXT FIELD WITH A LINE OF STUFF. A ONE
  15701. C               CHARACTER FIELD IS A FLAG FOR END OF PAGE.
  15702. C     COMMAND - A 20 CHARACTER FIELD WITH THE FULL COMMAND NAME.
  15703. C
  15704. C     THE CURRENT DATA BASE FILE IS CLOSED AND THE HELP FILES OPENED.
  15705. C     THE CURRENT COMMAND IS LOCATED IN THE DATA BASE UNLESS
  15706. C     SOMETHING ELSE IS REQUESTED.  AFTER PROCESSING HELP COMMANDS,
  15707. C     THE HELP DATA BASE IS CLOSED AND THE USERS DATA BASE IS REOPENED.
  15708. C
  15709.       INCLUDE rin:RMATTS.BLK
  15710.       INCLUDE rin:RMKEYW.BLK
  15711.       INCLUDE rin:CONST4.BLK
  15712.       INCLUDE rin:FILES.BLK
  15713.       INCLUDE rin:FLAGS.BLK
  15714.       INCLUDE rin:RIMCOM.BLK
  15715.       INCLUDE rin:TUPLER.BLK
  15716.       INCLUDE rin:BUFFER.BLK
  15717.       INCLUDE rin:WHCOM.BLK
  15718.       INCLUDE rin:MISC.BLK
  15719.       INCLUDE rin:TUPLEA.BLK
  15720.       INCLUDE rin:SELCOM.BLK
  15721.       INCLUDE rin:RIMPTR.BLK
  15722.       INCLUDE rin:DCLAR4.BLK
  15723.       INCLUDE rin:CONST8.BLK
  15724.       INTEGER SULPP,SUMCPL
  15725.       LOGICAL SPCENT,SRUCK
  15726.       LOGICAL ISAVE
  15727. C
  15728. C     SET PROMPT CHARACTER TO H FOR HELPPPPPPPP
  15729. C
  15730.       CALL LXSET(K4PROM,K4HP)
  15731.       STOL = TOL
  15732.       SPCENT = PCENT
  15733.       SRUCK = RUCK
  15734.       SULPP = ULPP
  15735.       SUMCPL = UMCPL
  15736. C
  15737. C     CLOSE EXISTING DATA BASE
  15738. C
  15739.       IFILE = DBNAME
  15740.       ISAVE = DFLAG
  15741.       CALL RMOPEN(K8HDB)
  15742. C
  15743. C     SET UP PRELIMINARY WHERE CLAUSE
  15744. C
  15745.       NBOO = 1
  15746.       BOO(1) = K4AND
  15747.       KOMTYP(1) = 2
  15748.       KOMPOS(1) = 1
  15749.       KOMLEN(1) = 1
  15750.       KOMPOT(1) = 1
  15751.       LIMTU = ALL9S
  15752.       MAXTU = ALL9S
  15753.       KSTRT = 0
  15754.       NS = 0
  15755.       ITEMS = LXITEM(IDUM)
  15756.       IP = 2
  15757.       IF(ITEMS.GT.1) GO TO 1100
  15758. C
  15759. C     USE LAST COMMAND VIA KEY3 ATTRIBUTE
  15760. C
  15761.       CALL HTOI(3,1,KATTL(1))
  15762.       CALL HTOI(3,1,WHRLEN(1))
  15763.       WHRVAL(1) = LSTCMD
  15764.       KATTP(1) = 1
  15765.       KATTY(1) = KZTEXT
  15766.       I = LOCREL(KWHELP)
  15767.       IF(I.NE.0) GO TO 8000
  15768.       I = LOCATT(BLANK,NAME)
  15769.       IF(I.NE.0) GO TO 8000
  15770.       CALL ATTGET(ISTAT)
  15771.       KSTRT = ATTKEY
  15772.       IF(KSTRT.NE.0) NS = 2
  15773. C
  15774. C     GO PRINT VERBAGE
  15775. C
  15776.       GO TO 2000
  15777.  1000 CONTINUE
  15778.       IP = 1
  15779. C
  15780. C     GET NEXT INPUT
  15781. C
  15782.     if(nout.eq.6)goto 2
  15783.       WRITE (NOUT,1005)
  15784.  1005 FORMAT(32H Enter END To End HELP or a RIM ,
  15785.      X       19HKeyword to Continue )
  15786.     goto 3
  15787. 2    continue
  15788.     write(c128wk,1005)
  15789.     call atxto
  15790. 3    continue
  15791.       CALL LXLREC(IDUM,0,IDUM)
  15792.       ITEMS = LXITEM(IDUM)
  15793.       IF(ITEMS.GT.1) GO TO 1100
  15794.       IF(LXID(1).EQ.K4EOF) GO TO 9000
  15795.       IF(LXID(1).NE.KZTEXT) GO TO 8100
  15796.       IF(LXWREC(1,1).EQ.K4END) GO TO 9000
  15797.  1100 CONTINUE
  15798. C
  15799. C     SET UP WHERE CLAUSE FOR USER ENTERD COMMAND
  15800. C
  15801.       I = LOCREL(KWHELP)
  15802.       IF(I.NE.0) GO TO 8000
  15803.       I = LOCATT(K8COMM,NAME)
  15804.       IF(I.NE.0) GO TO 8000
  15805.       CALL ATTGET(ISTAT)
  15806.       KATTP(1) = ATTCOL
  15807.       KATTL(1) = ATTLEN
  15808.       KATTY(1) = ATTYPE
  15809.       KSTRT = ATTKEY
  15810.       IF(KSTRT.NE.0) NS = 2
  15811.       IF(LXID(IP).NE.KZTEXT) GO TO 8100
  15812.       NC = LXLENC(IP)
  15813.       CALL FILCH(WHRVAL,1,20,BLANK)
  15814.       CALL LXSREC(IP,1,NC,WHRVAL,1)
  15815.       IP = IP + 1
  15816.       IF(IP.GT.ITEMS) GO TO 1150
  15817. C
  15818. C     GET ANOTHER ITEM
  15819. C
  15820.       MC = LXLENC(IP)
  15821.       IF(LXID(IP).NE.KZTEXT) GO TO 8100
  15822.       CALL LXSREC(IP,1,MC,WHRVAL,NC+2)
  15823.  1150 CONTINUE
  15824.       WHRLEN(1) = ATTLEN
  15825.  2000 CONTINUE
  15826. C
  15827. C     LOOP THRU RECORDS AND DISPLAY
  15828. C
  15829.       CALL RMLOOK(ITUP,1,1,LENGTH)
  15830.       IF(RMSTAT.EQ.0) GO TO 2100
  15831.     if(nout.eq.6)goto 4
  15832.       WRITE (NOUT,2050)
  15833.  2050 FORMAT(42H Unable To Find Help For Requested Command )
  15834.       Go TO 1000
  15835. 4    continue
  15836.     write(c128wk,2050)
  15837.     call atxto
  15838.     goto 1000
  15839.  2100 CONTINUE
  15840.       ITEXT = ITUP + BUFFER(ITUP+1)
  15841.       NC = BUFFER(ITEXT)
  15842.       NW = BUFFER(ITEXT-1)
  15843.     if(nout.eq.6)goto 5
  15844.       IF(NC.NE.1) WRITE(NOUT,2150)(BUFFER(ITEXT+I),I=1,NW)
  15845.  2150 FORMAT(20A4)
  15846.     goto 6
  15847. 5    continue
  15848.       IF(NC.NE.1) WRITE(c128wk,2150)(BUFFER(ITEXT+I),I=1,NW)
  15849.     call atxto
  15850. 6    continue
  15851.       IF(NC.NE.1) GO TO 2300
  15852. C
  15853. C     PAGE BREAK
  15854. C
  15855.     if(nout.eq.6)goto 7
  15856.       WRITE (NOUT,2250)
  15857.  2250 FORMAT(28H More Text Follows - Enter * ,
  15858.      X       28H to Continue or QUIT to STOP )
  15859.     goto 8
  15860. 7    continue
  15861.     write(c128wk,2250)
  15862.     call atxto
  15863. 8    continue
  15864.       CALL LXLREC(IDUM,0,IDUM)
  15865.       IF(LXID(1).EQ.K4EOF) GO TO 2300
  15866.       IF(LXWREC(1,1).EQ.K4QUIT) GO TO 1000
  15867.  2300 CONTINUE
  15868.       CALL RMLOOK(ITUP,1,1,LENGTH)
  15869.       IF(RMSTAT.EQ.0) GO TO 2100
  15870.       GO TO 1000
  15871.  8000 CONTINUE
  15872. C
  15873. C     HELP NOT AVAILABLE
  15874. C
  15875.     if(nout.eq.6)goto 9
  15876.       WRITE (NOUT,8005)
  15877.  8005 FORMAT(32H HELP is NOT currently available )
  15878.       GO TO 9000
  15879. 9    continue
  15880.     write(c128wk,8005)
  15881.     call atxto
  15882.     goto 9000
  15883.  8100 CONTINUE
  15884. C
  15885. C     NON TEXT INPUT
  15886. C
  15887.     if(nout.eq.6)goto 10
  15888.       WRITE (NOUT,8105)
  15889.  8105 FORMAT(28H HELP requires text commands )
  15890.       GO TO 1000
  15891. 10    continue
  15892.     write(c128wk,8105)
  15893.     call atxto
  15894.     goto 1000
  15895.  9000 CONTINUE
  15896. C
  15897. C     TRY TO REVERT TO ENTRY CONDITIONS
  15898. C
  15899.       CALL RMCLOS
  15900.       IF(ISAVE) CALL RMOPEN(IFILE)
  15901.       CALL LXSET(K4PRES,IDUM)
  15902.       TOL = STOL
  15903.       PCENT = SPCENT
  15904.       RUCK = SRUCK
  15905.       SULPP = ULPP
  15906.       SUMCPL = UMCPL
  15907.     if(nout.eq.6)goto 11
  15908.       WRITE (NOUT,9005)
  15909.  9005 FORMAT(20H Enter Next Command )
  15910.       RETURN
  15911. 11    continue
  15912.     write(c128wk,9005)
  15913.     call atxto
  15914.     return
  15915.       END
  15916.       SUBROUTINE RMLATT(RNAME)
  15917.       INCLUDE rin:TEXT.BLK
  15918. C
  15919. C  PURPOSE: THIS ROUTINE SETS THE POINTERS TO THE FIRST ATTRIBUTE
  15920. C           OF RELATION RNAME
  15921. C           (FORTRAN INTERFACE COVER ROUTINE FOR LOCATT)
  15922. C
  15923. C  PARAMETERS: RNAME--RELATION NAME
  15924. C
  15925.       INCLUDE rin:RIMPTR.BLK
  15926.       INCLUDE rin:RIMCOM.BLK
  15927.       INCLUDE rin:FLAGS.BLK
  15928.       INCLUDE rin:TUPLER.BLK
  15929.       INCLUDE rin:MISC.BLK
  15930.       INTEGER STATUS
  15931.       LOGICAL EQ
  15932.       INCLUDE rin:DCLAR1.BLK
  15933. C
  15934.       RMSTAT = 0
  15935.       INDCUR = NULL
  15936. C
  15937. C         MAKE SURE DB IS DEFINED
  15938. C
  15939.       IF(DFLAG) GOTO 10
  15940.       RMSTAT = 16
  15941.       GOTO 999
  15942. C
  15943.    10 CONTINUE
  15944.       IF(RNAME.EQ.NAME) GO TO 200
  15945.       I = LOCREL(RNAME)
  15946.       IF(I.EQ.0) GO TO 100
  15947.       RMSTAT = 20
  15948.       GO TO 999
  15949. C
  15950. C  GET THE RELATION PASSWORDS
  15951. C
  15952.   100 CONTINUE
  15953.       CALL RELGET(STATUS)
  15954.       IF(STATUS.NE.0) GO TO 999
  15955. C
  15956. C   CHECK PERMISSION
  15957. C
  15958.       IF(EQ(USERID,OWNER)) GO TO 200
  15959.       IF(EQ(RPW,NONE)) GO TO 200
  15960.       IF(EQ(RPW,USERID)) GO TO 200
  15961.       IF(EQ(MPW,USERID)) GO TO 200
  15962.       RMSTAT = 90
  15963.       GO TO 999
  15964.   200 CONTINUE
  15965.       J = LOCATT(BLANK,RNAME)
  15966.   999 RETURN
  15967.       END
  15968.       SUBROUTINE RMLOAD(INDPTR,TUPLE)
  15969.       INCLUDE rin:TEXT.BLK
  15970. C
  15971. C  THIS ROUTINE LOADS DATA FROM TUPLE INTO THE CURRENT RELATION.
  15972. C
  15973. C  PARAMETERS:
  15974. C         INDPTR--INDEX TO SAVE BLOCK (RANGE OF 0 TO 9)
  15975. C         TUPLE---USER ARRAY WITH REPLACEMENT TUPLE
  15976.       INCLUDE rin:RIMCOM.BLK
  15977.       INCLUDE rin:VARDAT.BLK
  15978.       INCLUDE rin:KEYDAT.BLK
  15979.       INCLUDE rin:MISC.BLK
  15980.       INCLUDE rin:FLAGS.BLK
  15981.       INCLUDE rin:RULCOM.BLK
  15982.       INCLUDE rin:RIMPTR.BLK
  15983.       INCLUDE rin:WHCOM.BLK
  15984.       INCLUDE rin:CONST4.BLK
  15985.       INCLUDE rin:RMATTS.BLK
  15986.       INCLUDE rin:TUPLER.BLK
  15987.       INCLUDE rin:TUPLEA.BLK
  15988.       INCLUDE rin:START.BLK
  15989.       INTEGER COLUMN
  15990. C
  15991.       INTEGER TUPLE(*)
  15992.       RMSTAT = 0
  15993. C         MAKE SURE DB IS DEFINED
  15994. C
  15995.       IF(DFLAG) GOTO 10
  15996.       RMSTAT = 16
  15997.       GOTO 9999
  15998. C
  15999.    10 CONTINUE
  16000. C
  16001. C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
  16002. C
  16003.       CALL RMDBLK(DBNAME)
  16004.       IF(RMSTAT.NE.0) GO TO 9999
  16005. C
  16006. C  RESTORE THE BLOCKS AS NEEDED.
  16007. C
  16008.       CALL RMRES(INDPTR)
  16009.       IF(RMSTAT.NE.0) GO TO 9999
  16010. C
  16011. C  SET THE INDEX POINTER
  16012. C
  16013.       INDEX = INDPTR
  16014.       IF(INDEX.EQ.0) INDEX = 1
  16015.       IF(INDEX.GT.3) INDEX = 3
  16016. C
  16017. C  CHECK FOR WRITE PERMISSION ON THIS RELATION.
  16018. C
  16019.       I = LOCPRM(NAME,2)
  16020.       IF(RMSTAT.NE.0) GO TO 9999
  16021.       NEWL = NCOL
  16022. C
  16023. C  CONVERT THE VARIABLE ATTRIBUTE HEADERS FROM USER TO INTERNAL
  16024. C
  16025.       IF(NUMVAR.EQ.0) GOTO 360
  16026.       CALL RMVARC(1,TUPLE)
  16027.       IF(RMSTAT.NE.0) GO TO 9999
  16028. C
  16029. C  FIND OUT HOW LONG THE NEW TUPLE IS.
  16030. C
  16031.   200 CONTINUE
  16032.       I = LOCATT(BLANK,NAME)
  16033.       NEWL = 0
  16034.   320 CONTINUE
  16035.       CALL ATTGET(ISTAT)
  16036.       IF(ISTAT.NE.0) GO TO 360
  16037.       NWORDS = ATTWDS
  16038.       IF(ATTWDS.NE.0) GO TO 340
  16039. C
  16040. C  VARIABLE LENGTH ATTRIBUTE.
  16041. C
  16042.       COLUMN = TUPLE(ATTCOL)
  16043.       IF((COLUMN.LE.1).OR.(COLUMN.GT.MAXCOL)) GO TO 800
  16044.       NWORDS = TUPLE(COLUMN) + 3
  16045.       IF(NWORDS.LE.3) GO TO 800
  16046.   340 CONTINUE
  16047.       NEWL = NEWL + NWORDS
  16048.       GO TO 320
  16049.   360 CONTINUE
  16050.       IF(NEWL.GT.MAXCOL) GO TO 800
  16051. C
  16052. C  SEE IF ANY APPLICABLE RULES ARE MET.
  16053. C
  16054.       IF(.NOT.RUCK) GO TO 440
  16055.       IF(.NOT.RULES) GO TO 440
  16056. C
  16057. C  SAVE THE CURRENT POSITION DATA
  16058. C
  16059.       CALL RMSAV(INDCUR)
  16060. C
  16061. C  LOAD THE RULE WHERE CLAUSE
  16062. C
  16063.       NBOO = 1
  16064.       BOO(1) = K4AND
  16065.       KATTP(1) = 1
  16066.       KATTL(1) = 1
  16067.       KATTY(1) = KZINT
  16068.       KOMTYP(1) = 2
  16069.       KOMPOS(1) = 1
  16070.       KOMLEN(1) = 1
  16071.       KOMPOT(1) = 1
  16072.       KSTRT = 0
  16073.       MAXTU = ALL9S
  16074.       LIMTU = ALL9S
  16075.       WHRVAL(1) = 0
  16076.       WHRLEN(1) = 1
  16077.       CALL CHKTUP(TUPLE,ISTAT)
  16078.       RMSTAT = 0
  16079.       IF(ISTAT.GT.0) RMSTAT = 200 + ISTAT
  16080.       IF(ISTAT.LT.0) RMSTAT = 112
  16081. C
  16082. C  RESTORE THE CURRENT POSITION DATA
  16083. C
  16084.       INDCUR = 0
  16085.       CALL RMRES(INDPTR)
  16086.       IF(RMSTAT.EQ.0) GO TO 440
  16087.       GO TO 9999
  16088. C
  16089. C  ADD THE NEW TUPLE.
  16090. C
  16091.   440 CONTINUE
  16092.       CALL ADDDAT(INDEX,REND,TUPLE,NEWL)
  16093.       IF(RSTART.EQ.0) RSTART = REND
  16094.       RDATE = DBDATE
  16095.       NTUPLE = NTUPLE + 1
  16096.       CALL RELPUT
  16097.       IF(NUMKEY.EQ.0) GO TO 9999
  16098. C
  16099. C  FIX UP THE KEYS FOR THE ADDED TUPLE.
  16100. C
  16101.       I = 0
  16102.       IF(NUMKEY.LE.5) GO TO 460
  16103.       I = LOCATT(BLANK,NAME)
  16104.   460 CONTINUE
  16105.       IF(NUMKEY.GT.5) GO TO 465
  16106.       I  = I + 1
  16107.       IF(I.GT.NUMKEY) GO TO 9999
  16108.       START = KEYDAT(1,I)
  16109.       KSTART = KEYDAT(1,I)
  16110.       COLUMN = KEYDAT(2,I)
  16111.       ATTWDS = KEYDAT(3,I)
  16112.       ATTYPE = KEYDAT(4,I)
  16113.       GO TO 470
  16114.   465 CONTINUE
  16115.       CALL ATTGET(ISTAT)
  16116.       IF(ISTAT.NE.0) GO TO 9999
  16117.       IF(ATTKEY.EQ.0) GO TO 460
  16118.       START = ATTKEY
  16119.       KSTART = ATTKEY
  16120.       COLUMN = ATTCOL
  16121.   470 CONTINUE
  16122.       IF(ATTWDS.NE.0) GO TO 480
  16123.       COLUMN = TUPLE(COLUMN) + 2
  16124.   480 CONTINUE
  16125.       IF(TUPLE(COLUMN).EQ.NULL) GO TO 460
  16126.       CALL BTADD(TUPLE(COLUMN),REND,ATTYPE)
  16127.       IF(START.EQ.KSTART) GO TO 460
  16128.       IF(NUMKEY.LE.5) GO TO 490
  16129.       ATTKEY = START
  16130.       CALL ATTPUT(ISTAT)
  16131.       GO TO 460
  16132.   490 CONTINUE
  16133.       ISTAT = LOCATT(KEYDAT(5,I),NAME)
  16134.       CALL ATTGET(ISTAT)
  16135.       ATTKEY = START
  16136.       CALL ATTPUT(ISTAT)
  16137.       KEYDAT(1,I) = START
  16138.       GO TO 460
  16139. C
  16140. C  NEW TUPLE HAS VARIABLE LENGTH POINTERS WHICH ARE WIERD.
  16141. C
  16142.   800 CONTINUE
  16143.       RMSTAT = 100
  16144.  9999 CONTINUE
  16145.       RETURN
  16146.       END
  16147.       SUBROUTINE RMLOOK(MAT,INDEX,IFLAG,LENGTH)
  16148.       INCLUDE rin:TEXT.BLK
  16149. C
  16150. C   LOCATE NEXT DESIRED TUPLE
  16151. C
  16152. C  PARAMETERS:
  16153. C         MAT-----ARRAY TO HOLD ONE TUPLE
  16154. C                 IF(IFLAG.NE.0) MAT IS POINTER TO TUPLE
  16155. C                 IN INPUT BUFFER.
  16156. C         INDEX---PAGE BUFFER TO USE
  16157. C         IFLAG---0 IFF TUPLE IS RETURNED
  16158. C                 ELSE POINTER TO TUPLE IS RETURNED IN MAT
  16159. C         LENGTH--LENGTH OF TUPLE IN WORDS
  16160.       INCLUDE rin:RMATTS.BLK
  16161.       INCLUDE rin:CONST4.BLK
  16162.       INCLUDE rin:MISC.BLK
  16163.       INCLUDE rin:RIMCOM.BLK
  16164.       INCLUDE rin:RIMPTR.BLK
  16165.       INCLUDE rin:WHCOM.BLK
  16166.       INCLUDE rin:START.BLK
  16167.       INCLUDE rin:BUFFER.BLK
  16168.       INCLUDE rin:FLAGS.BLK
  16169. C
  16170.       DIMENSION MAT(*)
  16171.       LOGICAL QUAL,OK,BTEST
  16172.       LOGICAL EQTEST
  16173. C
  16174. C  SCAN MAT.
  16175. C
  16176.       RMSTAT = 0
  16177.     1 CONTINUE
  16178. C
  16179. C  SEE IF WE ARE USING A KEY VALUE.
  16180. C
  16181.       IF(NS.EQ.0) GO TO 30
  16182.       IF(NS.EQ.3) GO TO 10
  16183. C
  16184. C  FIRST TIME THROUGH. USE BTLOOK TO FIND THE TUPLES.
  16185. C
  16186.       START = KSTRT
  16187.       NBOOX = IABS(NBOO)
  16188.       NUMP = KOMPOS(NBOOX)
  16189.       IF(KATTY(NBOOX).EQ.KZINT ) CALL BTLKI(WHRVAL(NUMP),NID,MID)
  16190.       IF(KATTY(NBOOX).EQ.KZREAL) CALL BTLKR(WHRVAL(NUMP),NID,MID)
  16191.       IF(KATTY(NBOOX).EQ.KZDOUB) CALL BTLKR(WHRVAL(NUMP),NID,MID)
  16192.       IF(KATTY(NBOOX).EQ.KZTEXT) CALL BTLKT(WHRVAL(NUMP),NID,MID)
  16193.       NS = 3
  16194.       IF(NID.NE.0) GO TO 20
  16195.    10 CONTINUE
  16196.       IF(MID.EQ.0) GO TO 1300
  16197.       CALL MOTSCN(MID,NID)
  16198.       IF(NID.NE.0) GO TO 20
  16199.       GO TO 10
  16200.    20 CONTINUE
  16201.       CID = NID
  16202.       CALL GETDAT(INDEX,NID,ITUP,LENGTH)
  16203.       GO TO 40
  16204.    30 CONTINUE
  16205.       IF(NID.EQ.0) GO TO 1300
  16206.       CALL ITOH(N1,N2,NID)
  16207.       IF(N2.EQ.0) GO TO 1300
  16208.       CID = NID
  16209.       CALL GETDAT(INDEX,NID,ITUP,LENGTH)
  16210.       IF(NID.LT.0) GO TO 1300
  16211. C
  16212. C  SCAN THROUGH EACH BOOLEAN CONDITION OF THE WHERE CLAUSE.
  16213. C
  16214.    40 CONTINUE
  16215.       IVAL = IVAL + 1
  16216.       IF(NBOO.LE.0) GO TO 1200
  16217.       IF(IVAL.GT.MAXTU) GO TO 1300
  16218.       QUAL = .TRUE.
  16219.       DO 1000 J=1,NBOO
  16220.       ITYPE = KATTY(J)
  16221.       IF(ITYPE.EQ.0)ITYPE = KZINT
  16222.       OK = .FALSE.
  16223.       CALL ITOH(NR,LEN,KATTL(J))
  16224.       NUM = KOMLEN(J)
  16225.       NK = KOMTYP(J)
  16226.       NUMP = KOMPOS(J)
  16227.       IP = ITUP + KATTP(J) - 1
  16228.       IF(KATTP(J).NE.0) GO TO 100
  16229. C
  16230. C  TUPLE NUMBERS
  16231. C
  16232.       OK = .TRUE.
  16233.       IF(NK.EQ.2) OK = .FALSE.
  16234.       DO 80 JJ=1,NUM
  16235.       BTEST = .FALSE.
  16236.       CALL KOMPXX(IVAL,WHRVAL(JJ+NUMP-1),1,NK,BTEST,ITYPE)
  16237.       IF(NK.EQ.2) OK = OK .OR. BTEST
  16238.       IF(NK.NE.2) OK = OK .AND. BTEST
  16239.    80 CONTINUE
  16240.       GO TO 900
  16241.   100 CONTINUE
  16242.       IF(NK.LT.10) GO TO 300
  16243. C
  16244. C  ATTRIBUTE - ATTRIBUTE COMPARISON
  16245. C
  16246.       KP = ITUP + NUMP - 1
  16247. C
  16248. C  DUMMY TOLERANCE FOR ATTRIBUTE TO ATTRIBUTE
  16249. C
  16250.       IF(LEN.NE.0) GO TO 120
  16251. C
  16252. C     SET POINTER FOR VARIABLE ATTRIBUTES
  16253. C
  16254.       IP = BUFFER(IP) + ITUP - 1
  16255.       KP = BUFFER(KP) + ITUP - 1
  16256.       IF(NK.EQ.13) OK = .TRUE.
  16257.       LEN = BUFFER(IP)
  16258.       IF(BUFFER(KP).NE.BUFFER(IP)) GO TO 900
  16259.       IF(BUFFER(KP+1).NE.BUFFER(IP+1)) GO TO 900
  16260.       OK = .FALSE.
  16261.       IP = IP + 2
  16262.       KP = KP + 2
  16263.   120 CONTINUE
  16264.       TTOL = TOL
  16265.       TOL = 0.
  16266.       NK = NK - 10
  16267.       CALL KOMPXX(BUFFER(IP),BUFFER(KP),LEN,NK,OK,ITYPE)
  16268.       TOL = TTOL
  16269.       GO TO 900
  16270.   300 CONTINUE
  16271.       IF(LEN.NE.0) GO TO 320
  16272. C
  16273. C     SET POINTER FOR VARIABLE ATTRIBUTE
  16274. C
  16275.       IP = BUFFER(IP) + ITUP - 1
  16276.       LEN = BUFFER(IP)
  16277.       NR = BUFFER(IP+1)
  16278.       IP = IP + 2
  16279.   320 CONTINUE
  16280. C
  16281. C     REGULAR ATTRIBUTE
  16282. C
  16283.       NPOS = KOMPOS(J)
  16284.       NPOT = KOMPOT(J)
  16285.       OK = .TRUE.
  16286.       EQTEST = .FALSE.
  16287.       IF((NK.EQ.2).OR.(NK.EQ.9)) EQTEST = .TRUE.
  16288.       IF(EQTEST) OK = .FALSE.
  16289.       DO 400 JJ=1,NUM
  16290.       BTEST = .FALSE.
  16291.       CALL ITOH(NNR,NW,WHRLEN(NPOT))
  16292.       IF(NK.LE.1) GO TO 350
  16293.       IF(BUFFER(IP).EQ.NULL) GO TO 350
  16294.       IF((LEN.EQ.NW).AND.(NR.EQ.NNR)) GO TO 350
  16295. C
  16296. C     COMPARE OF DIFFERENT LENGTHS
  16297. C
  16298.       IF(NK.EQ.9) GO TO 350
  16299.       IF(NK.NE.3) GO TO 375
  16300.       OK = .TRUE.
  16301.       GO TO 900
  16302.   350 CONTINUE
  16303.       IF(NK.NE.9)CALL KOMPXX(BUFFER(IP),WHRVAL(NPOS),NW,NK,BTEST,ITYPE)
  16304.       IF(NK.NE.9) GO TO 375
  16305. C
  16306. C     CONTAINS
  16307. C
  16308.       M1 = LSTRNG(BUFFER(IP),1,NR,WHRVAL(NPOS),1,NNR)
  16309.       IF(M1.GT.0) BTEST = .TRUE.
  16310.   375 CONTINUE
  16311.       IF(EQTEST) OK = OK.OR.BTEST
  16312.       IF(.NOT.EQTEST) OK = OK.AND.BTEST
  16313.       IF(OK.AND.EQTEST) GO TO 900
  16314.       NPOS = NPOS + NW
  16315.       NPOT = NPOT + 1
  16316.   400 CONTINUE
  16317.   900 CONTINUE
  16318.       IF(BOO(J).EQ.K4AND) QUAL = QUAL .AND. OK
  16319.       IF(BOO(J).EQ.K4OR ) QUAL = QUAL .OR.  OK
  16320.  1000 CONTINUE
  16321.       IF(.NOT.QUAL) GO TO 1
  16322. C
  16323. C  FOUND IT.
  16324. C
  16325.  1200 CONTINUE
  16326.       LIMVAL = LIMVAL + 1
  16327.       IF(LIMVAL.GT.LIMTU) GO TO 1300
  16328.       MAT(1) = ITUP
  16329.       IF(IFLAG.NE.0) RETURN
  16330.       IP = ITUP
  16331.       DO 1250 I=1,LENGTH
  16332.       MAT(I) = BUFFER(IP)
  16333.       IP = IP + 1
  16334.  1250 CONTINUE
  16335.       RMSTAT = 0
  16336.       RETURN
  16337. C
  16338. C  END OF DATA.
  16339. C
  16340.  1300 CONTINUE
  16341.       NS = 0
  16342.       RMSTAT = -1
  16343.       RETURN
  16344.       END
  16345.       SUBROUTINE RMLREL
  16346.       INCLUDE rin:TEXT.BLK
  16347. C
  16348. C  PURPOSE: THIS ROUTINE SETS THE POINTERS TO THE FIRST RELATION
  16349. C           (FORTRAN INTERFACE COVER ROUTINE FOR LOCREL)
  16350. C
  16351. C  PARAMETERS: NONE
  16352. C
  16353.       INCLUDE rin:RIMPTR.BLK
  16354.       INCLUDE rin:RIMCOM.BLK
  16355.       INCLUDE rin:FLAGS.BLK
  16356.       INCLUDE rin:MISC.BLK
  16357.       INCLUDE rin:TUPLER.BLK
  16358.       INTEGER STATUS
  16359.       LOGICAL EQ
  16360.       RMSTAT = 0
  16361.       INDCUR = NULL
  16362. C
  16363. C         MAKE SURE DB IS DEFINED
  16364. C
  16365.       IF(DFLAG) GOTO 10
  16366.       RMSTAT = 16
  16367.       GOTO 999
  16368. C
  16369.    10 CONTINUE
  16370.       I = LOCREL(BLANK)
  16371.       NP = 0
  16372.       IF(I.EQ.0) GO TO 100
  16373.       RMSTAT = 20
  16374.       GO TO 999
  16375.   100 CONTINUE
  16376. C
  16377. C  GET THE RELATION PASSWORDS
  16378. C
  16379.       CALL RELGET(STATUS)
  16380.       IF(STATUS.NE.0) GO TO 900
  16381. C
  16382. C   VALIDATE USER
  16383. C
  16384.       IF(EQ(USERID,OWNER)) NP = 1
  16385.       IF(EQ(RPW,NONE)) NP = 1
  16386.       IF(EQ(RPW,USERID)) NP = 1
  16387.       IF(EQ(MPW,USERID)) NP = 1
  16388.       GO TO 100
  16389. C
  16390. C  CHECK FOR UNAUTHORIZED RELATION ACCESS
  16391. C
  16392.   900 CONTINUE
  16393.       IF(NP.EQ.0) RMSTAT = 90
  16394. C
  16395. C  RMLREL COMPLETE
  16396. C
  16397.   999 CONTINUE
  16398.       I = LOCREL(BLANK)
  16399.       RETURN
  16400.       END
  16401.       SUBROUTINE RMOPEN(IFILE)
  16402.       INCLUDE rin:TEXT.BLK
  16403. C
  16404. C  PURPOSE:  OPEN A RIM DATABASE.
  16405. C
  16406. C  PARAMETERS:
  16407. C         IFILE---NAME OF THE DATABASE
  16408.       INCLUDE rin:CONST4.BLK
  16409.       INCLUDE rin:RIMCOM.BLK
  16410.       INCLUDE rin:FLAGS.BLK
  16411.       INCLUDE rin:ATTBLE.BLK
  16412.       INCLUDE rin:MISC.BLK
  16413.       INCLUDE rin:DCLAR4.BLK
  16414.       DATA ICALLS /0/
  16415.       IF(ICALLS.EQ.0) DFLAG = .FALSE.
  16416.       ICALLS = ICALLS + 1
  16417.       RMSTAT = 0
  16418. C
  16419. C  CLOSE ANY EXISTING DATABASES AND INITIALIZE
  16420. C
  16421.       IF(DFLAG) CALL RMCLOS
  16422.       CALL RMSTRT
  16423. C
  16424. C  SET THE NEW DATABASE NAME, DATE, AND TIME
  16425. C
  16426.       DBNAME = IFILE
  16427.       CALL RMDATE(DBDATE)
  16428.       CALL RMTIME(DBTIME)
  16429. C
  16430. C  FIND THE LAST NON-BLANK CHARACTER.
  16431. C
  16432.       DO 100 I=1,7
  16433.       CALL GETT(IFILE,I,IT)
  16434.       IF(IT.EQ.IBLANK) GO TO 200
  16435.   100 CONTINUE
  16436.       I = 7
  16437.   200 CONTINUE
  16438. C
  16439. C  FIX UP THE FILE NAMES.
  16440. C
  16441.       FILE = BLANK
  16442.       CALL STRMOV(IFILE,1,I,FILE,1)
  16443.       RIMDB1 = FILE
  16444.       CALL PUTT(RIMDB1,I,K41)
  16445.       RIMDB2 = FILE
  16446.       CALL PUTT(RIMDB2,I,K42)
  16447.       RIMDB3 = FILE
  16448.       CALL PUTT(RIMDB3,I,K43)
  16449. C
  16450. C  OPEN FILE 1.
  16451. C
  16452.       CALL F1OPN(RIMDB1)
  16453.       IF((RMSTAT.NE.0).AND.(RMSTAT.NE.15)) GO TO 999
  16454. C
  16455. C  OPEN FILE 2.
  16456. C
  16457.       CALL F2OPN(RIMDB2)
  16458.       IF((RMSTAT.NE.0).AND.(RMSTAT.NE.15)) GO TO 999
  16459. C
  16460. C  OPEN FILE 3.
  16461. C
  16462.       CALL F3OPN(RIMDB3)
  16463.       IF((RMSTAT.NE.0).AND.(RMSTAT.NE.15)) GO TO 999
  16464. C
  16465. C  IF THIS IS A NEW DATABASE WE NEED TO SET UP THE FIRST BTREE.
  16466. C
  16467.       IF(DFLAG) CALL RMDATE(DBDATE)
  16468.   999 RETURN
  16469.       END
  16470.       SUBROUTINE RMPUT(INDPTR,TUPLE)
  16471.       INCLUDE rin:TEXT.BLK
  16472. C
  16473. C  THIS ROUTINE PUTS DATA FROM TUPLE INTO THE CURRENT ROW.
  16474. C
  16475. C  PARAMETERS:
  16476. C         INDPTR--INDEX TO SAVE BLOCK (RANGE OF 0 TO 9)
  16477. C         TUPLE---USER ARRAY WITH REPLACEMENT TUPLE
  16478.       INCLUDE rin:KEYDAT.BLK
  16479.       INCLUDE rin:RIMCOM.BLK
  16480.       INCLUDE rin:VARDAT.BLK
  16481.       INCLUDE rin:MISC.BLK
  16482.       INCLUDE rin:FLAGS.BLK
  16483.       INCLUDE rin:TUPLER.BLK
  16484.       INCLUDE rin:TUPLEA.BLK
  16485.       INCLUDE rin:RIMPTR.BLK
  16486.       INCLUDE rin:RULCOM.BLK
  16487.       INCLUDE rin:WHCOM.BLK
  16488.       INCLUDE rin:CONST4.BLK
  16489.       INCLUDE rin:RMATTS.BLK
  16490.       INCLUDE rin:BUFFER.BLK
  16491.       INCLUDE rin:START.BLK
  16492.       INTEGER COLUMN
  16493. C
  16494.       INTEGER TUPLE(*)
  16495.       RMSTAT = 0
  16496. C         MAKE SURE DB IS DEFINED
  16497. C
  16498.       IF(DFLAG) GOTO 10
  16499.       RMSTAT = 16
  16500.       GOTO 9999
  16501. C
  16502.    10 CONTINUE
  16503. C
  16504. C  CALL RMDBLK TO MAKE SURE THE DATABASE MAY BE MODIFIED
  16505. C
  16506.       CALL RMDBLK(DBNAME)
  16507.       IF(RMSTAT.NE.0) GO TO 9999
  16508. C
  16509. C  RESTORE THE BLOCKS AS NEEDED.
  16510. C
  16511.       CALL RMRES(INDPTR)
  16512.       IF(RMSTAT.NE.0) GO TO 9999
  16513. C
  16514. C  CHECK FOR WRITE PERMISSION ON THIS RELATION.
  16515. C
  16516.       I = LOCPRM(NAME,2)
  16517.       IF(RMSTAT.NE.0) GO TO 9999
  16518. C
  16519. C  CHECK THAT RMGET WAS CALLED
  16520. C
  16521.       IF((IVAL.GT.0).AND.(IVAL.LT.ALL9S)) GO TO 200
  16522. C
  16523. C  RMGET WAS NOT CALLED BEFORE RMPUT
  16524. C
  16525.       RMSTAT = 60
  16526.       GO TO 9999
  16527. C
  16528. C  CONVERT THE VARIABLE ATTRIBUTE HEADERS FROM USER TO INTERNAL
  16529. C
  16530.   200 CONTINUE
  16531.       IF(NUMVAR.EQ.0) GO TO 250
  16532.       CALL RMVARC(1,TUPLE)
  16533.       IF(RMSTAT.NE.0) GO TO 9999
  16534.   250 CONTINUE
  16535. C
  16536. C  CHECK FOR RULES
  16537. C
  16538.       IF(.NOT.RUCK) GO TO 290
  16539.       IF(.NOT.RULES) GO TO 290
  16540. C
  16541. C  SAVE THE CURRENT POSITION DATA
  16542. C
  16543.       CALL RMSAV(INDCUR)
  16544. C
  16545. C  LOAD THE RULE WHERE CLAUSE
  16546. C
  16547.       NBOO = 1
  16548.       BOO(1) = K4AND
  16549.       KATTP(1) = 1
  16550.       KATTL(1) = 1
  16551.       KATTY(1) = KZINT
  16552.       KOMTYP(1) = 2
  16553.       KOMPOS(1) = 1
  16554.       KOMLEN(1) = 1
  16555.       KOMPOT(1) = 1
  16556.       KSTRT = 0
  16557.       MAXTU = ALL9S
  16558.       LIMTU = ALL9S
  16559.       WHRVAL(1) = 0
  16560.       WHRLEN(1) = 1
  16561.       CALL CHKTUP(TUPLE,ISTAT)
  16562.       RMSTAT = 0
  16563.       IF(ISTAT.GT.0) RMSTAT = 200 + ISTAT
  16564.       IF(ISTAT.LT.0) RMSTAT = 112
  16565. C
  16566. C  RESTORE THE CURRENT POSITION DATA
  16567. C
  16568.       INDCUR = 0
  16569.       CALL RMRES(INDPTR)
  16570.       IF(RMSTAT.EQ.0) GO TO 290
  16571.       GO TO 9999
  16572. C
  16573. C  RETRIEVE THE CURRENT ROW IN A SCRATCH TUPLE.
  16574. C
  16575.   290 CONTINUE
  16576.       CALL BLKCHG(11,MAXCOL,1)
  16577.       KQ1 = BLKLOC(11)
  16578.       NID = CID
  16579.       INDEX = INDPTR
  16580.       IF(INDEX.EQ.0) INDEX = 1
  16581.       IF(INDEX.GT.3) INDEX = 3
  16582.       LNBOO = NBOO
  16583.       NBOO = 0
  16584.       LNS = NS
  16585.       NS = 0
  16586.       CALL RMLOOK(BUFFER(KQ1),INDEX,0,KURLEN)
  16587.       NS = LNS
  16588.       NBOO = LNBOO
  16589.       IVAL = IVAL - 1
  16590.       IF(RMSTAT.EQ.0) GO TO 300
  16591. C
  16592. C  NO DATA AVAILABLE
  16593. C
  16594.       RMSTAT = 60
  16595.       GO TO 9999
  16596. C
  16597. C  SEE IF THE NEW TUPLE IS LONGER THAN THE OLD ONE.
  16598. C
  16599.   300 CONTINUE
  16600.       NEWL = KURLEN
  16601.       IF(NUMVAR.EQ.0) GO TO 370
  16602.       I = LOCATT(BLANK,NAME)
  16603.       NEWL = 0
  16604.   320 CONTINUE
  16605.       CALL ATTGET(ISTAT)
  16606.       IF(ISTAT.NE.0) GO TO 360
  16607.       NWORDS = ATTWDS
  16608.       IF(ATTWDS.NE.0) GO TO 340
  16609. C
  16610. C  VARIABLE LENGTH ATTRIBUTE.
  16611. C
  16612.       COLUMN = TUPLE(ATTCOL)
  16613.       IF((COLUMN.LE.1).OR.(COLUMN.GT.MAXCOL)) GO TO 800
  16614.       NWORDS = TUPLE(COLUMN) + 3
  16615.       IF(NWORDS.LT.3) GO TO 800
  16616.   340 CONTINUE
  16617.       NEWL = NEWL + NWORDS
  16618.       GO TO 320
  16619.   360 CONTINUE
  16620.       IF(NEWL.GT.MAXCOL) GO TO 800
  16621.   370 CONTINUE
  16622.       IF(NEWL.LE.KURLEN) GO TO 500
  16623. C
  16624. C  NEW TUPLE IS LONGER THAN THE OLD ONE.
  16625. C  OLD TUPLE MUST BE DELETED AND THE CHANGED ONE ADDED.
  16626. C
  16627.       CALL DELDAT(INDEX,CID)
  16628. C
  16629. C  CHANGE THE POINTERS FOR ANY KEY ELEMENTS.
  16630. C
  16631.       IF(NUMKEY.EQ.0) GO TO 440
  16632.       I = 0
  16633.       IF(NUMKEY.LE.5) GO TO 380
  16634.       I = LOCATT(BLANK,NAME)
  16635.   380 CONTINUE
  16636.       IF(NUMKEY.GT.5) GO TO 390
  16637.       I = I + 1
  16638.       IF(I.GT.NUMKEY) GO TO 440
  16639.       START = KEYDAT(1,I)
  16640.       COLUMN = KEYDAT(2,I)
  16641.       ATTWDS = KEYDAT(3,I)
  16642.       ATTYPE = KEYDAT(4,I)
  16643.       GO TO 395
  16644.   390 CONTINUE
  16645.       CALL ATTGET(ISTAT)
  16646.       IF(ISTAT.NE.0) GO TO 440
  16647.       IF(ATTKEY.EQ.0) GO TO 380
  16648.       START = ATTKEY
  16649.       COLUMN = ATTCOL
  16650.   395 CONTINUE
  16651.       IF(ATTWDS.NE.0) GO TO 400
  16652.       COLUMN = BUFFER(KQ1+COLUMN-1) + 2
  16653.   400 CONTINUE
  16654.       IF(BUFFER(KQ1+COLUMN-1).EQ.NULL) GO TO 380
  16655.       CALL BTREP(BUFFER(KQ1+COLUMN-1),0,CID,ATTYPE)
  16656.       GO TO 380
  16657. C
  16658. C  ADD THE NEW TUPLE.
  16659. C
  16660.   440 CONTINUE
  16661.       IF(CID.EQ.RSTART) RSTART = NID
  16662.       CALL ADDDAT(INDEX,REND,TUPLE,NEWL)
  16663.       RDATE = DBDATE
  16664.       CALL RELPUT
  16665. C
  16666. C  FIX UP THE KEYS FOR THE ADDED TUPLE.
  16667. C
  16668.       IF(NUMKEY.EQ.0) GO TO 9999
  16669.       I = 0
  16670.       IF(NUMKEY.LE.5) GO TO 460
  16671.       I = LOCATT(BLANK,NAME)
  16672.   460 CONTINUE
  16673.       IF(NUMKEY.GT.5) GO TO 470
  16674.       I = I + 1
  16675.       IF(I.GT.NUMKEY) GO TO 9999
  16676.       START = KEYDAT(1,I)
  16677.       COLUMN = KEYDAT(2,I)
  16678.       ATTWDS = KEYDAT(3,I)
  16679.       ATTYPE = KEYDAT(4,I)
  16680.       GO TO 475
  16681.   470 CONTINUE
  16682.       CALL ATTGET(ISTAT)
  16683.       IF(ISTAT.NE.0) GO TO 9999
  16684.       IF(ATTKEY.EQ.0) GO TO 460
  16685.       START = ATTKEY
  16686.       KSTART = ATTKEY
  16687.       COLUMN = ATTCOL
  16688.   475 CONTINUE
  16689.       IF(ATTWDS.NE.0) GO TO 480
  16690.       COLUMN = TUPLE(COLUMN) + 2
  16691.   480 CONTINUE
  16692.       IF(TUPLE(COLUMN).EQ.NULL) GO TO 460
  16693.       CALL BTADD(TUPLE(COLUMN),REND,ATTYPE)
  16694.       IF(START.EQ.KSTART) GO TO 460
  16695.       IF(NUMKEY.LE.5) GO TO 490
  16696.       ATTKEY = START
  16697.       CALL ATTPUT(ISTAT)
  16698.       GO TO 460
  16699.   490 CONTINUE
  16700.       ISTAT = LOCATT(KEYDAT(5,I),NAME)
  16701.       CALL ATTGET(ISTAT)
  16702.       ATTKEY = START
  16703.       CALL ATTPUT(ISTAT)
  16704.       GO TO 460
  16705. C
  16706. C  NEW TUPLE WILL FIT IN PLACE.
  16707. C
  16708.   500 CONTINUE
  16709.       CALL PUTDAT(INDEX,CID,TUPLE,NEWL)
  16710.       RDATE = DBDATE
  16711.       CALL RELPUT
  16712. C
  16713. C  CHANGE THE POINTERS FOR ANY KEY ATTRIBUTES.
  16714. C
  16715.       IF(NUMKEY.EQ.0) GO TO 9999
  16716.       I = 0
  16717.       IF(NUMKEY.LE.5) GO TO 520
  16718.       I = LOCATT(BLANK,NAME)
  16719.   520 CONTINUE
  16720.       IF(NUMKEY.GT.5) GO TO 530
  16721.       I = I + 1
  16722.       IF(I.GT.NUMKEY) GO TO 9999
  16723.       START = KEYDAT(1,I)
  16724.       KSTART = KEYDAT(1,I)
  16725.       IPOLD = KEYDAT(2,I)
  16726.       IPNEW = IPOLD
  16727.       ATTWDS = KEYDAT(3,I)
  16728.       ATTYPE = KEYDAT(4,I)
  16729.       GO TO 535
  16730.   530 CONTINUE
  16731.       CALL ATTGET(ISTAT)
  16732.       IF(ISTAT.NE.0) GO TO 9999
  16733.       IF(ATTKEY.EQ.0) GO TO 520
  16734.       START = ATTKEY
  16735.       KSTART = ATTKEY
  16736.       IPOLD = ATTCOL
  16737.       IPNEW = ATTCOL
  16738.   535 CONTINUE
  16739.       IF(ATTWDS.NE.0) GO TO 540
  16740. C
  16741. C  VARIABLE LENGTH ATTRIBUTE.
  16742. C
  16743.       IPOLD = BUFFER(KQ1+IPOLD-1) + 2
  16744.       IPNEW = TUPLE(IPNEW) + 2
  16745.       IF((IPNEW.LT.1).OR.(IPNEW.GT.MAXCOL)) GO TO 800
  16746.   540 CONTINUE
  16747.       IF(BUFFER(KQ1+IPOLD-1).EQ.TUPLE(IPNEW)) GO TO 520
  16748. C
  16749. C  THE VALUE CHANGED.
  16750. C
  16751.       IF(BUFFER(KQ1+IPOLD-1).NE.NULL)
  16752.      +CALL BTREP(BUFFER(KQ1+IPOLD-1),0,CID,ATTYPE)
  16753.       IF(TUPLE(IPNEW).NE.NULL)
  16754.      +CALL BTADD(TUPLE(IPNEW),CID,ATTYPE)
  16755.       IF(START.EQ.KSTART) GO TO 520
  16756.       IF(NUMKEY.LE.5) GO TO 550
  16757.       ATTKEY = START
  16758.       CALL ATTPUT(ISTAT)
  16759.       GO TO 520
  16760.   550 CONTINUE
  16761.       ISTAT = LOCATT(KEYDAT(5,I),NAME)
  16762.       CALL ATTGET(ISTAT)
  16763.       ATTKEY = START
  16764.       CALL ATTPUT(ISTAT)
  16765.       GO TO 520
  16766. C
  16767. C  NEW TUPLE HAS VARIABLE LENGTH POINTERS WHICH ARE WIERD.
  16768. C
  16769.   800 CONTINUE
  16770.       RMSTAT = 100
  16771.  9999 CONTINUE
  16772.       RETURN
  16773.       END
  16774.       SUBROUTINE RMRES(INDPTR)
  16775.       INCLUDE rin:TEXT.BLK
  16776. C
  16777. C  PURPOSE:   RESTORE THE INTERNAL POINTERS FOR THE NAVIGATION OF
  16778. C             MULTIPLE PROGRAM INTERFACE PATHS.
  16779. C
  16780. C  PARAMETERS:
  16781. C     INPUT:  INDPTR--INDEX TO SAVE BLOCK (RANGE OF 0 TO 9)
  16782.       INCLUDE rin:RIMCOM.BLK
  16783.       INCLUDE rin:VARDAT.BLK
  16784.       INCLUDE rin:KEYDAT.BLK
  16785.       INCLUDE rin:TUPLEA.BLK
  16786.       INCLUDE rin:RULCOM.BLK
  16787.       INCLUDE rin:TUPLER.BLK
  16788.       INCLUDE rin:RIMPTR.BLK
  16789.       INCLUDE rin:WHCOM.BLK
  16790.       INCLUDE rin:RELTBL.BLK
  16791.       INCLUDE rin:PTRCOM.BLK
  16792.       INCLUDE rin:MISC.BLK
  16793.       INCLUDE rin:SRTCOM.BLK
  16794.       LOGICAL NE
  16795.       LOGICAL EQ
  16796. C
  16797. C  SEE IF THE INDEX IS WITHIN RANGE.
  16798. C
  16799.       IF(INDCUR.EQ.NULL) GO TO 400
  16800.       IF(INDPTR.EQ.NULL) GO TO 400
  16801.       IF((INDPTR.LT.0).OR.(INDPTR.GT.9)) GO TO 500
  16802. C
  16803. C  SEE IF THE CURRENT BLOCK IS ALREADY THERE.
  16804. C
  16805.       IF(INDPTR.EQ.INDCUR) GO TO 999
  16806. C
  16807. C  SAVE THE CURRENT BLOCKS.
  16808. C
  16809.       CALL RMSAV(INDCUR)
  16810. C
  16811. C  RESTORE THE BLOCKS.
  16812. C
  16813.       DO 100 I=1,INDMAX
  16814.       IF(INDNUM(I).EQ.INDPTR) GO TO 200
  16815.   100 CONTINUE
  16816. C
  16817. C  NUMBER HAS NOT BEEN SAVED.
  16818. C
  16819.       GO TO 400
  16820.   200 CONTINUE
  16821. C
  16822. C  GET THE START OF THE POINTERS IN THE BUFFER
  16823. C
  16824.       I = INDPTR + 1
  16825.       KQ1 = SAVBLK(1,I)
  16826.       IF(KQ1.EQ.0) RETURN
  16827. C
  16828. C  MOVE THE POINTER VALUES FROM THE BUFFER TO THE COMMON BLOCKS
  16829. C
  16830. C TUPLEA
  16831.       NW = 10
  16832.       CALL BLKMOV(ATTNAM,SAVBUF(KQ1),NW)
  16833.       KQ1 = KQ1 + NW
  16834. C TUPLER
  16835.       NW = 13
  16836.       CALL BLKMOV(NAME,SAVBUF(KQ1),NW)
  16837.       KQ1 = KQ1 + NW
  16838.       IF(EQ(NAME,CNAME)) GO TO 210
  16839.       J = LOCREL(NAME)
  16840.       LRROW = LRROW + 1
  16841.   210 CONTINUE
  16842. C  RIMPTR
  16843.       CALL BLKMOV(IVAL,SAVBUF(KQ1),6)
  16844.       KQ1 = KQ1 + 6
  16845. C  VARDAT
  16846.       NUMVAR = SAVBUF(KQ1)
  16847.       NW = 1 + (NUMVAR*2)
  16848.       IF(NW.GT.11) NW = 11
  16849.       CALL BLKMOV(NUMVAR,SAVBUF(KQ1),NW)
  16850.       KQ1 = KQ1 + NW
  16851. C  KEYDAT
  16852.       NUMKEY = SAVBUF(KQ1)
  16853.       NW = 1 + (NUMKEY*6)
  16854.       IF(NW.GT.31) NW = 31
  16855.       CALL BLKMOV(NUMKEY,SAVBUF(KQ1),NW)
  16856.       KQ1 = KQ1 + NW
  16857. C  SRTCOM
  16858.       NREAD = SAVBUF(KQ1)
  16859.       NSORT = SAVBUF(KQ1+1)
  16860.       CALL BLKMOV(FIXLT,SAVBUF(KQ1+2),1)
  16861.       KQ1 = KQ1 + 3
  16862. C  RULCOM
  16863.       NW = 1
  16864.       RULCNT = SAVBUF(KQ1)
  16865.       IF(RULCNT.NE.0) NW = 18
  16866.       CALL BLKMOV(RULCNT,SAVBUF(KQ1),NW)
  16867.       KQ1 = KQ1 + NW
  16868. C  WHCOM
  16869.       NBOO = SAVBUF(KQ1)
  16870.       KSTRT = SAVBUF(KQ1+1)
  16871.       MAXTU = SAVBUF(KQ1+2)
  16872.       LIMTU = SAVBUF(KQ1+3)
  16873.       NEXPOS = SAVBUF(KQ1+4)
  16874.       NEXPOT = SAVBUF(KQ1+5)
  16875.       KQ1 = KQ1 + 6
  16876.       IF(NBOO.EQ.0) GO TO 230
  16877.       CALL BLKMOV(BOO,SAVBUF(KQ1),NBOO)
  16878.       KQ1 = KQ1 + NBOO
  16879.       CALL BLKMOV(KATTP,SAVBUF(KQ1),NBOO)
  16880.       KQ1 = KQ1 + NBOO
  16881.       CALL BLKMOV(KATTL,SAVBUF(KQ1),NBOO)
  16882.       KQ1 = KQ1 + NBOO
  16883.       CALL BLKMOV(KATTY,SAVBUF(KQ1),NBOO)
  16884.       KQ1 = KQ1 + NBOO
  16885.       CALL BLKMOV(KOMTYP,SAVBUF(KQ1),NBOO)
  16886.       KQ1 = KQ1 + NBOO
  16887.       CALL BLKMOV(KOMPOS,SAVBUF(KQ1),NBOO)
  16888.       KQ1 = KQ1 + NBOO
  16889.       CALL BLKMOV(KOMLEN,SAVBUF(KQ1),NBOO)
  16890.       KQ1 = KQ1 + NBOO
  16891.       CALL BLKMOV(KOMPOT,SAVBUF(KQ1),NBOO)
  16892.       KQ1 = KQ1 + NBOO
  16893.       CALL BLKMOV(WHRVAL,SAVBUF(KQ1),NEXPOS)
  16894.       KQ1 = KQ1 + NEXPOS
  16895.       CALL BLKMOV(WHRLEN,SAVBUF(KQ1),NEXPOT)
  16896.       KQ1 = KQ1 + NEXPOT
  16897.   230 CONTINUE
  16898.       INDCUR = INDPTR
  16899.       GO TO 999
  16900.   400 CONTINUE
  16901.       RMSTAT = 50
  16902.       GO TO 999
  16903.   500 CONTINUE
  16904.       RMSTAT = 70
  16905.   999 CONTINUE
  16906.       RETURN
  16907.       END
  16908.       SUBROUTINE RMRULE(SWITCH)
  16909.       INCLUDE rin:TEXT.BLK
  16910. C
  16911. C  PURPOSE:   SET THE RULE CHECKING FLAG
  16912. C
  16913. C  PARAMETERS:
  16914. C         SWITCH--0 MEANS NOCHECK, NOT 0 MEANS CHECK
  16915.       INCLUDE rin:FLAGS.BLK
  16916.       INTEGER SWITCH
  16917.       RUCK = .TRUE.
  16918.       IF(SWITCH.EQ.0) RUCK = .FALSE.
  16919.       RETURN
  16920.       END
  16921.       SUBROUTINE RMSAV(INDPTR)
  16922.       INCLUDE rin:TEXT.BLK
  16923. C
  16924. C  PURPOSE:   SAVE THE INTERNAL POINTERS FOR THE NAVIGATION OF
  16925. C             MULTIPLE PROGRAM INTERFACE PATHS.
  16926. C
  16927. C  PARAMETERS:
  16928. C     INPUT:  INDPTR--INDEX TO SAVE BLOCK (RANGE OF 0 TO 9)
  16929.       INCLUDE rin:CONST8.BLK
  16930.       INCLUDE rin:MISC.BLK
  16931.       INCLUDE rin:KEYDAT.BLK
  16932.       INCLUDE rin:SRTCOM.BLK
  16933.       INCLUDE rin:RULCOM.BLK
  16934.       INCLUDE rin:RIMCOM.BLK
  16935.       INCLUDE rin:VARDAT.BLK
  16936.       INCLUDE rin:TUPLEA.BLK
  16937.       INCLUDE rin:TUPLER.BLK
  16938.       INCLUDE rin:RIMPTR.BLK
  16939.       INCLUDE rin:WHCOM.BLK
  16940.       INCLUDE rin:PTRCOM.BLK
  16941.       INCLUDE rin:DCLAR4.BLK
  16942.     integer inited
  16943.     save inited
  16944.     data inited/0/
  16945. c      DATA NEXPOS /0/
  16946. c      DATA NEXPOT /0/
  16947. c      DATA NBLK /1/
  16948. c      DATA SAVBLK /20*0/
  16949.     if(inited.ne.0)goto 100
  16950.     inited=1
  16951.     nexpos=0
  16952.     nexpot=0
  16953.     nblk=1
  16954.     do 30 i=1,20
  16955.     savblk(i,1)=0
  16956. 30    continue
  16957. 100    continue
  16958. C
  16959. C  SEE IF THE INDEX IS WITHIN RANGE.
  16960. C
  16961.       IF((INDPTR.LT.0).OR.(INDPTR.GT.9)) GO TO 500
  16962.       IF(INDMAX.EQ.0) GO TO 300
  16963.       DO 200 I=1,INDMAX
  16964.       IF(INDNUM(I).EQ.INDPTR) GO TO 400
  16965.   200 CONTINUE
  16966. C
  16967. C  NUMBER HAS NOT BEEN SAVED.
  16968. C
  16969.   300 CONTINUE
  16970.       INDMAX = INDMAX + 1
  16971.       INDNUM(INDMAX) = INDPTR
  16972.   400 CONTINUE
  16973. C
  16974. C  SAVE ALL BLOCKS.
  16975. C
  16976. C  SET THE NUMBER OF WORDS TO SAVE THE POINTERS
  16977. C
  16978. C  TUPLEA 8 (10 ON 32 BIT MACHINES)
  16979. C  TUPLER 9 (13 ON 32 BIT MACHINES)
  16980. C  RIMPTR 6
  16981. C  VARDAT 1+2*NVAR
  16982. C  KEYDAT 1+5*NKEY (1+16*NKEY ON 32 BIT MACHINES)
  16983. C  SRTCOM 3
  16984. C  RULCOM 1 OR 18
  16985. C  WHCOM  6+8*NBOO (+2 IN NBOO NE 0)
  16986. C
  16987. C  TOTALS - 35 + 2*NVAR + 5*NKEY + 8*NBOO + .... (60/64 BIT MACHINES)
  16988. C           41 + 2*NVAR + 16*NKEY + 8*NBOO + ... (32 BIT MACHINES)
  16989. C
  16990.       NVAR = NUMVAR
  16991.       IF(NVAR.GT.5) NVAR = 5
  16992.       NKEY = NUMKEY
  16993.       IF(NKEY.GT.5) NKEY = 5
  16994.       NW = 41
  16995.       NW = NW + 2*NVAR
  16996.       NW = NW + 6*NKEY
  16997.       NW = NW + 8*NBOO
  16998.       IF(RULCNT.NE.0) NW = NW + 17
  16999.       IF(NBOO.NE.0) NW = NW + NEXPOS
  17000.       IF(NBOO.NE.0) NW = NW + NEXPOT
  17001. C
  17002. C  ESTABLISH THE SPACE IN THE POINTER BUFFER
  17003. C
  17004.       I = INDPTR + 1
  17005.       KQ1 = SAVBLK(1,I)
  17006.       IF(KQ1.EQ.0) KQ1 = NBLK
  17007.       IF(NW.EQ.SAVBLK(2,I)) GO TO 420
  17008.       NWO = SAVBLK(2,I)
  17009.       NADD = NW - NWO
  17010.       IF((NBLK+NADD).GT.1000) GO TO 600
  17011.       MOVE = NBLK - (KQ1+NWO)
  17012.       IF(NADD.GT.0) MOVE = -MOVE
  17013.       IF((KQ1+NWO).LT.NBLK)
  17014.      X     CALL BLKMOV(SAVBUF(KQ1+NW),SAVBUF(KQ1+NWO),MOVE)
  17015. C
  17016. C  UPDATE THE INDICES
  17017. C
  17018.       SAVBLK(1,I) = KQ1
  17019.       SAVBLK(2,I) = NW
  17020.       DO 410 K=1,10
  17021.       IF(SAVBLK(1,K).LE.KQ1) GO TO 410
  17022.       SAVBLK(1,K) = SAVBLK(1,K) + NADD
  17023.   410 CONTINUE
  17024.       NBLK = NBLK + NADD
  17025.   420 CONTINUE
  17026. C
  17027. C  THE THE POINTER VALUES TO THE BUFFER
  17028. C
  17029. C TUPLEA
  17030.       NW = 10
  17031.       CALL BLKMOV(SAVBUF(KQ1),ATTNAM,NW)
  17032.       KQ1 = KQ1 + NW
  17033. C TUPLER
  17034.       NW = 13
  17035.       CALL BLKMOV(SAVBUF(KQ1),NAME,NW)
  17036.       KQ1 = KQ1 + NW
  17037. C RIMPTR
  17038.       NW = 6
  17039.       CALL BLKMOV(SAVBUF(KQ1),IVAL,NW)
  17040.       KQ1 = KQ1 + NW
  17041. C VARDAT
  17042.       NW = 1 + NVAR*2
  17043.       CALL BLKMOV(SAVBUF(KQ1),NUMVAR,NW)
  17044.       KQ1 = KQ1 + NW
  17045. C KEYDAT
  17046.       NW = 1 + NKEY*6
  17047.       CALL BLKMOV(SAVBUF(KQ1),NUMKEY,NW)
  17048.       KQ1 = KQ1 + NW
  17049. C SRTCOM
  17050.       SAVBUF(KQ1) = NREAD
  17051.       SAVBUF(KQ1+1) = NSORT
  17052.       CALL BLKMOV(SAVBUF(KQ1+2),FIXLT,1)
  17053.       KQ1 = KQ1 + 3
  17054. C RULCOM
  17055.       NW = 1
  17056.       IF(RULCNT.NE.0) NW = 18
  17057.       CALL BLKMOV(SAVBUF(KQ1),RULCNT,NW)
  17058.       KQ1 = KQ1 + NW
  17059. C  WHCOM
  17060.       SAVBUF(KQ1  ) = NBOO
  17061.       SAVBUF(KQ1+1) = KSTRT
  17062.       SAVBUF(KQ1+2) = MAXTU
  17063.       SAVBUF(KQ1+3) = LIMTU
  17064.       SAVBUF(KQ1+4) = NEXPOS
  17065.       SAVBUF(KQ1+5) = NEXPOT
  17066.       KQ1 = KQ1 + 6
  17067.       IF(NBOO.EQ.0) GO TO 430
  17068.       CALL BLKMOV(SAVBUF(KQ1),BOO,NBOO)
  17069.       KQ1 = KQ1 + NBOO
  17070.       CALL BLKMOV(SAVBUF(KQ1),KATTP,NBOO)
  17071.       KQ1 = KQ1 + NBOO
  17072.       CALL BLKMOV(SAVBUF(KQ1),KATTL,NBOO)
  17073.       KQ1 = KQ1 + NBOO
  17074.       CALL BLKMOV(SAVBUF(KQ1),KATTY,NBOO)
  17075.       KQ1 = KQ1 + NBOO
  17076.       CALL BLKMOV(SAVBUF(KQ1),KOMTYP,NBOO)
  17077.       KQ1 = KQ1 + NBOO
  17078.       CALL BLKMOV(SAVBUF(KQ1),KOMPOS,NBOO)
  17079.       KQ1 = KQ1 + NBOO
  17080.       CALL BLKMOV(SAVBUF(KQ1),KOMLEN,NBOO)
  17081.       KQ1 = KQ1 + NBOO
  17082.       CALL BLKMOV(SAVBUF(KQ1),KOMPOT,NBOO)
  17083.       KQ1 = KQ1 + NBOO
  17084.       CALL BLKMOV(SAVBUF(KQ1),WHRVAL,NEXPOS)
  17085.       KQ1 = KQ1 + NEXPOS
  17086.       CALL BLKMOV(SAVBUF(KQ1),WHRLEN,NEXPOT)
  17087.       KQ1 = KQ1 + NEXPOT
  17088.   430 CONTINUE
  17089.       INDCUR = INDPTR
  17090.       RETURN
  17091.   500 CONTINUE
  17092.       RMSTAT = 70
  17093.       RETURN
  17094.   600 CONTINUE
  17095.       RMSTAT = 71
  17096.       RETURN
  17097.       END
  17098.       SUBROUTINE RMSORT(INDPTR,ANAMES,NUMATT,SORTOR)
  17099.       INCLUDE rin:TEXT.BLK
  17100. C
  17101. C  PURPOSE:  FORTRAN INTERFACE ROUTINE TO CALL SOCON TO SORT RIM DATA
  17102. C
  17103. C  PARAMETERS:
  17104. C              INDPTR--MULTIPLE RELATION POSITION POINTER
  17105. C              ANAMES--ARRAY OF ATTRIBUTES TO SORT ON
  17106. C              NUMATT--NUMBER OF ATTRIBUTES TO SORT ON
  17107. C              SORTOR--ARRAY OF ASCENDING OR DESCENDING INDICATORS
  17108. C                      LT 0 - DESCENDING
  17109. C                      GE 0 - ASCENDING
  17110. C
  17111.       INCLUDE rin:RMATTS.BLK
  17112.       INCLUDE rin:RIMPTR.BLK
  17113.       INCLUDE rin:VARDAT.BLK
  17114.       INCLUDE rin:WHCOM.BLK
  17115.       INCLUDE rin:SRTCOM.BLK
  17116.       INCLUDE rin:RIMCOM.BLK
  17117.       INCLUDE rin:MISC.BLK
  17118.       INCLUDE rin:BUFFER.BLK
  17119.       INCLUDE rin:TUPLEA.BLK
  17120.       INCLUDE rin:TUPLER.BLK
  17121.       INCLUDE rin:PTRCOM.BLK
  17122.       INCLUDE rin:INCORE.BLK
  17123.       INCLUDE rin:FLAGS.BLK
  17124. C
  17125.       INTEGER INFIL
  17126.       INTEGER OUTFIL
  17127.       LOGICAL SAORD
  17128.       INTEGER SORTOR(*)
  17129.       INCLUDE rin:DCLAR1.BLK
  17130. C
  17131.       RMSTAT = 0
  17132. C         MAKE SURE DB IS DEFINED
  17133. C
  17134.       IF(DFLAG) GOTO 10
  17135.       RMSTAT = 16
  17136.       GOTO 999
  17137. C
  17138.    10 CONTINUE
  17139. C
  17140. C  RESTORE THE NEEDED BLOCKS
  17141. C
  17142.       CALL RMRES(INDPTR)
  17143.       IF(RMSTAT.NE.0) GO TO 999
  17144. C
  17145. C  GET THE ATTRIBUTE DATA
  17146. C
  17147.       NSOVAR = 0
  17148.       DO 800 N=1,NUMATT
  17149.       K = LOCATT(ANAMES(N),NAME)
  17150.       CALL ATTGET(K)
  17151.       IF(K.EQ.0) GO TO 200
  17152.       RMSTAT = 30
  17153.       GO TO 999
  17154. C
  17155. C  SET UP THE ATTRIBUTE SORT DATA
  17156. C
  17157.   200 CONTINUE
  17158.       SAORD = .TRUE.
  17159.       IF(SORTOR(N).LT.0) SAORD = .FALSE.
  17160.       NUMCOL = ATTCOL
  17161. C
  17162. C  CHECK FOR VARIABLE LENGTH - SORTING ON VARIABLE LENGTH
  17163. C  ATTRIBUTES IS CURRENTLY NOT ALLOWED
  17164. C
  17165.       IF(ATTWDS.NE.0) GO TO 300
  17166.       RMSTAT = 80
  17167.       GO TO 999
  17168.   300 CONTINUE
  17169. C
  17170. C  IF TEXT ATTRIBUTE DETERMINE THE NUMBER OF WORDS TO SORT ON - THIS
  17171. C  IS BASED ON THE NUMBER OF CHARACTERS (CURRENTLY 20) AND THE WORD
  17172. C  SIZE.
  17173. C     32 BIT WORDS - 20 CHARACTERS (5 WORDS)
  17174. C     60 BIT WORDS - 20 CHARACTERS (2 WORDS)
  17175. C     64 BIT WORDS - 16 CHARACTERS (2 WORDS)
  17176. C
  17177.       LSL = 1
  17178.       IF(ATTYPE.NE.KZTEXT) GO TO 400
  17179. C
  17180. C  TEXT - DETERMINE SORT WORDS
  17181. C
  17182.       LSL = 20/CHPWD
  17183.       IF(ATTWDS.LT.LSL) LSL = ATTWDS
  17184. C
  17185. C  LOAD THE SORT ARRAYS
  17186. C
  17187.   400 CONTINUE
  17188.       DO 600 K=1,LSL
  17189.       NUMCOL = NUMCOL + 1
  17190.       NSOVAR = NSOVAR + 1
  17191. C
  17192. C  CHECK ON THE NUMBER OF SORT WORDS - CURRENTLY 10
  17193. C  THIS MAY WANT TO BE UPPER FOR THE SMALLER MACHINES
  17194. C
  17195.       IF(NSOVAR.LE.NSORTW) GO TO 500
  17196.       RMSTAT = 81
  17197.       GO TO 999
  17198. C
  17199. C  LOAD ARRAYS
  17200. C
  17201.   500 CONTINUE
  17202.       SORTYP(NSOVAR) = SAORD
  17203.       VARPOS(NSOVAR) = NUMCOL
  17204.       IF(ATTYPE.EQ.KZINT) L=1
  17205.       IF(ATTYPE.EQ.KZREAL) L=2
  17206.       IF(ATTYPE.EQ.KZDOUB) L=3
  17207.       IF(ATTYPE.EQ.KZTEXT) L=4
  17208.       IF(ATTYPE.EQ.KZIVEC) L=1
  17209.       IF(ATTYPE.EQ.KZRVEC) L=2
  17210.       IF(ATTYPE.EQ.KZDVEC) L=3
  17211.       IF(ATTYPE.EQ.KZIMAT) L=1
  17212.       IF(ATTYPE.EQ.KZRMAT) L=2
  17213.       IF(ATTYPE.EQ.KZDMAT) L=3
  17214.       VARTYP(NSOVAR) = L
  17215.   600 CONTINUE
  17216.   800 CONTINUE
  17217. C
  17218. C  DO THE SORT.
  17219. C  OPEN THE INPUT SORT FILE
  17220. C
  17221.       INFIL = 20
  17222.     open(infil,file='sortfil.dat',access='sequential',
  17223.      1  form='unformatted',status='unknown',iostat=ios)
  17224.     if(ios.ne.0)call warn(16)
  17225.     if(ios.ne.0)return
  17226.       REWIND INFIL
  17227. C
  17228. C  SET UP TUPLE LIMITS - SAVE USER SPECIFIED LIMIT
  17229. C
  17230.       LIMTUS = LIMTU
  17231.       LIMTU = ALL9S
  17232. C
  17233. C  WRITE THE COMPLETE TUPLE AND CID ON THE SORT FILE
  17234. C
  17235. C  CHECK FOR VARIABLE LENGTH TUPLES IN THE RELATION
  17236. C
  17237.       FIXLT = .TRUE.
  17238.       IF(NUMVAR.GT.0) FIXLT = .FALSE.
  17239. C
  17240. C  INITIALIZE THE REMAINING VARIABLES
  17241. C
  17242.       LTUMAX = 0
  17243.       LTUMIN = ALL9S
  17244.       NSORT = 0
  17245.       LTUPLE = 0
  17246.       IF(FIXLT) LTUPLE = NCOL + 1
  17247. C
  17248. C  READ IN THE TUPLES AND WRITE THE SORT FILE
  17249. C
  17250.  1200 CONTINUE
  17251.       CALL RMLOOK(IP,1,1,LEN)
  17252.       IF(RMSTAT.NE.0) GO TO 1400
  17253.       LENX = LEN + 1
  17254.       NSORT = NSORT + 1
  17255.       IP = IP - 1
  17256.       IF(FIXLT) GO TO 1300
  17257. C
  17258. C  VARIBLE LENGTH TUPLE
  17259. C
  17260.       LTUPLE = LTUPLE + LENX
  17261.       IF(LENX.GT.LTUMAX) LTUMAX = LENX
  17262.       IF(LENX.LT.LTUMIN) LTUMIN = LENX
  17263.       WRITE(INFIL) LENX,CID,(BUFFER(IP+K),K=1,LEN)
  17264.       GO TO 1200
  17265. C
  17266. C  FIXED LENGTH TUPLES
  17267. C
  17268.  1300 CONTINUE
  17269.       WRITE(INFIL) CID,(BUFFER(IP+K),K=1,LEN)
  17270.       GO TO 1200
  17271. C
  17272. C  CHECK THAT SOME TUPLES WERE WRITTIN ON INFIL
  17273. C  RESET THE TUPLE LIMIT
  17274. C
  17275.  1400 CONTINUE
  17276.       RMSTAT = 0
  17277.       LIMTU = LIMTUS
  17278.       IF(NSORT.GT.0) GO TO 1420
  17279.       RMSTAT = -1
  17280.       GO TO 998
  17281. C
  17282. C  OPEN THE OUTPUT FILES
  17283. C
  17284.  1420 CONTINUE
  17285.       OUTFIL = 20
  17286.       IF(INDPTR.EQ.0) GO TO 1430
  17287.       OUTFIL = INFIL + INDPTR
  17288.  1430 CONTINUE
  17289. C
  17290. C  CLEAR OUT ANY PAGE DATA LEFT IN BUFFER
  17291. C
  17292.       CALL BLKCLN
  17293. C
  17294. C  FIXUP THE LENGTHS FOR VARIABLE LENGTH STUFF
  17295. C
  17296.       IF(FIXLT) GO TO 1440
  17297.       LTUPLE = LTUPLE + NSORT
  17298.       LTUMAX = LTUMAX + 1
  17299.       LTUMIN = LTUMIN + 1
  17300. C
  17301. C  CALL SOCON TO DO THE ACTUAL SORT
  17302. C
  17303.  1440 CONTINUE
  17304.       IERR = 0
  17305.       CALL SWCON(BUFFER,LIMIT,INFIL,OUTFIL,IERR)
  17306.       IF(IERR.EQ.0) GO TO 1450
  17307.       RMSTAT = 89
  17308.       GO TO 998
  17309. C
  17310.  1450 CONTINUE
  17311. C
  17312. C  INITIALIZE THE BUFFER AND RESAVE THE POINTERS
  17313. C
  17314.       NS = 1
  17315.       CALL RMGTSO(IP,10,-1,LEN,INDPTR)
  17316.       CALL RMSAV(INDCUR)
  17317. C
  17318.   998 CONTINUE
  17319.       IF(INDPTR.EQ.0) GO TO 999
  17320. C
  17321. C  CLOSE THE SORT INPUT FILE
  17322. C
  17323.       CLOSE(UNIT=INFIL,STATUS='DELETE')
  17324.   999 CONTINUE
  17325.       RETURN
  17326.       END
  17327.       SUBROUTINE RMSTRT
  17328.       INCLUDE rin:TEXT.BLK
  17329. C
  17330. C  PURPOSE:   INITIALIZE ALL NEEDED VARIABLES AND ARRAYS
  17331. C
  17332.       INCLUDE rin:RMATTS.BLK
  17333.       INCLUDE rin:CONST4.BLK
  17334.       INCLUDE rin:CONST8.BLK
  17335.       INCLUDE rin:FLAGS.BLK
  17336.       INCLUDE rin:MISC.BLK
  17337.       INCLUDE rin:RELTBL.BLK
  17338.       INCLUDE rin:ATTBLE.BLK
  17339.       INCLUDE rin:INCORE.BLK
  17340.       INCLUDE rin:F1COM.BLK
  17341.       INCLUDE rin:F2COM.BLK
  17342.       INCLUDE rin:F3COM.BLK
  17343.       INCLUDE rin:RULCOM.BLK
  17344.       INCLUDE rin:RIMPTR.BLK
  17345.       INCLUDE rin:SRTCOM.BLK
  17346. C
  17347. C  CALL THE RMCONS ROUTINE TO INITIALIZE THE HOLLERITH CONSTANTS
  17348. C  THIS CALL IS MADE ONLY ONCE PER EXECUTION
  17349. C
  17350.       DATA KALTST /0/
  17351.       IF(KALTST.EQ.1) GO TO 100
  17352.       CALL RMCONS
  17353.       KALTST = 1
  17354.   100 CONTINUE
  17355. C
  17356. C  SET FLAGS AND VARIABLES.
  17357. C
  17358. C  /MISC/
  17359.       ALL9S = 999999999
  17360.       CHPWD = 4
  17361.       MAXCOL = 1021
  17362. C  /FLAGS/
  17363.       DFLAG = .FALSE.
  17364.       OWNER = NONE
  17365.       IFMOD = .FALSE.
  17366.       TOL = 0.
  17367.       PCENT = .FALSE.
  17368.       RUCK = .TRUE.
  17369. C  /RELTBL/
  17370.       CNAME = BLANK
  17371.       LRROW = 0
  17372.       NRROW = 74
  17373.       RELMOD = 0
  17374.       RPBUF = 73
  17375. C  /ATTBLE/
  17376.       CANAME = BLANK
  17377.       CRNAME = BLANK
  17378.       CRSTRT = 0
  17379.       CROW = 0
  17380.       LROW = 0
  17381.       NAROW = 227
  17382.       ATTMOD = 0
  17383.       APBUF = 113
  17384. C  /INCORE/
  17385.       CALL ZEROIT(BLOCKS(1,1),60)
  17386.       NEXT = 1
  17387.       LIMIT = 4608
  17388.       NUMBL = 0
  17389. C  /F1COM/
  17390.       FILE1 = 31
  17391.       LENBF1 = 1024
  17392.       LF1REC = 0
  17393.       CAREC = 0
  17394.       CRREC = 0
  17395. C  /F2COM/
  17396.       FILE2 = 32
  17397.       LENBF2 = 1024
  17398.       DO 200 I=1,3
  17399.       CURBLK(I) = 0
  17400.       MODFLG(I) = 0
  17401.   200 CONTINUE
  17402. C  /F3COM/
  17403.       FILE3 = 33
  17404.       LENBF3 = 126
  17405.       MAXIC = 20
  17406. C  /RIMPTR/
  17407.       IVAL = 0
  17408.       CID = 0
  17409.       NID = 0
  17410.       NS = 0
  17411.       MID = 0
  17412.       INDCUR = NULL
  17413.       INDMAX = 0
  17414. C  /SRTCOM/
  17415.       NSORTW = 10
  17416.       FIXLT = .TRUE.
  17417.       NSORT = 0
  17418.       NREAD = 0
  17419. C  /RULCOM/
  17420.       RIMRRC = K8RRC
  17421.       RIMRDT = K8RDT
  17422.       RULCNT = 0
  17423.       RETURN
  17424.       END
  17425.       SUBROUTINE RMTIME(IT)
  17426.       INCLUDE rin:TEXT.BLK
  17427. C
  17428. C  PURPOSE:   RETURN THE CURRENT TIME
  17429. C
  17430. C  PARAMETERS:
  17431. C         IT------THE CURRENT TIME IN HH.MM.SS FORMAT
  17432. C
  17433.       INCLUDE rin:MISC.BLK
  17434.       REAL*8 IT
  17435. c      character*24 ctime
  17436. c      external ctime
  17437. c      character*24 ctm
  17438. c      integer*4 ltm
  17439. c      character*1 ctm1(24),rt1(8)
  17440. c    equivalence(ctm1(1),ctm)
  17441. c    equivalence(ctm1(12),rt1(1))
  17442. c        character*8 rtt
  17443. c    equivalence(rtt,rt1(1))
  17444.     character*8 rt
  17445.     real*8 irt
  17446.     equivalence(irt,rt)
  17447.         integer itarr(3),ihr,imn,isc
  17448.     equivalence (ihr,itarr(1)),(imn,itarr(2)),(isc,itarr(3))
  17449.        call time(krt)
  17450.     ihr=krt/3600
  17451.     krt=krt-(ihr*3600)
  17452.     imn=krt/60
  17453.     krt=krt-(imn*60)
  17454.     isc=krt
  17455.        write(rt,1000)ihr,imn,isc
  17456. 1000   format(i2.2,'.',i2.2,'.',i2.2)
  17457.        it=irt
  17458. c      ltm=TIME()
  17459. c      ctm=ctime(ltm)
  17460. c    rt=rtt
  17461. c       it=irt
  17462. cc      CALL PUTT(IT,3,1H.)
  17463. cc      CALL PUTT(IT,6,1H.)
  17464.       RETURN
  17465.       END
  17466.       SUBROUTINE RMTOL(VAL,PERC)
  17467.       INCLUDE rin:TEXT.BLK
  17468. C
  17469. C  PURPOSE:  SET THE TOLERANCE VARIABLES IN THE FORTRAN INTERFACE
  17470. C
  17471. C  PARAMETERS: VAL----TOLERANCE VALUE - ABSOLUTE VALUE OR PERCENT
  17472. C              PERC---PERC = 0 -- VAL IS ABSOLUTE VALUE
  17473. C                     PERC = 1 -- VAL IS PERCENT
  17474. C
  17475.       INCLUDE rin:FLAGS.BLK
  17476.       INTEGER PERC
  17477. C
  17478.       TOL = VAL
  17479.       PCENT = .FALSE.
  17480.       IF(PERC.EQ.0) GO TO 999
  17481. C
  17482. C  PERCENTAGE
  17483. C
  17484.       TOL = VAL/100.
  17485.       PCENT = .TRUE.
  17486.   999 CONTINUE
  17487.       RETURN
  17488.       END
  17489.       SUBROUTINE RMUSER(ID)
  17490.       INCLUDE rin:TEXT.BLK
  17491. C
  17492. C  PURPOSE:   SET THE CURRENT USERID TO THE USER SUPPLIED ID
  17493. C
  17494.       INCLUDE rin:FLAGS.BLK
  17495.       INCLUDE rin:MISC.BLK
  17496.       INTEGER ID(*)
  17497. C
  17498. C  SET THE USERID TO ID.
  17499. C
  17500.       USERID = BLANK
  17501.       CALL STRMOV(ID,1,8,USERID,1)
  17502.       RETURN
  17503.       END
  17504.       SUBROUTINE RMVARC(CTYP,TUPVAL)
  17505.       INCLUDE rin:TEXT.BLK
  17506. C
  17507. C  PURPOSE: THIS ROUTINE CHANGES THE VARIABLE LENGTH ATTRIBUTE
  17508. C           TUPLE HEADERS FROM INTERNAL TO USER REPRESENTATION
  17509. C           OR VISA VERSA.
  17510. C
  17511. C                             USER                    INTERNAL
  17512. C           TYPE        WORD1       WORD2       WORD1       WORD2
  17513. C           ----------  ----------  ----------  ----------  ----------
  17514. C           TEXT        CHARACTERS  0           WORDS       CHARACTERS
  17515. C           INT         ITEMS       0           WORDS       1
  17516. C           REAL        ITEMS       0           WORDS       1
  17517. C           DOUBLE      ITEMS       0           WORDS       1
  17518. C           VECTORS     ITEMS       0           WORDS       1
  17519. C           MATRICES    ROWS        COLS        WORDS       ROWS
  17520. C
  17521. C  PARAMETERS:
  17522. C           CTYP-----CONVERSION TYPE - -1 = INTERNAL TO USER
  17523. C                                      +1 = USER TO INTERNAL
  17524. C           TUPVAL---ARRAY CONTAINING THE TUPLE VALUES
  17525. C
  17526.       INCLUDE rin:RMATTS.BLK
  17527.       INCLUDE rin:VARDAT.BLK
  17528.       INCLUDE rin:RIMCOM.BLK
  17529.       INCLUDE rin:TUPLER.BLK
  17530.       INCLUDE rin:TUPLEA.BLK
  17531.       INCLUDE rin:MISC.BLK
  17532. C
  17533.       INTEGER CTYP
  17534.       INTEGER TUPVAL(*)
  17535. C
  17536. C  IF THE NUMBER OF VARIABLE ATTRIBUTES EXCEEDS 5 WE HAVE TO USE
  17537. C  ATTGET ETC TO DO THE CONVERSION ----
  17538. C
  17539.       LOOP = NUMVAR
  17540.       IF(NUMVAR.LE.5) GO TO 100
  17541. C
  17542. C  MORE THAN 5 VARIABLE LENGTH ATTRIBUTES
  17543. C
  17544.       I = LOCATT(BLANK,NAME)
  17545.       LOOP = NATT
  17546. C
  17547. C  GET THE VALUES FOR EACH VARIABLE LENGTH ATTRIBUTE
  17548. C
  17549.   100 CONTINUE
  17550.       DO 500 K=1,LOOP
  17551.       IF(NUMVAR.LE.5) GO TO 200
  17552.       CALL ATTGET(ISTATX)
  17553.       IF(ISTATX.NE.0) GO TO 999
  17554.       IF(ATTWDS.NE.0) GO TO 500
  17555.       IP = TUPVAL(ATTCOL)
  17556.       ITYPE = ATTYPE
  17557.       GO TO 300
  17558.   200 CONTINUE
  17559.       IP = TUPVAL(POSVAR(1,K))
  17560.       ITYPE = POSVAR(2,K)
  17561.   300 CONTINUE
  17562.       IF((IP.LT.1).OR.(IP.GT.MAXCOL)) GO TO 998
  17563.       IW1 = TUPVAL(IP)
  17564.       IW2 = TUPVAL(IP+1)
  17565.       IF(CTYP.LT.0) GO TO 400
  17566. C
  17567. C  USER TO INTERNAL - RMPUT,RMLOAD
  17568. C
  17569.       IF(ITYPE.EQ.KZINT ) TUPVAL(IP) = IW1
  17570.       IF(ITYPE.EQ.KZREAL) TUPVAL(IP) = IW1
  17571.       IF(ITYPE.EQ.KZDOUB) TUPVAL(IP) = 2*IW1
  17572.       IF(ITYPE.EQ.KZTEXT) TUPVAL(IP) = (IW1-1)/CHPWD + 1
  17573.       IF(ITYPE.EQ.KZIVEC) TUPVAL(IP) = IW1
  17574.       IF(ITYPE.EQ.KZRVEC) TUPVAL(IP) = IW1
  17575.       IF(ITYPE.EQ.KZDVEC) TUPVAL(IP) = 2*IW1
  17576.       IF(ITYPE.EQ.KZIMAT) TUPVAL(IP) = IW1*IW2
  17577.       IF(ITYPE.EQ.KZRMAT) TUPVAL(IP) = IW1*IW2
  17578.       IF(ITYPE.EQ.KZDMAT) TUPVAL(IP) = 2*IW1*IW2
  17579.       TUPVAL(IP+1) = 1
  17580.       IF(ITYPE.EQ.KZTEXT) TUPVAL(IP+1) = IW1
  17581.       IF(ITYPE.EQ.KZIMAT) TUPVAL(IP+1) = IW1
  17582.       IF(ITYPE.EQ.KZRMAT) TUPVAL(IP+1) = IW1
  17583.       IF(ITYPE.EQ.KZDMAT) TUPVAL(IP+1) = IW1
  17584.       IF((TUPVAL(IP).LT.1).OR.(TUPVAL(IP).GT.MAXCOL)) GO TO 998
  17585.       GO TO 500
  17586. C
  17587. C  INTERNAL TO USER - RMGET
  17588. C
  17589.   400 CONTINUE
  17590.       IF(ITYPE.EQ.KZINT ) TUPVAL(IP) = IW1
  17591.       IF(ITYPE.EQ.KZREAL) TUPVAL(IP) = IW1
  17592.       IF(ITYPE.EQ.KZDOUB) TUPVAL(IP) = IW1/2
  17593.       IF(ITYPE.EQ.KZTEXT) TUPVAL(IP) = IW2
  17594.       IF(ITYPE.EQ.KZIVEC) TUPVAL(IP) = IW1
  17595.       IF(ITYPE.EQ.KZRVEC) TUPVAL(IP) = IW1
  17596.       IF(ITYPE.EQ.KZDVEC) TUPVAL(IP) = IW1/2
  17597.       IF(ITYPE.EQ.KZIMAT) TUPVAL(IP) = IW2
  17598.       IF(ITYPE.EQ.KZRMAT) TUPVAL(IP) = IW2
  17599.       IF(ITYPE.EQ.KZDMAT) TUPVAL(IP) = IW2
  17600.       TUPVAL(IP+1) = 0
  17601.       IF(ITYPE.EQ.KZIMAT) TUPVAL(IP+1) = IW1/IW2
  17602.       IF(ITYPE.EQ.KZRMAT) TUPVAL(IP+1) = IW1/IW2
  17603.       IF(ITYPE.EQ.KZDMAT) TUPVAL(IP+1) = (IW1/2)/IW2
  17604.   500 CONTINUE
  17605.       GO TO 999
  17606. C
  17607.   998 RMSTAT = 100
  17608. C
  17609.   999 CONTINUE
  17610.       RETURN
  17611.       END
  17612.       SUBROUTINE RMWHER(INDPTR,ANAMES,OPERS,VALS,NUMVAL,NXTBOO,NUMBOO)
  17613.       INCLUDE rin:TEXT.BLK
  17614. C
  17615. C  PURPOSE:  PROCESS A RIM WHERE CLAUSE IN THE FORTRAN INTERFACE
  17616. C
  17617. C  PARAMETERS:
  17618. C        INDPTR---MULTIPLE RELATION POSITION INDICATOR
  17619. C        ANAMES---ARRAY OF ATTRIBUTE NAMES
  17620. C        OPERS----ARRAY OF OPERATORS
  17621. C        VALS-----ARRAY OF CONDITION VALUES
  17622. C                   FIXED LENGTH - VSET1,VSET2,.....
  17623. C                   VARIABLE LENGTH ------
  17624. C                     TEXT  (NCHAR1)(0)VSET1,(NCHAR2)(0)VSET2,....
  17625. C                     INT,REAL,DOUB, AND VECTORS (ITEMS1)(0)VSET1,...
  17626. C                     MATRICES (ROWS1)(COLS1)VSET1,(ROWS2)(COLS2)VSET2,.
  17627. C        NUMVAL---NUMBER OF VALUE SETS (VSETS) IN VALS
  17628. C        NXTBOO---ARRAY OF "AND" "OR" OPERATORS
  17629. C        NUMBOO---NUMBER OF WHERE CONDITIONS (ROW DIMENSION
  17630. C                 OF ALL ARRAYS)
  17631. C
  17632.       INCLUDE rin:FLAGS.BLK
  17633.       INCLUDE rin:RMATTS.BLK
  17634.       INCLUDE rin:CONST4.BLK
  17635.       INCLUDE rin:CONST8.BLK
  17636.       INCLUDE rin:MISC.BLK
  17637.       INCLUDE rin:RIMCOM.BLK
  17638.       INCLUDE rin:TUPLEA.BLK
  17639.       INCLUDE rin:TUPLER.BLK
  17640.       INCLUDE rin:WHCOM.BLK
  17641.       INCLUDE rin:RIMPTR.BLK
  17642.       INCLUDE rin:PTRCOM.BLK
  17643. C
  17644.       LOGICAL IFVAR
  17645.       LOGICAL IFLIM
  17646.       LOGICAL IFTUP
  17647.       INTEGER OPERS(*)
  17648.       INTEGER VALS(NUMBOO,*)
  17649.       INTEGER NUMVAL(*)
  17650.       INTEGER NXTBOO(*)
  17651.       INTEGER IDUM(2)
  17652.       INCLUDE rin:DCLAR1.BLK
  17653. C
  17654. C
  17655. C  MAKE SURE DB IS OPEN
  17656. C
  17657.       IF(DFLAG) GO TO 10
  17658.       RMSTAT = 16
  17659.       GO TO 9999
  17660. C
  17661.    10 CONTINUE
  17662. C  CHECK THE NUMBER OF OPERATORS
  17663. C
  17664.       IF(NUMBOO.LE.10) GO TO 100
  17665.       RMSTAT = 40
  17666.       GO TO 9999
  17667. C
  17668. C  RESTORE THE REQUIRED BLOCKS
  17669. C
  17670.   100 CONTINUE
  17671.       RMSTAT = 0
  17672.       CALL RMRES(INDPTR)
  17673.       IF(RMSTAT.NE.0) GO TO 9999
  17674. C
  17675. C  INITIALIZE
  17676. C
  17677.       NS = 0
  17678.       NTUPC = 0
  17679.       KMM = 0
  17680.       KSTRT = 0
  17681.       MAXTU = 0
  17682.       LIMTU = ALL9S
  17683. C
  17684. C  BREAK UP EACH CONDITION.
  17685. C
  17686.       DO 600 I=1,10
  17687.       KOMPOS(I) = 0
  17688.       KOMPOT(I) = 0
  17689.       KOMLEN(I) = 0
  17690.       KATTP(I) = 0
  17691.       KATTL(I) = 0
  17692.       KATTY(I) = 0
  17693.   600 CONTINUE
  17694.       NBOO = 1
  17695.       BOO(1) = K4AND
  17696.       NEXPOT = 1
  17697.       NEXPOS = 1
  17698.       DO 2000 K=1,NUMBOO
  17699. C
  17700. C  GET THE ATTRIBUTE.
  17701. C
  17702.       IFLIM = .FALSE.
  17703.       IF(ANAMES(K).NE.K8LIM) GO TO 1150
  17704. C
  17705. C     LIMIT KEYWORD
  17706. C
  17707.       IF(OPERS(K).EQ.K4EQ) GO TO 700
  17708.       RMSTAT = 41
  17709.       GO TO 9999
  17710.   700 CONTINUE
  17711.       LIMTU = VALS(K,1)
  17712.       IF((LIMTU.GT.0).AND.(LIMTU.LT.ALL9S)) GO TO 800
  17713.       RMSTAT = 41
  17714.       GO TO 9999
  17715.   800 CONTINUE
  17716.       NBOO = NBOO - 1
  17717.       IFLIM = .TRUE.
  17718.       GO TO 1800
  17719.  1150 CONTINUE
  17720.       IFTUP = .FALSE.
  17721.       IF(ANAMES(K).EQ.K8ROWS) IFTUP = .TRUE.
  17722.       IF(.NOT.IFTUP) GO TO 1190
  17723. C
  17724. C  ROW WHERE CLAUSE - CHECK TYPE AND GET MAXIMUM ROW NUMBER
  17725. C
  17726.       NTUPC = NTUPC + 1
  17727.       MAXTUN = VALS(K,1)
  17728.       IF(MAXTUN.GT.MAXTU) MAXTU = MAXTUN
  17729.       KOMPAR = OPERS(K)
  17730.       KOMTYP(NBOO) = LOCBOO(KOMPAR)
  17731.       IF(KOMTYP(NBOO).NE.0) GO TO 1170
  17732. C
  17733. C  UNRECOGNIZED BOOLEAN COMPARISION.
  17734. C
  17735.       RMSTAT = 42
  17736.       GO TO 9999
  17737.  1170 CONTINUE
  17738.       IF((KOMTYP(NBOO).GE.3).AND.(KOMTYP(NBOO).LE.5)) MAXTU = NTUPLE
  17739.       GO TO 1500
  17740.  1190 CONTINUE
  17741.       I = LOCATT(ANAMES(K),NAME)
  17742.       IF(I.NE.0) GO TO 1200
  17743.       CALL ATTGET(I)
  17744.       IF(I.EQ.0) GO TO 1300
  17745. C
  17746. C  UNRECOGNIZED ATTRIBUTE.
  17747. C
  17748.  1200 CONTINUE
  17749.       RMSTAT = 30
  17750.       GO TO 9999
  17751.  1300 CONTINUE
  17752.       KATTP(NBOO) = ATTCOL
  17753.       KATTL(NBOO) = ATTLEN
  17754.       CALL TYPER(ATTYPE,MATVEC,KATTY(NBOO))
  17755. C
  17756. C  DETERMINE THE TYPE OF BOOLEAN EXPRESSION.
  17757. C
  17758.       KOMPAR = OPERS(K)
  17759.       KOMTYP(NBOO) = LOCBOO(KOMPAR)
  17760.       IF(KOMTYP(NBOO).NE.0) GO TO 1500
  17761. C
  17762. C  UNRECOGNIZED BOOLEAN COMPARISION.
  17763. C
  17764.       RMSTAT = 42
  17765.       GO TO 9999
  17766.  1500 CONTINUE
  17767. C
  17768. C  CHECK FOR FAILS OR EXISTS AND EQS ONLY ON TEXT ATTRIBUTES
  17769. C
  17770.       IF(KOMTYP(NBOO).LE.1) GO TO 1800
  17771.       IF(KOMTYP(NBOO).GE.10) GO TO 1600
  17772.       IF(KOMTYP(NBOO).NE.9) GO TO 1510
  17773.       IF(ATTYPE.EQ.KZTEXT) GO TO 1510
  17774.       RMSTAT = 43
  17775.       GO TO 9999
  17776. C
  17777. C     CHECK FOR "WHERE XXX EQ MIN OR MAX"
  17778. C
  17779.  1510 CONTINUE
  17780.       ITEMP = VALS(K,1)
  17781.       KMM = 0
  17782.       IF((ITEMP.EQ.K4MIN).OR.(ITEMP.EQ.K4MAX)) KMM = ITEMP
  17783.       IF(KMM.EQ.0) GO TO 1550
  17784. C
  17785. C  WE HAVE A MIN/MAX SPECIFICATION - CHECK SYNTAX
  17786. C
  17787.       IF((KOMTYP(NBOO).LT.2).OR.(KOMTYP(NBOO).GT.7)) GO TO 1550
  17788.       IF(ATTYPE.EQ.KZTEXT) GO TO 1550
  17789.       IF(ATTYPE.EQ.KZINT ) GO TO 1530
  17790.       IF(ATTYPE.EQ.KZREAL) GO TO 1530
  17791.       IF(ATTYPE.EQ.KZDOUB) GO TO 1530
  17792. C
  17793. C  ILLEGAL ATTRIBUTE FOR USE WITH MIN/MAX.
  17794. C
  17795.       RMSTAT = 44
  17796.       GO TO 9999
  17797.  1530 CONTINUE
  17798.       IF(ATTLEN.EQ.1) GO TO 1540
  17799.       IF((ATTLEN.EQ.2).AND.(ATTYPE.EQ.KZDOUB)) GO TO 1540
  17800. C
  17801. C  ILLEGAL USE OF MULTI-WORD ATTRIBUTE WITH MIN/MAX.
  17802. C
  17803.       RMSTAT = 44
  17804.       GO TO 9999
  17805.  1540 CONTINUE
  17806. C
  17807. C     SET NBOO AND LIMTU TO FOOL RMLOOK FOR MINMAX
  17808. C
  17809.       MNBOO = NBOO
  17810.       MLIMTU = LIMTU
  17811.       NBOO = 0
  17812.       LIMTU = ALL9S
  17813.       KOMPOS(MNBOO) = NEXPOS
  17814.       CALL MINMAX(WHRVAL(NEXPOS),KMM)
  17815.       IF(RMSTAT.NE.0) GO TO 9999
  17816.       NEXPOS = NEXPOS + ATTLEN
  17817.       KOMPOT(MNBOO) = NEXPOT
  17818.       WHRLEN(NEXPOT) = ATTLEN
  17819.       NEXPOT = NEXPOT + 1
  17820.       LIMTU = MLIMTU
  17821.       NBOO = MNBOO
  17822. C
  17823. C  RESET RELATION POINTERS
  17824. C
  17825.       I = LOCREL(NAME)
  17826.       IF(I.EQ.0) GO TO 1545
  17827.       RMSTAT = 20
  17828.       GO TO 9999
  17829.  1545 CONTINUE
  17830.       KOMLEN(NBOO) = 1
  17831.       IF(K.EQ.NUMBOO) GO TO 2100
  17832.       IF((NXTBOO(K).NE.K4AND).AND.(NXTBOO(K).NE.K4OR)) GO TO 8000
  17833.       NBOO = NBOO + 1
  17834.       BOO(NBOO) = NXTBOO(K)
  17835.       GO TO 2000
  17836.  1550 CONTINUE
  17837. C
  17838. C  VALUE COMPARISON. MAKE SURE THE VALUE LOOKS GOOD.
  17839. C
  17840.       IFVAR = .FALSE.
  17841.       CALL ITOH(NR,NW,KATTL(NBOO))
  17842.       IF((.NOT.IFTUP).AND.(NW.EQ.0)) IFVAR = .TRUE.
  17843.       IF(KATTY(NBOO).EQ.0) NW = 1
  17844.       ITYPE = ATTYPE
  17845.       IF(KATTY(NBOO).EQ.0) ITYPE = KZINT
  17846.       KOMPOS(NBOO) = NEXPOS
  17847.       KOMPOT(NBOO) = NEXPOT
  17848. C
  17849. C  TRANSFER VALUES FROM VALS TO WHRVAL
  17850. C
  17851.       II = 0
  17852.       LOOP = NUMVAL(K)
  17853.       IF(LOOP.EQ.1) GO TO 1551
  17854.       IF(KOMTYP(NBOO).EQ.2) GO TO 1551
  17855.       IF(KOMTYP(NBOO).EQ.3) GO TO 1551
  17856.       IF(KOMTYP(NBOO).EQ.9) GO TO 1551
  17857.       RMSTAT = 47
  17858.       GO TO 9999
  17859.  1551 CONTINUE
  17860.       DO 1560 KK=1,LOOP
  17861.       IF(.NOT.IFVAR) GO TO 1552
  17862. C
  17863. C  VARIABLE LENGTH TUPLES
  17864. C
  17865.       NW = 0
  17866.       II = II + 1
  17867.       IF(ITYPE.EQ.KZINT ) NW = VALS(K,II)
  17868.       IF(ITYPE.EQ.KZREAL) NW = VALS(K,II)
  17869.       IF(ITYPE.EQ.KZDOUB) NW = 2*VALS(K,II)
  17870.       IF(ITYPE.EQ.KZTEXT) NW = (VALS(K,II)-1)/CHPWD + 1
  17871.       IF(ITYPE.EQ.KZIVEC) NW = VALS(K,II)
  17872.       IF(ITYPE.EQ.KZRVEC) NW = VALS(K,II)
  17873.       IF(ITYPE.EQ.KZDVEC) NW = 2*VALS(K,II)
  17874.       IF(ITYPE.EQ.KZIMAT) NW = VALS(K,II)*VALS(K,II+1)
  17875.       IF(ITYPE.EQ.KZRMAT) NW = VALS(K,II)*VALS(K,II+1)
  17876.       IF(ITYPE.EQ.KZDMAT) NW = 2*VALS(K,II)*VALS(K,II+1)
  17877.       NR = 0
  17878.       IF(ITYPE.EQ.KZTEXT) NR = VALS(K,II)
  17879.       IF(ITYPE.EQ.KZIMAT) NR = VALS(K,II)
  17880.       IF(ITYPE.EQ.KZRMAT) NR = VALS(K,II)
  17881.       IF(ITYPE.EQ.KZDMAT) NR = VALS(K,II)
  17882.       II = II + 1
  17883. C
  17884. C  LOAD RTHE ARRAYS
  17885. C
  17886.  1552 CONTINUE
  17887.       DO 1554 I=1,NW
  17888.       II = II + 1
  17889.       WHRVAL(NEXPOS) = VALS(K,II)
  17890.       IF(.NOT.IFTUP) GO TO 1553
  17891.       IF(WHRVAL(NEXPOS).GT.MAXTU) MAXTU = WHRVAL(NEXPOS)
  17892.       IF((WHRVAL(NEXPOS).GT.0).AND.(WHRVAL(NEXPOS).LE.MAXCOL))
  17893.      X       GO TO 1553
  17894.       RMSTAT = 48
  17895.       GO TO 9999
  17896.  1553 CONTINUE
  17897.       NEXPOS = NEXPOS + 1
  17898.  1554 CONTINUE
  17899.       IF(KOMTYP(NBOO).NE.9) GO TO 1558
  17900. C
  17901. C  EQS - GET THE NUMBER OF CHARACTERS
  17902. C
  17903.       IK = II + 1
  17904.       DO 1556 I=1,NW
  17905.       IK = IK - 1
  17906.       IF(VALS(K,IK).EQ.IBLANK) GO TO 1556
  17907.       KPO = NSCAN(VALS(K,IK),CHPWD,-CHPWD,BLANK,1,1)
  17908.       NR = (NW-I)*CHPWD + KPO
  17909.       GO TO 1558
  17910.  1556 CONTINUE
  17911.  1558 CONTINUE
  17912.       CALL HTOI(NR,NW,WHRLEN(NEXPOT))
  17913.       NEXPOT = NEXPOT + 1
  17914.  1560 CONTINUE
  17915.       IF(K.EQ.NUMBOO) GO TO 2000
  17916.       KOMLEN(NBOO) = NUMVAL(K)
  17917.       IF((NXTBOO(K).NE.K4AND).AND.(NXTBOO(K).NE.K4OR)) GO TO 8000
  17918.       NBOO = NBOO + 1
  17919.       BOO(NBOO) = NXTBOO(K)
  17920.       GO TO 2000
  17921. C
  17922. C  ATTRIBUTE COMPARISON. CHECK FOR LEGAL ATTRIBUTE
  17923. C
  17924.  1600 CONTINUE
  17925. C
  17926. C  MESSY CODE SO THAT WE CAN MOVE 8 CHARACTERS ON ANY MACHINE
  17927. C
  17928.       IDUM(1) = VALS(K,1)
  17929.       IF(CHPWD.LT.8) IDUM(2) = VALS(K,2)
  17930.       ANAME = BLANK
  17931.       CALL STRMOV(IDUM(1),1,8,ANAME,1)
  17932.       I = LOCATT(ANAME,NAME)
  17933.       IF(I.NE.0) GO TO 1200
  17934.       CALL ATTGET(I)
  17935.       KOMPOS(NBOO) = ATTCOL
  17936.       IF((ATTLEN.EQ.KATTL(NBOO)).AND.(ATTYPE.EQ.KATTY(NBOO)))
  17937.      X     GO TO 1800
  17938.       RMSTAT = 46
  17939.       GO TO 9999
  17940.  1800 CONTINUE
  17941. C
  17942. C  LOOK FOR THE NEXT BOOLEAN JOIN.
  17943. C
  17944.       IF(K.EQ.NUMBOO) GO TO 2000
  17945.       IF((NXTBOO(K).NE.K4AND).AND.(NXTBOO(K).NE.K4OR)) GO TO 8000
  17946.       IF(.NOT.IFLIM) KOMLEN(NBOO) = 1
  17947. C
  17948. C  GET NEXT OPERATION
  17949. C
  17950.       NBOO = NBOO + 1
  17951.       BOO(NBOO) = NXTBOO(K)
  17952.  2000 CONTINUE
  17953. C
  17954. C  GET THE LENGTH OF THE LIST IN THE LAST CONDITION
  17955. C
  17956.       IF(IFLIM) GO TO 2100
  17957.       KOMLEN(NBOO) = NUMVAL(NUMBOO)
  17958.       IF(KOMTYP(NBOO).LE.1) KOMLEN(NBOO) = 1
  17959.       IF(KOMLEN(NBOO).LE.1) GO TO 2100
  17960. C
  17961. C  WE HAVE A LIST - VALID ONLY FOR EQ AND NE
  17962. C
  17963.       IF(KOMTYP(NBOO).EQ.2) GO TO 2005
  17964.       IF(KOMTYP(NBOO).EQ.3) GO TO 2005
  17965.       IF(KOMTYP(NBOO).EQ.9) GO TO 2005
  17966.       RMSTAT = 47
  17967.       GO TO 9999
  17968. C
  17969. C  ROW WHERE CLAUSE - CHECK TYPE AND GET MAXIMUM ROW NUMBER
  17970. C
  17971.  2005 CONTINUE
  17972.       IF(.NOT.IFTUP) GO TO 2100
  17973.       LOOP = KOMLEN(NBOO)
  17974.       DO 2010 I=2,LOOP
  17975.       MAXTUN = VALS(NUMBOO,I)
  17976.       IF(MAXTUN.GT.MAXTU) MAXTU = MAXTUN
  17977.  2010 CONTINUE
  17978. C
  17979. C  CHECK FOR KEY PROCESSING
  17980. C
  17981.  2100 CONTINUE
  17982.       BOO(1) = K4AND
  17983.       IF(NTUPC.NE.NBOO) MAXTU = 0
  17984.       IF(BOO(NBOO).NE.K4AND) GO TO 9998
  17985.       IF(KOMTYP(NBOO).NE.2) GO TO 9998
  17986.       IF(IFTUP) GO TO 9998
  17987.       IF(KOMLEN(NBOO).NE.1) GO TO 9998
  17988. C
  17989. C  USE KEY PROCESSING.
  17990. C
  17991.       KSTRT = ATTKEY
  17992.       IF(KSTRT.NE.0) NS = 2
  17993.       GO TO 9998
  17994. C
  17995. C  UNABLE TO PROCESS THE WHERE CLAUSE.
  17996. C
  17997.  8000 CONTINUE
  17998.       RMSTAT = 45
  17999.       GO TO 9999
  18000. C
  18001. C  EXIT.
  18002. C
  18003.  9998 CONTINUE
  18004.       IF(MAXTU.EQ.0) MAXTU = ALL9S
  18005.       CALL WHETOL
  18006.  9999 CONTINUE
  18007.       RETURN
  18008.       END
  18009.       SUBROUTINE RMZIP
  18010.       RETURN
  18011.       END
  18012.       SUBROUTINE RNAMEA(IATT)
  18013.       INCLUDE rin:TEXT.BLK
  18014. C
  18015. C     IATT....=2 IF COMMAND IS "RENAME ATTRIBUTE....."
  18016. C             =1 IF KEYWORD ATTRIBUTE IS OMITTED
  18017. C
  18018. C     THIS ROUTINE PROCESSES RENAME ATTRIBUTE COMMAND
  18019. C     STEP 1. CHECK SYNTAX
  18020. C     STEP 2. SEE IF NEWATT ALREADY EXISTS.
  18021. C             IF SO, CHECK THAT IT IS NOT IN SAME RELATION WITH
  18022. C             OLDATT AND THAT TYPE AND LENGTH AGREE WITH OLDATT.
  18023. C     STEP 3. LOOP ON ATTGET FOR ALL RELATIONS
  18024. C               CHECK PERMISSION.
  18025. C               RENAME
  18026. C               COUNT RENAMES
  18027. C     STEP 4. RENAME ATTRIBUTES IN RULES RELATION
  18028. C             ATTRIBUTE IS CHANGING NAMES IN ALL RELATIONS.
  18029. C             LOOP THRU CSCRTBL AND CHANGE.
  18030. C
  18031.       INCLUDE rin:CONST8.BLK
  18032.       INCLUDE rin:RMKEYW.BLK
  18033.       INCLUDE rin:CONST4.BLK
  18034.       INCLUDE rin:FILES.BLK
  18035.       INCLUDE rin:TUPLEA.BLK
  18036.       INCLUDE rin:BUFFER.BLK
  18037.       INCLUDE rin:MISC.BLK
  18038.       INCLUDE rin:DCLAR1.BLK
  18039.       INCLUDE rin:DCLAR6.BLK
  18040.       INCLUDE rin:WHCOM.BLK
  18041.       INCLUDE rin:RIMCOM.BLK
  18042.       INCLUDE rin:RIMPTR.BLK
  18043.       LOGICAL CHANGE
  18044.       LOGICAL NE,EQ,EQKEYW
  18045.       INTEGER STATUS
  18046.    10 CONTINUE
  18047. C
  18048. C     CHECK SYNTAX
  18049. C
  18050.       ITEMS = LXITEM(DUM)
  18051.       IF(.NOT.EQKEYW(IATT+2,KWTO,2)) GO TO 8100
  18052.       IF((ITEMS.GT.3+IATT).AND.(.NOT.EQKEYW(4+IATT,KWIN,2))) GO TO 8100
  18053.       IF((ITEMS.NE.3+IATT).AND.(ITEMS.NE.5+IATT)) GO TO 8100
  18054.       ANAME1 = BLANK
  18055.       ANAME2 = BLANK
  18056.       CALL LXSREC(1+IATT,1,8,ANAME1,1)
  18057.       CALL LXSREC(3+IATT,1,8,ANAME2,1)
  18058.       IF((LXLENC(3+IATT).GE.1).AND.(LXLENC(3+IATT).LE.8)) GO TO 20
  18059. C
  18060. C     WARNING - NEW ATTRIBUTE NAME IS LONGER THAN 8 CHARS.
  18061. C
  18062.       CALL WARN(7,KWATTR,K4E)
  18063.       GO TO 9999
  18064.    20 CONTINUE
  18065. C
  18066. C     SCAN FOR FROM OR IN
  18067. C
  18068.       RNAME1 = BLANK
  18069.       IFLAG = 0
  18070.       J = LFIND(1,ITEMS,KWIN,2)
  18071.       IF(J.EQ.0)J = LFIND(1,ITEMS,KWFROM,4)
  18072.       IF(J.EQ.0) GO TO 100
  18073. C
  18074. C     SPECIFIED RELATION
  18075. C
  18076.       IFLAG = 1
  18077.       CALL LXSREC(J+1,1,8,RNAME1,1)
  18078. C
  18079. C  CHECK THAT RELATION EXISTS
  18080. C
  18081.       I = LOCREL(RNAME1)
  18082.       IF(I.EQ.0) GO TO 100
  18083.       CALL WARN(1,RNAME1,BLANK)
  18084.       GO TO 9999
  18085.   100 CONTINUE
  18086. C
  18087. C     SEE IF ANAME1 EXISTS
  18088. C
  18089.       I = LOCATT(ANAME1,RNAME1)
  18090.       IF(I.NE.0) GO TO 8200
  18091. C
  18092. C     SEE IF ANAME2 ALREADY EXISTS
  18093. C
  18094.       I = LOCATT(ANAME2,BLANK )
  18095.       IF(I.NE.0) GO TO 200
  18096. C
  18097. C     EXISTS - CHECK TYPE AND LENGTH
  18098. C
  18099.       CALL ATTGET(STATUS)
  18100.       ILEN = ATTLEN
  18101.       ITYPE = ATTYPE
  18102.       I = LOCATT(ANAME1,RNAME1)
  18103.       CALL ATTGET(STATUS)
  18104.       IF(ILEN.NE.ATTLEN) GO TO 8300
  18105.       IF(ITYPE.NE.ATTYPE) GO TO 8300
  18106. C
  18107. C     NOW CHAECK THAT OLD AND NEW DON'T COHABITATE IN SAME RELATION
  18108. C
  18109.       NUM = 0
  18110.   120 CONTINUE
  18111.       NUM = NUM + 1
  18112.       I = LOCATT(ANAME1,RNAME1)
  18113.       DO 130 II=1,NUM
  18114.       CALL ATTGET(STATUS)
  18115.       IF(STATUS.NE.0) GO TO 200
  18116.   130 CONTINUE
  18117.       I = LOCATT(ANAME2,RELNAM)
  18118.       IF(I.NE.0) GO TO 120
  18119.     if(nout.eq.6)goto 3140
  18120.       WRITE (NOUT,140) ANAME2,RELNAM
  18121.   140 FORMAT(19H -ERROR- Attribute ,A8,
  18122.      X       28H Already Exists In Relation ,A8)
  18123.       GO TO 9999
  18124. 3140    continue
  18125.     write(c128wk,140)aname2,relnam
  18126.     call atxto
  18127.     goto 9999
  18128.   200 CONTINUE
  18129. C
  18130. C     RENAME ATTRIBUTE
  18131. C
  18132.       I = LOCATT(ANAME1,RNAME1)
  18133.       NUMT = 0
  18134.   210 CONTINUE
  18135.       CALL ATTGET(STATUS)
  18136.       IF(STATUS.NE.0) GO TO 300
  18137. C
  18138. C     CHECK FOR PERMISSION
  18139. C
  18140.       I = LOCREL(RELNAM)
  18141.       I = LOCPRM(RELNAM,2)
  18142.       IF(I.EQ.0) GO TO 220
  18143.       IF(IFLAG.EQ.1) GO TO 8400
  18144.       GO TO 210
  18145.   220 CONTINUE
  18146.       NUMT = NUMT + 1
  18147.       IF(NUMT.LE.10) NAMES(NUMT) = RELNAM
  18148.       ATTNAM = ANAME2
  18149.       CALL ATTPUT(STATUS)
  18150.       IF(IFLAG.NE.1) GO TO 210
  18151.   300 CONTINUE
  18152.     if(nout.eq.6)goto 3141
  18153.       WRITE (NOUT,305)ANAME1,NUMT
  18154.     goto 3142
  18155. 3141    continue
  18156.     write(c128wk,305)aname1,numt
  18157.     call atxto
  18158. 3142    continue
  18159.   305 FORMAT(11H Attribute ,A8,12H Renamed In ,I4,10H Relations)
  18160. C
  18161. C     NOW FOR THE NASTY NASTY RULES
  18162. C
  18163.       I = LOCREL(K8RDT  )
  18164.       IF(I.NE.0) GO TO 9999
  18165. C
  18166. C     LOOP THRU RMRULRRC AND CHANGE
  18167. C
  18168.       NS = 0
  18169.       NBOO = 0
  18170.       LIMTU = ALL9S
  18171.       NUMR = 0
  18172.   310 CONTINUE
  18173.       CALL RMLOOK(LOC,1,1,LENGTH)
  18174.       IF(RMSTAT.NE.0) GO TO 9997
  18175.       CHANGE = .FALSE.
  18176.       IF(NE(BUFFER(LOC+3),ANAME1)) GO TO 320
  18177.       IF((IFLAG.EQ.1).AND.(NE(BUFFER(LOC+5),RNAME1))) GO TO 320
  18178.       IF(NUMT.GT.10) GO TO 318
  18179.       DO 315 I=1,NUMT
  18180.       IF(EQ(NAMES(I),BUFFER(LOC+5))) GO TO 318
  18181.   315 CONTINUE
  18182.       GO TO 320
  18183.   318 CONTINUE
  18184.       CHANGE = .TRUE.
  18185.       CALL STRMOV(ANAME2,1,8,BUFFER(LOC+3),1)
  18186.       NUMR = NUMR + 1
  18187.   320 CONTINUE
  18188.       IF(NE(BUFFER(LOC+10),ANAME1)) GO TO 330
  18189.       IF((IFLAG.EQ.1).AND.(NE(BUFFER(LOC+12),RNAME1))) GO TO 330
  18190.       IF(NUMT.GT.10) GO TO 328
  18191.       DO 325 I=1,NUMT
  18192.       IF(EQ(NAMES(I),BUFFER(LOC+12))) GO TO 328
  18193.   325 CONTINUE
  18194.       GO TO 330
  18195.   328 CONTINUE
  18196.       CHANGE = .TRUE.
  18197.       CALL STRMOV(ANAME2,1,8,BUFFER(LOC+10),1)
  18198.       NUMR = NUMR + 1
  18199.   330 CONTINUE
  18200.       IF(CHANGE)CALL PUTDAT(1,CID,BUFFER(LOC),LENGTH)
  18201.       GO TO 310
  18202.  8100 CONTINUE
  18203. C
  18204. C     BAD SYNTAX
  18205. C
  18206.       CALL WARN(4,0,0)
  18207.       GO TO 9999
  18208.  8200 CONTINUE
  18209. C
  18210. C     ANAME1 NOT THERE
  18211. C
  18212.     if(nout.eq.6)goto 3143
  18213.       WRITE (NOUT,9200)ANAME1
  18214.  9200 FORMAT(19H -ERROR- Attribute ,A8,
  18215.      X       29H Is Not An Existing Attribute )
  18216.       GO TO 9999
  18217. 3143    continue
  18218.     write(c128wk,9200)aname1
  18219.     call atxto
  18220.     goto 9999
  18221.  8300 CONTINUE
  18222. C
  18223. C     TYPE/LENGTH DIFFERS
  18224. C
  18225.     if(nout.eq.6)goto 3144
  18226.       WRITE (NOUT,9300)ANAME2,ANAME1
  18227.  9300 FORMAT(19H -ERROR- Attribute ,A8,
  18228.      X       35H Exists - Type/Length Differs From ,A8)
  18229.       GO TO 9999
  18230. 3144    continue
  18231.     write(c128wk,9300)aname2,aname1
  18232.     call atxto
  18233.     goto 9999
  18234.  8400 CONTINUE
  18235.     if(nout.eq.6)goto 3145
  18236.       WRITE (NOUT,9400)
  18237.  9400 FORMAT(39H -ERROR- Unauthorized Access For RENAME )
  18238.       GO TO 9999
  18239. 3145    continue
  18240.     write(c128wk,9400)
  18241.     call atxto
  18242.     goto 9999
  18243.  9997 CONTINUE
  18244.     if(nout.eq.6)goto 3146
  18245.       WRITE(NOUT,9998) ANAME1,NUMR
  18246.  9998 FORMAT(11H Attribute ,A8,12H Renamed In ,I3,
  18247.      X       20H Places In The Rules)
  18248.       GO TO 9999
  18249. 3146    continue
  18250.     write(c128wk,9998)aname1,numr
  18251.     call atxto
  18252. c    goto 9999
  18253. C
  18254. C     ALL DONE
  18255. C
  18256.  9999 CONTINUE
  18257.       RETURN
  18258.       END
  18259.       SUBROUTINE RNAMER
  18260.       INCLUDE rin:TEXT.BLK
  18261. C
  18262. C     SUBROUTINE TO RENAME A RELATION INCLUDING SUCH
  18263. C     NASTIES AS CHANGING THE RULES.
  18264. C
  18265.       INCLUDE rin:RMATTS.BLK
  18266.       INCLUDE rin:RMKEYW.BLK
  18267.       INCLUDE rin:CONST8.BLK
  18268.       INCLUDE rin:RIMPTR.BLK
  18269.       INCLUDE rin:RIMCOM.BLK
  18270.       INCLUDE rin:TUPLEA.BLK
  18271.       INCLUDE rin:TUPLER.BLK
  18272.       INCLUDE rin:ATTBLE.BLK
  18273.       INCLUDE rin:START.BLK
  18274.       INCLUDE rin:BUFFER.BLK
  18275.       INCLUDE rin:FILES.BLK
  18276.       INCLUDE rin:MISC.BLK
  18277.       INCLUDE rin:DCLAR1.BLK
  18278.       INCLUDE rin:DCLAR6.BLK
  18279.       INCLUDE rin:WHCOM.BLK
  18280.       LOGICAL EQKEYW
  18281.       LOGICAL NE,EQ
  18282.       ITEMS = LXITEM(IDUM)
  18283.       IF(ITEMS.NE.5) GO TO 4000
  18284.       IF(.NOT.EQKEYW(4,KWTO,2)) GO TO 4000
  18285.       IF((LXLENC(5).GE.1).AND.(LXLENC(5).LE.8)) GO TO 2000
  18286.       CALL WARN(7,KWRELA,BLANK)
  18287.       GO TO 9999
  18288.  2000 CONTINUE
  18289.       NAMNEW = BLANK
  18290.       CALL LXSREC(5,1,8,NAMNEW,1)
  18291.       I = LOCREL(NAMNEW)
  18292.       IF(I.NE.0) GO TO 4150
  18293. C
  18294. C  NEW NAME IS A DUPLICATE.
  18295. C
  18296.     if(nout.eq.6)goto 3140
  18297.       WRITE(NOUT,9008)
  18298.  9008 FORMAT(44H -ERROR- Duplicate Relation Name Encountered)
  18299.       GO TO 9999
  18300. 3140    continue
  18301.     write(c128wk,9008)
  18302.     call atxto
  18303.     goto 9999
  18304.  4150 CONTINUE
  18305.       RNAME = BLANK
  18306.       CALL LXSREC(3,1,8,RNAME,1)
  18307.       I = LOCREL(RNAME)
  18308.       IF(I.EQ.0) GO TO 4200
  18309.       CALL WARN(1,RNAME,0)
  18310.       GO TO 9999
  18311.  4200 CONTINUE
  18312.       I = LOCPRM(NAME,2)
  18313.       IF(I.EQ.0) GO TO 4250
  18314. C
  18315. C     FAILS MODIFY PERMISSION
  18316. C
  18317.     if(nout.eq.6)goto 3141
  18318.       WRITE (NOUT,5)
  18319.     5 FORMAT(39H -ERROR- Unauthorized Access For RENAME )
  18320.       GO TO 9999
  18321. 3141    write(c128wk,5)
  18322.     call atxto
  18323.     goto 9999
  18324.  4250 CONTINUE
  18325. C
  18326. C  CHANGE EVERYTHING NEEDED FOR THE RELATION.
  18327. C
  18328.       CALL RELGET(ISTAT)
  18329.       NAMNEW = BLANK
  18330.       CALL LXSREC(5,1,8,NAMNEW,1)
  18331.       NAME = NAMNEW
  18332.       CALL RELPUT
  18333.       I = LOCATT(BLANK,RNAME)
  18334.       IF(I.NE.0) GO TO 9999
  18335.  4300 CONTINUE
  18336.       CALL ATTGET(ISTAT)
  18337.       IF(ISTAT.NE.0) GO TO 4400
  18338.       RELNAM = NAMNEW
  18339.       CALL ATTPUT(ISTAT)
  18340.       GO TO 4300
  18341.  4400 CONTINUE
  18342.     if(nout.eq.6)goto 3142
  18343.       WRITE(NOUT,9009) RNAME,NAMNEW
  18344.  9009 FORMAT(10H RELATION ,A8,12H RENAMED TO ,A8)
  18345. C
  18346.     goto 3143
  18347. 3142    write(c128wk,9009)rname,namnew
  18348.     call atxto
  18349. 3143    continue
  18350. C     CHECK FOR RULES AND RENAME THEM
  18351. C
  18352.       I = LOCREL(K8RRC  )
  18353.       IF(I.NE.0) GO TO 9999
  18354.       NS = 0
  18355.       NBOO = 0
  18356.       LIMTU = ALL9S
  18357. C
  18358. C     LOOP THRU RMRULRRC AND CHANGE
  18359. C
  18360.  5000 CONTINUE
  18361.       CALL RMLOOK(LOC,1,1,LENGTH)
  18362.       IF(RMSTAT.NE.0) GO TO 5500
  18363.       IF(NE(BUFFER(LOC),RNAME)) GO TO 5000
  18364.       CALL STRMOV(NAMNEW,1,8,BUFFER(LOC),1)
  18365.       CALL PUTDAT(1,CID,BUFFER(LOC),LENGTH)
  18366.       GO TO 5000
  18367.  5500 CONTINUE
  18368. C
  18369. C     LOOP THRU RMRULRDT AND CHANGE
  18370. C
  18371.       I = LOCREL(K8RDT  )
  18372.       IF(I.NE.0) GO TO 9999
  18373.       NS = 0
  18374.       NBOO = 0
  18375.       LIMTU = ALL9S
  18376.  5600 CONTINUE
  18377.       CALL RMLOOK(LOC,1,1,LENGTH)
  18378.       IF(RMSTAT.NE.0) GO TO 9999
  18379.       IFLAG = 0
  18380.       IF(NE(BUFFER(LOC+5),RNAME)) GO TO 5700
  18381.       IFLAG = 1
  18382.       CALL STRMOV(NAMNEW,1,8,BUFFER(LOC+5),1)
  18383.  5700 CONTINUE
  18384.       IF(NE(BUFFER(LOC+12),RNAME)) GO TO 5800
  18385.       IFLAG = 1
  18386.       CALL STRMOV(NAMNEW,1,8,BUFFER(LOC+12),1)
  18387.  5800 CONTINUE
  18388.       IF(IFLAG.EQ.0) GO TO 5600
  18389.       CALL PUTDAT(1,CID,BUFFER(LOC),LENGTH)
  18390.       GO TO 5600
  18391. C
  18392. C     SYNTAX ERRORS
  18393. C
  18394.  4000 CONTINUE
  18395.       CALL WARN(4,0,0)
  18396.       GO TO 9999
  18397.  9999 CONTINUE
  18398.       RETURN
  18399.       END
  18400.       REAL FUNCTION ROUN(REAL,NUMC,EF)
  18401.       INCLUDE rin:TEXT.BLK
  18402. C
  18403. C     RETURN A ROUNDED VERSION OF THE REAL NUMBER
  18404. C     TO FIT IN NUMC CHARACTERS.  IF REAL IS NEGATIVE
  18405. C     REDUCE NUMC BY ONE.
  18406. C
  18407.       LOGICAL EF
  18408.       NUM = NUMC
  18409.       IF(REAL.LT.0.)NUM = NUM - 1
  18410.       ROUN = REAL
  18411.       IF(REAL.EQ.0.) RETURN
  18412.       IE = IEXP(REAL)
  18413.       IF((.NOT.EF).AND.(IE.LT.0)) IE = 0
  18414.       V = .5
  18415.       IF(REAL.LT.0.) V = -.5
  18416.       ROUN = REAL + V*(10.**(IE-NUM))
  18417.       RETURN
  18418.       END
  18419.       SUBROUTINE RTOC(STRING,CHAR1,NUM,VEAL)
  18420.       INCLUDE rin:TEXT.BLK
  18421. C
  18422. C     THIS ROUTINE TRIES TO DETERMINE THE BEST F FORMAT FOR
  18423. C     A REAL NUMBER AND CALL RTOF TO CHARACTERIZE IT.
  18424. C
  18425.       INTEGER STRING(*)
  18426.       LOGICAL EF
  18427.       EF = .FALSE.
  18428.       REAL = ROUN(VEAL,NUM-1,EF)
  18429.       NUM1 = NUM
  18430.       NUM2 = NUM1 - 2
  18431.       IF(REAL.EQ.0.) GO TO 10
  18432.       NP = IEXP(REAL)
  18433.       N = NUM - 1
  18434.       IF(REAL.LT.0.) N = N - 1
  18435.       NUM2 = N - NP
  18436.       IF(NP.GE.0) GO TO 10
  18437.       NUM2 = N
  18438.       IF(IABS(NP).GT.NUM-2) NUM2 = 0
  18439.    10 CONTINUE
  18440.       CALL RTOF(STRING,CHAR1,NUM1,NUM2,VEAL)
  18441.       RETURN
  18442.       END
  18443.       SUBROUTINE RTOF(STRING,CHAR1,NUM1,NUM2,VEAL)
  18444.       INCLUDE rin:TEXT.BLK
  18445. C
  18446. C     THIS ROUTINE CONVERTS A REAL NUMBER TO CHARACTERS AND
  18447. C     PUTS THE RESULT IN STRING.  FIRST IT TRYS TO FIT THE
  18448. C     NUMBER INTO FX.Y FORMAT WHERE X IS NUM1 AND Y IS NUM2.
  18449. C     IF THE NUMBER WONT FIT (I.E. NO SIGNIFICANT DIGITS WILL
  18450. C     MAKE IT), IT TRYS TO MAKE AN E FORMAT IN THE SAME SPACE.
  18451. C     IF THAT FAILS THE FIELD IS FILLED WITH ASTERISKS.
  18452. C
  18453. C     STRING....REPOSITORY FOR CHARACTERS
  18454. C     CHAR1.....STARTING POINT IN STRING
  18455. C     NUM1......FIELD WIDTH
  18456. C     NUM2......SPACE AFTER DECIMAL POINT
  18457. C     VEAL......A REAL NUMBER
  18458. C
  18459.       INCLUDE rin:CONST4.BLK
  18460.       INCLUDE rin:MISC.BLK
  18461.       INTEGER STRING(*),CHAR1,ZERO
  18462.       LOGICAL EF
  18463.       EF = .FALSE.
  18464.       REAL = ROUN(VEAL,NUM1-1,EF)
  18465.       IERR = 0
  18466.       R = ABS(REAL)
  18467.       IN1 = INT(REAL)
  18468.       POINT = R - FLOAT(INT(R))
  18469.       NUM = NUM1 - NUM2 - 1
  18470.       IF(REAL.EQ.0.) GO TO 20
  18471.       IF(NUM.LT.0) GO TO 1000
  18472.       IF(NUM2.LT.0) GO TO 1000
  18473.       IF(NUM2.GT.NUM1) GO TO 1000
  18474.       IF(REAL.LT.0.) NUM = NUM - 1
  18475.       NUMM = -((NUM2+1)/2)
  18476.       IF(R.GE.10.**NUM ) GO TO 1000
  18477.       IF(R.LT.10.**NUMM) GO TO 1000
  18478.       IF(REAL.LT.0.) NUM = NUM + 1
  18479. C
  18480. C     FITS IN F FORMAT
  18481. C
  18482.    20 CONTINUE
  18483.       IF(NUM.GT.0) CALL ITOC(STRING,CHAR1,NUM,IN1,IERR)
  18484.       IF((NUM.EQ.1).AND.(REAL.LT.0.))CALL PUTT(STRING,CHAR1,K4MNUS)
  18485.       IF(IERR.NE.0) GO TO 1000
  18486.       CALL PUTT(STRING,CHAR1+NUM,K4DOT)
  18487.       IF(NUM2.EQ.0) GO TO 200
  18488.       POINT = POINT * 10.**NUM2
  18489.       IN1 = INT(POINT)
  18490.       CALL ITOC(STRING,CHAR1+NUM+1,NUM2,IN1,IERR)
  18491.       IF(IERR.NE.0) GO TO 1000
  18492. C
  18493. C     MAKE BLANKS AFTER THE DECIMAL POINT INTO ZEROS
  18494. C
  18495.       IL = CHAR1 + NUM + 1
  18496.       MAX = CHAR1 + NUM1 - 1
  18497.    50 CONTINUE
  18498.       IF(IL.GT.MAX) GO TO 200
  18499.       CALL GETT(STRING,IL,IC)
  18500.       IF(IC.NE.IBLANK) GO TO 200
  18501.       CALL PUTT(STRING,IL,K40)
  18502.       IL = IL + 1
  18503.       GO TO 50
  18504.   200 CONTINUE
  18505. C
  18506. C     CHANGE TRAILING ZEROS TO BLANKS
  18507. C
  18508.       NUM = CHAR1 + NUM1
  18509.       DO 250 I=1,NUM1
  18510.       NUM = NUM - 1
  18511.       CALL GETT(STRING,NUM,IC)
  18512.       IF(IC.NE.K40) GO TO 9999
  18513.       CALL PUTT(STRING,NUM,IBLANK)
  18514.   250 CONTINUE
  18515.       GO TO 9999
  18516.  1000 CONTINUE
  18517.       N = 4
  18518.       IF(ABS(REAL).LE.1.E+10) N = 3
  18519.       EF = .TRUE.
  18520.       REAL = ROUN(VEAL,NUM1-N,EF)
  18521. C
  18522. C      E - FORMAT
  18523. C
  18524.       MIN = 5
  18525.       IF(REAL.LT.0.) MIN = MIN + 1
  18526.       IF(NUM1.LT.MIN) GO TO 2000
  18527.       NUM = NUM1
  18528.       IC = CHAR1
  18529.       IF(REAL.GE.0) GO TO 1020
  18530.       CALL PUTT(STRING,IC,K4MNUS)
  18531.       IC = IC + 1
  18532.       NUM = NUM - 1
  18533.  1020 CONTINUE
  18534.       CALL PUTT(STRING,IC,K4DOT)
  18535.       IC = IC + 1
  18536.       NUM = NUM - 1
  18537. C
  18538. C     FIND THE INTEGER AND THE EXPONENT
  18539. C
  18540.       IE = IEXP(REAL)
  18541.       RR = ABS(REAL)/(10.**IE)
  18542.       IE = IE - 1
  18543.  1200 CONTINUE
  18544.       NUME = 1
  18545.       IF(IABS(IE).GE.10) NUME = 2
  18546.       IF(IABS(IE).GE.100) NUME = 3
  18547.       NUMI = NUM - NUME - 1
  18548.       IN1 = INT(RR*(10.**NUMI))
  18549.       CALL ITOC(STRING,IC,NUMI,IN1,IERR)
  18550.       IF(IERR.NE.0) GO TO 2000
  18551.       IC = IC + NUMI
  18552.       CALL PUTT(STRING,IC,K4PLUS)
  18553.       IF(IE.LT.0)CALL PUTT(STRING,IC,K4MNUS)
  18554.       IC = IC + 1
  18555.       CALL ITOC(STRING,IC,NUME,IABS(IE),IERR)
  18556.       IF(IERR.NE.0) GO TO 2000
  18557. C
  18558. C     SWITCH THE FIRST TWO CHARACTERS
  18559. C     I.E. X.XXX+YY RATHER THAN .XXXX+ZZ
  18560. C
  18561.       NUM = CHAR1
  18562.       IF(REAL.LT.0.) NUM = NUM + 1
  18563.       CALL GETT(STRING,NUM,IC1)
  18564.       CALL GETT(STRING,NUM+1,IC2)
  18565.       CALL PUTT(STRING,NUM,IC2)
  18566.       CALL PUTT(STRING,NUM+1,IC1)
  18567.       GO TO 9999
  18568.  2000 CONTINUE
  18569. C
  18570. C     STAR FILL
  18571. C
  18572.       CALL FILCH(STRING,CHAR1,NUM1,K4STAR)
  18573.  9999 CONTINUE
  18574.       RETURN
  18575.       END
  18576.       SUBROUTINE RULDEL(RNAME,NUMRUL)
  18577.       INCLUDE rin:TEXT.BLK
  18578. C
  18579. C  PURPOSE: THIS ROUTINE PROCESSES A DELETE RULE COMMAND
  18580. C
  18581. C  PARAMETERS
  18582. C         RNAME---RULE RELATION - RIMRRC OR RIMRDT
  18583. C         NUMREL--RULE NUMBER TO DELETE
  18584.       INCLUDE rin:CONST4.BLK
  18585.       INCLUDE rin:CONST8.BLK
  18586.       INCLUDE rin:TUPLER.BLK
  18587.       INCLUDE rin:TUPLEA.BLK
  18588.       INCLUDE rin:RIMCOM.BLK
  18589.       INCLUDE rin:RIMPTR.BLK
  18590.       INCLUDE rin:FILES.BLK
  18591.       INCLUDE rin:WHCOM.BLK
  18592.       INCLUDE rin:MISC.BLK
  18593.       INCLUDE rin:DCLAR1.BLK
  18594.       LOGICAL EQ
  18595. C
  18596.       NDP = 0
  18597.       ND = 0
  18598. C
  18599. C  CHECK IF A RULE NUMBER WAS ENTERED
  18600. C
  18601.       IF(NUMRUL.GT.0) GO TO 40
  18602.       CALL WARN(4,0,0)
  18603.       RMSTAT = 110
  18604.       GO TO 9999
  18605.    40 CONTINUE
  18606. C
  18607. C  SET UP THE RELATION DATA
  18608. C
  18609.       I = LOCREL(RNAME)
  18610.       IF(I.EQ.0) GO TO 100
  18611.    50 Continue
  18612.     if(nout.eq.6)goto 3140
  18613.     WRITE(NOUT,9000)
  18614.  9000 FORMAT(29H -WARNING- Rules Do Not Exist  )
  18615.       RMSTAT = 110
  18616.       GO TO 9999
  18617. 3140    continue
  18618.     write(c128wk,9000)
  18619.     call atxto
  18620.     rmstat=110
  18621.     goto 9999
  18622. C
  18623. C  SET UP THE WHERE CLAUSE.
  18624. C
  18625.   100 CONTINUE
  18626.       NBOO = 0
  18627.       I = LOCATT(K8NUM,RNAME)
  18628.       IF(I.NE.0) GO TO 50
  18629.       CALL ATTGET(I)
  18630.       IF(I.NE.0) GO TO 50
  18631.       NBOO = 1
  18632.       BOO(1) = K4AND
  18633.       KATTP(1) = ATTCOL
  18634.       KATTL(1) = ATTLEN
  18635.       KATTY(1) = ATTYPE
  18636.       KOMTYP(1) = 2
  18637.       KOMPOS(1) = 1
  18638.       KOMLEN(1) = 1
  18639.       KOMPOT(1) = 1
  18640.       KSTRT = 0
  18641.       MAXTU = ALL9S
  18642.       LIMTU = ALL9S
  18643.       WHRVAL(1) = NUMRUL
  18644.       WHRLEN(1) = 1
  18645.       NS = 0
  18646. C
  18647. C  SEQUENCE THROUGH THE DATA DELETING TUPLES.
  18648. C
  18649.       IF(NTUPLE.LE.0) GO TO 9999
  18650.       IID = CID
  18651.   200 CONTINUE
  18652.       CALL RMLOOK(MAT,1,1,LENGTH)
  18653.       IF(RMSTAT.NE.0) GO TO 700
  18654. C
  18655. C  DELINK THIS TUPLE.
  18656. C
  18657.       CALL DELDAT(1,CID)
  18658.       IF(CID.EQ.IID) IID = NID
  18659.       ND = ND + 1
  18660.       NDP = 1
  18661.       GO TO 200
  18662. C
  18663. C  CHANGE THE STARTING ID IF NEEDED.
  18664. C
  18665.   700 CONTINUE
  18666.       CALL RELGET(ISTAT)
  18667.       RSTART = IID
  18668.       NTUPLE = NTUPLE - ND
  18669.       CALL RELPUT
  18670.       RMSTAT = 0
  18671.       IF(ND.NE.0) GO TO 9999
  18672.     if(nout.eq.6)goto 3142
  18673.       WRITE(NOUT,8001) NUMRUL
  18674.     goto 3143
  18675. 3142    write(c128wk,8001)numrul
  18676.     call atxto
  18677. 3143   continue
  18678.  8001 FORMAT(15H -WARNING- Rule,I4,15H Does Not Exist)
  18679.       RMSTAT = 110
  18680.  9999 CONTINUE
  18681.     if(nout.eq.6)goto 3144
  18682.       IF(EQ(K8RDT,RNAME)) WRITE(NOUT,9001) NDP
  18683.  9001 FORMAT(2X,I6,14H RULES DELETED )
  18684.     return
  18685. 3144    continue
  18686.     if(.not.EQ(k8rdt,rname))return
  18687.     write(c128wk,9001)ndp
  18688.     call atxto
  18689. c
  18690. C
  18691. C  DONE.
  18692. C
  18693.       RETURN
  18694.       END
  18695.       SUBROUTINE RULES
  18696.       INCLUDE rin:TEXT.BLK
  18697. C
  18698. C  THE PURPOSE OF THIS ROUTINE IS TO INVOKE A ROUTINE TO
  18699. C  PRINT OUT ALL RULES PERTAINING TO A RIM SCHEMA IF SUCH
  18700. C  RULES EXIST.
  18701. C
  18702.       INCLUDE rin:CONST8.BLK
  18703.       INCLUDE rin:FILES.BLK
  18704.       INCLUDE rin:WHCOM.BLK
  18705.       INCLUDE rin:FLAGS.BLK
  18706.       INCLUDE rin:RIMCOM.BLK
  18707.       INCLUDE rin:MISC.BLK
  18708.       LOGICAL EQ
  18709.       INTEGER RRC(3)
  18710.       INTEGER OLDNUM
  18711.       INTEGER RULENO
  18712. C
  18713.       IF(EQ(USERID,OWNER)) GO TO 100
  18714.     if(nout.eq.6)goto 3140
  18715.       WRITE(NOUT,9000)
  18716.  9000 FORMAT(20H -ERROR- YOU are NOT,
  18717.      X       33H authorized to look at the rules )
  18718.       GO TO 999
  18719. 3140    write(c128wk,9000)
  18720.     call atxto
  18721.     goto 999
  18722.   100 CONTINUE
  18723. C
  18724. C  LOOK FOR THE RULE RELATION CORRESPONDENCE TABLE.
  18725. C
  18726.       I = LOCREL(K8RRC)
  18727.       IF(I.EQ.0) GO TO 200
  18728.     if(nout.eq.6)goto 3141
  18729.       WRITE(NOUT,9001)
  18730.  9001 FORMAT(45H -WARNING- No Rules Defined For This Database )
  18731.       GO TO 999
  18732. 3141    write(C128wk,9001)
  18733.     call atxto
  18734.     goto 999
  18735. C
  18736. C  CYCLE THROUGH THE RULES.
  18737. C
  18738.   200 CONTINUE
  18739.       OLDNUM = 0
  18740.       NBOO = 0
  18741.       LIMTU = ALL9S
  18742.   300 CONTINUE
  18743.       CALL RMLOOK(RRC,2,0,LEN)
  18744.       IF(RMSTAT.NE.0) GO TO 999
  18745.       NUMRUL = RRC(3)
  18746.       IF(NUMRUL.EQ.OLDNUM) GO TO 300
  18747. C
  18748. C  CALL PRULE TO DUMP OUT THE RULES.
  18749. C
  18750.       CALL PRULE(NUMRUL)
  18751.       OLDNUM = NUMRUL
  18752.       GO TO 300
  18753. C
  18754. C  DONE.
  18755. C
  18756.   999 CONTINUE
  18757.       RETURN
  18758.       END
  18759.       FUNCTION RXREC(I)
  18760.       INCLUDE rin:TEXT.BLK
  18761. C
  18762. C     THIS FUNCTION RETURNS THE REAL VALUE OF A REAL ITEM.
  18763. C
  18764.       INCLUDE rin:LXCARD.BLK
  18765.       INCLUDE rin:LXCON.BLK
  18766.       RXREC = 0.
  18767.       IF(I.LT.1) RETURN
  18768.       IF(I.GT.NEWN) RETURN
  18769.       IF(TYPE(I).NE.REAL) RETURN
  18770.       RXREC = RVAL(I)
  18771.       RETURN
  18772.       END
  18773.       SUBROUTINE SELECT
  18774.       INCLUDE rin:TEXT.BLK
  18775. C
  18776. C     THIS ROUTINE HANDLES THE SELECT COMMAND.
  18777. C
  18778.       INCLUDE rin:RMATTS.BLK
  18779.       INCLUDE rin:CONST4.BLK
  18780.       INCLUDE rin:PROM.BLK
  18781.       INCLUDE rin:BUFFER.BLK
  18782.       INCLUDE rin:BLNKFL.BLK
  18783.       INCLUDE rin:TUPLER.BLK
  18784.       INCLUDE rin:FILES.BLK
  18785.       INCLUDE rin:MISC.BLK
  18786.       INCLUDE rin:RIMCOM.BLK
  18787.       INCLUDE rin:RIMPTR.BLK
  18788.       INCLUDE rin:SELCOM.BLK
  18789.       LOGICAL DONE,ADONE
  18790.       LOGICAL ITALLY
  18791. C
  18792. C     SET LPP AND MCPL
  18793. C
  18794.       LPP = 10000000
  18795.       IF(.NOT.CONNO) LPP = 56
  18796.       MCPL = 78
  18797.       IF(.NOT.CONNO)MCPL = 132
  18798.       IF(ULPP.NE.0) LPP = ULPP
  18799.       IF(UMCPL.NE.0) MCPL = UMCPL
  18800. C
  18801. C     CALL SELPAR TO SET SELCOM BLOCK
  18802. C
  18803.       ITALLY = .FALSE.
  18804.       CALL SELPAR(ITALLY)
  18805.       IF(NUMATT.LE.0) GO TO 900
  18806.       NLINE = 3
  18807.       if(noutr.ne.6)WRITE (NOUTR,30)
  18808.       CALL SPOUT(TITLE,MCPL)
  18809.       CALL SPOUT(MINUS,MCPL)
  18810.    30 FORMAT(1H )
  18811. C
  18812. C  OPEN THE SORT FILE IF WE HAVE "SORTED BY ....... "
  18813. C
  18814.       LENGTH = NCOL
  18815.       IF(NS.EQ.1) CALL GTSORT(IP,1,-1,LENGTH)
  18816. C
  18817. C     LOOP ON RECORDS
  18818. C
  18819.    50 CONTINUE
  18820.       IF(NS.EQ.1) CALL GTSORT(IP,1,1,LENGTH)
  18821.       IF(NS.NE.1) CALL RMLOOK(IP,1,1,LENGTH)
  18822.       IF(RMSTAT.NE.0) GO TO 9999
  18823.       DO 55 II=1,NUMATT
  18824.       CURPOS(II) = 1
  18825.    55 CONTINUE
  18826. C
  18827. C     SET UP VARIABLE LENGTH ATTRIBUTES
  18828. C
  18829.       DO 60 I=1,NUMATT
  18830.       IF(.NOT.VAR(I)) GO TO 60
  18831.       JP = IP + FP(I) - 1
  18832.       JP = BUFFER(JP) + IP - 1
  18833.       LEN(I) = BUFFER(JP)
  18834.       IF(ATYPE(I).EQ.KZTEXT) LEN(I) = BUFFER(JP+1)
  18835.       IF(ATYPE(I).EQ.KZDOUB) LEN(I) = LEN(I)/2
  18836.       IF(ATYPE(I).EQ.KZDVEC) LEN(I) = LEN(I)/2
  18837.       IF(ATYPE(I).EQ.KZDMAT) LEN(I) = LEN(I)/2
  18838.       ROWD(I) = BUFFER(JP+1)
  18839.       IF(ATYPE(I).EQ.KZIMAT) COLD(I) = LEN(I)/ROWD(I)
  18840.       IF(ATYPE(I).EQ.KZRMAT) COLD(I) = LEN(I)/ROWD(I)
  18841.       IF(ATYPE(I).EQ.KZDMAT) COLD(I) = LEN(I)/ROWD(I)
  18842.    60 CONTINUE
  18843. C
  18844. C     LOOP ON LINES
  18845. C
  18846.       DONE = .FALSE.
  18847.    70 CONTINUE
  18848.       IF(DONE) GO TO 50
  18849.       DONE = .TRUE.
  18850.       CALL FILCH(LINE,1,MCPL,BLANK)
  18851. C
  18852. C     LOOP ON ATTRIBUTES
  18853. C
  18854.       DO 100 I=1,NUMATT
  18855.       JP = IP + FP(I) - 1
  18856.       IF(VAR(I)) JP = BUFFER(JP) + IP + 1
  18857.       CALL SELOUT(BUFFER(JP),I,ADONE)
  18858.       DONE = DONE.AND.ADONE
  18859.   100 CONTINUE
  18860.       IF(NLINE.LT.LPP) GO TO 120
  18861.       IF(.NOT.(CONNI.AND.CONNO)) GO TO 108
  18862.     if(noutr.eq.6)goto 3143
  18863.       WRITE(NOUTR,104)
  18864.   104 FORMAT(28H More Text Follows - Enter * ,
  18865.      X         28H To Continue Or QUIT To Stop )
  18866.     goto 3144
  18867. 3143    continue
  18868.     write(C128wk,104)
  18869.     call atxto
  18870. 3144    continue
  18871.       PROM = IBLANK
  18872.       CALL LXLREC(IDUM,0,IDUM)
  18873.       PROM = K4RP
  18874.       IF(LXWREC(1,1).EQ.K4QUIT) GO TO 9999
  18875.   108 CONTINUE
  18876.       NLINE = 3
  18877.       IF(.NOT.CONNO.and.(noutr.ne.6)) WRITE (NOUTR,110)
  18878.   110 FORMAT(1H1)
  18879.       if(noutr.ne.6)WRITE (NOUTR,30)
  18880.       CALL SPOUT(TITLE,MCPL)
  18881.       CALL SPOUT(MINUS,MCPL)
  18882.   120 CONTINUE
  18883.       CALL SPOUT(LINE,MCPL)
  18884.       IF(BLNKFL) NLINE = NLINE + 1
  18885.       GO TO 70
  18886.   900 CONTINUE
  18887. C
  18888. C     NO VALID ATTRIBUTES
  18889. C
  18890. C     WRITE (NOUT,910)
  18891. C 910 FORMAT(40H -WARNING- No Valid Attributes Specified )
  18892.  9999 CONTINUE
  18893.       RETURN
  18894.       END
  18895.       SUBROUTINE SELOUT(MAT,IATT,ADONE)
  18896.       INCLUDE rin:TEXT.BLK
  18897. C
  18898. C     THIS ROUTINE STUFFS THE CHARACTER REPRESENTATION OF AN
  18899. C     ATTRIBUTE VALUE INTO LINE FOR LATER PRINTING.
  18900. C
  18901. C     MAT.......DATA FOR THIS ATTRIBUTE
  18902. C     IATT......ATTRIBUTE NUMBER IN SELCOM
  18903. C     ADONE.....SET TO .TRUE. IF NO PARAGRAPHING LEFT
  18904. C
  18905.       INCLUDE rin:RMATTS.BLK
  18906.       INCLUDE rin:SELCOM.BLK
  18907.       INCLUDE rin:MISC.BLK
  18908.       DIMENSION MAT(*)
  18909.       LOGICAL ADONE
  18910.       ADONE = .TRUE.
  18911.       IPOS = 1
  18912.       IF((CURPOS(IATT).NE.1).AND.(PGRAPH(IATT).EQ.0)) GO TO 9999
  18913.       IF(CURPOS(IATT).GT.LEN(IATT)) GO TO 9999
  18914.       IF(ATYPE(IATT).NE.KZTEXT) GO TO 100
  18915. C
  18916. C     TEXT
  18917. C
  18918.       IF(PGRAPH(IATT).NE.0) GO TO 50
  18919. C
  18920. C     NON-PARAGRAPHED TEXT
  18921. C
  18922.       NC = NUMCOL(IATT)
  18923.       IF(NC.GT.LEN(IATT)) NC = LEN(IATT)
  18924.       GO TO 70
  18925.    50 CONTINUE
  18926. C
  18927. C     PARAGRAPHED TEXT
  18928. C
  18929.       NC = NUMCOL(IATT)
  18930.       MAX = LEN(IATT) - CURPOS(IATT) + 1
  18931.       IF(NC.GT.MAX) NC = MAX
  18932.       IF(NC.EQ.MAX) GO TO 70
  18933. C
  18934. C     SEE IF WE NEED WORRY ABOUT BROKEN WORDS
  18935. C
  18936.       MC = 0
  18937.       M2 = ISCAN(MAT(1),CURPOS(IATT)+NC,-NC,IBLANK,1,1,IPOS)
  18938.       IF(IPOS.NE.0) MC = IPOS - CURPOS(IATT) + 1
  18939.       IF(MC.GT.4) NC = MC
  18940.       ADONE = .FALSE.
  18941. C
  18942. C     CHECK IF REMAINDER OF LINE IS BLANK
  18943. C
  18944.       N = LEN(IATT) - CURPOS(IATT) - NC
  18945.       IPOS = NSCAN(MAT(1),CURPOS(IATT)+NC,N,IBLANK,1,1)
  18946.       IF(IPOS.EQ.0) ADONE = .TRUE.
  18947.    70 CONTINUE
  18948.       CALL STRMOV(MAT(1),CURPOS(IATT),NC,LINE,COL1(IATT))
  18949.       CURPOS(IATT) = CURPOS(IATT) + NC
  18950.       IF(IPOS.EQ.0) CURPOS(IATT) = LEN(IATT) + 1
  18951.       GO TO 9999
  18952.   100 CONTINUE
  18953. C
  18954. C     NON-TEXT STUFF
  18955. C
  18956.       IF(ATYPE(IATT).EQ.KZIMAT) GO TO 1000
  18957.       IF(ATYPE(IATT).EQ.KZRMAT) GO TO 1000
  18958.       IF(ATYPE(IATT).EQ.KZDMAT) GO TO 1000
  18959.       IF(SINGLE(IATT).NE.0) GO TO 3000
  18960. C
  18961. C     WE HAVE NON-MATRIX STUFF
  18962. C
  18963.       NUMTOP = (NUMCOL(IATT)+2)/(ITEMW(IATT)+2)
  18964.       IF((PGRAPH(IATT).NE.0).AND.(PGRAPH(IATT).LT.NUMTOP))
  18965.      X             NUMTOP = PGRAPH(IATT)
  18966.       IP = CURPOS(IATT)
  18967.       IF(ATYPE(IATT).EQ.KZDOUB) IP = 2*IP - 1
  18968.       IF(ATYPE(IATT).EQ.KZDVEC) IP = 2*IP - 1
  18969.       IC = COL1(IATT)
  18970.       IF(.NOT.VAR(IATT)) GO TO 150
  18971.       IF(NUMCOL(IATT).LT.20) GO TO 150
  18972.       IF(ATYPE(IATT).EQ.KZIVEC) GO TO 120
  18973.       IF(ATYPE(IATT).EQ.KZRVEC) GO TO 120
  18974.       IF(ATYPE(IATT).EQ.KZDVEC) GO TO 120
  18975.       GO TO 150
  18976.   120 CONTINUE
  18977. C
  18978. C     PUT IN DIMENSION
  18979. C
  18980.       NUMTOP = NUMTOP - 1
  18981.       IF(CURPOS(IATT).EQ.1) CALL ITOC(LINE,IC,6,LEN(IATT),IERR)
  18982.       IC = IC + 10
  18983.   150 CONTINUE
  18984.       NUMT = LEN(IATT) - CURPOS(IATT) + 1
  18985.       IF(NUMTOP.GT.NUMT) NUMTOP = NUMT
  18986.       DO 200 I=1,NUMTOP
  18987.       CALL SELPUT(MAT(IP),ATYPE(IATT),ITEMW(IATT),IC,LINE)
  18988.       IP = IP + 1
  18989.       IF(ATYPE(IATT).EQ.KZDOUB) IP = IP + 1
  18990.       IF(ATYPE(IATT).EQ.KZDVEC) IP = IP + 1
  18991.       IC = IC + 2 + ITEMW(IATT)
  18992.   200 CONTINUE
  18993.       CURPOS(IATT) = CURPOS(IATT) + NUMTOP
  18994.       IF(PGRAPH(IATT).EQ.0) GO TO 9999
  18995.       IF(CURPOS(IATT).LE.LEN(IATT)) ADONE = .FALSE.
  18996.       GO TO 9999
  18997.  1000 CONTINUE
  18998. C
  18999. C     MATRICIES
  19000. C
  19001.       IF(SINGLE(IATT).NE.0) GO TO 3500
  19002.       NUMTOP = (NUMCOL(IATT)+2)/(ITEMW(IATT)+2)
  19003.       IF((PGRAPH(IATT).NE.0).AND.(PGRAPH(IATT).LT.NUMTOP))
  19004.      X             NUMTOP = PGRAPH(IATT)
  19005.       IP = CURPOS(IATT)
  19006.       JC = (IP-1)/ROWD(IATT)
  19007.       JR = IP - JC*ROWD(IATT)
  19008.       JC = JC + 1
  19009.       IC = COL1(IATT)
  19010.       IF(.NOT.VAR(IATT)) GO TO 1150
  19011.       IF(NUMCOL(IATT).LT.20) GO TO 1150
  19012. C
  19013. C     PUT IN ROW AND COLUMN
  19014. C
  19015.       NUMTOP = NUMTOP - 1
  19016.       IF(CURPOS(IATT).NE.1) GO TO 1125
  19017.       CALL ITOC(LINE,IC,4,ROWD(IATT),IERR)
  19018.       CALL ITOC(LINE,IC+4,4,COLD(IATT),IERR)
  19019.  1125 CONTINUE
  19020.       IC = IC + 10
  19021.  1150 CONTINUE
  19022.       NUMT = COLD(IATT)*(ROWD(IATT)-JR) + COLD(IATT) - JC + 1
  19023.       IF(NUMTOP.GT.NUMT) NUMTOP = NUMT
  19024.       DO 1200 I=1,NUMTOP
  19025.       IP = ROWD(IATT)*(JC-1) + JR
  19026.       IF(ATYPE(IATT).EQ.KZDMAT) IP = 2 * IP - 1
  19027.       CALL SELPUT(MAT(IP),ATYPE(IATT),ITEMW(IATT),IC,LINE)
  19028.       JC = JC + 1
  19029.       IF(JC.LE.COLD(IATT)) GO TO 1170
  19030.       JC = 1
  19031.       JR = JR + 1
  19032.       IF(PGRAPH(IATT).NE.0) GO TO 1220
  19033.  1170 CONTINUE
  19034.       IC = IC + 2 + ITEMW(IATT)
  19035.  1200 CONTINUE
  19036.  1220 CONTINUE
  19037.       IF(.NOT.TRUNC(IATT)) GO TO 1240
  19038.       IF(JC.EQ.1) GO TO 1240
  19039.       JR = JR + 1
  19040.       JC = 1
  19041.  1240 CONTINUE
  19042.       CURPOS(IATT) = ROWD(IATT)*(JC-1) + JR
  19043.       IF(PGRAPH(IATT).EQ.0) GO TO 9999
  19044.       IF(JR.LE.ROWD(IATT)) ADONE = .FALSE.
  19045.       IF(ADONE)CURPOS(IATT) = LEN(IATT) + 1
  19046.       GO TO 9999
  19047.  3000 CONTINUE
  19048. C
  19049. C     SINGLE ITEM FROM A VECTOR
  19050. C
  19051.       IP = SINGLE(IATT)
  19052.       CURPOS(IATT) = LEN(IATT) + 1
  19053.       IF(IP.GT.LEN(IATT)) GO TO 3800
  19054.       CALL SELPUT(MAT(IP),ATYPE(IATT),ITEMW(IATT),COL1(IATT),LINE)
  19055.       GO TO 9999
  19056.  3500 CONTINUE
  19057. C
  19058. C     SINGLE ITEM FROM A MATRIX
  19059. C
  19060.       CURPOS(IATT) = LEN(IATT) + 1
  19061.       CALL ITOH(JR,JC,SINGLE(IATT))
  19062.       IF(JR.GT.ROWD(IATT)) GO TO 3800
  19063.       IF(JC.GT.COLD(IATT)) GO TO 3800
  19064.       IP = ROWD(IATT)*(JC-1) + JR
  19065.       IF(ATYPE(IATT).EQ.KZDMAT) IP = 2 * IP - 1
  19066.       CALL SELPUT(MAT(IP),ATYPE(IATT),ITEMW(IATT),COL1(IATT),LINE)
  19067.       GO TO 9999
  19068.  3800 CONTINUE
  19069. C
  19070. C     OUT OF RANGE
  19071. C
  19072.       CALL SELPUT(NULL,ATYPE(IATT),ITEMW(IATT),COL1(IATT),LINE)
  19073.  9999 CONTINUE
  19074.       RETURN
  19075.       END
  19076.       SUBROUTINE SELPAR(ITALLY)
  19077.       INCLUDE rin:TEXT.BLK
  19078. C
  19079. C     THIS ROUTINE GOES THRU ATTRIBUTES SPECIFIED ON THE SELECT
  19080. C     COMMAND THEN (OR ALL) AND
  19081. C     1. BUILDS THE TITLE LINE
  19082. C     2.BUILDS THE MINUS LINE
  19083. C     3.SET INFORMATION INTO COMMON BLOCK SELCOM
  19084. C
  19085.       INCLUDE rin:RMATTS.BLK
  19086.       INCLUDE rin:RMKEYW.BLK
  19087.       INCLUDE rin:CONST8.BLK
  19088.       INCLUDE rin:CONST4.BLK
  19089.       INCLUDE rin:MISC.BLK
  19090.       INCLUDE rin:TUPLEA.BLK
  19091.       INCLUDE rin:TUPLER.BLK
  19092.       INCLUDE rin:FILES.BLK
  19093.       INCLUDE rin:SELCOM.BLK
  19094.       LOGICAL EQKEYW,END,IFALL
  19095.       LOGICAL ITALLY
  19096.       INTEGER STATUS
  19097.       INCLUDE rin:DCLAR1.BLK
  19098. C
  19099. C     INITIALIZE
  19100. C
  19101.       NUMBAD = 0
  19102.       NUM = CHPWD*(1+((MCPL-1)/CHPWD))
  19103.       CALL FILCH(TITLE,1,NUM,BLANK)
  19104.       CALL FILCH(MINUS,1,NUM,BLANK)
  19105.       CALL FILCH(LINE,1,NUM,BLANK)
  19106.       NUMATT = 0
  19107.       IT = 2
  19108.       ITEMS = LXITEM(DUM)
  19109.       LAST = LFIND(1,ITEMS,KWFROM,4)
  19110.       LAST = LAST - 1
  19111.       IF(ITALLY) LAST = 2
  19112.       IFALL = .FALSE.
  19113.       IP = 0
  19114.       IF(LAST.NE.2) GO TO 10
  19115.       IF(.NOT.EQKEYW(IT,KWALL,3)) GO TO 10
  19116. C
  19117. C     ALL
  19118. C
  19119.       IFALL = .TRUE.
  19120.       CALL LOCATT(BLANK,NAME)
  19121. C
  19122. C     LOOP ON ATTRIBUTES
  19123. C
  19124.    10 CONTINUE
  19125. C
  19126. C     GET ATTRIBUTE INTO TUPLEA
  19127. C
  19128.       IF(IFALL) GO TO 50
  19129. C
  19130. C     LOOK AT NEXT ATTRIBUTE
  19131. C
  19132.       IF(IT.GT.LAST) GO TO 1000
  19133.       IF(LXID(IT).NE.KZINT) GO TO 15
  19134. C
  19135. C     INTEGER ATTRIBUTE NUMBER
  19136. C
  19137.       NUM = LXIREC(IT)
  19138.       IT = IT + 1
  19139.       IF(NUM.LE.0) GO TO 880
  19140.       IF(NUM.GT.NATT) GO TO 880
  19141.       CALL LOCATT(BLANK,NAME)
  19142.       DO 12 I=1,NUM
  19143.       CALL ATTGET(STATUS)
  19144.       IF(STATUS.NE.0) GO TO 880
  19145.    12 CONTINUE
  19146.       GO TO 20
  19147.    15 CONTINUE
  19148.       ANAME = BLANK
  19149.       CALL LXSREC(IT,1,8,ANAME,1)
  19150.       IT = IT + 1
  19151.       CALL LOCATT(ANAME,NAME)
  19152.       CALL ATTGET(STATUS)
  19153.       IF(STATUS.EQ.0) GO TO 20
  19154.       CALL WARN(3,ANAME,NAME)
  19155.       NUMBAD = NUMBAD + 1
  19156.       GO TO 10
  19157.    20 CONTINUE
  19158.       NUMATT = NUMATT + 1
  19159.       IF(NUMATT.GT.20) GO TO 8040
  19160. C
  19161. C     SEE IF MAT(I,J) OR VEC(I,J)
  19162. C
  19163.       SINGLE(NUMATT) = 0
  19164.       IF(LXID(IT).NE.KZTEXT) GO TO 40
  19165.       IF(LXLENC(IT).NE.1) GO TO 40
  19166.       IF(LXWREC(IT,1).NE.K4LPAR) GO TO 40
  19167.       NUM = 0
  19168.       IF(ATTYPE.EQ.KZIVEC) NUM = 1
  19169.       IF(ATTYPE.EQ.KZRVEC) NUM = 1
  19170.       IF(ATTYPE.EQ.KZDVEC) NUM = 1
  19171.       IF(ATTYPE.EQ.KZIMAT) NUM = 2
  19172.       IF(ATTYPE.EQ.KZRMAT) NUM = 2
  19173.       IF(ATTYPE.EQ.KZDMAT) NUM = 2
  19174.       NUMA = 0
  19175.       IF(LXWREC(IT+2,1).EQ.K4RPAR) NUMA = 1
  19176.       IF(LXWREC(IT+3,1).EQ.K4RPAR) NUMA = 2
  19177.       IF(NUM.EQ.0) GO TO 800
  19178.       IF(NUMA.EQ.0) GO TO 820
  19179.       IF(NUM.NE.NUMA) GO TO 840
  19180.       IF(LXID(IT+1).NE.KZINT) GO TO 860
  19181.       IF(LXID(IT+NUMA).NE.KZINT) GO TO 860
  19182.       I1 = LXIREC(IT+1)
  19183.       I2 = 1
  19184.       IF(NUM.EQ.2) I2 = LXIREC(IT+2)
  19185.       IF(I1.LE.0) GO TO 860
  19186.       IF(I2.LE.0) GO TO 860
  19187.       CALL ITOH(N1,N2,ATTLEN)
  19188.       IF(N2.EQ.0) GO TO 30
  19189.       IF(ATTYPE.EQ.KZDVEC) N2 = N2/2
  19190.       IF(ATTYPE.EQ.KZDMAT) N2 = N2/2
  19191.       IF(NUM.EQ.1) GO TO 25
  19192.       IF(N1.NE.0) N2 = N2/N1
  19193.       IF(I1.GT.N1) GO TO 8020
  19194.       IF(I2.GT.N2) GO TO 8020
  19195.       GO TO 30
  19196.    25 CONTINUE
  19197.       IF(I1.GT.N2) GO TO 8020
  19198.    30 CONTINUE
  19199.       SINGLE(NUMATT) = I1
  19200.       IF(NUM.EQ.2)CALL HTOI(I1,I2,SINGLE(NUMATT))
  19201.       IT = IT + 2 + NUMA
  19202.    40 CONTINUE
  19203. C
  19204. C     SEE IF NEXT IS PARAGRAPH
  19205. C
  19206.       PGRAPH(NUMATT) = 0
  19207.       IF(IT.GT.LAST) GO TO 100
  19208.       IF(LXWREC(IT,1).NE.K4EQS) GO TO 100
  19209.       IF(LXID(IT+1).NE.KZINT) GO TO 8000
  19210.       PGRAPH(NUMATT) = LXIREC(IT+1)
  19211.       IT = IT + 2
  19212.       GO TO 100
  19213.    50 CONTINUE
  19214. C
  19215. C     ALL
  19216. C
  19217.       CALL ATTGET(STATUS)
  19218.       IF(STATUS.NE.0) GO TO 1000
  19219.       NUMATT = NUMATT + 1
  19220.       IF(NUMATT.GT.20) GO TO 8040
  19221.       PGRAPH(NUMATT) = 0
  19222.       SINGLE(NUMATT) = 0
  19223.   100 CONTINUE
  19224. C
  19225. C     GOT ATTRIBUTE IN TUPLEA
  19226. C
  19227.       NC = 0
  19228.       IF(IP.GT.(MCPL-10)) NUMATT = NUMATT - 1
  19229.       IF(IP.GT.(MCPL-10)) GO TO 900
  19230.       IP = IP + 2
  19231.       ICOL = ATTCHA
  19232.       NWORDS = ATTWDS
  19233.       IF(ATTYPE.EQ.KZDOUB) NWORDS = NWORDS/2
  19234.       IF(ATTYPE.EQ.KZDVEC) NWORDS = NWORDS/2
  19235.       IF(ATTYPE.EQ.KZDMAT) NWORDS = NWORDS/2
  19236.       COL1(NUMATT) = IP
  19237.       ATYPE(NUMATT) = ATTYPE
  19238.       LEN(NUMATT) = NWORDS
  19239.       IF(ATTYPE.EQ.KZTEXT)LEN(NUMATT) = ICOL
  19240.       ROWD(NUMATT) = ICOL
  19241.       COLD(NUMATT) = 0
  19242.       IF(ICOL.NE.0) COLD(NUMATT) = NWORDS/ICOL
  19243.       VAR(NUMATT) = NWORDS.EQ.0
  19244.       FP(NUMATT) = ATTCOL
  19245.       IF(VAR(NUMATT)) GO TO 200
  19246. C
  19247. C     FIXED STUFF
  19248. C
  19249.       TRUNC(NUMATT) = .FALSE.
  19250.       GO TO 300
  19251.   200 CONTINUE
  19252. C
  19253. C     VARIABLE STUFF
  19254. C
  19255.       TRUNC(NUMATT) = .FALSE.
  19256.       IF(PGRAPH(NUMATT).NE.0) GO TO 300
  19257.       PGRAPH(NUMATT) = 4
  19258.       IF(ATTYPE.EQ.KZTEXT) PGRAPH(NUMATT) = 40
  19259.   300 CONTINUE
  19260.       ITEMW(NUMATT) = 8
  19261.       IF(ATTYPE.EQ.KZTEXT)ITEMW(NUMATT) = 1
  19262.       NC = LEN(NUMATT) * (2 + ITEMW(NUMATT)) - 2
  19263.       IF(PGRAPH(NUMATT).NE.0)NC = PGRAPH(NUMATT)*(2+ITEMW(NUMATT))-2
  19264.       IF(ATTYPE.NE.KZTEXT) GO TO 310
  19265.       NC = LEN(NUMATT)
  19266.       IF(PGRAPH(NUMATT).NE.0) NC = PGRAPH(NUMATT)
  19267.   310 CONTINUE
  19268.       IF(SINGLE(NUMATT).NE.0) NC = ITEMW(NUMATT) + 2
  19269.       IF(NC.LE.0) NC = 40
  19270. C
  19271. C     INSERT TITLE
  19272. C
  19273.       JP = IP
  19274.       IF(.NOT.VAR(NUMATT)) GO TO 315
  19275.       IF(NC.LT.20) GO TO 315
  19276.       IF(ATTYPE.EQ.KZTEXT) GO TO 315
  19277.       IF(ATTYPE.EQ.KZINT) GO TO 315
  19278.       IF(ATTYPE.EQ.KZREAL) GO TO 315
  19279.       IF(ATTYPE.EQ.KZDOUB) GO TO 315
  19280.       IF(ATTYPE.EQ.KZIVEC) CALL STRMOV(K4DIM,1,3,TITLE,IP+3)
  19281.       IF(ATTYPE.EQ.KZRVEC) CALL STRMOV(K4DIM,1,3,TITLE,IP+5)
  19282.       IF(ATTYPE.EQ.KZDVEC) CALL STRMOV(K4DIM,1,3,TITLE,IP+5)
  19283.       IF(ATTYPE.EQ.KZRMAT) CALL STRMOV(K8RC,1,8,TITLE,IP)
  19284.       IF(ATTYPE.EQ.KZDMAT) CALL STRMOV(K8RC,1,8,TITLE,IP)
  19285.       IF(ATTYPE.EQ.KZIMAT) CALL STRMOV(K8RC,1,8,TITLE,IP)
  19286.       JP = IP + 10
  19287.   315 CONTINUE
  19288.       CALL STRMOV(ATTNAM,1,MIN0(8,NC),TITLE,JP)
  19289.       END = .FALSE.
  19290.       IF((IP+NC-1).GT.MCPL) END = .TRUE.
  19291.       IF(END) NC = MCPL - IP + 1
  19292.       NUMCOL(NUMATT) = NC
  19293. C
  19294. C     MAKE DASHES
  19295. C
  19296.       CALL FILCH(MINUS,IP,NC,K4MNUS)
  19297.       IP = IP + NC
  19298.       IF(.NOT.END) GO TO 10
  19299.       GO TO 900
  19300.   800 CONTINUE
  19301. C
  19302. C     WRONG TYPE FOR FOLLOWING PARENS
  19303. C
  19304.     if(nout.eq.6)goto 3140
  19305.       WRITE (NOUT,810)
  19306.   810 FORMAT(58H -ERROR- Attribute Must Be VEC Or MAT For Following Pare
  19307.      Xns)
  19308.       GO TO 9000
  19309. 3140    write(c128wk,810)
  19310.     call atxto
  19311.     goto 9000
  19312.   820 CONTINUE
  19313. C
  19314. C     TRAILING PAREN IMPROPERLY SPECIFIED
  19315.     if(nout.eq.6)goto 3141
  19316. C
  19317.       WRITE (NOUT,830)
  19318.   830 FORMAT(36H -ERROR- Couldn't Find Closing Paren)
  19319.       GO TO 9000
  19320. 3141    continue
  19321.     write(c128wk,830)
  19322.     call atxto
  19323.     goto 9000
  19324.   840 CONTINUE
  19325. C
  19326. C     VEC/MAT MISMATCH
  19327. C
  19328.     if(nout.eq.6)goto 3142
  19329.       WRITE (NOUT,850)
  19330.   850 FORMAT(38H -ERROR- Number Of Dimensions Mismatch)
  19331.       GO TO 9000
  19332. 3142    write(c128wk,850)
  19333.     call atxto
  19334.     goto 9000
  19335.   860 CONTINUE
  19336. C
  19337. C     ROW/COL MUST BE POSITIVE INTEGER
  19338. C
  19339.     if(nout.eq.6)goto 3143
  19340.       WRITE (NOUT,870)
  19341.   870 FORMAT(42H -ERROR- ROW/COL Must Be Positive Integers)
  19342.       GO TO 9000
  19343. 3143    write(c128wk,870)
  19344.     call atxto
  19345.     goto 9000
  19346.   880 CONTINUE
  19347. C
  19348. C     BAD INTEGER ATTRIBUTE
  19349. C
  19350.     if(nout.eq.6)goto 3144
  19351.       WRITE (NOUT,890)
  19352.   890 FORMAT(49H -ERROR- Improper Integer Attribute Specification )
  19353.       GO TO 9000
  19354. 3144    write(c128wk,890)
  19355.     call atxto
  19356.     goto 9000
  19357.   900 CONTINUE
  19358. C
  19359. C     OOPS - NOT ENOUGH ROOM
  19360. C
  19361.     if(nout.eq.6)goto 3145
  19362.       WRITE(NOUT,910)
  19363.   910 FORMAT(25H -WARNING- Line Truncated )
  19364.     goto 3146
  19365. 3145    write(c128wk,910)
  19366.     call atxto
  19367. 3146    continue
  19368.  1000 CONTINUE
  19369.       MCPL = IP - 1
  19370.       IF(NUMBAD.GT.0) GO TO 9000
  19371.       RETURN
  19372.  8000 CONTINUE
  19373. C
  19374. C     PARAGRAPH NOT INTEGER
  19375. C
  19376.     if(nout.eq.6)goto 3147
  19377.       WRITE (NOUT,8010)
  19378.  8010 FORMAT(41H -ERROR- Improper Paragraph Specification )
  19379.       GO TO 9000
  19380. 3147    write(c128wk,8010)
  19381.     call atxto
  19382.     goto 9000
  19383.  8020 CONTINUE
  19384. C
  19385. C     SINGLE TOO BIG
  19386. C
  19387.     if(nout.eq.6)goto 3148
  19388.       WRITE (NOUT,8030)
  19389.  8030 FORMAT(39H -ERROR- Requested Element Out Of Range )
  19390.       GO TO 9000
  19391. 3148    write(c128wk,8030)
  19392.     call atxto
  19393.     goto 9000
  19394.  8040 CONTINUE
  19395. C
  19396. C  TOO MAY ATTRIBUTES SPECIFIED
  19397. C
  19398.     if(nout.eq.6)goto 3149
  19399.       WRITE(NOUT,8050)
  19400.  8050 FORMAT(46H -ERROR- Illegal Number Of Attributes (MAX 20))
  19401.       GO TO 9000
  19402. 3149    write(c128wk,8050)
  19403.     call atxto
  19404.  9000 CONTINUE
  19405. C
  19406. C     BLEW IT
  19407. C
  19408.       NUMATT = 0
  19409.       CALL WARN(4,0,0)
  19410.       RETURN
  19411.       END
  19412.       SUBROUTINE SELPUT(VAL,TYPE,WIDTH,START,STRING)
  19413.       INCLUDE rin:TEXT.BLK
  19414. C
  19415. C     THIS ROUTINE PUTS AN ACTUAL VALUE (NON-TEXT) INTO STRING.
  19416. C
  19417.       INCLUDE rin:RMATTS.BLK
  19418.       INCLUDE rin:CONST4.BLK
  19419.       INCLUDE rin:MISC.BLK
  19420. C
  19421.       INTEGER VAL,TYPE,WIDTH,START,STRING(*)
  19422.       IF(VAL.EQ.IBLANK) RETURN
  19423.       IF(VAL.NE.NULL) GO TO 100
  19424. C
  19425. C     NULL
  19426. C
  19427.       N = 3
  19428.       IF(WIDTH.LT.N) N = WIDTH
  19429.       CALL STRMOV(NULL,1,N,STRING,START)
  19430.       GO TO 9999
  19431.   100 CONTINUE
  19432.       IF(TYPE.EQ.KZINT) GO TO 200
  19433.       IF(TYPE.EQ.KZIVEC) GO TO 200
  19434.       IF(TYPE.EQ.KZIMAT) GO TO 200
  19435. C
  19436. C     TREAT AS REAL
  19437. C
  19438.       CALL RTOC(STRING,START,WIDTH,VAL)
  19439.       GO TO 9999
  19440.   200 CONTINUE
  19441. C
  19442. C     INTEGER
  19443. C
  19444.       CALL ITOC(STRING,START,WIDTH,VAL,IERR)
  19445.       IF(IERR.EQ.0) GO TO 9999
  19446.       CALL FILCH(STRING,START,WIDTH,K4STAR)
  19447.  9999 CONTINUE
  19448.       RETURN
  19449.       END
  19450.       SUBROUTINE SETIN(HFILE)
  19451.       INCLUDE rin:TEXT.BLK
  19452. C
  19453. C     SET THE INPUT FILE TO IFILE
  19454. C
  19455.       INCLUDE rin:CONST4.BLK
  19456.       INCLUDE rin:CONST8.BLK
  19457.       INCLUDE rin:FILES.BLK
  19458.       LOGICAL EQ
  19459.       REAL*8 HFILE
  19460.       CHARACTER*8 IFILE
  19461.       WRITE(IFILE,10) HFILE
  19462.    10 FORMAT(A8)
  19463.       IF(NINT.EQ.10) CLOSE(NINT)
  19464.       IF(EQ(HFILE,K8IN)) GO TO 100
  19465. C
  19466. C     NOT INPUT FILE
  19467. C
  19468.       CONNI = .FALSE.
  19469.       NINT = 10
  19470.       OPEN(UNIT=NINT,FILE=IFILE,STATUS='UNKNOWN')
  19471.       GO TO 900
  19472.   100 CONTINUE
  19473. C
  19474. C     INPUT FILE - NEVER CLOSED
  19475. C
  19476. C
  19477. C  CHECK THAT INPUT IS INPUT
  19478. C
  19479.       CONNI = .TRUE.
  19480.       NINT = 5
  19481.   900 CONTINUE
  19482.       CALL LXSET(K4INPT,NINT)
  19483.       RETURN
  19484.       END
  19485.       SUBROUTINE SETOUT(HFILE)
  19486.       INCLUDE rin:TEXT.BLK
  19487. C
  19488. C     SET THE OUTPUT FILE TO IFILE
  19489. C
  19490.       INCLUDE rin:CONST4.BLK
  19491.       INCLUDE rin:CONST8.BLK
  19492.       INCLUDE rin:FILES.BLK
  19493.       LOGICAL EQ
  19494.       REAL*8 HFILE
  19495.       CHARACTER*8 IFILE
  19496.       WRITE(IFILE,10) HFILE
  19497.    10 FORMAT(A8)
  19498.       IF(NOUT.EQ.11) CLOSE(NOUT)
  19499.       IF(NOUTR.EQ.11) CLOSE(NOUTR)
  19500.       IF(EQ(HFILE,K8OUT)) GO TO 100
  19501. C
  19502. C     NOT OUTPUT FILE
  19503. C
  19504.       CONNO = .FALSE.
  19505.       NOUTR = 11
  19506.       OPEN(UNIT=NOUTR,FILE=IFILE,STATUS='UNKNOWN')
  19507.       NOUT = 11
  19508.       IF(CONNI) NOUT = 6
  19509.       GO TO 900
  19510.   100 CONTINUE
  19511. C
  19512. C     OUTPUT FILE - NEVER CLOSED
  19513. C
  19514. C
  19515. C  CHECK THAT OUTPUT IS OUTPUT
  19516. C
  19517.       CONNO = .TRUE.
  19518.       NOUT = 6
  19519.       NOUTR = 6
  19520.   900 CONTINUE
  19521.       CALL LXSET(K4OTPT,NOUTR)
  19522.       RETURN
  19523.       END
  19524.       SUBROUTINE SETRUL
  19525.       INCLUDE rin:TEXT.BLK
  19526. C
  19527. C  THIS ROUTINE SETS UP THE RELATIONS NECESSARY TO ALLOW THE USER
  19528. C  TO DEFINE RULES FOR PROCESSING A RIM SCHEMA.  THESE RELATIONS
  19529. C  ARE :
  19530. C
  19531. C         RIMRDT --- THE RIM SCHEMA COMPILER RULE DESCRIPTION TABLE.
  19532. C
  19533. C         RIMRRC  --- THE RIM SCHEMA COMPILER RULE RELATION
  19534. C                     CORRESPONDENCE TABLE.
  19535. C
  19536.       INCLUDE rin:RMATTS.BLK
  19537.       INCLUDE rin:CONST4.BLK
  19538.       INCLUDE rin:CONST8.BLK
  19539.       INCLUDE rin:TUPLER.BLK
  19540.       INCLUDE rin:TUPLEA.BLK
  19541.       INCLUDE rin:MISC.BLK
  19542. C
  19543. C
  19544. C  SET UP RELATION TABLE FOR RIMRRC.
  19545. C
  19546.       NAME = K8RRC
  19547.       CALL RMDATE(RDATE)
  19548.       NCOL = 3
  19549.       NATT = 2
  19550.       NTUPLE = 0
  19551.       RSTART = 0
  19552.       REND = 0
  19553.       RPW = K8DBA
  19554.       MPW = K8DBA
  19555.       CALL RELADD
  19556.       CALL ATTNEW(NAME,2)
  19557. C
  19558. C  ADD ATTRIBUTES FOR RIMRRC
  19559. C
  19560.       RELNAM = NAME
  19561.       ATTKEY = 0
  19562.       NW = (8-1)/CHPWD + 1
  19563. C
  19564. C  RELATION NAME
  19565. C
  19566.       ATTNAM = K8NAM
  19567.       ATTCOL = 1
  19568.       CALL HTOI(8,NW,ATTLEN)
  19569.       ATTYPE = KZTEXT
  19570.       CALL ATTADD
  19571. C
  19572. C  RULE NUMBER
  19573. C
  19574.       ATTNAM = K8NUM
  19575.       ATTCOL = 3
  19576.       ATTLEN = 1
  19577.       ATTYPE = KZINT
  19578.       CALL ATTADD
  19579. C
  19580. C  SET UP RIMRDT RELATION
  19581. C
  19582.       NAME = K8RDT
  19583.       CALL RMDATE(RDATE)
  19584.       NCOL = 14 + ((40-1)/CHPWD + 1)
  19585.       NATT = 9
  19586.       NTUPLE = 0
  19587.       RSTART = 0
  19588.       REND = 0
  19589.       RPW = K8DBA
  19590.       MPW = K8DBA
  19591.       CALL RELADD
  19592.       CALL ATTNEW(NAME,9)
  19593. C
  19594. C  ADD ATTRIBUTES FOR RIMRDT
  19595. C
  19596.       ATTKEY = 0
  19597.       RELNAM = NAME
  19598. C
  19599. C  RULE NUMBER
  19600. C
  19601.       ATTNAM = K8NUM
  19602.       ATTCOL = 1
  19603.       ATTLEN = 1
  19604.       ATTYPE = KZINT
  19605.       CALL ATTADD
  19606. C
  19607. C  AND/OR SWITCH
  19608. C
  19609.       ATTNAM = K8AOR
  19610.       ATTCOL = 2
  19611.       CALL HTOI(8,NW,ATTLEN)
  19612.       ATTYPE = KZTEXT
  19613.       CALL ATTADD
  19614. C
  19615. C  1ST ATTRIBUTE NAME
  19616. C
  19617.       ATTNAM = K8AN1
  19618.       ATTCOL = 4
  19619.       CALL HTOI(8,NW,ATTLEN)
  19620.       ATTYPE = KZTEXT
  19621.       CALL ATTADD
  19622. C
  19623. C  RELATION OR BLANK
  19624. C
  19625.       ATTNAM = K8RN1
  19626.       ATTCOL = 6
  19627.       CALL HTOI(8,NW,ATTLEN)
  19628.       ATTYPE = KZTEXT
  19629.       CALL ATTADD
  19630. C
  19631. C  BOOLEAN OPERATOR
  19632. C
  19633.       ATTNAM = K8OPR
  19634.       ATTCOL = 8
  19635.       CALL HTOI(8,NW,ATTLEN)
  19636.       ATTYPE = KZTEXT
  19637.       CALL ATTADD
  19638. C
  19639. C  2ND ITEM DESCRIPTOR
  19640. C
  19641.       ATTNAM = K8TYP
  19642.       ATTCOL = 10
  19643.       ATTLEN = 1
  19644.       ATTYPE = KZINT
  19645.       CALL ATTADD
  19646. C
  19647. C  2ND ATTRIBUTE NAME
  19648. C
  19649.       ATTNAM = K8AN2
  19650.       ATTCOL = 11
  19651.       CALL HTOI(8,NW,ATTLEN)
  19652.       ATTYPE = KZTEXT
  19653.       CALL ATTADD
  19654. C
  19655. C  2ND RELATION OR BLANK
  19656. C
  19657.       ATTNAM = K8RN2
  19658.       ATTCOL = 13
  19659.       CALL HTOI(8,NW,ATTLEN)
  19660.       ATTYPE = KZTEXT
  19661.       CALL ATTADD
  19662. C
  19663. C  VALUE.
  19664. C
  19665.       ATTNAM = K8VAL
  19666.       ATTCOL = 15
  19667.       NW = (40-1)/CHPWD + 1
  19668.       CALL HTOI(40,NW,ATTLEN)
  19669.       ATTYPE = KZTEXT
  19670.       CALL ATTADD
  19671. C
  19672. C  DONE WITH SETRULE.
  19673. C
  19674.       RETURN
  19675.       END
  19676.       SUBROUTINE SORT(NKSORT,ios)
  19677.       INCLUDE rin:TEXT.BLK
  19678. C
  19679. C  PURPOSE:  INTERFACE WITH SOCON TO SORT RIM DATA
  19680. C
  19681. C  PARAMETERS:
  19682. C              NKSORT--INDICATOR FOR THE TYPE OF SORT
  19683. C                        1=TUPLE SORT (SELECT)
  19684. C                        2=ATTRIBUTE SORT (TALLY)
  19685. C                        3=ID (POINTER) + ATTRIBUTE SORT (BUILD)
  19686. C              INDPTR--MULTIPLE RMHUNT INDEX - USED TO ASSIGN FILES
  19687. C
  19688.       INCLUDE rin:RIMPTR.BLK
  19689.       INCLUDE rin:WHCOM.BLK
  19690.       INCLUDE rin:SRTCOM.BLK
  19691.       INCLUDE rin:RIMCOM.BLK
  19692.       INCLUDE rin:FILES.BLK
  19693.       INCLUDE rin:MISC.BLK
  19694.       INCLUDE rin:BUFFER.BLK
  19695.       INCLUDE rin:TUPLEA.BLK
  19696.       INCLUDE rin:TUPLER.BLK
  19697.       INCLUDE rin:INCORE.BLK
  19698. C
  19699.       INTEGER INFIL
  19700.       INTEGER OUTFIL
  19701. C
  19702. C  OPEN THE INPUT SORT FILE
  19703. C
  19704.       INFIL = 20
  19705.     open(infil,file='sortfil.dat',access='sequential',
  19706.      1  form='unformatted',status='unknown',iostat=ios)
  19707.     if(ios.eq.0)goto 50
  19708.     nsort=0
  19709.     goto 999
  19710. 50    continue
  19711. c      REWIND INFIL
  19712. C
  19713. C  SET UP TUPLE LIMITS - SAVE USER SPECIFIED LIMIT
  19714. C
  19715.       LIMTUS = LIMTU
  19716.       LIMTU = ALL9S
  19717. C
  19718. C  BRANCH DEPENDING ON THE TYPE OF SORT REQUESTED
  19719. C
  19720.       IF(NKSORT.EQ.2) GO TO 350
  19721.       IF(NKSORT.EQ.3) GO TO 370
  19722. C
  19723. C  TUPLE SORT - WRITE THE COMPLETE TUPLE ON THE SORT FILE
  19724. C
  19725. C  CHECK FOR VARIABLE LENGTH TUPLES IN THE RELATION
  19726. C
  19727.       FIXLT = .TRUE.
  19728.       I = LOCATT(BLANK,NAME)
  19729.       DO 100 J=1,NATT
  19730.       CALL ATTGET(ISTATX)
  19731.       IF(ISTATX.NE.0) GO TO 110
  19732.       IF(ATTWDS.EQ.0) FIXLT = .FALSE.
  19733.   100 CONTINUE
  19734.   110 CONTINUE
  19735. C
  19736. C  INITIALIZE THE REMAINING VARIABLES
  19737. C
  19738.       LTUMAX = 0
  19739.       LTUMIN = ALL9S
  19740.       NSORT = 0
  19741.       LTUPLE = 0
  19742.       IF(FIXLT) LTUPLE = NCOL
  19743. C
  19744. C  READ IN THE TUPLES AND WRITE THE SORT FILE
  19745. C
  19746.   200 CONTINUE
  19747.       CALL RMLOOK(IP,1,1,LEN)
  19748.       IF(RMSTAT.NE.0) GO TO 400
  19749.       NSORT = NSORT + 1
  19750.       IP = IP - 1
  19751.       IF(FIXLT) GO TO 300
  19752. C
  19753. C  VARIBLE LENGTH TUPLE
  19754. C
  19755.       LTUPLE = LTUPLE + LEN
  19756.       IF(LEN.GT.LTUMAX) LTUMAX = LEN
  19757.       IF(LEN.LT.LTUMIN) LTUMIN = LEN
  19758.       WRITE(INFIL) LEN,(BUFFER(IP+K),K=1,LEN)
  19759.       GO TO 200
  19760. C
  19761. C  FIXED LENGTH TUPLES
  19762. C
  19763.   300 CONTINUE
  19764.       WRITE(INFIL) (BUFFER(IP+K),K=1,LEN)
  19765.       GO TO 200
  19766. C
  19767. C  ATTRIBUTE SORT - WRITE ONLY THE REQUESTED ATTRIBUTE ON THE SORT FILE
  19768. C
  19769.   350 CONTINUE
  19770.       FIXLT = .TRUE.
  19771.       LTUMAX = 0
  19772.       LTUMIN = ALL9S
  19773.       NSORT = 0
  19774.       LTUPLE = ATTWDS
  19775. C
  19776. C  READ THE TUPLES AND WRITE THE ATTRIBUTE VALUES ON THE SORT FILE
  19777. C
  19778.   360 CONTINUE
  19779.       CALL RMLOOK(IP,1,1,LEN)
  19780.       IF(RMSTAT.NE.0) GO TO 400
  19781.       NSORT = NSORT + 1
  19782.       IP = IP - 2
  19783.       WRITE(INFIL) (BUFFER(IP+ATTCOL+K),K=1,LTUPLE)
  19784.       GO TO 360
  19785. C
  19786. C  ID + ATTRIBUTE SORT (BUILD)
  19787. C
  19788.   370 CONTINUE
  19789.       FIXLT = .TRUE.
  19790.       LTUMAX = 0
  19791.       LTUMIN = ALL9S
  19792.       NSORT = 0
  19793.       LTUPLE = 2
  19794.   380 CONTINUE
  19795.       IF(NID.EQ.0) GO TO 400
  19796.       CID = NID
  19797.       CALL GETDAT(1,NID,ITUP,LENGT)
  19798.       IF(NID.LT.0) GO TO 400
  19799.       IP = ITUP + ATTCOL - 1
  19800.       IF(ATTWDS.NE.0) GO TO 390
  19801. C
  19802. C  ATTRIBUTE IS A VARIABLE LENGTH ATTRIBUTE.
  19803. C
  19804.       IP = BUFFER(IP) + ITUP + 1
  19805.   390 CONTINUE
  19806.       IF(BUFFER(IP).EQ.NULL) GO TO 380
  19807. C
  19808. C WRITE THE SORT FILE
  19809. C
  19810.       NSORT = NSORT + 1
  19811.       WRITE(INFIL) BUFFER(IP),CID
  19812.       GO TO 380
  19813. C
  19814. C  CHECK THAT SOME TUPLES WERE WRITTIN ON INFIL
  19815. C  RESET THE TUPLE LIMIT
  19816. C
  19817.   400 CONTINUE
  19818.       LIMTU = LIMTUS
  19819.       IF(NSORT.GT.0) GO TO 420
  19820.     if(nout.eq.6)goto 3140
  19821.       WRITE(NOUT,410)
  19822.   410 FORMAT(36H -WARNING- No Rows Available To SORT)
  19823.       GO TO 999
  19824. 3140    write(c128wk,410)
  19825.     call atxto
  19826.     goto 999
  19827. C
  19828. C  OPEN THE OUTPUT FILES
  19829. C
  19830.   420 CONTINUE
  19831.       OUTFIL = 20
  19832. C
  19833. C  CLEAR OUT ANY PAGE DATA LEFT IN BUFFER
  19834. C
  19835.       CALL BLKCLN
  19836. C
  19837. C  FIXUP THE LENGTHS FOR THE VARIABLE LENGTH STUFF
  19838. C
  19839.       IF(FIXLT) GO TO 440
  19840.       LTUPLE = LTUPLE + NSORT
  19841.       LTUMAX = LTUMAX + 1
  19842.       LTUMIN = LTUMIN + 1
  19843. C
  19844. C  CALL SOCON TO DO THE ACTUAL SORT
  19845. C
  19846.   440 CONTINUE
  19847.       IERR = 0
  19848.       CALL SWCON(BUFFER,LIMIT,INFIL,OUTFIL,IERR)
  19849.       IF(IERR.EQ.0) GO TO 450
  19850.     if(nout.eq.6)goto 3141
  19851.       WRITE(NOUT,445)
  19852.   445 FORMAT(17H -ERROR- SORT I/O)
  19853.       NSORT = 0
  19854.       GO TO 999
  19855. 3141    write(c128wk,445)
  19856.     call atxto
  19857.     goto 999
  19858. C
  19859.   450 CONTINUE
  19860.       RMSTAT = 0
  19861. C
  19862.   999 CONTINUE
  19863.       RETURN
  19864.       END
  19865.       SUBROUTINE SPOUT(STRING,NUMC)
  19866.       INCLUDE rin:TEXT.BLK
  19867. C
  19868. C     WRITE A LINE TO OUTPUT IGNORING TRAILING BLANKS
  19869. C
  19870.       INCLUDE rin:FILES.BLK
  19871.       INCLUDE rin:BLNKFL.BLK
  19872.       INCLUDE rin:MISC.BLK
  19873.       INTEGER STRING(*)
  19874.       BLNKFL = .TRUE.
  19875.       NW = (NUMC-1)/CHPWD
  19876.       NW = NW + 1
  19877.       NEND = NW
  19878.       DO 10 I=1,NEND
  19879.       IF(STRING(NW).NE.IBLANK) GO TO 20
  19880.       NW = NW - 1
  19881.    10 CONTINUE
  19882.       BLNKFL = .FALSE.
  19883.       RETURN
  19884.    20 CONTINUE
  19885.     if(noutr.eq.6)goto 3140
  19886.       WRITE (NOUTR,30)(STRING(I),I=1,NW)
  19887.    30 FORMAT(33A4)
  19888.       RETURN
  19889. 3140    write(c128wk,30)(string(i),i=1,nw)
  19890.     call atxto
  19891.     return
  19892.       END
  19893.       SUBROUTINE STATUS(FILE,LFS)
  19894.       INCLUDE rin:TEXT.BLK
  19895.       CHARACTER*7 FILE
  19896.       LOGICAL EX
  19897.       LFS = 0
  19898.       INQUIRE(FILE=FILE,EXIST=EX)
  19899.       IF(EX) LFS = 1
  19900.       RETURN
  19901.       END
  19902.       SUBROUTINE STRMOV(IST1,IPOS1,NCH,IST2,IPOS2)
  19903.       INCLUDE rin:TEXT.BLK
  19904. C
  19905. C  PURPOSE:   MOVE A STRING OF CHARACTERS FROM ONE ARRAY TO ANOTHER
  19906. C
  19907. C  PARAMETERS:
  19908. C     IST1----ORIGINAL STRING WITH THE CHARACTERS TO BE MOVED
  19909. C     IPOS1---STARTING POSITION WITHIN THAT STRING
  19910. C     NCH-----NUMBER OF CHARACTERS TO MOVE
  19911. C     IST2----STRING TO RECEIVE THE CHARACTERS
  19912. C     IPOS2---STARTING POSITION WITHIN THAT STRING
  19913. C
  19914.       Character*1 IST1(*),IST2(*)
  19915.       INTEGER C1,C2
  19916. C
  19917. C  MAKE SURE THAT THINGS LOOK OK.
  19918. C
  19919.       IF(NCH.LE.0) RETURN
  19920.       C1 = IPOS1
  19921.       C2 = IPOS2
  19922. C
  19923. C  MOVE THE CHARACTERS FROM THE FIRST STRING TO THE SECOND.
  19924. C
  19925.       DO 100 I=1,NCH
  19926.       IST2(C2) = IST1(C1)
  19927.       C1 = C1 + 1
  19928.       C2 = C2 + 1
  19929.   100 CONTINUE
  19930.       RETURN
  19931.       END
  19932.       SUBROUTINE SUBREL
  19933.       INCLUDE rin:TEXT.BLK
  19934. C
  19935. C  THIS ROUTINE FINDS THE DIFFERENCE OF TWO RELATIONS BASED UPON
  19936. C  ATTRIBUTES.  THE RESULT FROM THIS PROCESS IS A PHYSICAL
  19937. C  RELATION WHICH HAS ALL TUPLES FROM THE SECOND RELATION WHICH
  19938. C  DO NOT HAVE MATCHES IN THE FIRST.
  19939. C
  19940. C  THE SYNTAX FOR THE SUBTRACT COMMAND IS:
  19941. C
  19942. C   SUBTRACT REL1 FROM REL2 FORMING REL3 [USING ATTR1 ATTR2...ATTR-N]
  19943. C
  19944. C
  19945.       INCLUDE rin:RMATTS.BLK
  19946.       INCLUDE rin:RMKEYW.BLK
  19947.       INCLUDE rin:CONST4.BLK
  19948.       INCLUDE rin:FLAGS.BLK
  19949.       INCLUDE rin:RIMCOM.BLK
  19950.       INCLUDE rin:RIMPTR.BLK
  19951.       INCLUDE rin:TUPLER.BLK
  19952.       INCLUDE rin:TUPLEA.BLK
  19953.       INCLUDE rin:FILES.BLK
  19954.       INCLUDE rin:BUFFER.BLK
  19955.       INCLUDE rin:WHCOM.BLK
  19956.       INCLUDE rin:MISC.BLK
  19957. C
  19958.       INTEGER PTABLE
  19959.       LOGICAL EQKEYW
  19960.       INCLUDE rin:DCLAR1.BLK
  19961.       INCLUDE rin:DCLAR3.BLK
  19962. C
  19963. C  CALL RMDBLK TO MAKE SURE DATABASE MAY BE MODIFIED
  19964. C
  19965.       CALL RMDBLK(DBNAME)
  19966.       IF(RMSTAT.EQ.0) GO TO 50
  19967.       CALL WARN(RMSTAT,DBNAME,0)
  19968.       GO TO 9999
  19969. C
  19970. C  LOCAL ARRAYS AND VARIABLES :
  19971. C
  19972. C  PTABLE (MATRIX 10) USED TO CONTROL POINTERS
  19973. C        ROWS1,2 -- ATTRIBUTE NAME
  19974. C        ROW3 -- ATTRIBUTE LOCATION IN RELATION 1
  19975. C        ROW4 -- ATTRIBUTE LOCATION IN RELATION 2
  19976. C        ROW5 -- ATTRIBUTE LOCATION IN RELATION 3
  19977. C        ROW6 -- LENGTH IN WORDS
  19978. C        ROW7 -- ATTRIBUTE TYPE
  19979. C
  19980. C  EDIT COMMAND SYNTAX
  19981. C
  19982.    50 CONTINUE
  19983.       CALL BLKCLN
  19984.       NS = 0
  19985.       IF(.NOT.EQKEYW(3,KWFROM,4)) GO TO 9900
  19986.       IF(.NOT.EQKEYW(5,KWFORM,7)) GO TO 9900
  19987.       ITEMS = LXITEM(IDUMMY)
  19988.       IF(ITEMS.GT.6 .AND. .NOT.EQKEYW(7,KWUSIN,5)) GO TO 9900
  19989. C
  19990. C  KEYWORD SYNTAX OKAY
  19991. C
  19992.       RNAME1 = BLANK
  19993.       CALL LXSREC(2,1,8,RNAME1,1)
  19994.       I = LOCREL(RNAME1)
  19995.       IF(I.EQ.0) GO TO 100
  19996. C
  19997. C  MISSING FIRST RELATION.
  19998. C
  19999.       CALL WARN(1,RNAME1,0)
  20000.       GO TO 9999
  20001.   100 CONTINUE
  20002. C
  20003. C  SAVE DATA ABOUT RELATION 1
  20004. C
  20005.       I1 = LOCPRM(RNAME1,1)
  20006.       IF(I1.EQ.0) GO TO 110
  20007.       CALL WARN(9,RNAME1,0)
  20008.       GO TO 9999
  20009.   110 CONTINUE
  20010.       NCOL1 = NCOL
  20011.       NATT1 = NATT
  20012.       RNAME2 = BLANK
  20013.       CALL LXSREC(4,1,8,RNAME2,1)
  20014.       I = LOCREL(RNAME2)
  20015.       IF(I.EQ.0) GO TO 200
  20016. C
  20017. C  MISSING SECOND RELATION.
  20018. C
  20019.       CALL WARN(1,RNAME2,0)
  20020.       GO TO 9999
  20021.   200 CONTINUE
  20022. C
  20023. C  SAVE DATA ABOUT RELATION 2
  20024. C
  20025.       I2 = LOCPRM(RNAME2,1)
  20026.       IF(I2.EQ.0) GO TO 210
  20027.       CALL WARN(9,RNAME2,0)
  20028.       GO TO 9999
  20029.   210 CONTINUE
  20030.       NCOL2 = NCOL
  20031.       NATT2 = NATT
  20032.       RPW2 = RPW
  20033.       MPW2 = MPW
  20034. C
  20035. C  CHECK FOR LEGAL RNAME3
  20036. C
  20037.       IF((LXLENC(6).GE.1).AND.(LXLENC(6).LE.8)) GO TO 250
  20038.       CALL WARN(7,KWRELA,BLANK)
  20039.       GO TO 9999
  20040.   250 CONTINUE
  20041. C
  20042. C  CHECK FOR DUPLICATE RELATION 3
  20043. C
  20044.       RNAME3 = BLANK
  20045.       CALL LXSREC(6,1,8,RNAME3,1)
  20046.       I = LOCREL(RNAME3)
  20047.       IF(I.NE.0) GO TO 300
  20048. C
  20049. C  ERROR
  20050. C
  20051.     if(nout.eq.6)goto 3141
  20052.       WRITE(NOUT,9000)
  20053.  9000 FORMAT(55H -ERROR- Resultant Relation Does Not Have A Unique Name)
  20054.       GO TO 9999
  20055. 3141    write(c128wk,9000)
  20056.     call atxto
  20057.     goto 9999
  20058. C
  20059. C  CHECK USER READ SECURITY
  20060. C
  20061.   300 CONTINUE
  20062.       IF((I1.NE.0).OR.(I2.NE.0)) GO TO 9999
  20063. C
  20064. C  RELATION NAMES OKAY -- CHECK THE ATTRIBUTES
  20065. C
  20066. C  SET UP PTABLE IN MATRIX POSITION 10
  20067. C
  20068.       CALL BLKDEF(10,7,NATT2)
  20069.       PTABLE = BLKLOC(10)
  20070.       NATT3 = 0
  20071.       IF(ITEMS.EQ.6) GO TO 500
  20072. C
  20073. C  SUBTRACT ON SOME OF THE ATTRIBUTES
  20074. C
  20075.       IF(ITEMS-7.LE.NATT2) GO TO 350
  20076.     if(nout.eq.6)goto 3143
  20077.       WRITE(NOUT,9001)
  20078.  9001 FORMAT(38H -ERROR- Too Many Attributes Specified)
  20079.       GO TO 9999
  20080. 3143    write(c128wk,9001)
  20081.     call atxto
  20082.     goto 9999
  20083.   350 CONTINUE
  20084.       IJ = 1
  20085.       DO 400 I=8,ITEMS
  20086. C
  20087. C  RETRIEVE ATTRIBUTE LENGTH FOR OLD ATTRIBUTE
  20088. C
  20089. C
  20090. C  SEE IF IT FROM RELATION 1.
  20091. C
  20092.       ANAME = BLANK
  20093.       CALL LXSREC(I,1,8,ANAME,1)
  20094.       ICHK1 = LOCATT(ANAME,RNAME1)
  20095. C
  20096. C  SEE IF IT IS FROM RELATION 2.
  20097. C
  20098.       ICHK2 = LOCATT(ANAME,RNAME2)
  20099.       IF(ICHK2.NE.0) GO TO 450
  20100. C
  20101. C  ATTRIBUTE IS OKAY -- SET UP PTABLE
  20102. C
  20103.       CALL ATTGET(ISTAT)
  20104.       NATT3 = NATT3 + 1
  20105.       BUFFER(PTABLE) = LXWREC(I,1)
  20106.       BUFFER(PTABLE+1) = LXWREC(I,2)
  20107.       BUFFER(PTABLE+3) = ATTCOL
  20108.       BUFFER(PTABLE+4) = IJ
  20109.       NWORDS = ATTWDS
  20110.       BUFFER(PTABLE+5) = ATTLEN
  20111.       IF(NWORDS.EQ.0) NWORDS = 1
  20112.       IJ = IJ + NWORDS
  20113.       BUFFER(PTABLE+6) = ATTYPE
  20114.       IF(ICHK1.NE.0) GO TO 360
  20115.       ICHK1 = LOCATT(ANAME,RNAME1)
  20116.       CALL ATTGET(ISTAT)
  20117.       BUFFER(PTABLE+2) = ATTCOL
  20118.   360 CONTINUE
  20119.       PTABLE = PTABLE + 7
  20120. C
  20121.   400 CONTINUE
  20122.       ICT = IJ - 1
  20123.       GO TO 555
  20124. C
  20125. C  ATTRIBUTE WAS NOT IN RELATION 2
  20126. C
  20127.   450 CONTINUE
  20128.       CALL WARN(3,ANAME,RNAME2)
  20129.       GO TO 9999
  20130. C
  20131. C  SUBTRACT IS ON ALL ATTRIBUTES
  20132. C
  20133.   500 CONTINUE
  20134.       ICT = 1
  20135. C
  20136. C  STORE DATA FROM RELATION 2 IN PTABLE
  20137. C
  20138.       I = LOCATT(BLANK,RNAME2)
  20139.       DO 525 I=1,NATT2
  20140.       CALL ATTGET(ISTAT)
  20141.       IF(ISTAT.NE.0) GO TO 525
  20142.       NATT3 = NATT3 + 1
  20143.       BUFFER(PTABLE) = IBLANK
  20144.       CALL STRMOV(ATTNAM,1,8,BUFFER(PTABLE),1)
  20145.       BUFFER(PTABLE+3) = ATTCOL
  20146.       BUFFER(PTABLE+4) = ICT
  20147.       NWORDS = ATTWDS
  20148.       BUFFER(PTABLE+5) = ATTLEN
  20149.       IF(NWORDS.EQ.0) NWORDS = 1
  20150.       ICT = ICT + NWORDS
  20151.       BUFFER(PTABLE+6) = ATTYPE
  20152.       PTABLE = PTABLE + 7
  20153.   525 CONTINUE
  20154. C
  20155. C  MARK COMMON ATTRIBUTES FROM RELATION 1
  20156. C
  20157. C
  20158. C  FIRST CHECK TO SEE IF ATTRIBUTE IS ALREADY IN PTABLE
  20159. C
  20160.       KQ1 = BLKLOC(10) - 7
  20161.       DO 550 I=1,NATT2
  20162.       KQ1 = KQ1 + 7
  20163.       J = LOCATT(BUFFER(KQ1),RNAME1)
  20164.       IF(J.NE.0) GO TO 550
  20165. C
  20166. C  ALREADY THERE -- CHANGE THE 2ND POINTER
  20167. C
  20168.       CALL ATTGET(ISTAT)
  20169.       BUFFER(KQ1+2) = ATTCOL
  20170.   550 CONTINUE
  20171.       ICT = ICT - 1
  20172. C
  20173. C  DONE LOADING PTABLE
  20174. C
  20175. C  SEE IF THERE ARE ANY COMMON ATTRIBUTES.
  20176. C
  20177.   555 CONTINUE
  20178.       PTABLE = BLKLOC(10)
  20179.       DO 570 I = 1,NATT3
  20180.       IF((BUFFER(PTABLE+2).NE.0).AND.(BUFFER(PTABLE+3).NE.0)) GO TO 600
  20181.       PTABLE = PTABLE + 7
  20182.   570 CONTINUE
  20183. C
  20184. C  NO COMMON ATTRIBUTES
  20185. C
  20186.     if(nout.eq.6)goto 3144
  20187.       WRITE(NOUT,9002) RNAME1,RNAME2
  20188.  9002 FORMAT(19H -ERROR- RELATIONS ,A8,5H AND ,A8,
  20189.      X26H Have No Common Attributes)
  20190.       GO TO 9999
  20191. 3144    write(c128wk,9002)rname1,rname2
  20192.     call atxto
  20193.     goto 9999
  20194. C
  20195. C  PTABLE IS CONSTRUCTED
  20196. C
  20197. C  NOW CREATE ATTRIBUTE AND RELATION TABLES AND THE RELATION
  20198. C
  20199.   600 CONTINUE
  20200. C
  20201. C  SET UP THE WHERE CLAUSE FOR THE SUBTRACT.
  20202. C  THIS IS A DUMMY WHERE CLAUSE USED ONLY BY THE KEY PROCESSING
  20203. C
  20204.       KEYCOL = BUFFER(PTABLE+3)
  20205.       KEYTYP = BUFFER(PTABLE+6)
  20206.       NBOO = -1
  20207.       KATTL(1) = BUFFER(PTABLE+5)
  20208.       KATTY(1) = KEYTYP
  20209.       IF(KEYTYP.EQ.KZIVEC) KATTY(1) = KZINT
  20210.       IF(KEYTYP.EQ.KZRVEC) KATTY(1) = KZREAL
  20211.       IF(KEYTYP.EQ.KZDVEC) KATTY(1) = KZDOUB
  20212.       IF(KEYTYP.EQ.KZIMAT) KATTY(1) = KZINT
  20213.       IF(KEYTYP.EQ.KZRMAT) KATTY(1) = KZREAL
  20214.       IF(KEYTYP.EQ.KZDMAT) KATTY(1) = KZDOUB
  20215.       KOMPOS(1) = 1
  20216.       KSTRT = 0
  20217.       MAXTU = ALL9S
  20218.       LIMTU = ALL9S
  20219. C
  20220. C  SET UP RELATION TABLE.
  20221. C
  20222.       NAME = RNAME3
  20223.       CALL RMDATE(RDATE)
  20224.       NCOL = ICT
  20225.       NCOL3 = ICT
  20226.       NATT = NATT3
  20227.       NTUPLE = 0
  20228.       RSTART = 0
  20229.       REND = 0
  20230.       RPW = RPW2
  20231.       MPW = MPW2
  20232.       CALL RELADD
  20233. C
  20234.       CALL ATTNEW(NAME,NATT)
  20235.       PTABLE = BLKLOC(10)
  20236.       DO 700 K=1,NATT3
  20237.       ATTNAM = BLANK
  20238.       CALL STRMOV(BUFFER(PTABLE),1,8,ATTNAM,1)
  20239.       RELNAM = NAME
  20240.       ATTCOL = BUFFER(PTABLE+4)
  20241.       ATTLEN = BUFFER(PTABLE+5)
  20242.       ATTYPE = BUFFER(PTABLE+6)
  20243.       ATTKEY = 0
  20244.       CALL ATTADD
  20245.       PTABLE = PTABLE + 7
  20246.   700 CONTINUE
  20247. C
  20248. C  SEE IF WE CAN DO KEY PROCESSING.
  20249. C
  20250.       PTABLE = BLKLOC(10) - 7
  20251.       DO 800 K=1,NATT3
  20252.       PTABLE = PTABLE + 7
  20253.       IF(BUFFER(PTABLE+2).EQ.0) GO TO 800
  20254.       IF(BUFFER(PTABLE+3).EQ.0) GO TO 800
  20255.       J = LOCATT(BUFFER(PTABLE),RNAME1)
  20256.       IF(J.NE.0) GO TO 800
  20257.       CALL ATTGET(ISTAT)
  20258.       IF(ATTKEY.EQ.0) GO TO 800
  20259. C
  20260. C  WE FOUND A KEY ELEMENT IN MATN1 WHICH IS COMMON.
  20261. C
  20262.       KSTRT = ATTKEY
  20263.       NS = 2
  20264.       KATTL(1) = BUFFER(PTABLE+5)
  20265.       KATTY(1) = BUFFER(PTABLE+6)
  20266.       KEYCOL = BUFFER(PTABLE+3)
  20267.       GO TO 900
  20268.   800 CONTINUE
  20269.   900 CONTINUE
  20270. C
  20271. C  CALL SUBTRC TO CONSTRUCT MATN3
  20272. C
  20273.       CALL BLKDEF(11,MAXCOL,1)
  20274.       KQ3 = BLKLOC(11)
  20275.       PTABLE = BLKLOC(10)
  20276.       I = LOCREL(RNAME2)
  20277.       CALL SUBTRC(RNAME1,RNAME3,BUFFER(KQ3),NCOL3,NATT3,BUFFER(PTABLE),
  20278.      XKEYCOL,KEYTYP)
  20279.       GO TO 9999
  20280. C
  20281. C  SYNTAX ERROR IN SUBTRACT COMMAND
  20282. C
  20283.  9900 CONTINUE
  20284.       CALL WARN(4,0,0)
  20285. C
  20286. C
  20287. C  DONE WITH SUBTRACT
  20288. C
  20289.  9999 CONTINUE
  20290.       CALL BLKCLR(10)
  20291.       CALL BLKCLR(11)
  20292.       RETURN
  20293.       END
  20294.       SUBROUTINE SUBTRC(RNAME1,RNAME3,MATN3,NCOL3,NATT3,PTABLE,
  20295.      XKEYCOL,KEYTYP)
  20296.       INCLUDE rin:TEXT.BLK
  20297. C
  20298. C  THIS ROUTINE PERFORMS THE ACTUAL SUBTRACT BETWEEN
  20299. C  RELATION 1 AND 2 FORMING 3
  20300. C
  20301. C  PARAMETERS:
  20302. C         NAME1---NAME OF THE FIRST RELATION
  20303. C         MATN3---DATA TUPLE FOR RELATION 3
  20304. C         NCOL3---NUMBER OF FIXED LENGTH COLUMNS IN MATN3
  20305. C         NATT3---NUMBER OF ATTRIBUTES IN MATN3
  20306. C         PTABLE--POINTER TABLE FOR THIS SUBTRACT
  20307. C         KEYCOL--COLUMN OF MATN2 USED FOR SUPPLYING KEY VALUES
  20308. C         KEYTYP--ATTRIBUTE TYPE OF MATN1 USED FOR KEY VALUES
  20309.       INCLUDE rin:RMATTS.BLK
  20310.       INCLUDE rin:FILES.BLK
  20311.       INCLUDE rin:TUPLER.BLK
  20312.       INCLUDE rin:RIMPTR.BLK
  20313.       INCLUDE rin:RIMCOM.BLK
  20314.       INCLUDE rin:BUFFER.BLK
  20315.       INCLUDE rin:WHCOM.BLK
  20316.       INCLUDE rin:DCLAR1.BLK
  20317.       DIMENSION MATN3(*)
  20318.       INTEGER PTABLE(7,*)
  20319.       INTEGER ATTLEN
  20320.       INTEGER ENDCOL
  20321. C
  20322. C  INITIALIZE THE MATRIX POINTERS.
  20323. C
  20324.       IDST = 0
  20325.       IDNEW = 0
  20326.       IDCUR = NID
  20327. C
  20328. C  GET THE PARAMETERS FOR THE FIRST MATRIX.
  20329. C
  20330.       I = LOCREL(RNAME1)
  20331.       IDM1 = NID
  20332.       NSP = 0
  20333.       IF(KSTRT.NE.0) NSP = 2
  20334.       NTUP3 = 0
  20335. C
  20336. C  SEQUENCE THROUGH MATN2.
  20337. C
  20338.   100 CONTINUE
  20339.       IF(IDCUR.EQ.0) GO TO 1000
  20340.       CALL ITOH(N1,N2,IDCUR)
  20341.       IF(N2.EQ.0) GO TO 1000
  20342.       CALL GETDAT(2,IDCUR,MATN2,NCOL2)
  20343.       IF(IDCUR.LT.0) GO TO 1000
  20344. C
  20345. C  MOVE THE COMPARISON VALUE INTO THE WHCOM ARRAYS.
  20346. C
  20347.       CALL ITOH(NCHAR,NWORDS,KATTL(1))
  20348.       IP = MATN2 + KEYCOL - 1
  20349.       IF(NWORDS.NE.0) GO TO 110
  20350. C
  20351. C  SPECIAL GYRATIONS FOR VARIABLE LENGTH STUFF.
  20352. C
  20353.       IP2 = BUFFER(IP)
  20354.       IP = MATN2 + IP2 + 1
  20355.   110 CONTINUE
  20356.       WHRVAL(1) = BUFFER(IP)
  20357.       NID = IDM1
  20358.       NS = NSP
  20359.   200 CONTINUE
  20360.       CALL RMLOOK(MATN1,1,1,NCOL1)
  20361.       IF(RMSTAT.NE.0) GO TO 400
  20362. C
  20363. C  CHECK TO SEE IF THE ATTRIBUTES MATCH.
  20364. C
  20365.       K = 1
  20366.   300 CONTINUE
  20367.       CALL PTRS(IPT1,IPT2,K,NATT3,PTABLE,LEN,ITYPE)
  20368. C
  20369. C  IF K IS 0 WE HAVE LOOKED AT ALL THE COMMON ATTRIBUTES.
  20370. C
  20371.       IF(K.EQ.0) GO TO 100
  20372.       I1 = MATN1 + IPT1 - 1
  20373.       I2 = MATN2 + IPT2 - 1
  20374.       IF(LEN.EQ.0) GO TO 320
  20375.       DO 310 I=1,LEN
  20376.       IF(BUFFER(I1).NE.BUFFER(I2)) GO TO 200
  20377.       I1 = I1 + 1
  20378.       I2 = I2 + 1
  20379.   310 CONTINUE
  20380. C
  20381. C  A MATCH. LOOK AT MORE ATTRIBUTES.
  20382. C
  20383.       GO TO 300
  20384. C
  20385. C  VARIABLE LENGTH ATTRIBUTE PROCESSING.
  20386. C
  20387.   320 CONTINUE
  20388.       IPT1 = BUFFER(I1)
  20389.       IPT2 = BUFFER(I2)
  20390.       I1 = MATN1 + IPT1 - 1
  20391.       I2 = MATN2 + IPT2 - 1
  20392.       IF(BUFFER(I1).NE.BUFFER(I2)) GO TO 200
  20393.       LEN = BUFFER(I1)
  20394.       I1 = I1 + 2
  20395.       I2 = I2 + 2
  20396.       DO 340 I=1,LEN
  20397.       IF(BUFFER(I1).NE.BUFFER(I2)) GO TO 200
  20398.       I1 = I1 + 1
  20399.       I2 = I2 + 1
  20400.   340 CONTINUE
  20401.       GO TO 300
  20402. C
  20403. C  OKAY -- NOW LOAD THE DATA.
  20404. C
  20405.   400 CONTINUE
  20406.       ENDCOL = NCOL3
  20407.       DO 900 KLM=1,NATT3
  20408.       KOL2 = PTABLE(4,KLM)
  20409.       KOL3 = PTABLE(5,KLM)
  20410.       ATTLEN = PTABLE(6,KLM)
  20411.       CALL ITOH(NCHAR,NWORDS,ATTLEN)
  20412.       IF(NWORDS.EQ.0) GO TO 700
  20413.       DO 600 I=1,NWORDS
  20414. C
  20415. C  LOAD THE ATTRIBUTE FROM MATN2.
  20416. C
  20417.       I2 = MATN2 + KOL2 - 1
  20418.       MATN3(KOL3) = BUFFER(I2)
  20419.       KOL3 = KOL3 + 1
  20420.       KOL2 = KOL2 + 1
  20421.   600 CONTINUE
  20422.       GO TO 900
  20423.   700 CONTINUE
  20424.       ENDCOL = ENDCOL + 1
  20425.       MATN3(KOL3) = ENDCOL
  20426.       I2 = MATN2 + KOL2 - 1
  20427.       KOL2 = BUFFER(I2)
  20428.       I2 = MATN2 + KOL2 - 1
  20429.       NWORDS = BUFFER(I2)
  20430.       MATN3(ENDCOL) = NWORDS
  20431.       NWORDS = NWORDS + 1
  20432.       DO 800 I=1,NWORDS
  20433.       ENDCOL = ENDCOL + 1
  20434.       I2 = I2 + 1
  20435.       MATN3(ENDCOL) = BUFFER(I2)
  20436.   800 CONTINUE
  20437.   900 CONTINUE
  20438.       CALL ADDDAT(3,IDNEW,MATN3,ENDCOL)
  20439.       IF(IDST.EQ.0) IDST = IDNEW
  20440.       NTUP3 = NTUP3 + 1
  20441. C
  20442. C  LOOK FOR MORE IN MATN2.
  20443. C
  20444.       GO TO 100
  20445. C
  20446. C  ALL DONE.
  20447. C
  20448.  1000 CONTINUE
  20449.       I = LOCREL(RNAME3)
  20450.       CALL RELGET(ISTAT)
  20451.       RSTART = IDST
  20452.       REND = IDNEW
  20453.       NTUPLE = NTUP3
  20454.       CALL RELPUT
  20455.       NUM = NTUP3
  20456.     if(nout.eq.6)goto 3147
  20457.       WRITE(NOUT,9000) NUM
  20458.  9000 FORMAT(31H Successful SUBTRACT Operation ,
  20459.      XI6,15H Rows Generated)
  20460. C
  20461. C  RETURN
  20462. C
  20463.       RETURN
  20464. 3147    write(c128wk,9000)num
  20465.     call atxto
  20466.     return
  20467.       END
  20468.       SUBROUTINE SWCON(BUFFER,LBUF,INFIL,OUTFIL,IERR)
  20469.       INCLUDE rin:TEXT.BLK
  20470. C
  20471. C  PURPOSE  CONTROLLING ROUTINE FOR SORT
  20472. C
  20473. C  METHOD   ROUTINE DETERMINES WHICH KIND
  20474. C           OF SORT IS REQUIRED AND CALLS
  20475. C           APPLICABLE ROUTINE TO CARRY OUT SORT
  20476. C           THE 4 TYPES OF SORT THAT ARE AVAILABLE ARE
  20477. C
  20478. C           INCORE,LINK LIST (HART)
  20479. C           INCORE,IN SITU POINTERS
  20480. C           OUT-OF-CORE,FIXED TUPLE SIZE
  20481. C           OUT-OF-CORE,VARIABLE TUPLE SIZE
  20482. C           INCORE SORT IS FIXED OR VARIABLE
  20483. C           LTUPLE TUPLES
  20484. C
  20485. C  TIMING   UNKNOWN
  20486. C
  20487. C  DEFINITION OF VARIABLES
  20488. C
  20489. C  INFIL   FILE NAME OF FILE (SEQ) WHICH    (INT,I)
  20490. C          CONTAINS INPUT TUPLES
  20491. C         INFIL IS UNFORMATTED (BINARY)
  20492. C         EACH TUPLE IS WRITTEN AS A
  20493. C         RECORD AS FOLLOWS
  20494. C         FOR FIXED LENGTH RECORDS
  20495. C           WRITE(INFIL) (TUP(I),I=1,LTUPLE)
  20496. C         FOR VARIABLE LENGTH RECORDS
  20497. C           WRITE(INFIL) L,(TUP(I),I=1,L)
  20498. C
  20499. C  OUTFIL  FILE NAME OF FILE (SEQ) WHICH    (INT,I)
  20500. C          CONTAINS OUTPUT (SORTED) TUPLES
  20501. C          OUTFIL MAY EQ INFIL
  20502. C          FORMAT OF OUTFIL IS THE
  20503. C          SAME AS THAT OF INFIL
  20504. C
  20505. C  IERR    ERROR CONDITION                  (INT,O)
  20506. C           0 NORMAL RETURN
  20507. C           1 ERROR IN FILE READ
  20508. C           2 ERROR IN FILE WRITE
  20509. C
  20510.       INCLUDE rin:CONST8.BLK
  20511.       INCLUDE rin:SRTCOM.BLK
  20512.       INTEGER OUTFIL,INFIL
  20513.       REAL*8 SCFIL1,SCFIL2
  20514. C
  20515. C  THE FOLLOWING THREE EXEC STATEM TO BE REPL
  20516. C  WITH UPDATE *CALL
  20517. C
  20518.       INTEGER BUFFER(*)
  20519.       INTEGER DPRU
  20520.       INCLUDE rin:DATA4.BLK
  20521. C
  20522. C  ESTABLISH RANDOM SCRATCH FILE NAMES
  20523. C
  20524.       SCFIL1 = K8ZZ98
  20525.       SCFIL2 = K8ZZ99
  20526.       REWIND INFIL
  20527.       I1 = 2*NSORT + 12
  20528.       IF(NSORT .GT. 2000) I1 = I1 + 89
  20529.    20 CONTINUE
  20530.       I3 = LTUPLE
  20531.       IF(FIXLT) I3 = LTUPLE*NSORT
  20532.       IF(I1+I3 .GT. LBUF) GO TO 100
  20533. C
  20534. C  INCORE SORT,HART METHOD
  20535. C
  20536.       CALL SWHART(INFIL,OUTFIL,BUFFER,I1,IERR)
  20537.       GO TO 400
  20538.   100 CONTINUE
  20539.       IF(NSORT+I3 .GT. LBUF) GO TO 200
  20540. C
  20541. C  INCORE SORT,POINTERS IN SITU
  20542. C
  20543.       CALL SWINPO(INFIL,OUTFIL,BUFFER,IERR)
  20544.       GO TO 400
  20545.   200 CONTINUE
  20546. CC
  20547. C  OUT-OF-CORE SORT
  20548. C
  20549.       IF( FIXLT) GO TO 300
  20550. C
  20551. C  VARIABLE LENGTH OUT-OF-CORE SORT
  20552. C
  20553.       CALL SWVLFS(INFIL,OUTFIL,SCFIL1,SCFIL2,
  20554.      X                 BUFFER,LBUF,LPRU,DPRU,IERR)
  20555.       GO TO 400
  20556.   300 CONTINUE
  20557. C
  20558. C  FIXED TUPLE LENGTH,OUT-OF-CORE SORT
  20559. C
  20560.       CALL SWFLFS(INFIL,OUTFIL,SCFIL1,SCFIL2,
  20561.      X                 BUFFER,LBUF,LPRU,DPRU,IERR)
  20562.   400 CONTINUE
  20563.       REWIND OUTFIL
  20564.       RETURN
  20565.       END
  20566.       SUBROUTINE SWCOST(NOPASS,NREC,LREC,SORD,COST)
  20567.       INCLUDE rin:TEXT.BLK
  20568. C
  20569. C  PURPOSE  DETERMINE COST OF A SORTING STRATEGY
  20570. C
  20571. C  METHOD   COMPUTE COST FROM FORMULA
  20572. C           COST=NOPASS*(2*NREC*(IOPOSC+LREC*IOTRAC) +
  20573. C                 + NSORT*NSOVAR*.5*SORD*COCOST
  20574. C                 + NREC*LREC*MOCOFI
  20575. C                 + NREC*(LREC-1)*MOCOAD)
  20576. C
  20577. C  DEFINITION OF PARAMETERS
  20578. C
  20579. C  NOPASS  NUMBER OF SORT PASSES EXCLUDING SEQUENTIAL     (INT,I)
  20580. C          READ AND WRITE (FIRST AND LAST)
  20581. C          EACH PASS CONSISTS OF ONE READ AND ONE WRITE
  20582. C
  20583. C  NREC   NUMBER OF PAGES ON SORT SCRATCH FILE           (INT,I)
  20584. C
  20585. C  LREC    LENGTH OF A SORT PAGE                          (INT,I)
  20586. C
  20587. C  SORD     SORT ORDER,I.E. NUMBER OF INPUT SORT BLOCKS   (INT,I)
  20588. C           IN CORE DURING MERGE PHASE
  20589. C
  20590. C  COST FORMULA PARAMETERS
  20591. C
  20592. C  IOPOSC  = RELATIVE COST FOR I OR O POSITIONING
  20593. C
  20594. C  IOTRAC  = RELATIVE COST OF I OR O TRANSFER OF ONE WORD
  20595. C
  20596. C  COCOST  = RELATIVE COST OF COMPARING TWO SINGLE VARIABLES
  20597. C
  20598. C  MOCOFI  = RELATIVE COST OF MOVING FIRST WORD OF ONE
  20599. C            BLOCK IN CORE
  20600. C
  20601. C  MOCOAD  = RELATIVE COST OF MOVING ADDITIONAL WORDS
  20602. C            OF THE BLOCK IN CORE
  20603. C
  20604.       INCLUDE rin:SRTCOM.BLK
  20605.       INTEGER SORD
  20606.       REAL IOPOSC,IOTRAC,COCOST,MOCOFI,MOCOAD
  20607.       INCLUDE rin:DATA5.BLK
  20608.       COST = NOPASS*(2*NREC*(IOPOSC+LREC*IOTRAC)
  20609.      X      +NSORT*NSOVAR*.5*SORD*COCOST
  20610.      X      +NREC*MOCOFI+NREC*(LREC-1)*MOCOAD)
  20611.       RETURN
  20612.       END
  20613.       SUBROUTINE SWFILO(BUFFER,LTUP,LREC,NTUREC,NINTUP,
  20614.      X                  INFIL,OUTFIL)
  20615.       INCLUDE rin:TEXT.BLK
  20616. C
  20617. C  PURPOSE  LOADING PASS FOR OUT-OF-CORE SORT
  20618. C           OF FIXED LENGTH TUPLES
  20619. C
  20620. C  TIMING   UNKNOWN
  20621. C
  20622. C  DEFINITION OF VARIABLES
  20623. C
  20624. C  BUFFER   CORE SCRATCH AREA OF                  (SCRATCH)
  20625. C           SUFFICIENT LENGTH
  20626. C              GE NINTUP*(1+LREC)+NTUREC*LREC
  20627. C
  20628. C  LTUP     LENGTH, IN WORDS, OF INDIVIDUAL       (INT,I)
  20629. C           TUPLE
  20630. C
  20631. C  LREC     LENGTH, IN WORDS, OF OUTPUT RECORD    (INT,I)
  20632. C
  20633. C  NTUREC   NUMBER OF TUPLES PER OUTPUT           (INT,I)
  20634. C           RECORD
  20635. C
  20636. C  NINTUP     NUMBER OF TUPLES                      (INT,I)
  20637. C           IN ONE SORT CHAIN
  20638. C
  20639. C
  20640. C  INFIL   FILE NAME OF FILE (SEQ) WHICH    (INT,I)
  20641. C           CONTAINS INPUT TUPLES
  20642. C           INFIL IS UNFORMATTED (BINARY)
  20643. C           EACH TUPLE IS WRITTEN AS A
  20644. C           RECORD AS FOLLOWS
  20645. C           FOR FIXED LENGTH RECORDS
  20646. C             WRITE(INFIL) (TUP(I),I=1,LTUPLE)
  20647. C           FOR VARIABLE LENGTH RECORDS
  20648. C             WRITE(INFIL) L,(TUP(I),I=1,L)
  20649. C
  20650. C  OUTFIL   FET FOR FILE      (RANDOM) WHICH      (INT,I)
  20651. C           CONTAINS CHAINS OF SORTED TUPLES
  20652. C           EACH CHAIN CONTAINS ONE OR MORE BLOCKS
  20653. C           EACH BLOCK CONTAINS
  20654. C            WORD 1   = NO TUPLES IN BLOCK
  20655. C            WORD 2   = CHAIN NO,NEG FOR LAST BLOCK
  20656. C            WORD 3FF = TUPLES INSORTED ORDER
  20657. C
  20658. C
  20659.       INCLUDE rin:SRTCOM.BLK
  20660.       INTEGER BUFFER(*)
  20661.       REWIND INFIL
  20662.       I2 = 0
  20663.       J1 = NINTUP*(1+LTUP)
  20664.       I8 = 0
  20665.    10 CONTINUE
  20666.       I8 = I8 + 1
  20667.       I1 = NINTUP
  20668.       DO 20 I=1,NINTUP
  20669.       READ(INFIL) (BUFFER(I1+I3),I3=1,LTUP)
  20670.       I2 = I2 + 1
  20671.       BUFFER(I) = I1 + 1
  20672.       I1 = I1 + LTUP
  20673.       IF(I2 .EQ. NSORT) GO TO 21
  20674.    20 CONTINUE
  20675.       I = NINTUP
  20676.    21 CONTINUE
  20677. C
  20678. C     READ COMPLETE FOR ONE CHAIN - SORT
  20679. C
  20680.       CALL SWICST(BUFFER,BUFFER,I)
  20681. C
  20682. C     SORT COMPLETE - UNLOAD
  20683. C
  20684.       I3 = 0
  20685.    40 CONTINUE
  20686.       I4 = J1 + 2
  20687.       DO 50 I5=1,NTUREC
  20688.       I3 = I3 + 1
  20689.       I7 = BUFFER(I3) - 1
  20690.       DO 45 I6=1,LTUP
  20691.    45 BUFFER(I4+I6) = BUFFER(I7+I6)
  20692.       I4 = I4 + LTUP
  20693.       IF(I3 .EQ. I) GO TO 55
  20694.    50 CONTINUE
  20695.       I5 = NTUREC
  20696.    55 CONTINUE
  20697. C
  20698. C  WRITE ONE RECORD
  20699. C
  20700.       BUFFER(J1+1) = I5
  20701.       I7 = I8
  20702.       IF(I3 .EQ. I) I7 = -I7
  20703.    60 BUFFER(J1+2) = I7
  20704. C
  20705. C  ADD IN RANDOM I/O STUFF
  20706. C
  20707.       CALL RIOOUT(OUTFIL,0,BUFFER(J1+1),LREC,IOS)
  20708.       IF(I3 .LT. I) GO TO 40
  20709.       IF(I2 .LT. NSORT) GO TO 10
  20710. C
  20711. C     SORT PASS COMPLETE FOR ALL CHAINS
  20712. C
  20713.       RETURN
  20714.       END
  20715.       SUBROUTINE SWFLFS(INFIL,OUTFIL,SCFIL1,SCFIL2,
  20716.      X                 BUFFER,LBUF,LPRU,DPRU,IERR)
  20717.       INCLUDE rin:TEXT.BLK
  20718. C
  20719. C  PURPOSE  DRIVER FOR OUT-OF-CORE SORT
  20720. C           OF FIXED LENGTH TUPLES
  20721. C
  20722. C  METHOD   A LEAST COST SORT STRATEGY
  20723. C           IS ESTABLISHED BASED UPON
  20724. C           MACHINE DEPENDENT PARAMETERS
  20725. C           THE COST IS BASED UPON
  20726. C           COST FOR POSITIONING ON
  20727. C           MASS STORAGE,MASS STORAGE
  20728. C           TRANSFERS,IN-CORE MOVEMENT
  20729. C           OF DATA AND COMPARISON OF
  20730. C           DATA.
  20731. C           AN N-ARY SORT/MERGE STRATEGY
  20732. C           IS CHOOSEN WHERE 2 LE N LE 9
  20733. C           N IS THE NUMBER OF CHAINS
  20734. C           OF DATA THAT IS MERGED IN
  20735. C           ONE SINGLE MERGE. EACH SORT PASS
  20736. C           MAY REQUIRE SEVERAL SUCH MERGES.
  20737. C
  20738. C
  20739. C
  20740. C
  20741. C  DEFINITION OF VARIABLES
  20742. C
  20743. C  INFIL   FILE NAME OF FILE (SEQ) WHICH    (TEXT,I)
  20744. C          CONTAINS INPUT TUPLES
  20745. C         INFIL IS UNFORMATTED (BINARY)
  20746. C         EACH TUPLE IS WRITTEN AS A
  20747. C         RECORD AS FOLLOWS
  20748. C         FOR FIXED LENGTH RECORDS
  20749. C           WRITE(INFIL) (TUP(I),I=1,LTUPLE)
  20750. C         FOR VARIABLE LENGTH RECORDS
  20751. C           WRITE(INFIL) L,(TUP(I),I=1,L)
  20752. C
  20753. C  OUTFIL  FILE NAME OF FILE (SEQ) WHICH    (TEXT,I)
  20754. C          CONTAINS OUTPUT (SORTED) TUPLES
  20755. C          OUTFIL MAY EQ INFIL
  20756. C          FORMAT OF OUTFIL IS THE
  20757. C          SAME AS THAT OF INFIL
  20758. C
  20759. C  SCFIL1  FILE NAME OF (RAN) SCRATCH FILE  (TEXT,I)
  20760. C
  20761. C  SCFIL2  FILE NAME OF (RAN) SCRATCH FILE  (TEXT,I)
  20762. C          NOTE THAT SCFIL1 MUST NOT BE
  20763. C          EQUAL TO SCFIL2
  20764. C
  20765. C  BUFFER  INCORE SCRATCH AREA              (ANY,SCRATCH)
  20766. C
  20767. C  LBUF    LENGTH OF BUFFER                 (INT,I)
  20768. C
  20769. C  LPRU    QUANTUM LENGTH OF RANDOM         (INT,I)
  20770. C          FILE RECORDS
  20771. C
  20772. C  DPRU    DELTA QUANTUM LENGTH OF          (INT,I)
  20773. C          RANDOM FILE RECORDS.
  20774. C          THE LENGTH OF SUCH A RECORD
  20775. C          MUST EQUAL
  20776. C          I*LPRU+DPRU
  20777. C
  20778. C  IERR    ERROR CONDITION                  (INT,O)
  20779. C           0 NORMAL RETURN
  20780. C           1 ERROR IN FILE READ
  20781. C           2 ERROR IN FILE WRITE
  20782. C
  20783. C
  20784. C  DEFINITION OF LOCAL VARIABLES
  20785. C
  20786. C  I1     SCRATCH
  20787. C  I2     SCRATCH,NO OF PAGES IN INITIAL
  20788. C         OFLOADING
  20789. C  I3     SCRATCH,NO OF SORT PASSES,NOT COUNTING
  20790. C         ACTIONS ON SEQUENTIAL FILES
  20791. C         OF WHOLE RANDOM FILES
  20792. C  I4     SCRATCH
  20793. C  I5     SCRATCH
  20794. C  I6     LOW COST SORT ORDER
  20795. C  I7     NO OF INCORE PAGES IN INITIAL
  20796. C         PASS WHERE SEQUENTIAL FILE IS
  20797. C         OFFLOADED
  20798. C  I8     SCRATCH,NO OF TUPLES PER RAN FILE PAGE
  20799. C  I9     SCRATCH,NO OF PAGES ON RANDOM FILES
  20800. C  I10    SCRATCH,LENGTH OF RANDOM FILE PAGE
  20801. C  COST   COST OF OPTIMUM SORT STRATEGY
  20802. C  NTUREC NO OF TUPLES PER RANDOM FILE PAGE
  20803. C  NRECS  NO OF PAGES ON RANDOM SCRATCH FILE
  20804. C  LREC   LENGTH OF RANDOM FILE PAGE
  20805. C  NPASS  NO OF SORT PASSES,NOT COUNTING
  20806. C         ACTIONS ON SEQUENTIAL FILES
  20807. C         ONE PASS CONTAINS ONE COMPLETE
  20808. C         WRITE AND ONE COMPLETE READ
  20809. C         OF WHOLE RANDOM FILES
  20810. C
  20811.       INCLUDE rin:SRTCOM.BLK
  20812.       DIMENSION BUFFER(*)
  20813.       INTEGER DPRU
  20814.       INTEGER SCARR1,SCARR2
  20815.       REAL*8 SCFIL1,SCFIL2
  20816.       INTEGER CHAIN1,OUTREC
  20817.       LOGICAL SWITCH
  20818.       LTUP = LTUPLE
  20819.       I6 = 0
  20820.       I1 = 2*LPRU
  20821.       I11 = 2*DPRU
  20822.       DO 100 I=2,9
  20823.       I1 = I1 + LPRU
  20824.       I11 = I11 + DPRU
  20825.       I10 = LPRU*((LBUF-I11)/I1) + DPRU
  20826.       IF(I10 .LT. LTUP) GO TO 110
  20827.       I8 = (I10-2)/LTUP
  20828.       I2 = (LBUF-I10)/(I10+I8)
  20829. C
  20830. C  I2 IS NO OF INCORE BLOCKS IN
  20831. C     INITIAL PASS
  20832. C
  20833.       I9 =(NSORT+I8-1)/I8
  20834.       I3 = 1
  20835.       I4 = I2
  20836.    10 CONTINUE
  20837.       I5 = I4
  20838.       I4 = I4*I + I5
  20839.       IF (I4 .GE. I9) GO TO 20
  20840.       I4 = I4 - I5
  20841.       I3 = I3 + 1
  20842.       GO TO 10
  20843.    20 CONTINUE
  20844. C
  20845.       CALL SWCOST(I3,I9,I10,I,A1)
  20846.       IF(I6 .GT. 0) GO TO 30
  20847.       GO TO 35
  20848.    30 CONTINUE
  20849.       IF(A1 .GE. COST) GO TO 90
  20850.    35 COST = A1
  20851.       I7 = I2
  20852.       I6 = I
  20853.       NTUREC = I8
  20854.       NRECS = I9
  20855.       NPASS = I3
  20856.       LREC = I10
  20857.    90 CONTINUE
  20858.       IF(I3 .EQ. 1) GO TO 110
  20859.   100 CONTINUE
  20860.   110 CONTINUE
  20861. C
  20862. C  OPTIMUM SORT STRATEGY DETERMINED
  20863. C
  20864. C  OPEN SORT SCRATCH FILES
  20865. C
  20866.       SCARR1 = 35
  20867.       SCARR2 = 36
  20868.       CALL DROPF(SCFIL1)
  20869.       CALL DROPF(SCFIL2)
  20870.       CALL RIOOPN(SCFIL1,SCARR1,LREC,IOS)
  20871.       CALL RIOOPN(SCFIL2,SCARR2,LREC,IOS)
  20872.       CALL SWFILO(BUFFER,LTUP,LREC,NTUREC,I7*NTUREC,
  20873.      X            INFIL,SCARR1)
  20874. C
  20875. C     NPASS IS THE NUMBER OF RANDOM TO RANDOM MERGES
  20876. C     NI IS THE NUMBER OF CHAINS ON THE INPUT FILE
  20877. C     NO IS THE NUMBER OF CHAINS ON THE OUTPUT FILE
  20878. C     NCHAIN IS THE NUMBER OF CHAINS TO MERGE
  20879. C     LCHAIN IS THE NUMBER OF PAGES PER INPUT CHAIN
  20880. C
  20881.       LCHAIN = I7
  20882.       NCHAIN = I6
  20883.       NI = (NRECS-1)/LCHAIN
  20884.       NI = NI + 1
  20885.       NO = NI
  20886.       SWITCH = .TRUE.
  20887. C
  20888. C     OUTER LOOP ON THE NUMBER OF PASSES
  20889. C
  20890.       NPASS = NPASS - 1
  20891.       IF(NPASS.EQ.0) GO TO 250
  20892.       DO 200 I=1,NPASS
  20893.       NI = NO
  20894.       NO = (NI-1)/NCHAIN
  20895.       NO = NO + 1
  20896.       SWITCH = .NOT. SWITCH
  20897.       INC = LCHAIN*NCHAIN
  20898. C
  20899. C     INNER LOOP ON NUMBER OF OUTPUT CHAINS
  20900. C
  20901.       DO 150 J=1,NO
  20902.       CHAIN1 = (J-1)*INC + 1
  20903.       OUTREC = CHAIN1
  20904.       IF(I.EQ.1) OUTREC = 0
  20905.       NCH = NCHAIN
  20906.       IF(J.EQ.NO) NCH = NI - (NO-1)*NCHAIN
  20907.       IF(SWITCH) CALL SWSMFL(BUFFER,CHAIN1,NCH,LCHAIN,OUTREC,J,NTUREC,
  20908.      X       LTUP,LREC,SCARR2,SCARR1)
  20909.       IF(.NOT.SWITCH) CALL SWSMFL(BUFFER,CHAIN1,NCH,LCHAIN,OUTREC,J,
  20910.      X       NTUREC,LTUP,LREC,SCARR1,SCARR2)
  20911.   150 CONTINUE
  20912.       LCHAIN = LCHAIN * NCHAIN
  20913.   200 CONTINUE
  20914.   250 CONTINUE
  20915. C
  20916. C     CALL SWUNLO TO CREATE OUTPUT SEQUENTIAL FILE
  20917. C
  20918.       CHAIN1 = 1
  20919.       OUTREC = 1
  20920.       NCH = NO
  20921.       IF(SWITCH) CALL SWUNLO(BUFFER,CHAIN1,NCH,LCHAIN,
  20922.      X      LTUP,LREC,SCARR1,OUTFIL)
  20923.       IF(.NOT.SWITCH) CALL SWUNLO(BUFFER,CHAIN1,NCH,LCHAIN,
  20924.      X      LTUP,LREC,SCARR2,OUTFIL)
  20925. C
  20926. C     RETURN THE SCRATCH RANDOM FILES
  20927. C
  20928.       CALL DROPF(SCFIL1)
  20929.       CALL DROPF(SCFIL2)
  20930.       RETURN
  20931.       END
  20932.       SUBROUTINE SWHART(INFIL,OUTFIL,BUFFER,LLL,IERR)
  20933.       INCLUDE rin:TEXT.BLK
  20934.       INCLUDE rin:SRTCOM.BLK
  20935.       INTEGER BUFFER(*)
  20936.       INTEGER OUTFIL
  20937. C
  20938. C  PURPOSE  CONTROLLING ROUTINE FOR IN-CORE HART SORT
  20939. C
  20940. C  TIMING   UNKNOWN
  20941. C
  20942. C  DEFINITION OF VARIABLES
  20943. C
  20944. C  INFIL   FILE NAME OF FILE (SEQ) WHICH    (INT,I)
  20945. C          CONTAINS INPUT TUPLES
  20946. C         INFIL IS UNFORMATTED (BINARY)
  20947. C         EACH TUPLE IS WRITTEN AS A
  20948. C         RECORD AS FOLLOWS
  20949. C         FOR FIXED LENGTH RECORDS
  20950. C           WRITE(INFIL) (TUP(I),I=1,LTUPLE)
  20951. C         FOR VARIABLE LENGTH RECORDS
  20952. C           WRITE(INFIL) L,(TUP(I),I=1,L)
  20953. C
  20954. C  OUTFIL  FILE NAME OF FILE (SEQ) WHICH    (INT,I)
  20955. C          CONTAINS OUTPUT (SORTED) TUPLES
  20956. C          OUTFIL MAY EQ INFIL
  20957. C          FORMAT OF OUTFIL IS THE
  20958. C          SAME AS THAT OF INFIL
  20959. C
  20960. C  BUFFER  CORE BUFFER TO USE FOR SORT      (ANY,SCR)
  20961. C
  20962. C  LLL     LENGTH OF LINK LIST              (INT,I)
  20963. C
  20964. C  IERR    ERROR CONDITION                  (INT,O)
  20965. C           0 NORMAL RETURN
  20966. C           1 ERROR IN FILE READ
  20967. C           2 ERROR IN FILE WRITE
  20968. C
  20969.       IF(FIXLT) GO TO 10
  20970. C
  20971. C  INCORE,VAR LENGTH
  20972. C
  20973.       I1 = LLL + 1
  20974.       DO 5 I2=1,NSORT
  20975.       BUFFER(I2) = I1 + 1
  20976. c      READ(INFIL) I4,(BUFFER(I1+I5),I5=1,I4)
  20977.       READ(INFIL) I4
  20978.       READ(INFIL) (BUFFER(I1+I5),I5=1,I4)
  20979.       BUFFER(I1) = I4
  20980.     5 I1 = I1 + I4 + 1
  20981.       GO TO 20
  20982.    10 CONTINUE
  20983. C
  20984. C  INCORE,FIXED LENGTH TUPLES
  20985. C
  20986.       I1 = LLL
  20987.       DO 15 I2=1,NSORT
  20988.       BUFFER(I2)= I1 + 1
  20989.       READ(INFIL) (BUFFER(I1+I4),I4=1,LTUPLE)
  20990.    15 I1 = I1 + LTUPLE
  20991.    20 CONTINUE
  20992. C
  20993. C  READ COMPLETED,SORT
  20994. C
  20995.       KGOTO = VARTYP(1)
  20996.       GO TO(21,22,23,23),KGOTO
  20997.    21 CALL SWHRTI(BUFFER(1),BUFFER(NSORT+1),BUFFER)
  20998.       GO TO 24
  20999.    22 CALL SWHRTR(BUFFER(1),BUFFER(NSORT+1),BUFFER)
  21000.       GO TO 24
  21001.    23 CALL SWHRTD(BUFFER(1),BUFFER(NSORT+1),BUFFER)
  21002.    24 CONTINUE
  21003. C
  21004. C  SORT COMPLETE,UNLOAD
  21005. C
  21006.       REWIND OUTFIL
  21007.       I5 = 2*NSORT + 1
  21008.       IF(FIXLT) GO TO 40
  21009. C
  21010. C  VARIABLE LENGTH TUPLES
  21011. C
  21012.       DO 35 I2=1,NSORT
  21013.       I3 = BUFFER(I5)
  21014.       I5 = NSORT + I3
  21015.       I1 = BUFFER(I3) - 1
  21016.       I4 = BUFFER(I1)
  21017.       WRITE(OUTFIL) I4,(BUFFER(I3+I1),I3=1,I4)
  21018.    35 CONTINUE
  21019.       RETURN
  21020.    40 CONTINUE
  21021. C
  21022. C  WRITE FIXED LENGTH TUPLES
  21023. C
  21024.       DO 45 I2=1,NSORT
  21025.       I3 = BUFFER(I5)
  21026.       I5 = I3 + NSORT
  21027.       I4 = BUFFER(I3) - 1
  21028.       WRITE(OUTFIL) (BUFFER(I3+I4),I3=1,LTUPLE)
  21029.    45 CONTINUE
  21030.       RETURN
  21031.       END
  21032.       SUBROUTINE SWHRTD(NN,LL,BUFFER)
  21033.       INCLUDE rin:TEXT.BLK
  21034. C
  21035. C  PURPOSE   TO SORT FIXED OR VARIABLE LENGTH
  21036. C            TUPLES ON ONE OR MORE ATTRIBUTES
  21037. C            INCORE SORT
  21038. C            GENERAL PURPOSE SORT
  21039. C
  21040. C  METHOD    FAST SORTING ALGORITHM PUBLISHED
  21041. C            1978 BY HART
  21042. C            CREATIVE COMPUTING JAN/FEB 1978
  21043. C            P 96 FF
  21044. C
  21045. C  TIMING   .13 CP SEC CYBER 760
  21046. C          1000 TUPLES,1 ATTRIBUTE SORT (INT)
  21047. C
  21048. C  DEFINITION OF VARIABLES
  21049. C
  21050. C  NN       VECTOR OF POINTERS TO BUFFER    (INT,I)
  21051. C
  21052. C  LL       LINK LIST OF POINTERS TO NN     (INT,O)
  21053. C           THE LIST DEFINES THE SORTED ORDER
  21054. C           ORDER OF BUFFER
  21055. C
  21056. C  BUFFER    VECTOR CONTAINING TUPLES TO SORT    (ANY,I)
  21057. C            NN POINTER ARE RELATIVE TO BUFFER(1)
  21058. C
  21059.       INCLUDE rin:SRTCOM.BLK
  21060.       INTEGER SWIICP,SWIRCP,SWIDCP,SWITCP
  21061.       DIMENSION NN(*),LL(*)
  21062.       INTEGER BUFFER(*)
  21063.       INTEGER S1
  21064.       K1=0
  21065.       I=0
  21066.       M1=0
  21067.       T2=0.
  21068.       T4=0.
  21069.       J=NSORT+1
  21070.       LL(1)=1
  21071.       LL(J)=1
  21072.       K2=1
  21073.       IF(NSORT.LE.1) RETURN
  21074.       S1=NSORT
  21075.   250 CONTINUE
  21076. C  CLIMB THE TREE
  21077.       IF(S1.LT.4) GO TO 320
  21078.       K2=K2*2
  21079.       B2=S1
  21080.       B2=B2/2.
  21081.       S1=INT(B2)
  21082.       T4=T4+(B2-S1)*K2
  21083.       GO TO 250
  21084.   320 CONTINUE
  21085. C  INITIAL CALCULATIONS
  21086.       T4=K2-T4
  21087.       B2=K2/2
  21088.   350 CONTINUE
  21089. C  NEXT TWIG
  21090.       IF(K1.EQ.K2) RETURN
  21091.       K1=K1+1
  21092.       T1=K1
  21093.       B1=B2
  21094.       T3=T2
  21095.   400 CONTINUE
  21096. C  ADD 1 TO REFLECTED BINARY COUNTER AND CARRY
  21097.       T1=T1/2.
  21098.       IF(INT(T1).LT.T1) GO TO 470
  21099.       M1=M1+1
  21100.       T2=T2-B1
  21101.       B1=B1/2.
  21102.       GO TO 400
  21103.   470 CONTINUE
  21104. C  TWIG CALCULATIONS
  21105.       T2=T2+B1
  21106.       IF(S1.EQ.2) GO TO 550
  21107. C  3-TWIGS AND 4-TWIGS
  21108.       IF(T3.LT.T4) GO TO 560
  21109. C  4-TWIG
  21110.       M1=-M1
  21111.       GO TO 630
  21112.   550 IF(T3.LT.T4) GO TO 610
  21113.   560 CONTINUE
  21114. C  3-TWIG
  21115.       M1=M1+1
  21116.       I=I+1
  21117.       LL(I)=I
  21118.       LL(J)=I
  21119.       J=J+1
  21120.   610 CONTINUE
  21121. C  2-TWIG
  21122.       M1=M1+1
  21123.   630 I=I+1
  21124.       L1=I
  21125.       LL(I)=I
  21126.       LL(J)=I
  21127.       L0=J
  21128.       J=J+1
  21129.       I=I+1
  21130.       L2=I
  21131.       LL(I)=I
  21132.       LL(J)=I
  21133.       GO TO 750
  21134.   700 CONTINUE
  21135. C  MERGE TWIGS AND BRANCHES
  21136.       J=J-1
  21137.       L0=J-1
  21138.       L1=LL(L0)
  21139.       L2=LL(J)
  21140.   750 CONTINUE
  21141.       DO 760 J3=1,NSOVAR
  21142.       JJ3 = VARPOS(J3) - 1
  21143.       NNL1 = NN(L1) + JJ3
  21144.       NNL2 = NN(L2) + JJ3
  21145.       KGOTO = VARTYP(J3)
  21146.       GO TO (751,752,753,754),KGOTO
  21147.   751 J2 = BUFFER(NNL2) - BUFFER(NNL1)
  21148.       GO TO 755
  21149.   752 J2 = SWIRCP(BUFFER(NNL1),BUFFER(NNL2))
  21150.       GO TO 755
  21151.   753 J2 = SWIDCP(BUFFER(NNL1),BUFFER(NNL2))
  21152.       GO TO 755
  21153.   754 J2 = SWITCP(BUFFER(NNL1),BUFFER(NNL2))
  21154.   755 CONTINUE
  21155.       IF(J2 .EQ. 0) GO TO 760
  21156.       IF((J2 .GT. 0 .AND. SORTYP(J3)) .OR.
  21157.      X   (J2 .LT. 0 .AND. .NOT. SORTYP(J3)))
  21158.      XGO TO 820
  21159.       GO TO 765
  21160.   760 CONTINUE
  21161.       GO TO 820
  21162.   765 CONTINUE
  21163.       LL(L0)=L2
  21164.   770 L0=L2
  21165.       L2=LL(L0)
  21166.       IF(L2.EQ.L0) GO TO 870
  21167.       DO 790 J3=1,NSOVAR
  21168.       JJ3 = VARPOS(J3) - 1
  21169.       NNL1 = NN(L1) + JJ3
  21170.       NNL2 = NN(L2) + JJ3
  21171.       KGOTO = VARTYP(J3)
  21172.       GO TO (781,782,783,784),KGOTO
  21173.   781 J2 = BUFFER(NNL2) - BUFFER(NNL1)
  21174.       GO TO 785
  21175.   782 J2 = SWIRCP(BUFFER(NNL1),BUFFER(NNL2))
  21176.       GO TO 785
  21177.   783 J2 = SWIDCP(BUFFER(NNL1),BUFFER(NNL2))
  21178.       GO TO 785
  21179.   784 J2 = SWITCP(BUFFER(NNL1),BUFFER(NNL2))
  21180.   785 CONTINUE
  21181.       IF(J2 .EQ. 0) GO TO 790
  21182.       IF((J2 .GT. 0 .AND. SORTYP(J3)) .OR.
  21183.      X   (J2 .LT. 0 .AND. .NOT. SORTYP(J3)))
  21184.      XGO TO 795
  21185.       GO TO 770
  21186.   790 CONTINUE
  21187.   795 CONTINUE
  21188.       LL(L0)=L1
  21189.   820 L0=L1
  21190.       L1=LL(L0)
  21191.       IF(L1.NE.L0) GO TO 750
  21192.       LL(L0)=L2
  21193.       GO TO 880
  21194.   870 LL(L0)=L1
  21195.   880 M1=M1-1
  21196.       IF(M1.GT.0) GO TO 700
  21197.       IF(M1.EQ.0) GO TO 350
  21198. C  GENERATE 2ND HALF OF A 4-TWIG
  21199.       M1=1-M1
  21200.       GO TO 630
  21201.       END
  21202.       SUBROUTINE SWHRTI(NN,LL,BUFFER)
  21203.       INCLUDE rin:TEXT.BLK
  21204. C
  21205. C  PURPOSE   TO SORT FIXED OR VARIABLE LENGTH
  21206. C            TUPLES ON ONE OR MORE ATTRIBUTES
  21207. C            INCORE SORT
  21208. C            FIRST SORT ATTRIBUTE IS INTEGER
  21209. C
  21210. C  METHOD    FAST SORTING ALGORITHM PUBLISHED
  21211. C            1978 BY HART
  21212. C            CREATIVE COMPUTING JAN/FEB 1978
  21213. C            P 96 FF
  21214. C
  21215. C  TIMING   .05 CP SEC CYBER 760
  21216. C          1000 TUPLES,1 ATTRIBUTE SORT (INT)
  21217. C
  21218. C  DEFINITION OF VARIABLES
  21219. C
  21220. C  NN       VECTOR OF POINTERS TO BUFFER    (INT,I)
  21221. C
  21222. C  LL       LINK LIST OF POINTERS TO NN     (INT,O)
  21223. C           THE LIST DEFINES THE SORTED ORDER
  21224. C           ORDER OF BUFFER
  21225. C
  21226. C  BUFFER    VECTOR CONTAINING TUPLES TO SORT    (ANY,I)
  21227. C            NN POINTER ARE RELATIVE TO BUFFER(1)
  21228. C
  21229.       INCLUDE rin:SRTCOM.BLK
  21230.       INTEGER SWIICP,SWIRCP,SWIDCP,SWITCP
  21231.       DIMENSION NN(*),LL(*)
  21232.       INTEGER BUFFER(*)
  21233.       INTEGER S1
  21234.       K1=0
  21235.       I=0
  21236.       M1=0
  21237.       T2=0.
  21238.       T4=0.
  21239.       J=NSORT+1
  21240.       LL(1)=1
  21241.       LL(J)=1
  21242.       K2=1
  21243.       IF(NSORT.LE.1) RETURN
  21244.       S1=NSORT
  21245.   250 CONTINUE
  21246. C  CLIMB THE TREE
  21247.       IF(S1.LT.4) GO TO 320
  21248.       K2=K2*2
  21249.       B2=S1
  21250.       B2=B2/2.
  21251.       S1=INT(B2)
  21252.       T4=T4+(B2-S1)*K2
  21253.       GO TO 250
  21254.   320 CONTINUE
  21255. C  INITIAL CALCULATIONS
  21256.       T4=K2-T4
  21257.       B2=K2/2
  21258.   350 CONTINUE
  21259. C  NEXT TWIG
  21260.       IF(K1.EQ.K2) RETURN
  21261.       K1=K1+1
  21262.       T1=K1
  21263.       B1=B2
  21264.       T3=T2
  21265.   400 CONTINUE
  21266. C  ADD 1 TO REFLECTED BINARY COUNTER AND CARRY
  21267.       T1=T1/2.
  21268.       IF(INT(T1).LT.T1) GO TO 470
  21269.       M1=M1+1
  21270.       T2=T2-B1
  21271.       B1=B1/2.
  21272.       GO TO 400
  21273.   470 CONTINUE
  21274. C  TWIG CALCULATIONS
  21275.       T2=T2+B1
  21276.       IF(S1.EQ.2) GO TO 550
  21277. C  3-TWIGS AND 4-TWIGS
  21278.       IF(T3.LT.T4) GO TO 560
  21279. C  4-TWIG
  21280.       M1=-M1
  21281.       GO TO 630
  21282.   550 IF(T3.LT.T4) GO TO 610
  21283.   560 CONTINUE
  21284. C  3-TWIG
  21285.       M1=M1+1
  21286.       I=I+1
  21287.       LL(I)=I
  21288.       LL(J)=I
  21289.       J=J+1
  21290.   610 CONTINUE
  21291. C  2-TWIG
  21292.       M1=M1+1
  21293.   630 I=I+1
  21294.       L1=I
  21295.       LL(I)=I
  21296.       LL(J)=I
  21297.       L0=J
  21298.       J=J+1
  21299.       I=I+1
  21300.       L2=I
  21301.       LL(I)=I
  21302.       LL(J)=I
  21303.       GO TO 750
  21304.   700 CONTINUE
  21305. C  MERGE TWIGS AND BRANCHES
  21306.       J=J-1
  21307.       L0=J-1
  21308.       L1=LL(L0)
  21309.       L2=LL(J)
  21310.   750 CONTINUE
  21311.       NNL2 = NN(L2) + VARPOS(1) - 1
  21312.       NNL1 = NN(L1) + VARPOS(1) - 1
  21313.       J2 = BUFFER(NNL2) - BUFFER(NNL1)
  21314.       IF(J2 .GT. 0 .AND. SORTYP(1)) GO TO 820
  21315.       IF(J2 .LT. 0 .AND. .NOT. SORTYP(1)) GO TO 820
  21316.       IF(J2 .NE. 0) GO TO 765
  21317.       IF(NSOVAR .EQ. 1) GO TO 820
  21318.       DO 760 J3=2,NSOVAR
  21319.       JJ3 = VARPOS(J3) - 1
  21320.       NNL1 = NN(L1) + JJ3
  21321.       NNL2 = NN(L2) + JJ3
  21322.       KGOTO = VARTYP(J3)
  21323.       GO TO (752,753,754,755),KGOTO
  21324.   752 J2 = BUFFER(NNL2) - BUFFER(NNL1)
  21325.       GO TO 756
  21326.   753 J2 = SWIRCP(BUFFER(NNL1),BUFFER(NNL2))
  21327.       GO TO 756
  21328.   754 J2 = SWIDCP(BUFFER(NNL1),BUFFER(NNL2))
  21329.       GO TO 756
  21330.   755 J2 = SWITCP(BUFFER(NNL1),BUFFER(NNL2))
  21331.   756 CONTINUE
  21332.       IF(J2 .EQ. 0) GO TO 760
  21333.       IF((J2 .GT. 0 .AND. SORTYP(J3)) .OR.
  21334.      X   (J2 .LT. 0 .AND. .NOT. SORTYP(J3)))
  21335.      XGO TO 820
  21336.       GO TO 765
  21337.   760 CONTINUE
  21338.       GO TO 820
  21339.   765 CONTINUE
  21340.       LL(L0)=L2
  21341.   770 L0=L2
  21342.       L2=LL(L0)
  21343.       IF(L2.EQ.L0) GO TO 870
  21344.       NNL2 = NN(L2) + VARPOS(1) - 1
  21345.       NNL1 = NN(L1) + VARPOS(1) - 1
  21346.       J2 = BUFFER(NNL2) - BUFFER(NNL1)
  21347.       IF(J2 .GT. 0 .AND. SORTYP(1)) GO TO 795
  21348.       IF(J2 .LT. 0 .AND. .NOT. SORTYP(1)) GO TO 795
  21349.       IF(J2 .NE. 0) GO TO 770
  21350.       IF(NSOVAR .EQ. 1) GO TO 795
  21351.       DO 790 J3=2,NSOVAR
  21352.       JJ3 = VARPOS(J3) - 1
  21353.       NNL1 = NN(L1) + JJ3
  21354.       NNL2 = NN(L2) + JJ3
  21355.       KGOTO = VARTYP(J3)
  21356.       GO TO (781,782,783,784),KGOTO
  21357.   781 J2 = BUFFER(NNL2) - BUFFER(NNL1)
  21358.       GO TO 785
  21359.   782 J2 = SWIRCP(BUFFER(NNL1),BUFFER(NNL2))
  21360.       GO TO 785
  21361.   783 J2 = SWIDCP(BUFFER(NNL1),BUFFER(NNL2))
  21362.       GO TO 785
  21363.   784 J2 = SWITCP(BUFFER(NNL1),BUFFER(NNL2))
  21364.   785 CONTINUE
  21365.       IF(J2 .EQ. 0) GO TO 790
  21366.       IF((J2 .GT. 0 .AND. SORTYP(J3)) .OR.
  21367.      X   (J2 .LT. 0 .AND. .NOT. SORTYP(J3)))
  21368.      XGO TO 795
  21369.       GO TO 770
  21370.   790 CONTINUE
  21371.   795 CONTINUE
  21372.       LL(L0)=L1
  21373.   820 L0=L1
  21374.       L1=LL(L0)
  21375.       IF(L1.NE.L0) GO TO 750
  21376.       LL(L0)=L2
  21377.       GO TO 880
  21378.   870 LL(L0)=L1
  21379.   880 M1=M1-1
  21380.       IF(M1.GT.0) GO TO 700
  21381.       IF(M1.EQ.0) GO TO 350
  21382. C  GENERATE 2ND HALF OF A 4-TWIG
  21383.       M1=1-M1
  21384.       GO TO 630
  21385.       END
  21386.       SUBROUTINE SWHRTR(NN,LL,BUFFER)
  21387.       INCLUDE rin:TEXT.BLK
  21388. C
  21389. C  PURPOSE   TO SORT FIXED OR VARIABLE LENGTH
  21390. C            TUPLES ON ONE OR MORE ATTRIBUTES
  21391. C            INCORE SORT
  21392. C             FIRST SORT ATTRIBUTE IS REAL
  21393. C
  21394. C  METHOD    FAST SORTING ALGORITHM PUBLISHED
  21395. C            1978 BY HART
  21396. C            CREATIVE COMPUTING JAN/FEB 1978
  21397. C            P 96 FF
  21398. C
  21399. C  TIMING   .05 CP SEC CYBER 760
  21400. C          1000 TUPLES,1 ATTRIBUTE SORT (REAL)
  21401. C
  21402. C  DEFINITION OF VARIABLES
  21403. C
  21404. C  NN       VECTOR OF POINTERS TO BUFFER    (INT,I)
  21405. C
  21406. C  LL       LINK LIST OF POINTERS TO NN     (INT,O)
  21407. C           THE LIST DEFINES THE SORTED ORDER
  21408. C           ORDER OF BUFFER
  21409. C
  21410. C  BUFFER    VECTOR CONTAINING TUPLES TO SORT    (ANY,I)
  21411. C            NN POINTER ARE RELATIVE TO BUFFER(1)
  21412. C
  21413.       INCLUDE rin:SRTCOM.BLK
  21414.       INTEGER SWIICP,SWIRCP,SWIDCP,SWITCP
  21415.       DIMENSION NN(*),LL(*)
  21416.       DIMENSION BUFFER(*)
  21417.       REAL BUFFER
  21418.       INTEGER S1
  21419.       K1=0
  21420.       I=0
  21421.       M1=0
  21422.       T2=0.
  21423.       T4=0.
  21424.       J=NSORT+1
  21425.       LL(1)=1
  21426.       LL(J)=1
  21427.       K2=1
  21428.       IF(NSORT.LE.1) RETURN
  21429.       S1=NSORT
  21430.   250 CONTINUE
  21431. C  CLIMB THE TREE
  21432.       IF(S1.LT.4) GO TO 320
  21433.       K2=K2*2
  21434.       B2=S1
  21435.       B2=B2/2.
  21436.       S1=INT(B2)
  21437.       T4=T4+(B2-S1)*K2
  21438.       GO TO 250
  21439.   320 CONTINUE
  21440. C  INITIAL CALCULATIONS
  21441.       T4=K2-T4
  21442.       B2=K2/2
  21443.   350 CONTINUE
  21444. C  NEXT TWIG
  21445.       IF(K1.EQ.K2) RETURN
  21446.       K1=K1+1
  21447.       T1=K1
  21448.       B1=B2
  21449.       T3=T2
  21450.   400 CONTINUE
  21451. C  ADD 1 TO REFLECTED BINARY COUNTER AND CARRY
  21452.       T1=T1/2.
  21453.       IF(INT(T1).LT.T1) GO TO 470
  21454.       M1=M1+1
  21455.       T2=T2-B1
  21456.       B1=B1/2.
  21457.       GO TO 400
  21458.   470 CONTINUE
  21459. C  TWIG CALCULATIONS
  21460.       T2=T2+B1
  21461.       IF(S1.EQ.2) GO TO 550
  21462. C  3-TWIGS AND 4-TWIGS
  21463.       IF(T3.LT.T4) GO TO 560
  21464. C  4-TWIG
  21465.       M1=-M1
  21466.       GO TO 630
  21467.   550 IF(T3.LT.T4) GO TO 610
  21468.   560 CONTINUE
  21469. C  3-TWIG
  21470.       M1=M1+1
  21471.       I=I+1
  21472.       LL(I)=I
  21473.       LL(J)=I
  21474.       J=J+1
  21475.   610 CONTINUE
  21476. C  2-TWIG
  21477.       M1=M1+1
  21478.   630 I=I+1
  21479.       L1=I
  21480.       LL(I)=I
  21481.       LL(J)=I
  21482.       L0=J
  21483.       J=J+1
  21484.       I=I+1
  21485.       L2=I
  21486.       LL(I)=I
  21487.       LL(J)=I
  21488.       GO TO 750
  21489.   700 CONTINUE
  21490. C  MERGE TWIGS AND BRANCHES
  21491.       J=J-1
  21492.       L0=J-1
  21493.       L1=LL(L0)
  21494.       L2=LL(J)
  21495.   750 CONTINUE
  21496.       JJ3 = VARPOS(1) - 1
  21497.       R2 = BUFFER(NN(L2)+JJ3) - BUFFER(NN(L1)+JJ3)
  21498.       IF(R2 .GT. 0. .AND. SORTYP(1)) GO TO 820
  21499.       IF(R2 .LT. 0. .AND. .NOT. SORTYP(1)) GO TO 820
  21500.       IF(R2 .NE. 0.) GO TO 765
  21501.       IF(NSOVAR .EQ. 1) GO TO 820
  21502.       DO 760 J3=2,NSOVAR
  21503.       JJ3 = VARPOS(J3) - 1
  21504.       NNL1 = NN(L1) + JJ3
  21505.       NNL2 = NN(L2) + JJ3
  21506.       KGOTO = VARTYP(J3)
  21507.       GO TO (752,753,754,755),KGOTO
  21508.   752 J2 = SWIICP(BUFFER(NNL1),BUFFER(NNL2))
  21509.       GO TO 756
  21510.   753 J2 = SWIRCP(BUFFER(NNL1),BUFFER(NNL2))
  21511.       GO TO 756
  21512.   754 J2 = SWIDCP(BUFFER(NNL1),BUFFER(NNL2))
  21513.       GO TO 756
  21514.   755 J2 = SWITCP(BUFFER(NNL1),BUFFER(NNL2))
  21515.   756 CONTINUE
  21516.       IF(J2 .EQ. 0) GO TO 760
  21517.       IF((J2 .GT. 0 .AND. SORTYP(J3)) .OR.
  21518.      X   (J2 .LT. 0 .AND. .NOT. SORTYP(J3)))
  21519.      XGO TO 820
  21520.       GO TO 765
  21521.   760 CONTINUE
  21522.       GO TO 820
  21523.   765 CONTINUE
  21524.       LL(L0)=L2
  21525.   770 L0=L2
  21526.       L2=LL(L0)
  21527.       IF(L2.EQ.L0) GO TO 870
  21528.       JJ3 = VARPOS(1)-1
  21529.       R2 = BUFFER(NN(L2)+JJ3) - BUFFER(NN(L1)+JJ3)
  21530.       IF(R2 .GT. 0. .AND. SORTYP(1)) GO TO 795
  21531.       IF(R2 .LT. 0. .AND. .NOT. SORTYP(1)) GO TO 795
  21532.       IF(R2 .NE. 0.) GO TO 770
  21533.       IF(NSOVAR .EQ. 1) GO TO 795
  21534.       DO 790 J3=2,NSOVAR
  21535.       JJ3 = VARPOS(J3) - 1
  21536.       NNL1 = NN(L1) + JJ3
  21537.       NNL2 = NN(L2) + JJ3
  21538.       KGOTO = VARTYP(J3)
  21539.       GO TO (781,782,783,784),KGOTO
  21540.   781 J2 = SWIICP(BUFFER(NNL1),BUFFER(NNL2))
  21541.       GO TO 785
  21542.   782 J2 = SWIRCP(BUFFER(NNL1),BUFFER(NNL2))
  21543.       GO TO 785
  21544.   783 J2 = SWIDCP(BUFFER(NNL1),BUFFER(NNL2))
  21545.       GO TO 785
  21546.   784 J2 = SWITCP(BUFFER(NNL1),BUFFER(NNL2))
  21547.   785 CONTINUE
  21548.       IF(J2 .EQ. 0) GO TO 790
  21549.       IF((J2 .GT. 0 .AND. SORTYP(J3)) .OR.
  21550.      X   (J2 .LT. 0 .AND. .NOT. SORTYP(J3)))
  21551.      XGO TO 795
  21552.       GO TO 770
  21553.   790 CONTINUE
  21554.   795 CONTINUE
  21555.       LL(L0)=L1
  21556.   820 L0=L1
  21557.       L1=LL(L0)
  21558.       IF(L1.NE.L0) GO TO 750
  21559.       LL(L0)=L2
  21560.       GO TO 880
  21561.   870 LL(L0)=L1
  21562.   880 M1=M1-1
  21563.       IF(M1.GT.0) GO TO 700
  21564.       IF(M1.EQ.0) GO TO 350
  21565. C  GENERATE 2ND HALF OF A 4-TWIG
  21566.       M1=1-M1
  21567.       GO TO 630
  21568.       END
  21569.       SUBROUTINE SWICST(MM,M,N)
  21570.       INCLUDE rin:TEXT.BLK
  21571.       DIMENSION M(*),MM(*)
  21572. C
  21573. C
  21574. C  PURPOSE       TO SORT A SUBSET OF EQUIDISTANT
  21575. C                ELEMENTS OF A VECTOR
  21576. C
  21577. C  TIMING        .00015*N*LN(N) SEC
  21578. C
  21579. C  DEFINITION OF PARAMETERS
  21580. C
  21581. C  M         VECTOR OF POINTERS TO MM
  21582. C
  21583. C  MM        VECTOR OF DATA TO SORT
  21584. C
  21585. C  N         NUMBER OF ELEMENTS TO SORT
  21586. C
  21587. C
  21588.       INCLUDE rin:SRTCOM.BLK
  21589.       INTEGER SWIICP,SWIRCP,SWIDCP,SWITCP
  21590.       I = 1
  21591.       DO 10 J=1,30
  21592.       IF(I .GE. N) GO TO 20
  21593.    10 I = I * 2
  21594.    20 CONTINUE
  21595.       ID1 = I
  21596.       NN = N
  21597.    50 ID2 = ID1
  21598.       I = I/2
  21599.       IF(I .GT. 0) GO TO 60
  21600.       RETURN
  21601.    60 CONTINUE
  21602.       ID1 = I
  21603.       III = N - I
  21604.       IF(III .GT. I) III = I
  21605.       DO 500 J=1,III
  21606.       I1 = J
  21607.       I2 = I1 + ID1
  21608.       J1 = M(I1)
  21609.       J2 = M(I2)
  21610.   200 CONTINUE
  21611.       DO 220 JJ3=1,NSOVAR
  21612.       JJ4 = VARPOS(JJ3) - 1
  21613.       KGOTO = VARTYP(JJ3)
  21614.       GO TO (211,212,213,214),KGOTO
  21615.   211 JJJ = SWIICP(MM(J1+JJ4),MM(J2+JJ4))
  21616.       GO TO 215
  21617.   212 JJJ = SWIRCP(MM(J1+JJ4),MM(J2+JJ4))
  21618.       GO TO 215
  21619.   213 JJJ = SWIDCP(MM(J1+JJ4),MM(J2+JJ4))
  21620.       GO TO 215
  21621.   214 JJJ = SWITCP(MM(J1+JJ4),MM(J2+JJ4))
  21622.   215 CONTINUE
  21623.       IF(.NOT. SORTYP(JJ3)) JJJ = -JJJ
  21624.       IF(JJJ .GT. 0) GO TO 400
  21625.       IF(JJJ .LT. 0) GO TO 240
  21626.   220 CONTINUE
  21627.       GO TO 400
  21628.   240 CONTINUE
  21629. C
  21630. C  NOT IN SORT
  21631. C
  21632.       M(I1) = J2
  21633.       I1 = I1 + ID1
  21634.       IF(I1 .LT. I2) GO TO 250
  21635. C
  21636. C  JUST FLIP-FLOP
  21637. C
  21638.       M(I2) = J1
  21639.       I2 = I2 + ID2
  21640.       IF(I2 .GT. NN) GO TO 500
  21641.       J2 = M(I2)
  21642.       GO TO 200
  21643. C
  21644. C  MORE THAN ONE TO MOVE DOWN
  21645. C
  21646.   250 JJ = I2 - ID1
  21647.       DO 300 II=I1,JJ,ID1
  21648.       J2 = M(I2 - ID1)
  21649.       M(I2) = J2
  21650.   300 I2 = I2 - ID1
  21651.       I2 = JJ + ID1 + ID2
  21652.       M(I1) = J1
  21653.       IF(I2 .GT. NN) GO TO 500
  21654.       J2 = M(I2)
  21655.       GO TO 200
  21656. C
  21657. C  IN SORT
  21658. C
  21659.   400 I1 = I1 + ID1
  21660.       IF(I1 .LT. I2) GO TO 450
  21661. C
  21662. C  ONE ONLY
  21663. C
  21664.       I2 = I2 + ID1
  21665.       IF(I2 .GT. NN) GO TO 500
  21666.       J1 = J2
  21667.       J2 = M(I2)
  21668.       GO TO 200
  21669. C
  21670. C   MORE THAN ONE
  21671. C
  21672.   450 J1 = M(I1)
  21673.       GO TO 200
  21674.   500 CONTINUE
  21675.       GO TO 50
  21676.       END
  21677.       INTEGER FUNCTION SWIDCP(I1,I2)
  21678.       INCLUDE rin:TEXT.BLK
  21679.       DOUBLE PRECISION I1,I2
  21680.       SWIDCP = 1
  21681.       IF(I1 .LT. I2) RETURN
  21682.       IF(I1 .GT. I2) GO TO 10
  21683.       SWIDCP = 0
  21684.       RETURN
  21685.    10 SWIDCP = -1
  21686.       RETURN
  21687.       END
  21688.       INTEGER FUNCTION SWIICP(I1,I2)
  21689.       INCLUDE rin:TEXT.BLK
  21690.       SWIICP = 1
  21691.       IF(I1 .LT. I2) RETURN
  21692.       IF(I1 .GT. I2) GO TO 10
  21693.       SWIICP = 0
  21694.       RETURN
  21695.    10 SWIICP = -1
  21696.       RETURN
  21697.       END
  21698.       SUBROUTINE SWINPO(INFIL,OUTFIL,BUFFER,IERR)
  21699.       INCLUDE rin:TEXT.BLK
  21700.       INCLUDE rin:SRTCOM.BLK
  21701.       DIMENSION BUFFER(*)
  21702.       INTEGER BUFFER,OUTFIL
  21703. C
  21704. C  PURPOSE  CONTROLLING ROUTINE FOR IN-CORE SORT
  21705. C              USING IN-SITU POINTER METHOD
  21706. C
  21707. C
  21708. C  TIMING   UNKNOWN
  21709. C
  21710. C  DEFINITION OF VARIABLES
  21711. C
  21712. C  INFIL   FILE NAME OF FILE (SEQ) WHICH    (INT,I)
  21713. C          CONTAINS INPUT TUPLES
  21714. C         INFIL IS UNFORMATTED (BINARY)
  21715. C         EACH TUPLE IS WRITTEN AS A
  21716. C         RECORD AS FOLLOWS
  21717. C         FOR FIXED LENGTH RECORDS
  21718. C           WRITE(INFIL) (TUP(I),I=1,LTUPLE)
  21719. C         FOR VARIABLE LENGTH RECORDS
  21720. C           WRITE(INFIL) L,(TUP(I),I=1,L)
  21721. C
  21722. C  OUTFIL  FILE NAME OF FILE (SEQ) WHICH    (INT,I)
  21723. C          CONTAINS OUTPUT (SORTED) TUPLES
  21724. C          OUTFIL MAY EQ INFIL
  21725. C          FORMAT OF OUTFIL IS THE
  21726. C          SAME AS THAT OF INFIL
  21727. C
  21728. C  BUFFER  CORE BUFFER TO USE FOR SORT      (ANY,SCR)
  21729. C
  21730. C  IERR    ERROR CONDITION                  (INT,O)
  21731. C           0 NORMAL RETURN
  21732. C           1 ERROR IN FILE READ
  21733. C           2 ERROR IN FILE WRITE
  21734. C
  21735.       I1 = NSORT
  21736.       IF(FIXLT) GO TO 10
  21737. C
  21738. C  INCORE,VAR LENGTH
  21739. C
  21740.       I1 = I1 + 1
  21741.       DO 5 I2=1,NSORT
  21742.       BUFFER(I2) = I1 + 1
  21743. c      READ(INFIL) I4,(BUFFER(I1+I5),I5=1,I4)
  21744.       READ(INFIL) I4
  21745.       READ(INFIL) (BUFFER(I1+I5),I5=1,I4)
  21746.       BUFFER(I1) = I4
  21747.     5 I1 = I1 + I4 + 1
  21748.       GO TO 20
  21749.    10 CONTINUE
  21750. C
  21751. C  INCORE,FIXED LENGTH TUPLES
  21752. C
  21753.       DO 15 I2=1,NSORT
  21754.       BUFFER(I2)= I1 + 1
  21755.       READ(INFIL) (BUFFER(I1+I4),I4=1,LTUPLE)
  21756.    15 I1 = I1 + LTUPLE
  21757.    20 CONTINUE
  21758. C
  21759. C  READ COMPLETED,SORT
  21760. C
  21761.       CALL SWICST(BUFFER,BUFFER,NSORT)
  21762. C
  21763. C  SORT COMPLETE,UNLOAD
  21764. C
  21765.       REWIND OUTFIL
  21766.       IF(FIXLT) GO TO 40
  21767. C
  21768. C  VARIABLE LENGTH TUPLES
  21769. C
  21770.       DO 35 I2=1,NSORT
  21771.       I3 = BUFFER(I2) - 1
  21772.       I4 = BUFFER(I3)
  21773.       WRITE(OUTFIL) I4,(BUFFER(I3+I1),I1=1,I4)
  21774.    35 CONTINUE
  21775.       RETURN
  21776.    40 CONTINUE
  21777. C
  21778. C  WRITE FIXED LENGTH TUPLES
  21779. C
  21780.       DO 45 I2=1,NSORT
  21781.       I3 = BUFFER(I2) - 1
  21782.       WRITE(OUTFIL) (BUFFER(I3+I4),I4=1,LTUPLE)
  21783.    45 CONTINUE
  21784.       RETURN
  21785.       END
  21786.       INTEGER FUNCTION SWIRCP(I1,I2)
  21787.       INCLUDE rin:TEXT.BLK
  21788.       REAL I1,I2
  21789.       SWIRCP = 1
  21790.       IF(I1 .LT. I2) RETURN
  21791.       IF(I1 .GT. I2) GO TO 10
  21792.       SWIRCP = 0
  21793.       RETURN
  21794.    10 SWIRCP = -1
  21795.       RETURN
  21796.       END
  21797.       INTEGER FUNCTION SWITCP(I1,I2)
  21798.       INCLUDE rin:TEXT.BLK
  21799.       Character*1 W1(4),W2(4)
  21800.       INTEGER IT1,IT2
  21801.       EQUIVALENCE (IT1,W1)
  21802.       EQUIVALENCE (IT2,W2)
  21803.       IT1 = I1
  21804.       IT2 = I2
  21805.       DO 100 I=1,4
  21806.       IF(W1(I).NE.W2(I)) GO TO 200
  21807.   100 CONTINUE
  21808.       SWITCP = 0
  21809.       RETURN
  21810.   200 CONTINUE
  21811.       IF(W1(I).GT.W2(I)) GO TO 300
  21812.       SWITCP = 1
  21813.       RETURN
  21814.   300 CONTINUE
  21815.       SWITCP = -1
  21816.       RETURN
  21817.       END
  21818.       SUBROUTINE SWSHEL(M,N)
  21819.       INCLUDE rin:TEXT.BLK
  21820. C
  21821. C     SORT AN INTEGER ARRAY OF LENGTH N
  21822. C     USING SHELL SORT ALGORITHM
  21823. C
  21824.       DIMENSION M(N)
  21825.       INC = 1
  21826.   100 CONTINUE
  21827.       IF((9*INC+4).GE.N) GO TO 200
  21828.       INC = 3*INC + 1
  21829.       GO TO 100
  21830.   200 CONTINUE
  21831.       IF(INC.LT.1) GO TO 1000
  21832.       NMMINC = N-INC
  21833. C
  21834. C     START THE SORT LOOP
  21835. C
  21836.       DO 800 IS = 1,NMMINC
  21837.       K1 = IS
  21838.       K2 = IS + INC
  21839.       IF(M(K1).LE.M(K2)) GO TO 800
  21840.       MOVE = IS
  21841.       MT = M(K2)
  21842.   400 CONTINUE
  21843.       K1 = MOVE
  21844.       K2 = K1 + INC
  21845.       M(K2) = M(K1)
  21846.       MOVE = MOVE - INC
  21847.       IF(MOVE.LT.1) GO TO 600
  21848.       IF(MT.LT.M(MOVE)) GO TO 400
  21849.   600 CONTINUE
  21850.       M(K1) = MT
  21851.   800 CONTINUE
  21852.       INC = (INC-1)/3
  21853.       GO TO 200
  21854.  1000 CONTINUE
  21855.       RETURN
  21856.       END
  21857.       SUBROUTINE SWSINK(IP,IIP,NIP,BUFFER)
  21858.       INCLUDE rin:TEXT.BLK
  21859. C
  21860. C  PURPOSE   TO INSERT A TUPLE INTO A SEQUENCE
  21861. C            OF SORTED TUPLES USING A SINK
  21862. C            SORT.  THE TOP TUPLE IS MOVED DOWN
  21863. C            IN THE EXISTING SEQUENCE UNTIL IT
  21864. C            IS NOT LESS THAN THE NEXT TUPLE
  21865. C            (IF ASCENDING SORT) OR NOT GREATER
  21866. C            THAN THE NEXT TUPLE (DESCENDING SORT)
  21867. C
  21868. C  DEFININITION OF VARIABLES
  21869. C
  21870. C  IP        VECTOR OF INDIRECT POINTERS          (INT,I/O)
  21871. C            IP(I) POINTS TO IIP.
  21872. C            IP(2), ... , IP(NIP) ARE
  21873. C            IN SORT UPON ENTRY. UPON
  21874. C            EXIT IP(1), ... ,IP(NIP)
  21875. C            ARE IN SORT
  21876. C
  21877. C  IIP       VECTOR OF CURRENT POINTERS           (INT,I)
  21878. C            TO BUFFER
  21879. C
  21880. C  NIP       NUMBER OF CURRENT CHAINS             (INT,I)
  21881. C            ** NOTICE **   NIP MUST BE GT 1
  21882. C
  21883. C  BUFFER     VECTOR CONTAINING TUPLES TO SORT    (ANY,I)
  21884. C             IIP POINTERS ARE RELATIVE TO
  21885. C             BUFFER(1)
  21886. C
  21887.       INCLUDE rin:SRTCOM.BLK
  21888.       INTEGER SWIICP,SWIRCP,SWIDCP,SWITCP
  21889.       DIMENSION IP(*),IIP(*)
  21890.       DIMENSION BUFFER(*)
  21891.       J1 = IP(1)
  21892.       I1 = IIP(J1)
  21893.       DO 100 I=2,NIP
  21894.       J3 = IP(I)
  21895.       I2 = IIP(J3)
  21896.       DO 20 J4=1,NSOVAR
  21897.       JJ4 = VARPOS(J4) - 1
  21898.       KGOTO = VARTYP(J4)
  21899.       GO TO (11,12,13,14),KGOTO
  21900.    11 J2 = SWIICP(BUFFER(I1+JJ4),BUFFER(I2+JJ4))
  21901.       GO TO 15
  21902.    12 J2 = SWIRCP(BUFFER(I1+JJ4),BUFFER(I2+JJ4))
  21903.       GO TO 15
  21904.    13 J2 = SWIDCP(BUFFER(I1+JJ4),BUFFER(I2+JJ4))
  21905.       GO TO 15
  21906.    14 J2 = SWITCP(BUFFER(I1+JJ4),BUFFER(I2+JJ4))
  21907.    15 CONTINUE
  21908.       IF(J2 .EQ. 0) GO TO 20
  21909.       IF((J2 .GT. 0 .AND. SORTYP(J4)) .OR.
  21910.      X   (J2 .LT. 0 .AND. .NOT. SORTYP(J4)))
  21911.      X    GO TO 200
  21912.       GO TO 30
  21913.    20 CONTINUE
  21914. C
  21915. C    EQUAL,PRESERVE ORIGINAL ORDER
  21916. C
  21917.       IF(J1 .LT. J3) GO TO 200
  21918.    30 CONTINUE
  21919. C
  21920. C     NOT IN SORT, CONTINUE TO SINK
  21921. C
  21922.       IP(I-1) = J3
  21923.       IP(I) = J1
  21924.   100 CONTINUE
  21925.   200 CONTINUE
  21926.       RETURN
  21927.       END
  21928.       SUBROUTINE SWSMFL(BUFFER,CHAIN1,NCHAIN,LCHAIN,OUTREC,OUTCHN,
  21929.      X                   NTUREC,LTUP,LREC,INFIL,OUTFIL)
  21930.       INCLUDE rin:TEXT.BLK
  21931. C
  21932. C  PURPOSE   MERGE ONE SET OF CHAINS INTO
  21933. C            SINGLE CHAIN OF SORTED TUPLES
  21934. C
  21935. C  METHOD    A STACK IS ESTABLISHED WITH
  21936. C            CURRENT FIRST TUPLE IN EACH
  21937. C            CHAIN.THE STACK IS IN ORDER.
  21938. C            THE FIRST TUPLE IS REMOVED
  21939. C            FROM THE STACK AND MOVED TO
  21940. C            OUTPUT BUFFER.THE NEXT TUPLE
  21941. C            IN THE PARTICULAR CHAIN IS
  21942. C            (IF ONE EXISTS) PUT ON TOP
  21943. C            OF STACK AND ALLOWED TO
  21944. C            SINK UNTIL IT IS IN SORT.
  21945. C            IF ONE DOES NOT EXIST,THE
  21946. C            STACK IS SHORTENED.WHEN
  21947. C            ONLY ONE CHAIN EXISTS,
  21948. C            ITS TAIL IS MOVED DIRECTLY
  21949. C            TO OUTPUT FILE
  21950. C  DEFINITION OF PARAMETERS
  21951. C
  21952. C  CHAIN1    RECORD NO ON INFILE WHICH CONTAINS   (INT,I)
  21953. C            PAGE 1 OF FIRST CHAIN
  21954. C
  21955. C  NCHAIN   NUMBER OF CHAINS TO MERGE           (INT,I)
  21956. C
  21957. C  LCHAIN    NUMBER OF PAGES PER INPUT CHAIN     (INT,I)
  21958. C
  21959. C  OUTREC    RECORD NO ON OUTFIL OF NEXT RECORD  (INT,I/O)
  21960. C            POSITION - IF ZERO EMPTY OUTPUT FILE - WRITE AT EOI
  21961. C
  21962. C  OUTCHN    OUTPUT CHAIN NUMBER                 (INT,I)
  21963. C
  21964. C  NTUREC     NUMBER OF TUPLES PER FULL PAGE     (INT,I)
  21965. C
  21966. C  LTUP      LENGTH OF A TUPLE                   (INT,I)
  21967. C
  21968. C  INFIL     FET OF INPUT FILE                   (FET,I)
  21969. CC
  21970. C  OUTFILE   FET OF OUTLUT FILE                 (FET,I)
  21971. C
  21972. C  DEFINITION OF LOCAL VARIABLES
  21973. C
  21974. C  IP    IP(I)  CONTAINS POINTER TO IP1
  21975. C               FOR I:TH TUPLE IN STACK
  21976. C  IP1   IP1(I) CONTAINS POINTER TO CURRENT
  21977. C               TUPLE ON PAGE I
  21978. C  IP2   IP2(I) CONTAINS POINTER TO LAST
  21979. C               TUPLE ON PAGE I
  21980. C  IP3   IP3(I) CONTAINS RECORD NUMBER ON
  21981. C               INFILE FOR CURRENT PAGE IN
  21982. C               CHAIN I.NEG IF LAST PAGE IN CHAIN
  21983. C  IP4   IP4(I) CONTAINS POINTER TO FIRST
  21984. C               WORD ON PAGE I
  21985. C
  21986. C  DEFINITION OF LOCAL VARIABLES
  21987. C
  21988. C  I5     NO OF TUPLES ON OUTPUT PAGE
  21989. C  I6     ADDRESS-1 TO NEXT TUPLE ON OUTPUT PAGE
  21990. C  J1      POINTER TO FIRST WORD OF OUTPUT PAGE
  21991. C
  21992.       INTEGER BUFFER(*)
  21993.       INTEGER CHAIN1,OUTREC,OUTCHN,OUTFIL
  21994.       DIMENSION IP(10),IP1(10),IP2(10),IP3(10),IP4(10)
  21995. C
  21996. C  INITIALIZE,IE LOAD THE FIRST
  21997. C  BLOCKS OF THE INPUT CHAINS,SET
  21998. C  UP CONTROL ARRAYS IP,IP1,...,IP4
  21999. C
  22000.       J1 = NCHAIN*LREC + 1
  22001.       BUFFER(J1) = NTUREC
  22002.       BUFFER(J1+1) = OUTCHN
  22003.       I1 = CHAIN1
  22004.       I2 = 1
  22005.       DO 10 I=1,NCHAIN
  22006. C* READ RECORD I1 TO BUFFER I2,LENGTH= LREC
  22007.       CALL RIOIN(INFIL,I1,BUFFER(I2),LREC,IOS)
  22008.       IP1(I) = I2+2
  22009.       IP2(I) = I2+(BUFFER(I2)-1)*LTUP+2
  22010.       IP3(I) = I1
  22011.       IF(BUFFER(I2+1) .LT. 0) IP3(I) = -IP3(I)
  22012.       IP(I) = I
  22013.       IP4(I) = I2
  22014.       I1 = I1 + LCHAIN
  22015.       I2 = I2 + LREC
  22016.    10 CONTINUE
  22017.       IF(NCHAIN .GT. 1) GO TO 17
  22018.       I1 = 1
  22019.       J1 = 1
  22020.       GO TO 123
  22021.    17 CONTINUE
  22022.       DO 15 I=2,NCHAIN
  22023.       CALL SWSINK(IP(NCHAIN-I+1),IP1(1),I,BUFFER)
  22024.    15 CONTINUE
  22025.       NIP = NCHAIN
  22026. C
  22027. C  INITIAL SETUP COMPLETE,
  22028. C  PREPARE FOR MERGE CYCLE
  22029. C
  22030.    20 CONTINUE
  22031.       I5 = 0
  22032.       I6 = J1 + 1
  22033. C
  22034. C  I5 IS NO TUPLES IN OUTPUT PAGE
  22035. C  I6 IS ADDRESS-1 TO NEXT TUPLE
  22036. C        ON OUTPUT PAGE
  22037. C
  22038.    25 CONTINUE
  22039.       IF(I5 .LT. NTUREC) GO TO 27
  22040. C
  22041. C  OUTPUT PAGE FULL
  22042. C
  22043. C* WRITE OUTPUT BUFFER TO OUTFILE,RECORD OUTREC
  22044.       CALL RIOOUT(OUTFIL,OUTREC,BUFFER(J1),LREC,IOS)
  22045.       IF(OUTREC.NE.0) OUTREC = OUTREC + 1
  22046.       GO TO 20
  22047.    27 I1 = IP(1)
  22048.       I2 = IP1(I1) - 1
  22049.       DO 30 I=1,LTUP
  22050.    30 BUFFER(I6+I) = BUFFER(I2+I)
  22051.       I5 = I5+1
  22052.       I6 = I6 + LTUP
  22053.       IP1(I1) = IP1(I1) + LTUP
  22054.       IF(IP1(I1) .LE. IP2(I1)) GO TO 50
  22055. C
  22056. C  INPUT BLOCK EMPTY
  22057. C
  22058.       IF(IP3(I1) .LT. 0) GO TO 40
  22059.       I2 = IP4(I1)
  22060. C*  READ BLOCK IP3(I1) TO BUFFER(I2)
  22061.       IP3(I1) = IP3(I1) + 1
  22062.       CALL RIOIN(INFIL,IP3(I1),BUFFER(I2),LREC,IOS)
  22063.       IP1(I1) =I2+2
  22064.       IP2(I1) = I2 + (BUFFER(I2)-1)*LTUP + 2
  22065.       IF(BUFFER(I2+1) .LT. 0) IP3(I1) = -IP3(I1)
  22066.       GO TO 50
  22067.    40 CONTINUE
  22068. C
  22069. C  CURRENT PAGE IS LAST PAGE IN CHAIN
  22070. C
  22071.       DO 45 I=2,NIP
  22072.    45 IP(I-1) = IP(I)
  22073.       NIP = NIP - 1
  22074.       IF(NIP .EQ. 1) GO TO 100
  22075.       GO TO 25
  22076.    50 CONTINUE
  22077. C
  22078. C  CURRENT IP(1) TUPLE MOVED
  22079. C  PICK UP NEXT AND LET IT SINK
  22080. C
  22081.       CALL SWSINK(IP,IP1,NIP,BUFFER)
  22082.       GO TO 25
  22083.   100 CONTINUE
  22084. C
  22085. C  ONLY ONE INPUT CHAIN LEFT
  22086. C
  22087.       I1 = IP(1)
  22088.       IF(I5 .LT. NTUREC) GO TO 103
  22089.       CALL RIOOUT(OUTFIL,OUTREC,BUFFER(J1),LREC,IOS)
  22090.       IF(OUTREC .NE. 0) OUTREC = OUTREC + 1
  22091.       J1 = IP4(I1)
  22092.       GO TO 123
  22093.   103 CONTINUE
  22094.       I2 = IP1(I1) - 1
  22095.       GO TO 115
  22096.   105 CONTINUE
  22097.       DO 110 I=1,LTUP
  22098.   110 BUFFER(I6+I) = BUFFER(I2+I)
  22099.       I6 = I6 + LTUP
  22100.       I2 = I2 + LTUP
  22101.       I5 = I5 + 1
  22102.   115 IF(I2 .LT. IP2(I1)) GO TO 105
  22103.       BUFFER(J1) = I5
  22104.       IF(IP3(I1) .LT. 0) BUFFER(J1+1) = -BUFFER(J1+1)
  22105. C* WRITE OUTPUT BUFFER
  22106.       CALL RIOOUT(OUTFIL,OUTREC,BUFFER(J1),LREC,IOS)
  22107.       IF(OUTREC.NE.0) OUTREC = OUTREC + 1
  22108.       IF(IP3(I1) .LT. 0) RETURN
  22109.   120 CONTINUE
  22110. C* READ RECORD IP3(I1) TO OUTPUT RECORD
  22111.       IP3(I1) = IP3(I1) + 1
  22112.       CALL RIOIN(INFIL,IP3(I1),BUFFER(J1),LREC,IOS)
  22113.   123 CONTINUE
  22114.       IF(BUFFER(J1+1) .LT. 0) GO TO 125
  22115.       BUFFER(J1+1) = OUTCHN
  22116. C* WRITE OUTPUT BUFFER
  22117.       CALL RIOOUT(OUTFIL,OUTREC,BUFFER(J1),LREC,IOS)
  22118.       IF(OUTREC.NE.0) OUTREC = OUTREC + 1
  22119.       GO TO 120
  22120.   125 CONTINUE
  22121.       BUFFER(J1+1) = -OUTCHN
  22122. C* WRITE OUTPUT BUFFER
  22123.       CALL RIOOUT(OUTFIL,OUTREC,BUFFER(J1),LREC,IOS)
  22124.       IF(OUTREC.NE.0) OUTREC = OUTREC + 1
  22125.       RETURN
  22126.       END
  22127.       SUBROUTINE SWSMVL(BUFFER,CHAIN1,NCHAIN,LCHAIN,OUTREC,OUTCHN,
  22128.      X                   INCH1,LREC,INFIL,OUTFIL)
  22129.       INCLUDE rin:TEXT.BLK
  22130. C
  22131. C  PURPOSE   MERGE ONE SET OF CHAINS INTO
  22132. C            SINGLE CHAIN OF SORTED TUPLES
  22133. C
  22134. C  METHOD    A STACK IS ESTABLISHED WITH
  22135. C            CURRENT FIRST TUPLE IN EACH
  22136. C            CHAIN.THE STACK IS IN ORDER.
  22137. C            THE FIRST TUPLE IS REMOVED
  22138. C            FROM THE STACK AND MOVED TO
  22139. C            OUTPUT BUFFER.THE NEXT TUPLE
  22140. C            IN THE PARTICULAR CHAIN IS
  22141. C            (IF ONE EXISTS) PUT ON TOP
  22142. C            OF STACK AND ALLOWED TO
  22143. C            SINK UNTIL IT IS IN SORT.
  22144. C            IF ONE DOES NOT EXIST,THE
  22145. C            STACK IS SHORTENED.WHEN
  22146. C            ONLY ONE CHAIN EXISTS,
  22147. C            ITS TAIL IS MOVED DIRECTLY
  22148. C            TO OUTPUT FILE
  22149. C  DEFINITION OF PARAMETERS
  22150. C
  22151. C  CHAIN1    RECORD NO ON INFILE WHICH CONTAINS   (INT,I)
  22152. C            PAGE 1 OF FIRST CHAIN
  22153. C
  22154. C  NCHAIN   NUMBER OF CHAINS TO MERGE           (INT,I)
  22155. C
  22156. C  LCHAIN    NUMBER OF PAGES PER INPUT CHAIN     (INT,I)
  22157. C
  22158. C  OUTREC    RECORD NO ON OUTFIL OF NEXT RECORD  (INT,I/O)
  22159. C            POSITION - IF ZERO EMPTY OUTPUT FILE - WRITE AT EOI
  22160. C
  22161. C  OUTCHN    OUTPUT CHAIN NUMBER                 (INT,I)
  22162. C
  22163. C  INCH1     CHAIN NUMBER OF FIRST INPUT CHAIN   (INT,I)
  22164. C
  22165. C  INFIL     FET OF INPUT FILE                   (FET,I)
  22166. CC
  22167. C  OUTFILE   FET OF OUTLUT FILE                 (FET,I)
  22168. C
  22169. C  DEFINITION OF LOCAL VARIABLES
  22170. C
  22171. C  IP    IP(I)  CONTAINS POINTER TO IP1
  22172. C               FOR I:TH TUPLE IN STACK
  22173. C  IP1   IP1(I) CONTAINS POINTER TO CURRENT
  22174. C               TUPLE ON PAGE I
  22175. C  IP2   IP2(I) CONTAINS NUMBER OF TUPLES
  22176. C               ON PAGE I
  22177. C  IP3   IP3(I) CONTAINS RECORD NUMBER ON
  22178. C               INFILE FOR CURRENT PAGE IN
  22179. C               CHAIN I.NEG IF LAST PAGE IN CHAIN
  22180. C  IP4   IP4(I) CONTAINS POINTER TO FIRST
  22181. C               WORD ON PAGE I
  22182. C
  22183. C  IP5   IP5(I) CONTAINS SEQUENTIAL TUPLE NUMBER
  22184. C                OF CURRENT TUPLE PAGE I.
  22185. C
  22186. C  DEFINITION OF LOCAL VARIABLES
  22187. C
  22188. C  I5     NO OF TUPLES ON OUTPUT PAGE
  22189. C  I6     ADDRESS-1 TO NEXT TUPLE ON OUTPUT PAGE
  22190. C  J1      POINTER TO FIRST WORD OF OUTPUT PAGE
  22191. C  INCH    INPUT CHAIN NUMBER
  22192. C  OUCH    OUTPUT RECORD NUMBER IN CHAIN
  22193. C
  22194.       INTEGER BUFFER(*)
  22195.       INTEGER CHAIN1,OUTREC,OUTCHN,OUTFIL
  22196.       DIMENSION IP(10),IP1(10),IP2(10),IP3(10),IP4(10)
  22197.       DIMENSION IP5(10)
  22198.       INTEGER OUCH
  22199. C
  22200. C  INITIALIZE,IE LOAD THE FIRST
  22201. C  BLOCKS OF THE INPUT CHAINS,SET
  22202. C  UP CONTROL ARRAYS IP,IP1,...,IP4
  22203. C
  22204.       J1 = NCHAIN*LREC + 1
  22205.       J2 = J1 + LREC - 1
  22206.       BUFFER(J1+1) = OUTCHN
  22207.       I1 = CHAIN1
  22208.       I2 = 1
  22209.       OUCH = 1
  22210.       INCH = INCH1
  22211.       DO 10 I=1,NCHAIN
  22212. C* READ RECORD I1 TO BUFFER I2,LENGTH= LREC
  22213.     1 CONTINUE
  22214. C
  22215. C     LOOK FOR CORRECT RECORD
  22216. C
  22217.       CALL RIOIN(INFIL,I1,BUFFER(I2),LREC,IOS)
  22218.       NUMCH = IABS(BUFFER(I2+1))
  22219.       IF(NUMCH.LT.INCH) GO TO 5
  22220.       IF(NUMCH.GT.INCH) GO TO 7
  22221. C
  22222. C     WE ARE IN THE CORRECT CHAIN
  22223. C
  22224.       INT = BUFFER(I2+2)
  22225.       IF(INT.EQ.1) GO TO 8
  22226.       I1 = I1 - INT + 1
  22227.       GO TO 1
  22228.     5 CONTINUE
  22229. C
  22230. C     IN SOME PREVIOUS CHAIN
  22231. C
  22232.       I1 = I1 + 1
  22233.       IF(BUFFER(I2+1).GT.0) I1 = I1 + 1
  22234.       GO TO 1
  22235.     7 CONTINUE
  22236. C
  22237. C     GOOD LORD - IN SOME SUBSEQUENT CHAIN
  22238. C
  22239.       I1 = I1 - BUFFER(I2+2)
  22240.       GO TO 1
  22241.     8 CONTINUE
  22242. C
  22243. C     FOUND THE FIRST RECORD IN CHAIN INCH
  22244. C
  22245.       IP1(I) = I2+4
  22246.       IP2(I) = BUFFER(I2)
  22247.       IP5(I) = 1
  22248.       IP3(I) = I1
  22249.       IF(BUFFER(I2+1) .LT. 0) IP3(I) = -IP3(I)
  22250.       IP(I) = I
  22251.       IP4(I) = I2
  22252.       I1 = I1 + LCHAIN
  22253.       I2 = I2 + LREC
  22254.       INCH = INCH + 1
  22255.    10 CONTINUE
  22256.       IF(NCHAIN.EQ.1) GO TO 18
  22257.       DO 15 I=2,NCHAIN
  22258.       CALL SWSINK(IP(NCHAIN-I+1),IP1(1),I,BUFFER)
  22259.    15 CONTINUE
  22260.    18 CONTINUE
  22261.       NIP = NCHAIN
  22262. C
  22263. C  INITIAL SETUP COMPLETE,
  22264. C  PREPARE FOR MERGE CYCLE
  22265. C
  22266.    20 CONTINUE
  22267.       I5 = 0
  22268.       I6 = J1 + 2
  22269. C
  22270. C  I5 IS NO TUPLES IN OUTPUT PAGE
  22271. C  I6 IS ADDRESS-1 TO NEXT TUPLE
  22272. C        ON OUTPUT PAGE
  22273. C
  22274.    25 CONTINUE
  22275.       I1 = IP(1)
  22276.       I2 = IP1(I1) - 2
  22277.       LTUP = BUFFER(I2+1) + 1
  22278.       IF((I6+LTUP).LE.J2) GO TO 27
  22279. C
  22280. C  OUTPUT PAGE FULL
  22281. C
  22282. C* WRITE OUTPUT BUFFER TO OUTFILE,RECORD OUTREC
  22283.       BUFFER(J1) = I5
  22284.       BUFFER(J1+2) = OUCH
  22285.       CALL RIOOUT(OUTFIL,OUTREC,BUFFER(J1),LREC,IOS)
  22286.       OUCH = OUCH + 1
  22287.       IF(OUTREC.NE.0) OUTREC = OUTREC + 1
  22288.       GO TO 20
  22289.    27 CONTINUE
  22290.       DO 30 I=1,LTUP
  22291.    30 BUFFER(I6+I) = BUFFER(I2+I)
  22292.       I5 = I5+1
  22293.       I6 = I6 + LTUP
  22294.       IP1(I1) = IP1(I1) + LTUP
  22295.       IP5(I1) = IP5(I1) + 1
  22296.       IF(IP5(I1) .LE. IP2(I1)) GO TO 50
  22297. C
  22298. C  INPUT BLOCK EMPTY
  22299. C
  22300.       IF(IP3(I1) .LT. 0) GO TO 40
  22301.       I2 = IP4(I1)
  22302. C*  READ BLOCK IP3(I1) TO BUFFER(I2)
  22303.       IP3(I1) = IP3(I1) + 1
  22304.       CALL RIOIN(INFIL,IP3(I1),BUFFER(I2),LREC,IOS)
  22305.       IP1(I1) =I2 + 4
  22306.       IP2(I1) = BUFFER(I2)
  22307.       IP5(I1) = 1
  22308.       IF(BUFFER(I2+1) .LT. 0) IP3(I1) = -IP3(I1)
  22309.       GO TO 50
  22310.    40 CONTINUE
  22311. C
  22312. C  CURRENT PAGE IS LAST PAGE IN CHAIN
  22313. C
  22314.       IF(NIP.EQ.1) GO TO 100
  22315.       DO 45 I=2,NIP
  22316.    45 IP(I-1) = IP(I)
  22317.       NIP = NIP - 1
  22318.       GO TO 25
  22319.    50 CONTINUE
  22320. C
  22321. C  CURRENT IP(1) TUPLE MOVED
  22322. C  PICK UP NEXT AND LET IT SINK
  22323. C
  22324.       IF(NIP.GT.1) CALL SWSINK(IP,IP1,NIP,BUFFER)
  22325.       GO TO 25
  22326.   100 CONTINUE
  22327. C
  22328. C     ALL DONE
  22329. C
  22330.       IF(I5.EQ.0) RETURN
  22331.       BUFFER(J1) = I5
  22332.       BUFFER(J1+2) = OUCH
  22333.       BUFFER(J1+1) = -OUTCHN
  22334. C* WRITE OUTPUT BUFFER
  22335.       CALL RIOOUT(OUTFIL,OUTREC,BUFFER(J1),LREC,IOS)
  22336.       IF(OUTREC.NE.0) OUTREC = OUTREC + 1
  22337.       RETURN
  22338.       END
  22339.       SUBROUTINE SWUNLO(BUFFER,CHAIN1,NCHAIN,LCHAIN,
  22340.      X                   LTUP,LREC,INFIL,OUTFIL)
  22341.       INCLUDE rin:TEXT.BLK
  22342. C
  22343. C  PURPOSE   MERGE ONE SET OF CHAINS INTO
  22344. C            SINGLE CHAIN OF SORTED TUPLES
  22345. C
  22346. C  METHOD    A STACK IS ESTABLISHED WITH
  22347. C            CURRENT FIRST TUPLE IN EACH
  22348. C            CHAIN.THE STACK IS IN ORDER.
  22349. C            THE FIRST TUPLE IS REMOVED
  22350. C            FROM THE STACK AND MOVED TO
  22351. C            OUTPUT BUFFER.THE NEXT TUPLE
  22352. C            IN THE PARTICULAR CHAIN IS
  22353. C            (IF ONE EXISTS) PUT ON TOP
  22354. C            OF STACK AND ALLOWED TO
  22355. C            SINK UNTIL IT IS IN SORT.
  22356. C            IF ONE DOES NOT EXIST,THE
  22357. C            STACK IS SHORTENED.WHEN
  22358. C            ONLY ONE CHAIN EXISTS,
  22359. C            ITS TAIL IS MOVED DIRECTLY
  22360. C            TO OUTPUT FILE
  22361. C  DEFINITION OF PARAMETERS
  22362. C
  22363. C  CHAIN1    RECORD NO ON INFILE WHICH CONTAINS   (INT,I)
  22364. C            PAGE 1 OF FIRST CHAIN
  22365. C
  22366. C  NCHAIN   NUMBER OF CHAINS TO MERGE           (INT,I)
  22367. C
  22368. C  LCHAIN    NUMBER OF PAGES PER INPUT CHAIN     (INT,I)
  22369. C
  22370. C
  22371. C  LTUP      LENGTH OF A TUPLE                   (INT,I)
  22372. C
  22373. C  INFIL     FET OF INPUT FILE                   (FET,I)
  22374. CC
  22375. C  OUTFILE   FET OF OUTLUT FILE                 (FET,I)
  22376. C
  22377. C  DEFINITION OF LOCAL VARIABLES
  22378. C
  22379. C  IP    IP(I)  CONTAINS POINTER TO IP1
  22380. C               FOR I:TH TUPLE IN STACK
  22381. C  IP1   IP1(I) CONTAINS POINTER TO CURRENT
  22382. C               TUPLE ON PAGE I
  22383. C  IP2   IP2(I) CONTAINS POINTER TO LAST
  22384. C               TUPLE ON PAGE I
  22385. C  IP3   IP3(I) CONTAINS RECORD NUMBER ON
  22386. C               INFILE FOR CURRENT PAGE IN
  22387. C               CHAIN I.NEG IF LAST PAGE IN CHAIN
  22388. C  IP4   IP4(I) CONTAINS POINTER TO FIRST
  22389. C               WORD ON PAGE I
  22390. C
  22391.       INTEGER BUFFER(*)
  22392.       INTEGER CHAIN1
  22393.       INTEGER OUTFIL
  22394.       DIMENSION IP(10),IP1(10),IP2(10),IP3(10),IP4(10)
  22395. C
  22396. C  INITIALIZE,IE LOAD THE FIRST
  22397. C  BLOCKS OF THE INPUT CHAINS,SET
  22398. C  UP CONTROL ARRAYS IP,IP1,...,IP4
  22399. C
  22400.       REWIND OUTFIL
  22401.       I1 = CHAIN1
  22402.       I2 = 1
  22403.       DO 10 I=1,NCHAIN
  22404. C* READ RECORD I1 TO BUFFER I2,LENGTH= LREC
  22405.       CALL RIOIN(INFIL,I1,BUFFER(I2),LREC,IOS)
  22406.       IP1(I) = I2+2
  22407.       IP2(I) = I2+(BUFFER(I2)-1)*LTUP+2
  22408.       IP3(I) = I1
  22409.       IF(BUFFER(I2+1) .LT. 0) IP3(I) = -IP3(I)
  22410.       IP(I) = I
  22411.       IP4(I) = I2
  22412.       I1 = I1 + LCHAIN
  22413.       I2 = I2 + LREC
  22414.    10 CONTINUE
  22415.       IF(NCHAIN .GT. 1) GO TO 17
  22416.       IP3(1) = CHAIN1 - 1
  22417.       I1 = 1
  22418.       GO TO 120
  22419.    17 CONTINUE
  22420.       DO 15 I=2,NCHAIN
  22421.       CALL SWSINK(IP(NCHAIN-I+1),IP1(1),I,BUFFER)
  22422.    15 CONTINUE
  22423.       NIP = NCHAIN
  22424. C
  22425. C  INITIAL SETUP COMPLETE,
  22426. C  PREPARE FOR MERGE CYCLE
  22427. C
  22428.    20 CONTINUE
  22429.    25 CONTINUE
  22430.       I1 = IP(1)
  22431.       I2 = IP1(I1) - 1
  22432.       WRITE(OUTFIL) (BUFFER(I2+I),I=1,LTUP)
  22433.       IP1(I1) = IP1(I1) + LTUP
  22434.       IF(IP1(I1) .LE. IP2(I1)) GO TO 50
  22435. C
  22436. C  INPUT BLOCK EMPTY
  22437. C
  22438.       IF(IP3(I1) .LT. 0) GO TO 40
  22439.       I2 = IP4(I1)
  22440. C*  READ BLOCK IP3(I1) TO BUFFER(I2)
  22441.       IP3(I1) = IP3(I1) + 1
  22442.       CALL RIOIN(INFIL,IP3(I1),BUFFER(I2),LREC,IOS)
  22443.       IP1(I1) =I2+2
  22444.       IP2(I1) = I2 + (BUFFER(I2)-1)*LTUP + 2
  22445.       IF(BUFFER(I2+1) .LT. 0) IP3(I1) = -IP3(I1)
  22446.       GO TO 50
  22447.    40 CONTINUE
  22448. C
  22449. C  CURRENT PAGE IS LAST PAGE IN CHAIN
  22450. C
  22451.       DO 45 I=2,NIP
  22452.    45 IP(I-1) = IP(I)
  22453.       NIP = NIP - 1
  22454.       IF(NIP .EQ. 1) GO TO 100
  22455.       GO TO 25
  22456.    50 CONTINUE
  22457. C
  22458. C  CURRENT IP(1) TUPLE MOVED
  22459. C  PICK UP NEXT AND LET IT SINK
  22460. C
  22461.       CALL SWSINK(IP,IP1,NIP,BUFFER)
  22462.       GO TO 25
  22463.   100 CONTINUE
  22464. C
  22465. C  ONLY ONE INPUT CHAIN LEFT
  22466. C
  22467.       I1 = IP(1)
  22468.       I2 = IP1(I1) - 1
  22469.       GO TO 115
  22470.   105 CONTINUE
  22471.       WRITE(OUTFIL) (BUFFER(I2+I),I=1,LTUP)
  22472.       I2 = I2 + LTUP
  22473.   115 IF(I2 .LT. IP2(I1)) GO TO 105
  22474.       IF(IP3(I1) .LT. 0) RETURN
  22475.   120 CONTINUE
  22476. C* READ RECORD IP3(I1)
  22477.       I2 = IP4(I1)
  22478.       IP3(I1) = IP3(I1) + 1
  22479.       CALL RIOIN(INFIL,IP3(I1),BUFFER(I2),LREC,IOS)
  22480.       IP1(I1) = I2 + 2
  22481.       IP2(I1) = I2 + (BUFFER(I2)-1)*LTUP +2
  22482.       IF(BUFFER(I2+1) .LT. 0) IP3(I1) = -IP3(I1)
  22483.       GO TO 100
  22484.       END
  22485.       SUBROUTINE SWUNVL(BUFFER,CHAIN1,NCHAIN,LCHAIN,
  22486.      X                   INCH1,LREC,INFIL,OUTFIL)
  22487.       INCLUDE rin:TEXT.BLK
  22488. C
  22489. C  PURPOSE   MERGE ONE SET OF CHAINS INTO
  22490. C            SINGLE CHAIN OF SORTED TUPLES
  22491. C
  22492. C  METHOD    A STACK IS ESTABLISHED WITH
  22493. C            CURRENT FIRST TUPLE IN EACH
  22494. C            CHAIN.THE STACK IS IN ORDER.
  22495. C            THE FIRST TUPLE IS REMOVED
  22496. C            FROM THE STACK AND MOVED TO
  22497. C            OUTPUT BUFFER.THE NEXT TUPLE
  22498. C            IN THE PARTICULAR CHAIN IS
  22499. C            (IF ONE EXISTS) PUT ON TOP
  22500. C            OF STACK AND ALLOWED TO
  22501. C            SINK UNTIL IT IS IN SORT.
  22502. C            IF ONE DOES NOT EXIST,THE
  22503. C            STACK IS SHORTENED.WHEN
  22504. C            ONLY ONE CHAIN EXISTS,
  22505. C            ITS TAIL IS MOVED DIRECTLY
  22506. C            TO OUTPUT FILE
  22507. C  DEFINITION OF PARAMETERS
  22508. C
  22509. C  CHAIN1    RECORD NO ON INFILE WHICH CONTAINS   (INT,I)
  22510. C            PAGE 1 OF FIRST CHAIN
  22511. C
  22512. C  NCHAIN   NUMBER OF CHAINS TO MERGE           (INT,I)
  22513. C
  22514. C  LCHAIN    NUMBER OF PAGES PER INPUT CHAIN     (INT,I)
  22515. C
  22516. C  INCH1     CHAIN NUMBER OF FIRST INPUT CHAIN   (INT,I)
  22517. C
  22518. C  INFIL     FET OF INPUT FILE                   (FET,I)
  22519. CC
  22520. C  OUTFILE   FET OF OUTLUT FILE                 (FET,I)
  22521. C
  22522. C  DEFINITION OF LOCAL VARIABLES
  22523. C
  22524. C  IP    IP(I)  CONTAINS POINTER TO IP1
  22525. C               FOR I:TH TUPLE IN STACK
  22526. C  IP1   IP1(I) CONTAINS POINTER TO CURRENT
  22527. C               TUPLE ON PAGE I
  22528. C  IP2   IP2(I) CONTAINS NUMBER OF TUPLES
  22529. C               ON PAGE I
  22530. C  IP3   IP3(I) CONTAINS RECORD NUMBER ON
  22531. C               INFILE FOR CURRENT PAGE IN
  22532. C               CHAIN I.NEG IF LAST PAGE IN CHAIN
  22533. C  IP4   IP4(I) CONTAINS POINTER TO FIRST
  22534. C               WORD ON PAGE I
  22535. C
  22536. C  IP5   IP5(I) CONTAINS SEQUENTIAL TUPLE NUMBER
  22537. C                OF CURRENT TUPLE PAGE I.
  22538. C
  22539. C  DEFINITION OF LOCAL VARIABLES
  22540. C
  22541. C  INCH    INPUT CHAIN NUMBER
  22542. C
  22543.       INTEGER BUFFER(*)
  22544.       INTEGER CHAIN1
  22545.       INTEGER OUTFIL
  22546.       DIMENSION IP(10),IP1(10),IP2(10),IP3(10),IP4(10)
  22547.       DIMENSION IP5(10)
  22548. C
  22549. C  INITIALIZE,IE LOAD THE FIRST
  22550. C  BLOCKS OF THE INPUT CHAINS,SET
  22551. C  UP CONTROL ARRAYS IP,IP1,...,IP4
  22552. C
  22553.       REWIND OUTFIL
  22554.       I1 = CHAIN1
  22555.       I2 = 1
  22556.       INCH = INCH1
  22557.       DO 10 I=1,NCHAIN
  22558. C* READ RECORD I1 TO BUFFER I2,LENGTH= LREC
  22559.     1 CONTINUE
  22560. C
  22561. C     LOOK FOR CORRECT RECORD
  22562. C
  22563.       CALL RIOIN(INFIL,I1,BUFFER(I2),LREC,IOS)
  22564.       NUMCH = IABS(BUFFER(I2+1))
  22565.       IF(NUMCH.LT.INCH) GO TO 5
  22566.       IF(NUMCH.GT.INCH) GO TO 7
  22567. C
  22568. C     WE ARE IN THE CORRECT CHAIN
  22569. C
  22570.       INT = BUFFER(I2+2)
  22571.       IF(INT.EQ.1) GO TO 8
  22572.       I1 = I1 - INT + 1
  22573.       GO TO 1
  22574.     5 CONTINUE
  22575. C
  22576. C     IN SOME PREVIOUS CHAIN
  22577. C
  22578.       I1 = I1 + 1
  22579.       IF(BUFFER(I2+1).GT.0) I1 = I1 + 1
  22580.       GO TO 1
  22581.     7 CONTINUE
  22582. C
  22583. C     GOOD LORD - IN SOME SUBSEQUENT CHAIN
  22584. C
  22585.       I1 = I1 - BUFFER(I2+2)
  22586.       GO TO 1
  22587.     8 CONTINUE
  22588. C
  22589. C     FOUND THE FIRST RECORD IN CHAIN INCH
  22590. C
  22591.       IP1(I) = I2+4
  22592.       IP2(I) = BUFFER(I2)
  22593.       IP5(I) = 1
  22594.       IP3(I) = I1
  22595.       IF(BUFFER(I2+1) .LT. 0) IP3(I) = -IP3(I)
  22596.       IP(I) = I
  22597.       IP4(I) = I2
  22598.       I1 = I1 + LCHAIN
  22599.       I2 = I2 + LREC
  22600.       INCH = INCH + 1
  22601.    10 CONTINUE
  22602.       IF(NCHAIN.EQ.1) GO TO 18
  22603.       DO 15 I=2,NCHAIN
  22604.       CALL SWSINK(IP(NCHAIN-I+1),IP1(1),I,BUFFER)
  22605.    15 CONTINUE
  22606.    18 CONTINUE
  22607.       NIP = NCHAIN
  22608. C
  22609. C  INITIAL SETUP COMPLETE,
  22610. C  PREPARE FOR MERGE CYCLE
  22611. C
  22612.    25 CONTINUE
  22613.       I1 = IP(1)
  22614.       I2 = IP1(I1) - 2
  22615.       LTUP = BUFFER(I2+1) + 1
  22616.    27 CONTINUE
  22617.       WRITE(OUTFIL) (BUFFER(I+I2),I=1,LTUP)
  22618.       IP1(I1) = IP1(I1) + LTUP
  22619.       IP5(I1) = IP5(I1) + 1
  22620.       IF(IP5(I1) .LE. IP2(I1)) GO TO 50
  22621. C
  22622. C  INPUT BLOCK EMPTY
  22623. C
  22624.       IF(IP3(I1) .LT. 0) GO TO 40
  22625.       I2 = IP4(I1)
  22626. C*  READ BLOCK IP3(I1) TO BUFFER(I2)
  22627.       IP3(I1) = IP3(I1) + 1
  22628.       CALL RIOIN(INFIL,IP3(I1),BUFFER(I2),LREC,IOS)
  22629.       IP1(I1) =I2 + 4
  22630.       IP2(I1) = BUFFER(I2)
  22631.       IP5(I1) = 1
  22632.       IF(BUFFER(I2+1) .LT. 0) IP3(I1) = -IP3(I1)
  22633.       GO TO 50
  22634.    40 CONTINUE
  22635. C
  22636. C  CURRENT PAGE IS LAST PAGE IN CHAIN
  22637. C
  22638.       IF(NIP.EQ.1) GO TO 100
  22639.       DO 45 I=2,NIP
  22640.    45 IP(I-1) = IP(I)
  22641.       NIP = NIP - 1
  22642.       GO TO 25
  22643.    50 CONTINUE
  22644. C
  22645. C  CURRENT IP(1) TUPLE MOVED
  22646. C  PICK UP NEXT AND LET IT SINK
  22647. C
  22648.       IF(NIP.GT.1) CALL SWSINK(IP,IP1,NIP,BUFFER)
  22649.       GO TO 25
  22650.   100 CONTINUE
  22651. C
  22652. C     ALL DONE
  22653. C
  22654.       RETURN
  22655.       END
  22656.       SUBROUTINE SWVLFS(INFIL,OUTFIL,SCFIL1,SCFIL2,
  22657.      X                 BUFFER,LBUF,LPRU,DPRU,IERR)
  22658.       INCLUDE rin:TEXT.BLK
  22659. C
  22660. C  PURPOSE  DRIVER FOR OUT-OF-CORE SORT
  22661. C           OF VARIABLE LENGTH TUPLES
  22662. C
  22663. C  METHOD   A LEAST COST SORT STRATEGY
  22664. C           IS ESTABLISHED BASED UPON
  22665. C           MACHINE DEPENDENT PARAMETERS
  22666. C           THE COST IS BASED UPON
  22667. C           COST FOR POSITIONING ON
  22668. C           MASS STORAGE,MASS STORAGE
  22669. C           TRANSFERS,IN-CORE MOVEMENT
  22670. C           OF DATA AND COMPARISON OF
  22671. C           DATA.
  22672. C           AN N-ARY SORT/MERGE STRATEGY
  22673. C           IS CHOOSEN WHERE 2 LE N LE 9
  22674. C           N IS THE NUMBER OF CHAINS
  22675. C           OF DATA THAT IS MERGED IN
  22676. C           ONE SINGLE MERGE. EACH SORT PASS
  22677. C           MAY REQUIRE SEVERAL SUCH MERGES.
  22678. C
  22679. C
  22680. C  DEFINITION OF VARIABLES
  22681. C
  22682. C  INFIL   FILE NAME OF FILE (SEQ) WHICH    (INT,I)
  22683. C          CONTAINS INPUT TUPLES
  22684. C         INFIL IS UNFORMATTED (BINARY)
  22685. C         EACH TUPLE IS WRITTEN AS A
  22686. C         RECORD AS FOLLOWS
  22687. C         FOR FIXED LENGTH RECORDS
  22688. C           WRITE(INFIL) (TUP(I),I=1,LTUPLE)
  22689. C         FOR VARIABLE LENGTH RECORDS
  22690. C           WRITE(INFIL) L,(TUP(I),I=1,L)
  22691. C
  22692. C  OUTFIL  FILE NAME OF FILE (SEQ) WHICH    (INT,I)
  22693. C          CONTAINS OUTPUT (SORTED) TUPLES
  22694. C          OUTFIL MAY EQ INFIL
  22695. C          FORMAT OF OUTFIL IS THE
  22696. C          SAME AS THAT OF INFIL
  22697. C
  22698. C  SCFIL1  FILE NAME OF (RAN) SCRATCH FILE  (TEXT,I)
  22699. C
  22700. C  SCFIL2  FILE NAME OF (RAN) SCRATCH FILE  (TEXT,I)
  22701. C          NOTE THAT SCFIL1 MUST NOT BE
  22702. C          EQUAL TO SCFIL2
  22703. C
  22704. C  BUFFER  INCORE SCRATCH AREA              (ANY,SCRATCH)
  22705. C
  22706. C  LBUF    LENGTH OF BUFFER                 (INT,I)
  22707. C
  22708. C  LPRU    QUANTUM LENGTH OF RANDOM         (INT,I)
  22709. C          FILE RECORDS
  22710. C
  22711. C  DPRU    DELTA QUANTUM LENGTH OF          (INT,I)
  22712. C          RANDOM FILE RECORDS.
  22713. C          THE LENGTH OF SUCH A RECORD
  22714. C          MUST EQUAL
  22715. C          I*LPRU+DPRU
  22716. C
  22717. C  IERR    ERROR CONDITION                  (INT,O)
  22718. C           0 NORMAL RETURN
  22719. C           1 ERROR IN FILE READ
  22720. C           2 ERROR IN FILE WRITE
  22721. C
  22722. C
  22723. C  DEFINITION OF LOCAL VARIABLES
  22724. C
  22725. C  I1     SCRATCH
  22726. C  I2     SCRATCH,NO OF PAGES IN INITIAL
  22727. C         OFLOADING
  22728. C  I3     SCRATCH,NO OF SORT PASSES,NOT COUNTING
  22729. C         ACTIONS ON SEQUENTIAL FILES
  22730. C         OF WHOLE RANDOM FILES
  22731. C  I4     SCRATCH
  22732. C  I5     SCRATCH
  22733. C  I6     LOW COST SORT ORDER
  22734. C  I7     NO OF INCORE PAGES IN INITIAL
  22735. C         PASS WHERE SEQUENTIAL FILE IS
  22736. C         OFFLOADED
  22737. C  I8     SCRATCH,NO OF TUPLES PER RAN FILE PAGE
  22738. C  I9     SCRATCH,NO OF PAGES ON RANDOM FILES
  22739. C  I10    SCRATCH,LENGTH OF RANDOM FILE PAGE
  22740. C  COST   COST OF OPTIMUM SORT STRATEGY
  22741. C  NRECS  NO OF PAGES ON RANDOM SCRATCH FILE
  22742. C  LREC   LENGTH OF RANDOM FILE PAGE
  22743. C
  22744.       INCLUDE rin:SRTCOM.BLK
  22745.       DIMENSION BUFFER(*)
  22746.       INTEGER DPRU
  22747.       INTEGER SCARR1,SCARR2
  22748.       REAL*8 SCFIL1,SCFIL2
  22749.       INTEGER CHAIN1,OUTREC
  22750.       INTEGER TUPL
  22751.       LOGICAL SWITCH
  22752.       I6 = 0
  22753.       I1 = 2*LPRU
  22754.       I11 = 2*DPRU
  22755.       TUPL = LTUPLE/NSORT
  22756.       DO 100 I=2,9
  22757.       I1 = I1 + LPRU
  22758.       I11 = I11 + DPRU
  22759.       I10 = LPRU*((LBUF-I11)/I1) + DPRU
  22760.       IF(I10 .LT. LTUMAX+2) GO TO 110
  22761.       I8 = (I10 - 2 - TUPL/2) / TUPL
  22762.       IF(I8 .EQ. 0) I8 = 1
  22763.       I2 = (LTUMIN*(LBUF-LTUMAX-I10))/((LTUMIN+1)*(I10-2))
  22764. C
  22765. C  I2 IS NO OF INCORE BLOCKS IN
  22766. C     INITIAL PASS
  22767. C
  22768.       I9 =(NSORT+I8-1)/I8
  22769.       I3 = 1
  22770.       I4 = I2
  22771.    10 CONTINUE
  22772.       I5 = I4
  22773.       I4 = I4*I + I5
  22774.       IF (I4 .GE. I9) GO TO 20
  22775.       I4 = I4 - I5
  22776.       I3 = I3 + 1
  22777.       GO TO 10
  22778.    20 CONTINUE
  22779. C
  22780.       CALL SWCOST(I3,I9,I10,I,A1)
  22781.       IF(I6 .GT. 0) GO TO 30
  22782.       GO TO 35
  22783.    30 CONTINUE
  22784.       IF(A1 .GE. COST) GO TO 90
  22785.    35 COST = A1
  22786.       I7 = I2
  22787.       I6 = I
  22788.       LREC = I10
  22789.    90 CONTINUE
  22790.       IF(I3 .EQ. 1) GO TO 110
  22791.   100 CONTINUE
  22792.   110 CONTINUE
  22793. C
  22794. C  OPTIMUM SORT STRATEGY DETERMINED
  22795. C
  22796. C  OPEN SORT SCRATCH FILES
  22797. C
  22798.       SCARR1 = 35
  22799.       SCARR2 = 36
  22800.       CALL DROPF(SCFIL1)
  22801.       CALL DROPF(SCFIL2)
  22802.       CALL RIOOPN(SCFIL1,SCARR1,LREC,IOS)
  22803.       CALL RIOOPN(SCFIL2,SCARR2,LREC,IOS)
  22804.       CALL SWVLLO(BUFFER,LREC,I7,INFIL,SCARR1,NI)
  22805. C
  22806. C     NPASS IS THE NUMBER OF RANDOM TO RANDOM MERGES
  22807. C     NI IS THE NUMBER OF CHAINS ON THE INPUT FILE
  22808. C     NO IS THE NUMBER OF CHAINS ON THE OUTPUT FILE
  22809. C     NCHAIN IS THE NUMBER OF CHAINS TO MERGE
  22810. C     LCHAIN IS THE NUMBER OF PAGES PER INPUT CHAIN
  22811. C
  22812.       LCHAIN = I7
  22813.       NCHAIN = I6
  22814.       NO = NI
  22815.       SWITCH = .TRUE.
  22816. C
  22817. C     OUTER LOOP ON THE NUMBER OF PASSES
  22818.       IF(NI .LE. I6) GO TO 250
  22819.   130 CONTINUE
  22820.       NI = NO
  22821.       NO = (NI-1)/NCHAIN
  22822.       NO = NO + 1
  22823.       SWITCH = .NOT. SWITCH
  22824.       IF(SWITCH) CALL DROPF(SCFIL1)
  22825.       IF(SWITCH) CALL RIOOPN(SCFIL1,SCARR1,LREC,IOS)
  22826.       IF(.NOT.SWITCH) CALL DROPF(SCFIL2)
  22827.       IF(.NOT.SWITCH) CALL RIOOPN(SCFIL2,SCARR2,LREC,IOS)
  22828.       INC = LCHAIN*NCHAIN
  22829. C
  22830. C     INNER LOOP ON NUMBER OF OUTPUT CHAINS
  22831. C
  22832.       INCH = 1
  22833.       DO 150 J=1,NO
  22834.       CHAIN1 = (J-1)*INC + 1
  22835.       OUTREC = 0
  22836.       NCH = NCHAIN
  22837.       IF(J.EQ.NO) NCH = NI - (NO-1)*NCHAIN
  22838.       IF(SWITCH) CALL SWSMVL(BUFFER,CHAIN1,NCH,LCHAIN,OUTREC,J,
  22839.      X       INCH,LREC,SCARR2,SCARR1)
  22840.       IF(.NOT.SWITCH) CALL SWSMVL(BUFFER,CHAIN1,NCH,LCHAIN,OUTREC,J,
  22841.      X       INCH,LREC,SCARR1,SCARR2)
  22842.       INCH = INCH + NCH
  22843.   150 CONTINUE
  22844.       LCHAIN = LCHAIN * NCHAIN
  22845.       IF(NO .GT. I6+1) GO TO 130
  22846.   250 CONTINUE
  22847. C
  22848. C     CALL SWUNVL TO CREATE OUTPUT SEQUENTIAL FILE
  22849. C
  22850.       CHAIN1 = 1
  22851.       NCH = NO
  22852.       INCH = 1
  22853.       IF(SWITCH) CALL SWUNVL(BUFFER,CHAIN1,NCH,LCHAIN,
  22854.      X      INCH,LREC,SCARR1,OUTFIL)
  22855.       IF(.NOT.SWITCH) CALL SWUNVL(BUFFER,CHAIN1,NCH,LCHAIN,
  22856.      X      INCH,LREC,SCARR2,OUTFIL)
  22857. C
  22858. C     RETURN THE SCRATCH RANDOM FILES
  22859. C
  22860.       CALL DROPF(SCFIL1)
  22861.       CALL DROPF(SCFIL2)
  22862.       RETURN
  22863.       END
  22864.       SUBROUTINE SWVLLO(BUFFER,LREC,NREC,INFIL,OUTFIL,NI)
  22865.       INCLUDE rin:TEXT.BLK
  22866. C
  22867. C  PURPOSE  LOADING PASS FOR OUT-OF-CORE SORT
  22868. C           OF VARIABLE LENGTH TUPLES
  22869. C
  22870. C  TIMING   UNKNOWN
  22871. C
  22872. C  DEFINITION OF VARIABLES
  22873. C
  22874. C  BUFFER   CORE SCRATCH AREA OF                  (SCRATCH)
  22875. C           SUFFICIENT LENGTH
  22876. C
  22877. C  LBUF     LENGTH OF BUFFER                      (INT,I)
  22878. C
  22879. C  LREC     LENGTH, IN WORDS, OF OUTPUT RECORD    (INT,I)
  22880. C
  22881. C
  22882. C  INFIL   FILE NAME OF FILE (SEQ) WHICH    (INT,I)
  22883. C           CONTAINS INPUT TUPLES
  22884. C           INFIL IS UNFORMATTED (BINARY)
  22885. C           EACH TUPLE IS WRITTEN AS A
  22886. C           RECORD AS FOLLOWS
  22887. C           FOR FIXED LENGTH RECORDS
  22888. C             WRITE(INFIL) (TUP(I),I=1,LENGTH)
  22889. C           FOR VARIABLE LENGTH RECORDS
  22890. C             WRITE(INFIL) L,(TUP(I),I=1,L)
  22891. C
  22892. C  OUTFIL   FET FOR FILE      (RANDOM) WHICH      (INT,I)
  22893. C           CONTAINS CHAINS OF SORTED TUPLES
  22894. C           EACH CHAIN CONTAINS ONE OR MORE BLOCKS
  22895. C           EACH BLOCK CONTAINS
  22896. C            WORD 1   = NO TUPLES IN BLOCK
  22897. C            WORD 2   = CHAIN NO,NEG FOR LAST BLOCK
  22898. C            WORD 3   = RECORD NUMBER IN CHAIN
  22899. C            WORD 4FF = TUPLES IN SORTED ORDER
  22900. C
  22901. C  NI         NUMBER OF CHAINS GENERATED
  22902. C
  22903.       INTEGER BUFFER(*)
  22904.       INTEGER OUTFIL
  22905. C
  22906. C  DEFINITION OF LOCAL VARIABLES
  22907. C  FIRST AN EXPLANATION OF HOW BUFFER IS USED
  22908. C
  22909. C  ON TOP OF BUFFER IS TUPLE INPUT AREA,LENGTH LTUMAX-1
  22910. C  SECOND IS RECORD OUTPUT AREA,LENGTH LREC
  22911. C  THIRD IS TUPLE SORT AREA,LENGTH NREC*(LREC-2)
  22912. C  FOUTH AND LAST IS POINTER AREA,LENGTH (NREC*(LREC-2))/LTUMIN
  22913. C
  22914. C  I1  ADDRESS TO FIRST WORD IN TUPLE AREA
  22915. C  I2  ADDRESS TO NEXT TUPLE (LENGTH WORD)
  22916. C  I3  AVAILABLE ROOM IN TUPLE AREA
  22917. C  I4  ADDRESS TO FIRST WORD IN POINTER AREA
  22918. C  I5  ADDRESS TO CURRENT POINTER
  22919. C  I6  CURRENT TUPLE ON INPUT FILE
  22920. C  I8  ADDRESS TO CURRENT TUPLE IN OUTPUT BUFFER
  22921. C  I9  NUMBER OF TUPLES IN OUTPUT BUFFER
  22922. C  I10 NUMBER OF OUTPUT RECORDS CURRENTLY WRITTEN
  22923. C      IN CHAIN
  22924. C  I11 LENGTH OF TUPLE IN INPUT AREA
  22925. C
  22926.       INCLUDE rin:SRTCOM.BLK
  22927.       REWIND INFIL
  22928.       I1 = LTUMAX + LREC
  22929.       LTUM = LTUMAX - 1
  22930.       I2 = I1
  22931.       I33 = NREC*(LREC - 3)
  22932.       I3 = I33
  22933.       I4 = I1 + I3
  22934.       I5 = I4
  22935.       I6 = 0
  22936.       NI = 0
  22937.       ILAST = 0
  22938.    10 CONTINUE
  22939. C
  22940. C  FILL TUPLE AREA
  22941. C
  22942.       I6 = I6 + 1
  22943.       IF(I6 .GT. NSORT) GO TO 100
  22944. c      READ(INFIL) I11,(BUFFER(J2),J2=1,I11)
  22945.       READ(INFIL) I11
  22946.       READ(INFIL) (BUFFER(J2),J2=1,I11)
  22947.    12 CONTINUE
  22948.       IF(I11 .GE. I3) GO TO 20
  22949.       DO 15 J2=1,I11
  22950.    15 BUFFER(I2+J2) = BUFFER(J2)
  22951.       BUFFER(I2) = I11
  22952.       BUFFER(I5) = I2 + 1
  22953.       I2 = I2 + I11 + 1
  22954.       I5 = I5 + 1
  22955.       I3 = I3 - I11 - 1
  22956.       GO TO 10
  22957.    20 CONTINUE
  22958. C
  22959. C  TUPLE AREA FULL,OR NO
  22960. C  MORE TUPLES ON INPUT FILE
  22961. C  SORT,UNLOAD
  22962. C
  22963.       CALL SWICST(BUFFER,BUFFER(I4),I5-I4)
  22964.       NI = NI + 1
  22965.       BUFFER(LTUM+2) = NI
  22966.       J1 = I4
  22967.       I10 = 0
  22968.    25 I9 = 0
  22969.       I8 = LTUM + 4
  22970.    30 CONTINUE
  22971.       J2 = BUFFER(J1) - 1
  22972.       J3 = BUFFER(J2)
  22973.       IF(J3+I8 .GE. I1) GO TO 50
  22974.       DO 40 J4=1,J3
  22975.    40 BUFFER(I8+J4) = BUFFER(J2+J4)
  22976.       I9 = I9 + 1
  22977.       J1 = J1 + 1
  22978.       BUFFER(I8) = J3
  22979.       I8 = I8 + J3 + 1
  22980.       IF(J1 .LT. I5) GO TO 30
  22981.       BUFFER(LTUM+2) = -NI
  22982.    50 CONTINUE
  22983. C
  22984. C  WRITE OUTPUT BUFFER
  22985. C
  22986.       BUFFER(LTUM+1) = I9
  22987.       I10 = I10 + 1
  22988.       IF(I10 .EQ. NREC .AND. ILAST .EQ. 0) BUFFER(LTUM+2) = -NI
  22989.       BUFFER(LTUM+3) = I10
  22990.       CALL RIOOUT(OUTFIL,0,BUFFER(LTUM+1),LREC,IOS)
  22991.       IF(BUFFER(LTUM+2).GT.0) GO TO 25
  22992. C
  22993. C  SHUFFLE TUPLE AREA IF REQUIRED
  22994. C
  22995.       I2 = I1
  22996.       I3 = I33
  22997.       I55 = I5
  22998.       I5 = I4
  22999.       IF(J1 .LT. I55) GO TO 60
  23000.       IF(ILAST .EQ. 0) GO TO 12
  23001.       RETURN
  23002.    60 CONTINUE
  23003.       NUM = I55 - J1
  23004.       CALL SWSHEL(BUFFER(J1),NUM)
  23005.    65 CONTINUE
  23006.       J2 = BUFFER(J1) - 1
  23007.       J3 = BUFFER(J2)
  23008.       DO 70 J4=1,J3
  23009.    70 BUFFER(I2+J4) = BUFFER(J2+J4)
  23010.       BUFFER(I2) = J3
  23011.       BUFFER(I5) = I2 + 1
  23012.       I2 = I2 + J3 + 1
  23013.       I5 = I5 + 1
  23014.       I3 = I3 - J3 - 1
  23015.       J1 = J1 + 1
  23016.       IF(J1 .LT. I55) GO TO 65
  23017.       GO TO 12
  23018.   100 CONTINUE
  23019. C
  23020. C  ALL TUPLES READ FROM INFIL
  23021. C
  23022.       ILAST = 1
  23023.       GO TO 20
  23024.       END
  23025.       SUBROUTINE TALLY
  23026.       INCLUDE rin:TEXT.BLK
  23027. C
  23028. C  PURPOSE:  THIS ROUTINE PROCESSES THE RIM TALLY COMMAND
  23029. C
  23030. C  PARAMETERS: NONE
  23031. C
  23032.       INCLUDE rin:RMATTS.BLK
  23033.       INCLUDE rin:CONST4.BLK
  23034.       INCLUDE rin:RIMCOM.BLK
  23035.       INCLUDE rin:WHCOM.BLK
  23036.       INCLUDE rin:FILES.BLK
  23037.       INCLUDE rin:MISC.BLK
  23038.       INCLUDE rin:BUFFER.BLK
  23039.       INCLUDE rin:SELCOM.BLK
  23040.       INCLUDE rin:TUPLEA.BLK
  23041. C
  23042.       LOGICAL DONE
  23043.       LOGICAL ITALLY
  23044. C
  23045. C  THE FOLLOWING FUNNY LOOKING STUFF IS TO MAKE THE TITLE
  23046. C  "NUMBER OF OCCURANCES" WORK. FTN5, PORTABLE, ETC. -----
  23047. C
  23048.       INTEGER HEADER(6)
  23049.       EQUIVALENCE (HEADER(1),K4HEAD(1))
  23050. C
  23051. C     SET LPP AND MCPL
  23052. C
  23053.       LPP = 10000000
  23054.       IF(.NOT.CONNO) LPP = 56
  23055.       MCPL = 50
  23056.       IF(.NOT.CONNO)MCPL = 100
  23057.       IF(ULPP.NE.0) LPP = ULPP
  23058.       IF(UMCPL.NE.0) MCPL = UMCPL - 25
  23059.       IF(MCPL.LT.10) MCPL = 10
  23060. C
  23061. C     CALL SELPAR TO SET SELCOM BLOCK
  23062. C
  23063.       ITALLY = .TRUE.
  23064.       CALL SELPAR(ITALLY)
  23065.       IF(NUMATT.LE.0) GO TO 900
  23066.       NLINE = 3
  23067. C
  23068. C  PUT "NUMBER OF OCCURANCES" INTO THE TITLE LINE
  23069. C
  23070.       NPOS1 = NUMCOL(1) + 2
  23071.       NPOS = NPOS1 + 3
  23072.       CALL FILCH(TITLE,NPOS1,3,BLANK)
  23073.       CALL FILCH(MINUS,NPOS1,3,BLANK)
  23074.       NPOSH = NPOS
  23075.       DO 20 K=1,6
  23076.       CALL STRMOV(HEADER(K),1,4,TITLE,NPOSH)
  23077.       NPOSH = NPOSH + 4
  23078.    20 CONTINUE
  23079.       CALL FILCH(MINUS,NPOS,21,K4MNUS)
  23080.       NUM = NPOS + 20
  23081.       if(noutr.ne.6)WRITE (NOUTR,30)
  23082.    30 FORMAT(1H )
  23083.       CALL SPOUT(TITLE,NUM)
  23084.       CALL SPOUT(MINUS,NUM)
  23085. C
  23086. C  GET THE ATTRIBUTE LENGTH
  23087. C
  23088.       N2 = ATTWDS
  23089. C
  23090. C  SET UP THE NUMBER OF WORDS THAT WERE SORTED ON
  23091. C
  23092.       LOOP = 1
  23093.       IF(ATTYPE.EQ.KZTEXT) LOOP = 20/CHPWD
  23094.       IF(ATTYPE.EQ.KZDOUB) LOOP = 2
  23095.       IF(ATTYPE.EQ.KZDVEC) LOOP = 2
  23096.       IF(ATTYPE.EQ.KZDMAT) LOOP = 2
  23097.       IF(LOOP.GT.N2) LOOP = N2
  23098. C
  23099. C  SET UP A SCRATCH AREA IN BUFFER TO HOLD TUPLES
  23100. C
  23101. C  ESTABLISH THE BUFFER POINTER
  23102. C
  23103.       CALL BLKCHG(10,MAXCOL,1)
  23104.       KQ1 = BLKLOC(10) - 1
  23105. C
  23106. C  RETRIVE THE SORTED ATTRIBUTE VALUES FROM THE SORT FILE
  23107. C
  23108.       CALL GTSORT(IP,1,-1,N2)
  23109. C
  23110. C  GET THE VERY FIRST VALUE.
  23111. C
  23112.       NPRT = 0
  23113.       LIMTUT = LIMTU
  23114.       LIMTU = ALL9S
  23115.       CALL GTSORT(IP,1,1,N2)
  23116.   100 CONTINUE
  23117.       NOCC = 1
  23118. C
  23119. C  USE BUFFER AS A SCRATCH ARRAY TO HOLD THE ATTRIBUTE VALUE
  23120. C
  23121.       DO 110 N=1,N2
  23122.       BUFFER(KQ1+N) = BUFFER(IP+N-1)
  23123.   110 CONTINUE
  23124.   200 CONTINUE
  23125.       CALL GTSORT(IP,1,1,N2)
  23126.       IF(RMSTAT.NE.0) GO TO 400
  23127.       DO 210 N=1,LOOP
  23128.       IF(BUFFER(IP+N-1).NE.BUFFER(KQ1+N)) GO TO 400
  23129.   210 CONTINUE
  23130.       NOCC = NOCC + 1
  23131.       GO TO 200
  23132. C
  23133. C  THERE HAS BEEN A VALUE CHANGE. PRINT THE VALUE AND COUNT.
  23134. C
  23135.   400 CONTINUE
  23136.       NPRT = NPRT + 1
  23137.       IF(NPRT.LE.LIMTUT) GO TO 405
  23138. C
  23139. C  ALL DONE - CLOSE THE SORT FILE
  23140. C
  23141.       LIMTU = 0
  23142.       CALL GTSORT(IP,1,1,N2)
  23143.       GO TO 999
  23144.   405 CONTINUE
  23145.       CURPOS(1) = 1
  23146.       CALL FILCH(LINE,1,NUM,BLANK)
  23147.       CALL SELOUT(BUFFER(KQ1+1),1,DONE)
  23148.       IF(NLINE.LT.LPP) GO TO 420
  23149.       NLINE = 3
  23150.       IF(.NOT.CONNO.and.noutr.ne.6) WRITE(NOUTR,410)
  23151.   410 FORMAT(1H1)
  23152.       if(noutr.ne.6)WRITE(NOUTR,30)
  23153.       CALL SPOUT(TITLE,NUM)
  23154.       CALL SPOUT(MINUS,NUM)
  23155.   420 CONTINUE
  23156. C
  23157. C  PUT THE COUNT INTO LINE AND PRINT
  23158. C
  23159.       CALL ITOC(LINE,NPOS1+5,8,NOCC,IERR)
  23160.       CALL SPOUT(LINE,NUM)
  23161.       NLINE = NLINE + 1
  23162.       IF(RMSTAT.EQ.0) GO TO 100
  23163.       GO TO 999
  23164. C
  23165. C     NO VALID ATTRIBUTES
  23166. C
  23167.   900 CONTINUE
  23168.     if(nout.eq.6)goto 3148
  23169.       WRITE (NOUT,910)
  23170.     goto 999
  23171. 3148    write(c128wk,910)
  23172.     call atxto
  23173.   910 FORMAT(40H -WARNING- No Valid Attributes Specified )
  23174.   999 CONTINUE
  23175.       LIMTU = LIMTUT
  23176.       CALL BLKCLR(10)
  23177.       RETURN
  23178.       END
  23179.       SUBROUTINE TOLED(K,V,N)
  23180.       INCLUDE rin:TEXT.BLK
  23181. C
  23182. C     THIS ROUTINE APPLIES A TOLERANCE TO A DOUBLE ROUTINE
  23183. C
  23184. C     K IS LOCBOO VALUE
  23185. C     V(N) IS DOUBLE ARRAY
  23186. C
  23187.       INCLUDE rin:FLAGS.BLK
  23188.       DOUBLE PRECISION V(N)
  23189.       DOUBLE PRECISION X
  23190.       X = TOL
  23191.       IF(K.GT.5) X = -X
  23192.       IF(PCENT) GO TO 50
  23193.       DO 20 I=1,N
  23194.       V(I) = V(I) - X
  23195.    20 CONTINUE
  23196.       RETURN
  23197.    50 CONTINUE
  23198.       DO 70 I=1,N
  23199.       V(I) = V(I)*(1.-X)
  23200.    70 CONTINUE
  23201.       RETURN
  23202.       END
  23203.       SUBROUTINE TOLER(K,V,N)
  23204.       INCLUDE rin:TEXT.BLK
  23205. C
  23206. C     THIS ROUTINE APPLIES A TOLERANCE TO A REAL ROUTINE
  23207. C
  23208. C     K IS LOCBOO VALUE
  23209. C     V(N) IS REAL ARRAY
  23210. C
  23211.       INCLUDE rin:FLAGS.BLK
  23212.       DIMENSION V(N)
  23213.       X = TOL
  23214.       IF(K.GT.5) X = -TOL
  23215.       IF(PCENT) GO TO 50
  23216.       DO 20 I=1,N
  23217.       V(I) = V(I) - X
  23218.    20 CONTINUE
  23219.       RETURN
  23220.    50 CONTINUE
  23221.       DO 70 I=1,N
  23222.       V(I) = V(I)*(1.-X)
  23223.    70 CONTINUE
  23224.       RETURN
  23225.       END
  23226.       LOGICAL FUNCTION TTY(I)
  23227. C
  23228. C  DUMMY ROUTINE FOR TTY ON THE VAX -- ALWAYS TRUE
  23229. C
  23230.       TTY = .TRUE.
  23231.       RETURN
  23232.       END
  23233.       SUBROUTINE TYPER(ATYPE,VECMAT,TYPE)
  23234.       INCLUDE rin:TEXT.BLK
  23235. C
  23236. C     THIS ROUTINE TURNS RIM TYPES SUCH AS IVEC
  23237. C     INTO TWO USEFUL TYPES.
  23238. C
  23239. C     ATYPE...RIM TYPE
  23240. C     VECMAT..3HVEC,3HMAT OR BLANKS
  23241. C     TYPE....3HINT,4HREAL,4HDOUB,4HTEXT
  23242. C
  23243.       INCLUDE rin:RMATTS.BLK
  23244.       INCLUDE rin:MISC.BLK
  23245.       INCLUDE rin:CONST4.BLK
  23246. C
  23247.       INTEGER ATYPE,VECMAT,TYPE
  23248.       VECMAT = IBLANK
  23249.       TYPE = ATYPE
  23250.       IF(TYPE.EQ.KZTEXT) RETURN
  23251.       IF(TYPE.EQ.KZINT ) RETURN
  23252.       IF(TYPE.EQ.KZREAL) RETURN
  23253.       IF(TYPE.EQ.KZDOUB) RETURN
  23254.       VECMAT = KZVEC
  23255.       TYPE = K4NONE
  23256.       IF(ATYPE.EQ.KZIVEC) TYPE = KZINT
  23257.       IF(ATYPE.EQ.KZRVEC) TYPE = KZREAL
  23258.       IF(ATYPE.EQ.KZDVEC) TYPE = KZDOUB
  23259.       IF(TYPE.NE.K4NONE) RETURN
  23260.       VECMAT = KZMAT
  23261.       IF(ATYPE.EQ.KZIMAT) TYPE = KZINT
  23262.       IF(ATYPE.EQ.KZRMAT) TYPE = KZREAL
  23263.       IF(ATYPE.EQ.KZDMAT) TYPE = KZDOUB
  23264.       RETURN
  23265.       END
  23266.       SUBROUTINE UNDATA (ALL,IRCNTR,IDAY,WORD1,LHASH,NAMOWN)
  23267.       INCLUDE rin:TEXT.BLK
  23268. C
  23269. C  PURPOSE:  UNLOADS THE DATA OF A DATABASE.
  23270. C
  23271. C  INPUTS:
  23272. C          ALL---------TRUE IF ALL RELATIONS ARE SPECIFIED.
  23273. C          IRCNTR------NUMBER OF RELATIONS IF SPECIFIED (ALL IS FALSE).
  23274. C          IDAY--------DAY CODE FOR HASH
  23275. C          WORD1--------COMMAND SPECIFIED.
  23276. C          LHASH--------LOGICAL SWITCH FOR HASH
  23277. C          NAMOWN--------FOR CHECKING PERMISSION
  23278. C          NAMOWN-------NAMOWN TO PASS TO CHKREL
  23279. C          NAMDB--------NAMDB FOR DEFINE.
  23280. C
  23281.       INCLUDE rin:RMATTS.BLK
  23282.       INCLUDE rin:RMKEYW.BLK
  23283.       INCLUDE rin:CONST4.BLK
  23284.       INCLUDE rin:DCLAR6.BLK
  23285.       INCLUDE rin:FILES.BLK
  23286.       INCLUDE rin:MISC.BLK
  23287.       INCLUDE rin:BUFFER.BLK
  23288.       INCLUDE rin:RIMCOM.BLK
  23289.       INCLUDE rin:TUPLEA.BLK
  23290.       INCLUDE rin:TUPLER.BLK
  23291.       INCLUDE rin:DCLAR1.BLK
  23292.       INCLUDE rin:DCLAR2.BLK
  23293.       INCLUDE rin:DCLAR3.BLK
  23294.       INTEGER LINE (20),QUOTE,DONE,
  23295.      X                START,ATTSTR,ATTCNT,TUPLE,STEP
  23296.       REAL*8 IREL(100)
  23297.       INTEGER ATDATA(250,5),STAT
  23298.       EQUIVALENCE (BUFFER(1),IREL(1)),(BUFFER(201),ATDATA(1,1))
  23299.       LOGICAL ALL,PERM,LHASH
  23300. C
  23301. C
  23302. C
  23303. C
  23304.     if(noutr.eq.6)goto 3140
  23305.       WRITE (NOUTR,50)
  23306.     goto 3141
  23307. 3140    write(c128wk,50)
  23308.     call atxto
  23309. 3141    continue
  23310.    50 FORMAT (1X,7HNOCHECK)
  23311.       J = LOCREL (BLANK)
  23312.       I = 0
  23313.       CALL FILCH (LINE,1,80,IBLANK)
  23314.       MPW1 = BLANK
  23315.    75 CONTINUE
  23316. C
  23317. C  GET MODIFY PASSWORD
  23318. C
  23319.       IF (ALL) GO TO 80
  23320. C
  23321. C  SUBSET OF THE DATA
  23322. C
  23323.       I = I + 1
  23324.       IF (I .GT. IRCNTR) GO TO 800
  23325.       RNAME = IREL(I)
  23326.       J = LOCREL (RNAME)
  23327.       GO TO 85
  23328.    80 CONTINUE
  23329.       CALL CHKREL (PERM,WORD1,ISTAT,NAMOWN)
  23330.       IF (ISTAT .NE. 0) GO TO 800
  23331.       IF  (.NOT. PERM) GO TO 80
  23332.    85 CONTINUE
  23333.       IF ((MPW .EQ. K4NONE) .OR. (MPW .EQ. MPW1)) GO TO 100
  23334.       CALL STRMOV(KWUSER,1,4,LINE,2)
  23335.       CALL PUTT(LINE,7,K4QUOT)
  23336.       NUM = 16
  23337.       IF (LHASH) NUM = 24
  23338.       IF (LHASH) CALL HASHIN (MPW,IDAY,LINE,8)
  23339.       IF (.NOT. LHASH) CALL STRMOV (MPW,1,8,LINE,8)
  23340.       CALL PUTT (LINE,NUM,K4QUOT)
  23341.       CALL SPOUT (LINE,NUM)
  23342.       MPW1 = MPW
  23343.   100 CONTINUE
  23344. C
  23345. C  WRITE LOAD COMMAND
  23346. C
  23347.     if(noutr.eq.6)goto 3142
  23348.       WRITE (NOUTR,150) NAME
  23349.     goto 3143
  23350. 3142    write(c128wk,150)name
  23351.     call atxto
  23352. 3143    continue
  23353.   150 FORMAT (1X,4HLOAD,1X,A8)
  23354.       J = LOCATT (BLANK,NAME)
  23355.       IND = 1
  23356.       ATTCNT = 0
  23357.   160 CALL ATTGET (ISTAT)
  23358.       IF (ISTAT .NE. 0) GO TO 250
  23359.       ATTCNT = ATTCNT + 1
  23360.       ATDATA (ATTCNT,1) = ATTCOL
  23361.       ATDATA (ATTCNT,2) = ATTCHA
  23362.       ATDATA (ATTCNT,3) = ATTWDS
  23363. C
  23364. C  GET ATTRIBUTE TYPE AND STRUCTURE
  23365. C
  23366.       CALL TYPER (ATTYPE,ATDATA(ATTCNT,5),ATDATA(ATTCNT,4))
  23367.       GO TO 160
  23368.   250 CONTINUE
  23369.       NEXTID = RSTART
  23370.       STAT = 0
  23371. C
  23372. C  PROCESS THE TUPLES
  23373. C
  23374.       DO 600 NEXTUP = 1,NTUPLE
  23375.       NC = 2
  23376.       KK = 0
  23377.       DONE = 0
  23378. C
  23379. C  GET THE DATA -- NC IS THE NUMBER OF CHARACTERS
  23380. C
  23381.       CALL GETDAT(IND,NEXTID,ITUP,LEN)
  23382.       CALL FILCH (LINE,1,80,IBLANK)
  23383. C
  23384. C  PROCESS THE TUPLE ACCORDING TO THE NUMBER OF ATTRIBUTES
  23385. C
  23386.       DO 500 LL = 1,ATTCNT
  23387.       STEP = 1
  23388.       ICOUNT = ATDATA (LL,1)
  23389.       IF (LL .EQ. ATTCNT) DONE = 1
  23390.       LEN1 = ATDATA (LL,2)
  23391.       LEN2 = ATDATA (LL,3)
  23392.       ATTSTR = ATDATA (LL,5)
  23393.       TUPLE = ITUP + ICOUNT - 1
  23394. C
  23395. C  CHECK TO SEE IF VARYING LENGTH -- IF SO GET NEW LENGTHS
  23396. C
  23397.       IF (LEN2 .NE. 0) GO TO 265
  23398. C
  23399. C  VARYING ATTRIBUTE
  23400. C
  23401. C  CHECK TO SEE IF VARYING SCALAR--IF SO, CHANGE TO VECTOR
  23402.       IF (ATTSTR .EQ. IBLANK) ATTSTR = KZVEC
  23403.       TUPLE = BUFFER (TUPLE) + ITUP - 1
  23404.       LEN2 = BUFFER (TUPLE)
  23405.       LEN1 = BUFFER (TUPLE + 1)
  23406.       TUPLE = TUPLE + 2
  23407.   265 CONTINUE
  23408.       ATTYPE = ATDATA (LL,4)
  23409.       IF (ATTYPE .NE. KZDOUB) GO TO 270
  23410.       LEN2 = LEN2/2
  23411.       STEP = 2
  23412.   270 CONTINUE
  23413.       IF(BUFFER(TUPLE).NE.NULL) GO TO 272
  23414. C
  23415. C  NULL VALUE - UNLOAD -0- ONLY
  23416. C
  23417.       CALL STRMOV(NULL,1,3,LINE,NC)
  23418.       NC = NC + 4
  23419.       IF(DONE.EQ.1) STAT = 1
  23420.       IF(NC.GE.60) CALL WRLINE(NC,STAT,LINE)
  23421.       GO TO 500
  23422.   272 CONTINUE
  23423.       IF (ATTYPE .NE. KZTEXT) GO TO 300
  23424. C
  23425. C  TEXT ITEM -- LEN1 IS NUMBER OF CHARACTERS
  23426. C
  23427.       CALL PUTT (LINE,NC,K4QUOT)
  23428. C
  23429. C  TEXT PROCESSING SECTION
  23430. C
  23431.       START = 1
  23432.       NC = NC + 1
  23433.       NONBLK = NSCAN (BUFFER(TUPLE),LEN1,-LEN1,IBLANK,1,1)
  23434. C
  23435. C  CHECK FOR BLANK LINE
  23436. C
  23437.       IF (NONBLK .EQ. 0) NONBLK = 1
  23438. C
  23439. C  CHECK FOR DOUBLE QUOTES
  23440. C
  23441.   290 CONTINUE
  23442.       ICHAR = NONBLK
  23443.       QUOTE = LSTRNG (BUFFER(TUPLE),START,NONBLK,K4QUOT,1,1)
  23444.       IF (QUOTE .NE. 0) ICHAR = (QUOTE - START + 1)
  23445. C
  23446. C  CHECK TO SEE IF THE TEXT STRING CAN FIT ON THE LINE
  23447. C
  23448.       IF ((NC + ICHAR) .GT. 60) ICHAR = 60 - NC
  23449.       IF(ICHAR.EQ.0) ICHAR = 1
  23450.       CALL STRMOV (BUFFER (TUPLE),START,ICHAR,LINE,NC)
  23451.       NC = NC + ICHAR
  23452. C
  23453. C  CHECK TO SEE IF WE ARE DONE
  23454. C
  23455.       IF (ICHAR .NE. (QUOTE - START + 1)) GO TO 295
  23456. C
  23457. C  NOT DONE -- HAVE A DOUBLE QUOTE
  23458. C
  23459.       CALL PUTT (LINE,NC,K4QUOT)
  23460.       NC = NC + 1
  23461.   295 CONTINUE
  23462.       START = START + ICHAR
  23463.       NONBLK = NONBLK - ICHAR
  23464. C
  23465. C  CHECK FOR FULL LINE
  23466. C
  23467.       IF ((NONBLK .NE. 0) .AND. (NC .GE. 60))
  23468.      X             CALL WRLINE (NC,STAT,LINE)
  23469. C
  23470. C  CHECK TO MAKE SURE SPLIT TEXT BEGINS IN COL. 1
  23471. C
  23472.       IF ((NONBLK .NE. 0) .AND. (NC .EQ. 2)) NC = 1
  23473. C
  23474. C  SPLIT LINE TEXT ATTRIBUTE OR DOUBLE QUOTE
  23475. C
  23476.       IF (NONBLK .NE. 0) GO TO 290
  23477. C
  23478. C  DONE WITH PROCESSING TEXT ITEM -- ADD QUOTES
  23479. C
  23480. C
  23481. C  LENGTH OF TEXT ATTRIBUTE IS STORED IN LEN2
  23482. C
  23483.   298 CONTINUE
  23484.       IF (DONE .EQ. 1) STAT = 1
  23485.       CALL PUTT (LINE,NC,K4QUOT)
  23486.       NC = NC + 2
  23487.       IF (NC .GE. 60) CALL WRLINE (NC,STAT,LINE)
  23488.       GO TO 500
  23489. C
  23490. C  PROCESS REAL AND INTEGER STUFF
  23491. C
  23492.   300 CONTINUE
  23493.       MATLEN = 1
  23494. C
  23495. C  PROCESS REAL OR INTEGER ATTRIBUTE (MATRIX,VECTOR, OR SCALAR)
  23496. C
  23497.       IF (ATTSTR .NE. KZMAT) GO TO 315
  23498. C
  23499. C  MATRIX PROCESSING -- NEED TO SET MATLEN AND CHANGE LEN2
  23500. C  TO THE NUMBER OF COLUMNS
  23501. C
  23502.       MATLEN = LEN1
  23503.       IF (LEN1 .NE. 0) LEN2 = LEN2/LEN1
  23504.       CALL PUTT (LINE,NC,K4LPAR)
  23505.       NC = NC + 1
  23506.   315 CONTINUE
  23507.       DO 350 KK = 1,LEN2
  23508.       IF ((((LEN2 .EQ. 1) .AND. (ATTSTR .NE. KZVEC)) .OR. (KK .GT. 1))
  23509.      X        .AND. (ATTSTR .NE. KZMAT)) GO TO 320
  23510.       CALL PUTT (LINE,NC,K4LPAR)
  23511.       NC = NC + 1
  23512.   320 CONTINUE
  23513.       DO 330 J = 1,MATLEN
  23514. C
  23515. C  CHECK TO SEE IF LAST DATA IN TUPLE -- IF SO SET STAT TO 1
  23516. C
  23517.       IF ((KK .EQ. LEN2) .AND. (J .EQ. MATLEN)
  23518.      X      .AND. (DONE .EQ. 1)) STAT = 1
  23519.       CALL SELPUT (BUFFER(TUPLE),ATTYPE,10,NC,LINE)
  23520.       NC = NC + 11
  23521. C
  23522. C             MAKE SURE NO DANGLING PARENS WITHOUT PLUS SIGN
  23523. C
  23524.       IF ((STAT .EQ. 1) .AND. (NC .GE. 60) .AND.
  23525.      X ((ATTSTR .EQ. KZVEC) .OR. (ATTSTR .EQ. KZMAT)))  STAT = 0
  23526.       IF (NC .GE. 60) CALL WRLINE (NC,STAT,LINE)
  23527.       TUPLE = TUPLE + STEP
  23528.   330 CONTINUE
  23529.       IF (ATTSTR .NE. KZMAT) GO TO 350
  23530.       CALL STRMOV (K4RPAR,1,2,LINE,NC)
  23531.       NC = NC + 2
  23532.   350 CONTINUE
  23533.       IF ((ATTSTR .EQ. IBLANK) .AND. (LEN2 .EQ. 1)) GO TO 360
  23534.       IF (NC .NE. 2) NC = NC - 1
  23535.       CALL STRMOV (K4RPAR,1,2,LINE,NC)
  23536.       NC = NC + 2
  23537.   360 CONTINUE
  23538.       IF (NC .GE. 60) CALL WRLINE (NC,STAT,LINE)
  23539.   500 CONTINUE
  23540.       IF (NC .NE. 2) CALL WRLINE (NC,1,LINE)
  23541.       STAT = 0
  23542.   600 CONTINUE
  23543. C
  23544. C  WRITE END STATEMENT FOR RELATION
  23545. C
  23546.     if(noutr.eq.6)goto 3145
  23547.       WRITE (NOUTR,700)
  23548.   700 FORMAT (1X,3HEND)
  23549.       GO TO 75
  23550. 3145    write(c128wk,700)
  23551.     call atxto
  23552.     goto 75
  23553.   800 CONTINUE
  23554.       RMSTAT = 0
  23555.       RETURN
  23556.       END
  23557.       SUBROUTINE UNDEF (ALL,IRCNTR,IDAY,WORD1,LHASH,NAMOWN,NAMDB)
  23558.       INCLUDE rin:TEXT.BLK
  23559. C
  23560. C  PURPOSE:  UNLOADS THE DEFINITION OF A DATABASE.
  23561. C
  23562. C  INPUTS:
  23563. C          ALL------------TRUE IF ALL RELATIONS ARE SPECIFIED.
  23564. C          IRCNTR---------NUMBER OF RELATIONS IF SPECIFIED (ALL IS FALSE
  23565. C          IDAY-----------DAY CODE FOR HASH.
  23566. C          WORD1-----------COMMAND SPECIFIED.
  23567. C
  23568.       INCLUDE rin:RMATTS.BLK
  23569.       INCLUDE rin:RMKEYW.BLK
  23570.       INCLUDE rin:CONST4.BLK
  23571.       INCLUDE rin:DCLAR2.BLK
  23572.       INCLUDE rin:DCLAR6.BLK
  23573.       INCLUDE rin:FILES.BLK
  23574.       INCLUDE rin:MISC.BLK
  23575.       INCLUDE rin:BUFFER.BLK
  23576.       INCLUDE rin:FLAGS.BLK
  23577.       INCLUDE rin:TUPLEA.BLK
  23578.       INCLUDE rin:TUPLER.BLK
  23579.       INCLUDE rin:DCLAR1.BLK
  23580.       INCLUDE rin:DCLAR3.BLK
  23581.       LOGICAL ALL,PERM,LHASH
  23582. C
  23583. C
  23584.       REAL*8 IREL(100),ATREL(2000)
  23585.       INTEGER STRUC,TYPE,WITH
  23586.       EQUIVALENCE (BUFFER(1),IREL(1)),(BUFFER(201),ATREL(1))
  23587.       DIMENSION LINE(20)
  23588.       IACNTR = 0
  23589.       CALL FILCH (LINE,1,80,IBLANK)
  23590.     if(noutr.eq.6)goto 3140
  23591.       WRITE (NOUTR,3) NAMDB
  23592.     goto 3141
  23593. 3140    write(c128wk,3)namdb
  23594.     call atxto
  23595. 3141    continue
  23596.     3 FORMAT (1X,7HDEFINE ,A6)
  23597.       CALL STRMOV(KWOWNE,1,5,LINE,2)
  23598.       CALL PUTT(LINE,8,K4QUOT)
  23599.       NUM = 17
  23600.       IF (LHASH) NUM = 25
  23601.       IF (LHASH) CALL HASHIN (USERID,IDAY,LINE,9)
  23602.       IF (.NOT. LHASH) CALL STRMOV (USERID,1,8,LINE,9)
  23603.       CALL PUTT (LINE,NUM,K4QUOT)
  23604.       CALL SPOUT (LINE,NUM)
  23605.     if(noutr.eq.6)goto 3142
  23606.       WRITE (NOUTR,4)
  23607.     4 FORMAT (1X,10HATTRIBUTES)
  23608.     goto 3143
  23609. 3142    write(c128wk,4)
  23610.     call atxto
  23611. 3143    continue
  23612. C
  23613. C  PROCESS ATTRIBUTES
  23614. C
  23615.       I = 0
  23616.       IF (IRCNTR .EQ. ALL9S) IRCNTR = 0
  23617.       J = LOCREL(BLANK)
  23618.     5 CONTINUE
  23619.       IF (ALL) GO TO 7
  23620.       I = I + 1
  23621.       IF (I .GT. IRCNTR) GO TO 50
  23622.       K = LOCATT (BLANK,IREL(I))
  23623.       GO TO 10
  23624.     7 CONTINUE
  23625.       CALL CHKREL(PERM,WORD1,ISTAT,NAMOWN)
  23626.       IF (ISTAT .NE. 0) GO TO 50
  23627.       IF (.NOT. PERM)  GO TO 7
  23628.       IRCNTR = IRCNTR + 1
  23629.       K = LOCATT (BLANK,NAME)
  23630.    10 CONTINUE
  23631.       CALL ATTGET (ISTAT)
  23632.       IF (ISTAT .NE. 0) GO TO 5
  23633.       IF (IACNTR .EQ. 0) GO TO 20
  23634.       DO 15 L = 1,IACNTR
  23635.       IF (ATTNAM .EQ. ATREL(L)) GO TO 10
  23636.    15 CONTINUE
  23637. C
  23638. C  NEW ATTRIBUTE
  23639. C
  23640.    20 CONTINUE
  23641.       IACNTR = IACNTR + 1
  23642.       ATREL(IACNTR) = ATTNAM
  23643.       CALL TYPER (ATTYPE,STRUC,TYPE)
  23644.       DO 22 KK = 1,4
  23645.    22 LINE(KK) = IBLANK
  23646.       IF (ATTKEY .NE. 0) LINE (4) = K4KEY
  23647.       IF (ATTWDS .EQ. 0) LINE (3) = KZVAR
  23648.       IF ((TYPE .NE. KZTEXT) .OR. (ATTWDS .EQ. 0)) GO TO 25
  23649.       ATTWDS = ATTCHA
  23650.       IF(ATTCHA.EQ.1) CALL PUTT(LINE(3),4,K41)
  23651.    25 CONTINUE
  23652.       IF (TYPE .EQ. KZDOUB) ATTWDS = ATTWDS/2
  23653.       IF ((ATTWDS .NE. 0) .AND. (ATTWDS .NE. ATTCHA) .AND.
  23654.      X           (STRUC .NE. IBLANK)) ATTWDS = ATTWDS/ATTCHA
  23655.       IF ((STRUC .NE. IBLANK) .AND. (ATTWDS .NE. 0))
  23656.      X              CALL ITOC (LINE(3),1,4,ATTWDS,IERR)
  23657.       IF ((STRUC .EQ. IBLANK) .AND. (ATTWDS .GT. 1))
  23658.      X              CALL ITOC (LINE(3),1,4,ATTWDS,IERR)
  23659.       IF (STRUC .NE. KZMAT) GO TO 40
  23660.       IF (ATTCHA .NE. 0) CALL ITOC (LINE(1),1,4,ATTCHA,IERR)
  23661.       LINE(2) = K4COMA
  23662.       IF (ATTCHA .EQ. 0) LINE(1) = KZVAR
  23663.    40 CONTINUE
  23664.     if(noutr.eq.6)goto 3144
  23665.       WRITE (NOUTR,45) ATTNAM,ATTYPE,(LINE(IN),IN=1,4)
  23666.    45 FORMAT (1X,A8,2X,A4,2X,A4,A1,A4,2X,A3)
  23667.       GO TO 10
  23668. 3144    write(c128wk,45)attnam,attype,(line(in),in=1,4)
  23669.     call atxto
  23670.     goto 10
  23671. C
  23672. C
  23673.    50 CONTINUE
  23674.       IF (IRCNTR .EQ. 0) GO TO 400
  23675.       J = LOCREL(BLANK)
  23676.     if(noutr.eq.6)goto 3145
  23677.       WRITE (NOUTR,80)
  23678.     goto 3146
  23679. 3145    write(c128wk,80)
  23680.     call atxto
  23681. 3146    continue
  23682.    80 FORMAT (1X,9HRELATIONS)
  23683. C
  23684. C  LOOP THROUGH AND PRINT THE RELATIONS WITH THEIR ATTRIBUTES
  23685. C
  23686.       DO 150 I = 1,IRCNTR
  23687.       IF (ALL) GO TO 90
  23688.       RNAME = IREL(I)
  23689.       J = LOCREL (RNAME)
  23690.       CALL RELGET (ISTAT)
  23691.       GO TO 95
  23692.    90 CONTINUE
  23693.       CALL CHKREL (PERM,WORD1,ISTAT,NAMOWN)
  23694.       IF (ISTAT .NE. 0) GO TO 150
  23695.       IF (.NOT. PERM) GO TO 90
  23696.       RNAME = NAME
  23697.    95 CONTINUE
  23698.       ICUM = 0
  23699.       ICOUNT = 1
  23700.       NAMES (1) = RNAME
  23701.       WITH = K4WITH
  23702.       IEND = K4PLUS
  23703.       J = LOCATT (BLANK,RNAME)
  23704.   100 CONTINUE
  23705.       CALL ATTGET (ISTAT)
  23706.       IF (ISTAT .NE. 0) GO TO 105
  23707.       ICOUNT = ICOUNT + 1
  23708.       ICUM = ICUM + 1
  23709.       NAMES (ICOUNT) = ATTNAM
  23710.       IF (ICOUNT .LT. 5) GO TO 100
  23711.   105 IF (ICUM .EQ. NATT) IEND = IBLANK
  23712.     if(noutr.eq.6)goto 3147
  23713.       IF (ICOUNT .NE. 1) WRITE (NOUTR,110) NAMES(1),WITH,
  23714.      X         (NAMES(KK),KK=2,ICOUNT),IEND
  23715.     goto 3148
  23716. 3147    continue
  23717.       IF (ICOUNT .NE. 1) WRITE (c128wk,110) NAMES(1),WITH,
  23718.      X         (NAMES(KK),KK=2,ICOUNT),IEND
  23719.     if(icount.ne.q)call atxto
  23720. 3148    continue
  23721.   110 FORMAT (1X,A8,1X,A4,1X,5(A8,1X))
  23722.       NAMES(1) = BLANK
  23723.       WITH = IBLANK
  23724.       ICOUNT = 1
  23725.       IF (ISTAT .EQ. 0) GO TO 100
  23726.   150 CONTINUE
  23727. C
  23728. C  PRINT PASSWORDS (HASHED)
  23729. C
  23730.     if(noutr.eq.6)goto 3149
  23731.       WRITE (NOUTR,175)
  23732.     goto 3150
  23733. 3149    write(c128wk,175)
  23734.     call atxto
  23735. 3150    continue
  23736.   175 FORMAT (1X,9HPASSWORDS)
  23737.       CALL FILCH (LINE,1,80,IBLANK)
  23738.       J = LOCREL (BLANK)
  23739.       DO 300 I = 1,IRCNTR
  23740.       IF (ALL) GO TO 225
  23741.       J = LOCREL (IREL(I))
  23742.       RNAME = IREL(I)
  23743.       GO TO 240
  23744.   225 CONTINUE
  23745.       CALL CHKREL (PERM,WORD1,ISTAT,NAMOWN)
  23746.       IF (.NOT. PERM) GO TO 225
  23747.       RNAME = NAME
  23748.   240 CONTINUE
  23749.       CALL STRMOV(KWRPW,1,3,LINE,2)
  23750.       CALL STRMOV(K4FOR,1,3,LINE,6)
  23751.       CALL STRMOV (RNAME,1,8,LINE,10)
  23752.       CALL STRMOV(K4IS,1,2,LINE,19)
  23753.       CALL PUTT(LINE,22,K4QUOT)
  23754.       NUM = 31
  23755.       IF (LHASH) NUM = 39
  23756.       CALL PUTT (LINE,NUM,K4QUOT)
  23757.       RPW1 = RPW
  23758.       DO 250 J = 1,2
  23759.       IF (RPW1 .EQ. K4NONE) GO TO 230
  23760.       IF (LHASH) CALL HASHIN (RPW1,IDAY,LINE,23)
  23761.       IF (.NOT. LHASH) CALL STRMOV (RPW1,1,8,LINE,23)
  23762.       CALL SPOUT (LINE,NUM)
  23763.   230 CONTINUE
  23764.       RPW1 = MPW
  23765.       CALL PUTT (LINE,2,K4M)
  23766.   250 CONTINUE
  23767.   300 CONTINUE
  23768.   400 CONTINUE
  23769.     if(noutr.eq.6)goto 3151
  23770.       WRITE (NOUTR,450)
  23771.   450 FORMAT (1X,3HEND)
  23772.       RETURN
  23773. 3151    write(c128wk,450)
  23774.     call atxto
  23775.     return
  23776.       END
  23777.       SUBROUTINE UNLOAD
  23778.       INCLUDE rin:TEXT.BLK
  23779. C
  23780. C  PURPOSE:  SUBROUTINE CHECKS SYNTAX ON UNLOAD COMMAND AND UNLOADS
  23781. C            ACCORDING TO WHAT THE USER SPECIFIED.  CALLS UNDATA AND
  23782. C            UNDEF TO ACCOMPLISH THIS PURPOSE.
  23783. C
  23784. C
  23785.       INCLUDE rin:CONST4.BLK
  23786.       INCLUDE rin:CONST8.BLK
  23787.       INCLUDE rin:FILES.BLK
  23788.       INCLUDE rin:BUFFER.BLK
  23789.       INCLUDE rin:FLAGS.BLK
  23790.       INCLUDE rin:RIMCOM.BLK
  23791.       INCLUDE rin:TUPLER.BLK
  23792.       INCLUDE rin:DCLAR1.BLK
  23793.       INCLUDE rin:DCLAR2.BLK
  23794.       INCLUDE rin:DCLAR3.BLK
  23795.       INCLUDE rin:DCLAR6.BLK
  23796.       INCLUDE rin:MISC.BLK
  23797.       REAL*8 IREL(100)
  23798.       INTEGER CHAR1,CHAR2
  23799.       EQUIVALENCE (BUFFER(1),IREL(1))
  23800.       LOGICAL ALL,PERM,LHASH
  23801.       DIMENSION NUMBER(9)
  23802.       EQUIVALENCE (NUMBER(1),K41)
  23803.       DATA NAMES /10*0/
  23804.       DATA NWORDS /2500/
  23805.       NAMES(1) = K8SCH
  23806.       NAMES(2) = K8ALL
  23807.       NAMES(3) = K8DATA
  23808.       LHASH = .FALSE.
  23809.       NOGO = 0
  23810. C
  23811. C  CLEAR OUT ANY PAGE DATA LEFT IN BUFFER
  23812. C
  23813.       CALL BLKCLN
  23814.       RMSTAT = 0
  23815.       ALL = .TRUE.
  23816.       WORD1 = K8ALL
  23817.       NUM = 2
  23818.       NAMOWN = USERID
  23819.       NAMDB = DBNAME
  23820.       ITEMS = LXITEM (I)
  23821. C
  23822. C  CHECK TO SEE IF DEFAULTS
  23823. C
  23824.       IF (ITEMS .EQ. 1) GO TO 25
  23825. C
  23826. C  FIND OUT IF WANT ALL,SCHEMA, OR DATA
  23827. C
  23828. C  SAVE THE PARTICULAR UNLOAD COMMAND IN WORD1
  23829. C
  23830.       WORD2 = BLANK
  23831.       CALL LXSREC (2,1,8,WORD2,1)
  23832.       DO 5 I = 1,3
  23833.       IF (NAMES (I) .NE. WORD2) GO TO 5
  23834.       WORD1 = WORD2
  23835.       GO TO 20
  23836.     5 CONTINUE
  23837. C
  23838. C  CHECK FOR DATA BASE NAME
  23839. C
  23840.       NAMDB = WORD2
  23841.       IF (NAMDB .NE. DBNAME) GO TO 9000
  23842. C
  23843. C  CHECK TO SEE IF DEFAULTS TO ALL
  23844. C
  23845.       IF (ITEMS .EQ. 2) GO TO 20
  23846.       NUM = NUM + 1
  23847. C
  23848. C  CHECK TO SEE IF WANTS TO CHANGE THE DBNAME
  23849. C
  23850. C
  23851.       IF (LXWREC (3,1) .NE. K4EQS) GO TO 15
  23852.       IF (ITEMS .EQ. 3) GO TO 9000
  23853. C
  23854. C  CHANGE THE NAME
  23855. C
  23856.       NAMDB = BLANK
  23857.       CALL LXSREC (4,1,6,NAMDB,1)
  23858.       NUM = NUM + 2
  23859. C
  23860. C  CHECK TO SEE IF JUST DEFAULT TO ALL
  23861. C
  23862.       IF (ITEMS .LE. 4) GO TO 20
  23863.    15 CONTINUE
  23864.       WORD1 = BLANK
  23865.       CALL LXSREC (NUM,1,8,WORD1,1)
  23866. C
  23867. C  CHECK TO SEE IF VALID COMMAND
  23868. C
  23869.       IF ((WORD1 .NE. K8ALL) .AND. (WORD1 .NE. K8SCH) .AND.
  23870.      X      (WORD1 .NE. K8DATA)) GO TO 9000
  23871. C
  23872. C
  23873.   20  CONTINUE
  23874. C
  23875. C  CHECK FOR HASH
  23876. C
  23877.       IF (NUM .EQ. ITEMS) GO TO 25
  23878.       IF (LXWREC(NUM + 1,1) .NE. K4EQS) GO TO 25
  23879.       IF (NUM + 1 .EQ. ITEMS) GO TO 9000
  23880.       IF (LXWREC(NUM + 2,1) .NE. K4HASH) GO TO 9000
  23881.       LHASH = .TRUE.
  23882.       NUM = NUM + 2
  23883.    25 CONTINUE
  23884.       ICNTR = 0
  23885.       CALL BLKDEF (10,NWORDS,1)
  23886.       IPERM = 0
  23887.   100 CONTINUE
  23888.       IF (ITEMS .GT. NUM) GO TO 200
  23889. C
  23890. C  THE COMMAND IS ALL SO SET ICNTR TO MAX
  23891. C
  23892.       ICNTR = ALL9S
  23893.       GO TO 400
  23894. C
  23895. C  THE USER HAS SPECIFIED WHICH RELATIONS HE WANTS DUMPED
  23896. C
  23897.   200 CONTINUE
  23898.       J = NUM + 1
  23899.       ALL = .FALSE.
  23900.   210 CONTINUE
  23901.       RNAME = BLANK
  23902.       CALL LXSREC (J,1,8,RNAME,1)
  23903.       IERR = 0
  23904.       IN = LOCREL (RNAME)
  23905.       IF (IN .EQ. 0) GO TO 225
  23906.     if(nout.eq.6)goto 3140
  23907.       WRITE (NOUT,215) RNAME
  23908.     goto 3141
  23909. 3140    write(c128wk,215)rname
  23910.     call atxto
  23911. 3141    continue
  23912.   215 FORMAT (2X,34H--ERROR-- Incorrect Relation Name ,A8)
  23913.       RMSTAT = 2
  23914.       IERR = 1
  23915.   225 CONTINUE
  23916.       IF ((J + 1) .GT. ITEMS) GO TO 250
  23917.       RNAME1 = BLANK
  23918.       CALL LXSREC (J+1,1,8,RNAME1,1)
  23919.       IF (RNAME1 .NE. K4EQS) GO TO 250
  23920. C
  23921. C  CHECK FOR INCORRECT SYNTAX
  23922. C
  23923.       IF ((J + 2) .GT. ITEMS) GO TO 9000
  23924.       J = J + 2
  23925.       IF (IERR .EQ. 1) GO TO 350
  23926. C
  23927. C  CHECK FOR PASSWORD
  23928. C
  23929.       NAMOWN = BLANK
  23930.       CALL LXSREC (J,1,8,NAMOWN,1)
  23931.   250 CONTINUE
  23932. C
  23933. C
  23934. C  CALL CHKREL TO CHECK PASSWORD PERMISSION ON THE UNLOAD
  23935. C
  23936.       CALL CHKREL (PERM,WORD1,ISTAT,NAMOWN)
  23937.       IF (PERM) GO TO 300
  23938.     if(nout.eq.6)goto 3142
  23939.       WRITE (NOUT,275) RNAME
  23940.     goto 3143
  23941. 3142    write(c128wk,275)rname
  23942.     call atxto
  23943. 3143    continue
  23944.   275 FORMAT (2X,43H--ERROR-- YOU Are Not Authorized To UNLOAD ,A8)
  23945.       RMSTAT = 9
  23946.       IERR = 1
  23947.       GO TO 350
  23948.   300 CONTINUE
  23949. C
  23950. C  CHECK TO MAKE SURE THERE IS ONLY ONE OF THE RELATIONS LISTED
  23951. C
  23952.       IF (ICNTR .EQ. 0 ) GO TO 335
  23953.       DO 310 KK = 1,ICNTR
  23954.       IF (IREL(ICNTR) .EQ. RNAME) GO TO 325
  23955.   310 CONTINUE
  23956.       GO TO 335
  23957.   325 CONTINUE
  23958.     if(nout.eq.6)goto 3144
  23959.       WRITE (NOUT,330) RNAME
  23960.   330 FORMAT (2X,39H--WARNING-- You Have Already Specified ,
  23961.      X            14HRelation Name ,A8)
  23962.       GO TO 350
  23963. 3144    write(c128wk,330)rname
  23964.     call atxto
  23965.     goto 350
  23966. C
  23967. C  EVERYTHING IS CORRECT -- SAVE CERTAIN DATA IN IREL(ICNTR)
  23968. C
  23969.   335 CONTINUE
  23970.       ICNTR = ICNTR + 1
  23971.       IREL(ICNTR) = NAME
  23972.   350 CONTINUE
  23973.       J = J + 1
  23974.       IF (IERR .EQ. 1) NOGO = 1
  23975.       IF ( J .LE. ITEMS) GO TO 210
  23976. C
  23977. C  DONE WITH PERMISSION AND CRACKING
  23978. C
  23979.   400 CONTINUE
  23980.       IF (NOGO .EQ. 1) GO TO 9999
  23981.     if(noutr.eq.6)goto 3145
  23982.       WRITE(NOUTR,425)
  23983.     goto 3146
  23984. 3145    write(c128wk,3425)
  23985.     call atxto
  23986. 3146    continue
  23987. 425    FORMAT(16H*(SET SEMI=NULL),/,18H*(SET DOLLAR=NULL))
  23988. 3425    FORMAT(16H*(SET SEMI=NULL),1x,18H*(SET DOLLAR=NULL))
  23989.       IF (.NOT. LHASH) GO TO 480
  23990.       CALL RMDATE (IDAY)
  23991.       CALL RMTIME (ITIME)
  23992.     if(noutr.eq.6)goto 3147
  23993.       WRITE (NOUTR,450) ITIME,IDAY
  23994.     goto 3148
  23995. 3147    write(c128wk,450)itime,iday
  23996.     call atxto
  23997. 3148    continue
  23998.   450 FORMAT (24H RIM Communication File ,2A10)
  23999. C
  24000. C  CHANGE DAY DATE TO INTEGER
  24001. C
  24002.       CALL GETT (IDAY,8,CHAR1)
  24003.       CALL GETT (IDAY,7,CHAR2)
  24004.       DO 475 KK=1,9
  24005.       IF (CHAR1 .EQ. NUMBER (KK)) CHAR1 = KK
  24006.       IF (CHAR2 .EQ. NUMBER (KK)) CHAR2 = KK
  24007.   475 CONTINUE
  24008.       IF(CHAR1.EQ.K40) CHAR1 = 0
  24009.       IF((CHAR2.EQ.K40).OR.(CHAR2.EQ.IBLANK)) CHAR2 = 0
  24010.       NUM = CHAR2 * 10 + CHAR1
  24011.       NUM = MOD (NUM,7)
  24012. C
  24013. C  IF DIRECTIVE ALL OR SCHEMA CALL UNDEF
  24014. C
  24015.   480 CONTINUE
  24016.       IF ((WORD1 .EQ. K8SCH) .OR. (WORD1 .EQ. K8ALL))
  24017.      X             CALL UNDEF (ALL,ICNTR,NUM,WORD1,LHASH,NAMOWN,NAMDB)
  24018.       IF (ICNTR .EQ. 0) GO TO 8000
  24019.       IF ((WORD1 .EQ. K8ALL) .OR. (WORD1 .EQ. K8DATA))
  24020.      X             CALL UNDATA (ALL,ICNTR,NUM,WORD1,LHASH,NAMOWN)
  24021.       IF (ICNTR .EQ. 0) GO TO 8000
  24022.     if(noutr.eq.6)goto 3149
  24023.       WRITE(NOUTR,490)
  24024.   490 FORMAT(13H*(SET SEMI=;),/,15H*(SET DOLLAR=$))
  24025.       GO TO 9999
  24026. 3149    write(c128wk,3490)
  24027.  3490 FORMAT(13H*(SET SEMI=;),15H*(SET DOLLAR=$))
  24028.     call atxto
  24029.     goto 9999
  24030.  8000 CONTINUE
  24031. C
  24032. C  ERROR FOR UNLOADING ALL OF THE DATA
  24033. C
  24034.     if(nout.eq.6)goto 3150
  24035.       WRITE (NOUT,8001)
  24036.  8001 FORMAT (/,2X,39H--ERROR-- YOU Do Not Have Authorization,
  24037.      X        /,13X,26HTo UNLOAD All Of The Data.,/)
  24038.       RMSTAT = 9
  24039.       GO TO 9999
  24040. 3150    write(c128wk,3801)
  24041.  3801 FORMAT (2X,39H--ERROR-- YOU Do Not Have Authorization,
  24042.      X        3X,26HTo UNLOAD All Of The Data.)
  24043.     call atxto
  24044.     rmstat=9
  24045.     goto 9999
  24046. C
  24047. C  INCORRECT SYNTAX ERROR MESSAGE
  24048. C
  24049.  9000 CONTINUE
  24050.     if(nout.eq.6)goto 3152
  24051.       WRITE (NOUT,9001)
  24052.  9001 FORMAT (2X,42H--ERROR-- Incorrect Syntax For The Command)
  24053.       RMSTAT = 4
  24054.     goto 9999
  24055. 3152    write(c128wk,9001)
  24056.     call atxto
  24057. C
  24058. C  CLEAN UP AND END
  24059. C
  24060.  9999 CONTINUE
  24061.       CALL BLKCLR (10)
  24062.       RETURN
  24063.       END
  24064.       SUBROUTINE LOWER(I,LOW)
  24065.       Character*1 I,LOW
  24066.       Character*1 TABLE(2,26)
  24067.       DATA TABLE /1HA,1Ha,1HB,1Hb,1HC,1Hc,1HD,1Hd,1HE,1He
  24068.      x,1HF,1Hf,1HG,1Hg,1HH,1Hh,1HI,1Hi,1HJ,1Hj,1HK,1Hk,1HL,1Hl
  24069.      x,1HM,1Hm,1HN,1Hn,1HO,1Ho,1HP,1Hp,1HQ,1Hq,1HR,1Hr,1HS,1Hs
  24070.      x,1HT,1Ht,1HU,1Hu,1HV,1Hv,1HW,1Hw,1HX,1Hx,1HY,1Hy,1HZ,1Hz/
  24071.       DO 100 J=1,26
  24072.       IF(TABLE(1,J).EQ.I) LOW = TABLE(2,J)
  24073.   100 CONTINUE
  24074.       RETURN
  24075.       END
  24076.       SUBROUTINE WARN(NUM,WORD1,WORD2)
  24077.       INCLUDE rin:TEXT.BLK
  24078. C
  24079. C  PURPOSE:   GENERAL PURPOSE WARNING PRINT ROUTINE
  24080. C
  24081. C  PARAMETERS:
  24082. C     INPUT:  NUM-----WARNING NUMBER
  24083. C             WORD1----OPTIONAL NAME
  24084. C             WORD2----OPTIONAL NAME
  24085. C
  24086.       INCLUDE rin:CONST8.BLK
  24087.       INCLUDE rin:FILES.BLK
  24088.       INCLUDE rin:DCLAR6.BLK
  24089. C
  24090.     if(nout.eq.6)goto 3140
  24091.       IF(NUM.NE.1) GO TO 2
  24092.       WRITE (NOUT,100) WORD1
  24093.   100 FORMAT(9H -ERROR- ,A8,
  24094.      X      34H Is Not A Recognized Relation Name )
  24095.       GO TO 99
  24096. C
  24097.     2 IF(NUM.NE.2) GO TO 3
  24098.       WRITE (NOUT,200)
  24099.   200 FORMAT(27H -ERROR- Undefined Relation )
  24100.       GO TO 99
  24101. C
  24102.     3 IF(NUM.NE.3) GO TO 4
  24103.       WRITE (NOUT,300) WORD1,WORD2
  24104.   300 FORMAT(19H -ERROR- ATTRIBUTE ,A8,
  24105.      X       24H is not in the relation ,A8)
  24106.       GO TO 99
  24107. C
  24108.     4 IF(NUM.NE.4) GO TO 5
  24109.       WRITE (NOUT,400)
  24110.   400 FORMAT(45H -ERROR- Syntax Is Incorrect For The Command )
  24111.       GO TO 99
  24112. C
  24113.     5 IF(NUM.NE.5) GO TO 6
  24114.       WRITE (NOUT,500)
  24115.   500 FORMAT(49H -ERROR- Syntax Is Incorrect For The WHERE Clause )
  24116.       GO TO 99
  24117. C
  24118.     6 IF(NUM.NE.6) GO TO 7
  24119.       WRITE (NOUT,600)
  24120.   600 FORMAT(41H Command Terminated - Enter Next Command )
  24121.       CALL SETIN(K8IN)
  24122.       GO TO 99
  24123. C
  24124.     7 IF(NUM.NE.7) GO TO 8
  24125.       WRITE (NOUT,700) WORD1,WORD2
  24126.   700 FORMAT(9H -ERROR- ,A8,A1,
  24127.      X      34H Names May Not Exceed 8 Characters  )
  24128.       GO TO 99
  24129. C
  24130.     8 IF(NUM.NE.8) GO TO 9
  24131.       GO TO 99
  24132. C
  24133.     9 IF(NUM.NE.9) GO TO 10
  24134.       WRITE(NOUT,900) WORD1
  24135.   900 FORMAT(41H -ERROR- Unauthorized Access To Relation ,A8)
  24136.       GO TO 99
  24137. C
  24138.    10 IF(NUM.NE.10) GO TO 11
  24139.       WRITE (NOUT,1000)
  24140.  1000 FORMAT(50H -ERROR- DATA FILES Do Not Contain A RIM Data Base)
  24141.       GO TO 99
  24142. C
  24143.    11 IF(NUM.NE.11) GO TO 12
  24144.       WRITE (NOUT,1100)
  24145.  1100 FORMAT(52H -ERROR- DATA BASE NAME Does Not Match File Contents)
  24146.       GO TO 99
  24147. C
  24148.    12 IF(NUM.NE.12) GO TO 13
  24149.       WRITE(NOUT,1200) WORD1
  24150.  1200 FORMAT(13H -ERROR- The ,A7,32H DATABASE Files Are Incompatible)
  24151.       GO TO 99
  24152. C
  24153.    13 IF(NUM.NE.13) GO TO 14
  24154.       WRITE(NOUT,1300) WORD1
  24155.  1300 FORMAT(1X,12H-ERROR- THE ,A7,25H DATABASE Is Attached In ,
  24156.      1            14HRead Only Mode)
  24157.       GO TO 99
  24158. C
  24159.    14 IF(NUM.NE.14) GO TO 15
  24160.       WRITE(NOUT,1400) WORD1
  24161.  1400 FORMAT(1X, 4HTHE ,A7,29H DATABASE Is Being Updated - ,
  24162.      1            16HPlease Try Later)
  24163.       GO TO 99
  24164. C
  24165.    15 IF(NUM.NE.15) GO TO 16
  24166.       WRITE(NOUT,1500) WORD1
  24167.  1500 FORMAT(18H -ERROR- DATABASE ,A7,20H Is Not A Local File )
  24168.       GO TO 99
  24169. C
  24170.    16 CONTINUE
  24171.     if(num.ne.16) goto 17
  24172.     write(nout,1600)
  24173.     goto 99
  24174. 17    continue
  24175.    99 RETURN
  24176. 3140    continue
  24177.       IF(NUM.NE.1) GO TO 92
  24178.       WRITE (c128wk,100) WORD1
  24179.     call atxto
  24180.       GO TO 99
  24181. C
  24182.    92 IF(NUM.NE.2) GO TO 93
  24183.       WRITE (c128wk,200)
  24184.     call atxto
  24185.       GO TO 99
  24186. C
  24187.    93 IF(NUM.NE.3) GO TO 94
  24188.       WRITE (c128wk,300) WORD1,WORD2
  24189.     call atxto
  24190.       GO TO 99
  24191. C
  24192.    94 IF(NUM.NE.4) GO TO 95
  24193.       WRITE (c128wk,400)
  24194.     call atxto
  24195.       GO TO 99
  24196. C
  24197.    95 IF(NUM.NE.5) GO TO 96
  24198.       WRITE (c128wk,500)
  24199.     call atxto
  24200.       GO TO 99
  24201. C
  24202.    96 IF(NUM.NE.6) GO TO 107
  24203.       WRITE (c128wk,600)
  24204.     call atxto
  24205.       CALL SETIN(K8IN)
  24206.       GO TO 99
  24207. C
  24208.   107 IF(NUM.NE.7) GO TO 108
  24209.       WRITE (c128wk,700) WORD1,WORD2
  24210.     call atxto
  24211.       GO TO 99
  24212. C
  24213.   108 IF(NUM.NE.8) GO TO 109
  24214.       GO TO 99
  24215. C
  24216.   109 IF(NUM.NE.9) GO TO 1010
  24217.       WRITE(c128wk,900) WORD1
  24218.     call atxto
  24219.       GO TO 99
  24220. C
  24221.  1010 IF(NUM.NE.10) GO TO 1011
  24222.       WRITE (c128wk,1000)
  24223.     call atxto
  24224.       GO TO 99
  24225. C
  24226.  1011 IF(NUM.NE.11) GO TO 1012
  24227.       WRITE (c128wk,1100)
  24228.     call atxto
  24229.       GO TO 99
  24230. C
  24231.  1012 IF(NUM.NE.12) GO TO 1013
  24232.       WRITE(c128wk,1200) WORD1
  24233.     call atxto
  24234.       GO TO 99
  24235. C
  24236.  1013 IF(NUM.NE.13) GO TO 1014
  24237.       WRITE(c128wk,1300) WORD1
  24238.     call atxto
  24239.       GO TO 99
  24240. C
  24241.  1014 IF(NUM.NE.14) GO TO 1015
  24242.       WRITE(c128wk,1400) WORD1
  24243.     call atxto
  24244.       GO TO 99
  24245. C
  24246.  1015 IF(NUM.NE.15) GO TO 1016
  24247.       WRITE(c128wk,1500) WORD1
  24248.     call atxto
  24249.       GO TO 99
  24250. C
  24251.  1016 CONTINUE
  24252.     if(num.ne.16)goto 1017
  24253.     write(c128wk,1600)
  24254. 1600    format(' Error in sort file I/O')
  24255.     call atxto
  24256. 1017    continue
  24257.     return
  24258.       END
  24259.       SUBROUTINE WHERE(IS)
  24260.       INCLUDE rin:TEXT.BLK
  24261. C
  24262. C  PURPOSE:  PROCESS A RIM WHERE CLAUSE
  24263. C
  24264. C  PARAMETERS:
  24265. C         IS------POINTER TO WHERE IN IREC ARRAY
  24266.       INCLUDE rin:RMATTS.BLK
  24267.       INCLUDE rin:RMKEYW.BLK
  24268.       INCLUDE rin:CONST4.BLK
  24269.       INCLUDE rin:MISC.BLK
  24270.       INCLUDE rin:RIMCOM.BLK
  24271.       INCLUDE rin:TUPLEA.BLK
  24272.       INCLUDE rin:TUPLER.BLK
  24273.       INCLUDE rin:WHCOM.BLK
  24274.       INCLUDE rin:FILES.BLK
  24275.       INCLUDE rin:RIMPTR.BLK
  24276. C
  24277.       LOGICAL EQKEYW
  24278.       LOGICAL IFLIM
  24279.       LOGICAL IFTUP
  24280.       INCLUDE rin:DCLAR1.BLK
  24281.       NS = 0
  24282.       NTUPC = 0
  24283.       KMM = 0
  24284.       KSTRT = 0
  24285.       MAXTU = 0
  24286.       LIMTU = ALL9S
  24287.       ITEMS = LXITEM(ITEMP)
  24288.       JE = ITEMS - IS
  24289.       IF(JE.LT.2) GO TO 7000
  24290. C
  24291. C  BREAK UP EACH CONDITION.
  24292. C
  24293.       DO 600 I=1,10
  24294.       KOMPOS(I) = 0
  24295.       KOMPOT(I) = 0
  24296.       KOMLEN(I) = 0
  24297.       KATTP(I) = 0
  24298.       KATTL(I) = 0
  24299.       KATTY(I) = 0
  24300.   600 CONTINUE
  24301.       RMSTAT = 0
  24302.       NBOO = 1
  24303.       BOO(1) = K4AND
  24304.       NEXPOT = 1
  24305.       NEXPOS = 1
  24306.  1000 CONTINUE
  24307.       IS = IS + 1
  24308.       IF(IS.GT.ITEMS) GO TO 2000
  24309. C
  24310. C  GET THE ATTRIBUTE.
  24311. C
  24312.       IFLIM = .FALSE.
  24313.       IF(.NOT.EQKEYW(IS,KWLIMI,5)) GO TO 1150
  24314. C
  24315. C     LIMIT KEYWORD
  24316. C
  24317.       IF(.NOT.EQKEYW(IS+1,KWEQ,2)) GO TO 7100
  24318.       IF(LXID(IS+2).NE.KZINT) GO TO 7200
  24319.       LIMTU = LXIREC(IS+2)
  24320.       IF(LIMTU.LE.0) GO TO 7200
  24321.       NBOO = NBOO - 1
  24322.       IFLIM = .TRUE.
  24323.       GO TO 1800
  24324.  1150 CONTINUE
  24325.       IF(NBOO.LE.10) GO TO 1160
  24326. C
  24327. C  TOO MANY CONDITIONS.
  24328. C
  24329.     if(nout.eq.6)goto 3140
  24330.       WRITE(NOUT,9002)
  24331.  9002 FORMAT(52H -ERROR- More Than 10 Conditions In The WHERE Clause)
  24332.       GO TO 8000
  24333. 3140   write(c128wk,9002)
  24334.     call atxto
  24335.     goto 8000
  24336.  1160 CONTINUE
  24337.       IFTUP = EQKEYW(IS,KWROWS,4)
  24338.       IF(.NOT.IFTUP) GO TO 1190
  24339. C
  24340. C  ROW WHERE CLAUSE - CHECK TYPE AND GET MAXIMUM ROW NUMBER
  24341. C
  24342.       NTUPC = NTUPC + 1
  24343.       IF(LXID(IS+2).NE.KZINT) GO TO 7300
  24344.       MAXTUN = LXIREC(IS+2)
  24345.       IF(MAXTUN.LE.0) GO TO 7300
  24346.       IF(MAXTUN.GT.MAXTU) MAXTU = MAXTUN
  24347.       KOMPAR = IBLANK
  24348.       CALL LXSREC(IS+1,1,3,KOMPAR,1)
  24349.       KOMTYP(NBOO) = LOCBOO(KOMPAR)
  24350.       IF(KOMTYP(NBOO).NE.0) GO TO 1170
  24351. C
  24352. C  UNRECOGNIZED BOOLEAN COMPARISION.
  24353. C
  24354.     if(nout.eq.6)goto 3141
  24355.       WRITE(NOUT,9003) KOMPAR
  24356.       GO TO 8000
  24357. 3141    write(c128wk,9003)kompar
  24358.     call atxto
  24359.     goto 8000
  24360.  1170 CONTINUE
  24361.       IF((KOMTYP(NBOO).GE.3).AND.(KOMTYP(NBOO).LE.5)) MAXTU = NTUPLE
  24362.       GO TO 1500
  24363.  1190 ANAME = BLANK
  24364.       CALL LXSREC(IS,1,8,ANAME,1)
  24365.       I = LOCATT(ANAME,NAME)
  24366.       IF(I.NE.0) GO TO 1200
  24367.       CALL ATTGET(I)
  24368.       IF(I.EQ.0) GO TO 1300
  24369. C
  24370. C  UNRECOGNIZED ATTRIBUTE.
  24371. C
  24372.  1200 CONTINUE
  24373.       CALL WARN(3,ANAME,NAME)
  24374.       GO TO 8000
  24375.  1300 CONTINUE
  24376.       KATTP(NBOO) = ATTCOL
  24377.       KATTL(NBOO) = ATTLEN
  24378.       CALL TYPER(ATTYPE,MATVEC,KATTY(NBOO))
  24379. C
  24380. C  DETERMINE THE TYPE OF BOOLEAN EXPRESSION.
  24381. C
  24382.       KOMPAR = IBLANK
  24383.       CALL LXSREC(IS+1,1,3,KOMPAR,1)
  24384.       KOMTYP(NBOO) = LOCBOO(KOMPAR)
  24385.       IF(KOMTYP(NBOO).NE.0) GO TO 1500
  24386. C
  24387. C  UNRECOGNIZED BOOLEAN COMPARISION.
  24388. C
  24389.     if(nout.eq.6)goto 3141
  24390.       WRITE(NOUT,9003) KOMPAR
  24391.  9003 FORMAT(9H -ERROR- ,A4,34H Is Not A Valid Boolean Comparison)
  24392.       GO TO 8000
  24393.  1500 CONTINUE
  24394. C
  24395. C  CHECK FOR FAILS OR EXISTS
  24396. C
  24397.       IF(KOMTYP(NBOO).LE.1) GO TO 1800
  24398.       IF(KOMTYP(NBOO).GE.10) GO TO 1600
  24399. C
  24400. C     CHECK FOR "WHERE XXX EQ MIN OR MAX"
  24401. C
  24402.       ITEMP = LXWREC(IS+2,1)
  24403.       KMM = 0
  24404.       IF((ITEMP.EQ.K4MIN).OR.(ITEMP.EQ.K4MAX)) KMM = ITEMP
  24405.       IF(KMM.EQ.0) GO TO 1550
  24406. C
  24407. C  WE HAVE A MIN/MAX SPECIFICATION - CHECK SYNTAX
  24408. C
  24409.       IF((KOMTYP(NBOO).LT.2).OR.(KOMTYP(NBOO).GT.7)) GO TO 1550
  24410.       IF(ATTYPE.EQ.KZTEXT) GO TO 1550
  24411.       IF(ATTYPE.EQ.KZINT ) GO TO 1530
  24412.       IF(ATTYPE.EQ.KZREAL) GO TO 1530
  24413.       IF(ATTYPE.EQ.KZDOUB) GO TO 1530
  24414. C
  24415. C  ILLEGAL ATTRIBUTE FOR USE WITH MIN/MAX.
  24416. C
  24417.     if(nout.eq.6)goto 3142
  24418.       WRITE(NOUT,9000) ATTYPE
  24419.  9000 FORMAT(9H -ERROR- ,A4,42H Attributes Cannot Be Used With MIN Or MA
  24420.      XX)
  24421.       GO TO 8000
  24422. 3142    write(c128wk,9000)
  24423.     call atxto
  24424.     goto 8000
  24425.  1530 CONTINUE
  24426.       IF(ATTLEN.EQ.1) GO TO 1540
  24427.       IF((ATTLEN.EQ.2).AND.(ATTYPE.EQ.KZDOUB)) GO TO 1540
  24428. C
  24429. C  ILLEGAL USE OF MULTI-WORD ATTRIBUTE WITH MIN/MAX.
  24430. C
  24431.     if(nout.eq.6)goto 3143
  24432.       WRITE(NOUT,9001)
  24433.  9001 FORMAT(61H -ERROR- Multi-Word Attributes Cannot Be Used With MIN o
  24434.      Xr MAX)
  24435.       GO TO 8000
  24436. 3143    write(c128wk,9001)
  24437.     call atxto
  24438.     goto 8000
  24439.  1540 CONTINUE
  24440. C
  24441. C     SET NBOO AND LIMTU TO FOOL RMLOOK FOR MINMAX
  24442. C
  24443.       MNBOO = NBOO
  24444.       MLIMTU = LIMTU
  24445.       NBOO = 0
  24446.       LIMTU = ALL9S
  24447.       KOMPOS(MNBOO) = NEXPOS
  24448.       CALL MINMAX(WHRVAL(NEXPOS),KMM)
  24449.       IF(RMSTAT.NE.0) GO TO 7700
  24450.       NEXPOS = NEXPOS + ATTLEN
  24451.       KOMPOT(MNBOO) = NEXPOT
  24452.       WHRLEN(NEXPOT) = ATTLEN
  24453.       NEXPOT = NEXPOT + 1
  24454.       LIMTU = MLIMTU
  24455.       NBOO = MNBOO
  24456. C
  24457. C  RESET RELATION POINTERS
  24458. C
  24459.       I = LOCREL(NAME)
  24460.       IS = IS + 3
  24461.       KOMLEN(NBOO) = 1
  24462.       IF(IS.GT.ITEMS) GO TO 2100
  24463.       IF((LXWREC(IS,1).NE.K4AND).AND.(LXWREC(IS,1).NE.K4OR)) GO TO 7400
  24464.       NBOO = NBOO + 1
  24465.       BOO(NBOO) = LXWREC(IS,1)
  24466.       GO TO 1000
  24467.  1550 CONTINUE
  24468. C
  24469. C  VALUE COMPARISON. MAKE SURE THE VALUE LOOKS GOOD.
  24470. C
  24471.       NLIST = 0
  24472.       IS = IS + 2
  24473.       CALL ITOH(NR,NW,KATTL(NBOO))
  24474.       IF(KATTY(NBOO).EQ.0) NW = 1
  24475.       ITYPE = ATTYPE
  24476.       IF(KATTY(NBOO).EQ.0) ITYPE = KZINT
  24477.       KOMPOS(NBOO) = NEXPOS
  24478.       KOMPOT(NBOO) = NEXPOT
  24479.       IF(KOMTYP(NBOO).EQ.9) GO TO 1580
  24480.  1560 CONTINUE
  24481. C
  24482. C     USE PARVAL TO EXTRACT NEXT VALUE
  24483. C
  24484.       NWORDS = NW
  24485.       NROW = NR
  24486.       CALL PARVAL(IS,WHRVAL(NEXPOS),ITYPE,NWORDS,NROW,0,IERR)
  24487.       IF(IERR.NE.0) GO TO 8000
  24488.       IF(.NOT.IFTUP) GO TO 1570
  24489. C
  24490. C  ROW WHERE CLAUSE - CHECK TYPE AND SET MAXIMUM ROW
  24491. C
  24492.       IF(WHRVAL(NEXPOS).LE.0) GO TO 7300
  24493.       IF(WHRVAL(NEXPOS).GT.ALL9S) GO TO 7300
  24494.       IF(WHRVAL(NEXPOS).GT.MAXTU) MAXTU = WHRVAL(NEXPOS)
  24495.  1570 CONTINUE
  24496.       NLIST = NLIST + 1
  24497.       NEXPOS = NEXPOS + NWORDS
  24498.       CALL HTOI(NROW,NWORDS,WHRLEN(NEXPOT))
  24499.       NEXPOT = NEXPOT + 1
  24500.       KOMLEN(NBOO) = NLIST
  24501.       IF(NLIST.EQ.1) GO TO 1575
  24502. C
  24503. C  WE HAVE A LIST - VALID ONLY FOR EQ, EQS, AND NE
  24504. C
  24505.       IF((KOMTYP(NBOO).NE.2).AND.(KOMTYP(NBOO).NE.3)) GO TO 7600
  24506.  1575 CONTINUE
  24507.       IF(IS.GT.ITEMS) GO TO 2100
  24508.       IF((LXWREC(IS,1).NE.K4AND).AND.(LXWREC(IS,1).NE.K4OR)) GO TO 1560
  24509.       NBOO = NBOO + 1
  24510.       BOO(NBOO) = LXWREC(IS,1)
  24511.       GO TO 1000
  24512.  1580 CONTINUE
  24513. C
  24514. C     EQS - ONLY SAVE WHATS INPUT
  24515. C
  24516.       IF(ATTYPE.EQ.KZTEXT) GO TO 1585
  24517.  1581 CONTINUE
  24518.     if(nout.eq.6)goto 3145
  24519.       WRITE (NOUT,1582)
  24520.  1582 FORMAT(46H -ERROR- EQS Requires TEXT Elements And Values )
  24521.       GO TO 8000
  24522. 3145    write(c128wk,1582)
  24523.     call atxto
  24524.     goto 8000
  24525.  1585 CONTINUE
  24526.       IF(LXID(IS).NE.KZTEXT) GO TO 1581
  24527.       NW = LXLENW(IS)
  24528.       NR = LXLENC(IS)
  24529.       CALL LXSREC(IS,1,NR,WHRVAL(NEXPOS),1)
  24530.       NEXPOS = NEXPOS + NW
  24531.       IS = IS + 1
  24532.       CALL HTOI(NR,NW,WHRLEN(NEXPOT))
  24533.       NEXPOT = NEXPOT + 1
  24534.       NLIST = NLIST + 1
  24535.       KOMLEN(NBOO) = NLIST
  24536.       IF(IS.GT.ITEMS) GO TO 2100
  24537.       IF((LXWREC(IS,1).NE.K4AND).AND.(LXWREC(IS,1).NE.K4OR)) GO TO 1585
  24538.       NBOO = NBOO + 1
  24539.       BOO(NBOO) = LXWREC(IS,1)
  24540.       GO TO 1000
  24541. C
  24542. C  ATTRIBUTE COMPARISON. CHECK FOR LEGAL ATTRIBUTE
  24543. C
  24544.  1600 CONTINUE
  24545.       ISAVE = ATTYPE
  24546.       ANAME = BLANK
  24547.       CALL LXSREC(IS+2,1,8,ANAME,1)
  24548.       I = LOCATT(ANAME,NAME)
  24549.       IF(I.EQ.0) GO TO 1700
  24550.       CALL WARN(3,ANAME,NAME)
  24551.       GO TO 8000
  24552.  1700 CONTINUE
  24553.       CALL ATTGET(I)
  24554.       KOMPOS(NBOO) = ATTCOL
  24555.       IF(ATTLEN.NE.KATTL(NBOO)) GO TO 7500
  24556.       IF(ATTYPE.NE.ISAVE) GO TO 7500
  24557.  1800 CONTINUE
  24558. C
  24559. C  LOOK FOR THE NEXT BOOLEAN JOIN.
  24560. C
  24561.       JE = ITEMS - IS
  24562.       IF(JE.LE.1) GO TO 2000
  24563.       IF ( (JE.EQ.2) .AND. (KOMTYP(NBOO).GT.1) ) GO TO 2000
  24564.       ISOR = LFIND(IS,JE,K4OR,2)
  24565.       ISAND = LFIND(IS,JE,K4AND,3)
  24566.       ISA = ISOR
  24567.       IF((ISAND.NE.0).AND.(ISAND.LT.ISOR))ISA = ISAND
  24568.       IF(ISOR.EQ.0) ISA = ISAND
  24569.       IF(ISA.EQ.0) GO TO 2000
  24570.       IF(IFLIM) GO TO 1900
  24571.       KOMLEN(NBOO) = ISA - IS - 2
  24572.       IF( (KOMLEN(NBOO).NE.0) .AND. (KOMTYP(NBOO).LE.1) ) GO TO 7800
  24573.       IF(KOMTYP(NBOO).LE.1) KOMLEN(NBOO) = 1
  24574.       IF(KOMLEN(NBOO).LE.1) GO TO 1900
  24575. C
  24576. C  WE HAVE A LIST - VALID ONLY FOR EQ, EQS, AND NE
  24577. C
  24578.       GO TO 7600
  24579. C
  24580. C  CONVERT WORDS TO CHARACTERS FOR TEXT ATTRIBUTES
  24581. C
  24582.  1900 CONTINUE
  24583.       NBOO = NBOO + 1
  24584.       IS = ISA
  24585.       BOO(NBOO) = LXWREC(IS,1)
  24586.       GO TO 1000
  24587. C
  24588. C  GET THE LENGTH OF THE LIST IN THE LAST CONDITION
  24589. C
  24590.  2000 CONTINUE
  24591.       IF(IFLIM) GO TO 2100
  24592.       KOMLEN(NBOO) = ITEMS - IS - 1
  24593.       IF( (KOMLEN(NBOO).NE.0) .AND. (KOMTYP(NBOO).LE.1) ) GO TO 7800
  24594.       IF(KOMTYP(NBOO).LE.1) KOMLEN(NBOO) = 1
  24595.       IF(KOMLEN(NBOO).LE.1) GO TO 2100
  24596. C
  24597. C  WE HAVE A LIST - VALID ONLY FOR EQ, EQS, AND NE
  24598. C
  24599.       GO TO 7600
  24600. C
  24601. C  CHECK FOR KEY PROCESSING
  24602. C
  24603.  2100 CONTINUE
  24604.       BOO(1) = K4AND
  24605.       IF(NTUPC.NE.NBOO) MAXTU = 0
  24606.       IF(BOO(NBOO).NE.K4AND) GO TO 9999
  24607.       IF(KOMTYP(NBOO).NE.2) GO TO 9999
  24608.       IF(IFTUP) GO TO 9999
  24609.       IF(KOMLEN(NBOO).NE.1) GO TO 9999
  24610. C
  24611. C  USE KEY PROCESSING.
  24612. C
  24613.       KSTRT = ATTKEY
  24614.       IF(KSTRT.NE.0) NS = 2
  24615.       GO TO 9999
  24616.  7000 CONTINUE
  24617.     if(nout.eq.6)goto 3146
  24618.       WRITE (NOUT,7010)
  24619.  7010 FORMAT(31H -ERROR- WHERE Clause Too Short )
  24620.       GO TO 8000
  24621. 3146    write(c128wk,7010)
  24622.     call atxto
  24623.     goto 8000
  24624.  7100 CONTINUE
  24625.     if(nout.eq.6)goto 3147
  24626.       WRITE (NOUT,7110)
  24627.  7110 FORMAT(34H -ERROR- LIMIT Keyword Requires EQ )
  24628.       GO TO 8000
  24629. 3147    write(c128wk,7110)
  24630.     call atxto
  24631.     goto 8000
  24632.  7200 CONTINUE
  24633.     if(nout.eq.6)goto 3148
  24634.       WRITE (NOUT,7210)
  24635.  7210 FORMAT(50H -ERROR- LIMIT Keyword Requires A Positive Integer )
  24636.       GO TO 8000
  24637. 3148    write(c128wk,7210)
  24638.     call atxto
  24639.     goto 8000
  24640.  7300 CONTINUE
  24641.     if(nout.eq.6)goto 3149
  24642.       WRITE (NOUT,7310)
  24643.  7310 FORMAT(47H -ERROR- ROW Keyword Requires Positive Integers )
  24644.       GO TO 8000
  24645. 3149    write(c128wk,7310)
  24646.     call atxto
  24647.     goto 8000
  24648.  7400 CONTINUE
  24649.     if(nout.eq.6)goto 3150
  24650.       WRITE (NOUT,7410)
  24651.  7410 FORMAT(51H -ERROR- MIN/MAX Should Only Be Followed By AND/OR )
  24652.       GO TO 8000
  24653. 3150    write(c128wk,7410)
  24654.     call atxto
  24655.     goto 8000
  24656.  7500 CONTINUE
  24657.     if(nout.eq.6)goto 3151
  24658.       WRITE (NOUT,7510)
  24659.  7510 FORMAT(28H -ERROR- Compared Attributes,
  24660.      X       36H Must Be The Same In Type And Length )
  24661.       GO TO 8000
  24662. 3151    write(c128wk,7510)
  24663.     call atxto
  24664.     goto 8000
  24665.  7600 CONTINUE
  24666.     if(nout.eq.6)goto 3152
  24667.       WRITE (NOUT,7610)
  24668.  7610 FORMAT(47H -ERROR- Lists Are Only Valid For EQ EQS And NE)
  24669.       GO TO 8000
  24670. 3152    write(c128wk,7610)
  24671.     call atxto
  24672.     goto 8000
  24673.  7700 CONTINUE
  24674.     if(nout.eq.6)goto 3153
  24675.       WRITE(NOUT,7710)
  24676.  7710 FORMAT(50H -ERROR- MIN/MAX Not Available For Null Attributes)
  24677.       GO TO 8000
  24678. 3153    write(c128wk,7710)
  24679.     call atxto
  24680.     goto 8000
  24681.  7800 CONTINUE
  24682.     if(nout.eq.6)goto 3154
  24683.       WRITE (NOUT,7810)
  24684.  7810 FORMAT(55H -ERROR- FAILS/EXISTS Should Only Be Followed By AND/OR)
  24685.       GO TO 8000
  24686. 3154    write(c128wk,7810)
  24687.     call atxto
  24688.     goto 8000
  24689. C
  24690. C  UNABLE TO PROCESS THE WHERE CLAUSE.
  24691. C
  24692.  8000 CONTINUE
  24693.     if(nout.eq.6)goto 3155
  24694.       IF(NBOO.NE.0) WRITE (NOUT,8010)NBOO
  24695.  8010 FORMAT(9X,36HError Detected On Boolean Condition ,I2)
  24696.     goto 3156
  24697. 3155    write(c128wk,8010)nboo
  24698.     call atxto
  24699. 3156    continue
  24700.  
  24701.       RMSTAT = 4
  24702. C
  24703. C  QUIT.
  24704. C
  24705.  9999 CONTINUE
  24706.       IF(MAXTU.EQ.0) MAXTU = ALL9S
  24707.       CALL WHETOL
  24708.       RETURN
  24709.       END
  24710.       SUBROUTINE WHETOL
  24711.       INCLUDE rin:TEXT.BLK
  24712. C
  24713. C     THIS ROUTINE CHANGES THE WHERE COMMON BLOCK TO REFLECT
  24714. C     TOLERANCES WHERE POSSIBLE.  LE,LT,GE,GT TOLERANCES ARE
  24715. C     CRANKED INTO WHCOM TO AVOID CALCULATING THEM FOR EVERY
  24716. C     ROW.  EQ AND NE WILL BE DONE IN KOMPAR.
  24717. C
  24718.       INCLUDE rin:RMATTS.BLK
  24719.       INCLUDE rin:WHCOM.BLK
  24720.       INCLUDE rin:FLAGS.BLK
  24721.       INCLUDE rin:RIMPTR.BLK
  24722.       IF(TOL.EQ.0.) RETURN
  24723.       IF(NBOO.EQ.0) RETURN
  24724.       IF(KATTY(NBOO).EQ.KZREAL) NS = 0
  24725.       IF(KATTY(NBOO).EQ.KZDOUB) NS = 0
  24726.       DO 1000 I=1,NBOO
  24727.       IF(KATTY(I).EQ.KZTEXT) GO TO 1000
  24728.       IF(KATTY(I).EQ.KZINT) GO TO 1000
  24729.       IF(KOMTYP(I).LT.4) GO TO 1000
  24730.       IF(KOMTYP(I).GT.7) GO TO 1000
  24731. C
  24732. C     CHANGE THEM VALUES
  24733. C
  24734.       NUM = KOMLEN(I)
  24735.       NPOS = KOMPOS(I)
  24736.       NPOT = KOMPOT(I)
  24737.       DO 100 J=1,NUM
  24738.       CALL ITOH(NR,NW,WHRLEN(NPOT))
  24739.       NPOT = NPOT + 1
  24740.       IF(KATTY(I).EQ.KZREAL) CALL TOLER(KOMTYP(I),WHRVAL(NPOS),NW)
  24741.       IF(KATTY(I).EQ.KZDOUB) CALL TOLED(KOMTYP(I),WHRVAL(NPOS),NW/2)
  24742.       NPOS = NPOS + NW
  24743.   100 CONTINUE
  24744.  1000 CONTINUE
  24745.       RETURN
  24746.       END
  24747.       SUBROUTINE WRLINE (NC,ISTAT,LINE)
  24748.       INCLUDE rin:TEXT.BLK
  24749. C
  24750. C  PURPOSE:  WRITES LINE TO OUTPUT BY USING SPOUT,BLANKS IT OUT AND
  24751. C            RESETS NC (NUMBER OF CHARACTERS) TO 1.
  24752. C
  24753. C  INPUTS:
  24754. C            NC---------NUMBER OF CHARACTERS
  24755. C            ISTAT------ARE WE DONE?  EQUAL TO 1 IF WE ARE.
  24756. C            LINE-------OUTPUT LINE
  24757. C
  24758.       INCLUDE rin:CONST4.BLK
  24759.       INCLUDE rin:MISC.BLK
  24760.       INTEGER LINE(*)
  24761.       IEND = K4PLUS
  24762.       IF (ISTAT .EQ. 1) IEND = IBLANK
  24763.       CALL PUTT (LINE,NC,IEND)
  24764.       CALL SPOUT (LINE,NC)
  24765.       CALL FILCH (LINE,1,80,IBLANK)
  24766.       NC = 2
  24767.       RETURN
  24768.       END
  24769.       SUBROUTINE XHIBIT
  24770.       INCLUDE rin:TEXT.BLK
  24771. C
  24772. C  THIS ROUTINE IS PART OF THE RIM DATA DICTIONARY/DIRECTORY SYSTEM.
  24773. C  IT ENABLES THE USER TO LIST ALL RELATIONS HAVING CERTAIN ATTRIBUTES.
  24774. C
  24775.       INCLUDE rin:TUPLER.BLK
  24776.       INCLUDE rin:FILES.BLK
  24777.       INCLUDE rin:MISC.BLK
  24778.       INCLUDE rin:FLAGS.BLK
  24779. C
  24780.       LOGICAL EQ
  24781.       LOGICAL FLAG
  24782.       INCLUDE rin:DCLAR1.BLK
  24783. C
  24784. C  EDIT THE EXHIBIT COMMAND
  24785. C
  24786.       ITEMS = LXITEM(IDUMMY)
  24787.       IF(ITEMS.EQ.1) GO TO 9900
  24788.       IF(ITEMS.GT.11) GO TO 9900
  24789.       NUMBER = ITEMS - 1
  24790. C
  24791. C  COMMAND IS OKAY
  24792. C
  24793.       FLAG = .FALSE.
  24794. C
  24795.       DO 100 I=1,NUMBER
  24796.       NAMES(I) = BLANK
  24797.       CALL LXSREC(I+1,1,8,NAMES(I),1)
  24798.   100 CONTINUE
  24799.     if(nout.eq.6)goto 3140
  24800.       WRITE(NOUTR,9000) (NAMES(I),I=1,NUMBER)
  24801.  9000 FORMAT(22H Relations Containing ,A8,1X,A8,1X,A8,1X,A8,
  24802.      X A8,1X,A8,1X,A8,1X,A8,1X,A8,1X,A8)
  24803.     goto 3141
  24804. 3140    write(c128wk,9000) (names(i),i=1,number)
  24805.     call atxto
  24806. 3141    continue
  24807. C
  24808. C  GO THROUGH EACH REALTION.
  24809. C
  24810.       I = LOCREL(BLANK)
  24811.   200 CONTINUE
  24812.       CALL RELGET(ISTAT)
  24813.       IF(ISTAT.NE.0) GO TO 500
  24814. C
  24815. C  SEE IF ALL THE ATTRIBUTES LISTED APPEAR IN THIS RELATION
  24816. C
  24817.       DO 300 I=1,NUMBER
  24818.       K = LOCATT(NAMES(I),NAME)
  24819.       IF(K.NE.0) GO TO 200
  24820.   300 CONTINUE
  24821. C
  24822. C  CHECK USER READ SECURITY.
  24823. C
  24824.       IF(EQ(USERID,OWNER)) GO TO 400
  24825.       IF(EQ(RPW,NONE)) GO TO 400
  24826.       IF(EQ(RPW,USERID)) GO TO 400
  24827.       IF(EQ(MPW,USERID)) GO TO 400
  24828. C
  24829. C  RELATION IS NOT AVAILABLE TO THE USER.
  24830. C
  24831.       GO TO 200
  24832. C
  24833.   400 CONTINUE
  24834. C
  24835. C  ATTRIBUTES ARE IN THIS RELATION
  24836. C
  24837.     if(noutr.eq.6)goto 3142
  24838.       WRITE(NOUTR,9001) NAME
  24839.  9001 FORMAT(5X,A8)
  24840. 3143      FLAG = .TRUE.
  24841.       GO TO 200
  24842. 3142    write(c128wk,9001)name
  24843.     call atxto
  24844.     goto 3143
  24845.   500 CONTINUE
  24846. C
  24847. C  SEE IF ANY RELATIONS HAD THE ATTRIBUTES
  24848. C
  24849.       IF(FLAG) GO TO 9999
  24850. C
  24851. C  NONE OF THE RELATIONS HAD THE ATTRIBUTES
  24852. C
  24853.     if(nout.eq.6)goto 3144
  24854.       WRITE(NOUT,9002)
  24855.  9002 FORMAT(57H -WARNING- Attribute List Does Not Occur In Any Relation
  24856.      Xs)
  24857.       GO TO 9999
  24858. 3144    write(c128wk,9002)
  24859.     call atxto
  24860.     goto 9999
  24861. C
  24862. C  INVALID SYNTAX FOR 'EXHIBIT'
  24863. C
  24864.  9900 CONTINUE
  24865.     if(nout.eq.6)goto 3145
  24866.       WRITE(NOUT,9003)
  24867.  9003 FORMAT(47H -ERROR- Illegal Number Of Attributes Specified )
  24868.     goto 9999
  24869. 3145    write(c128wk,9003)
  24870.     call atxto
  24871. C
  24872. C  DONE WITH EXHIBIT
  24873. C
  24874.  9999 RETURN
  24875.       END
  24876.       SUBROUTINE ZEROIT(ARRAY,NWDS)
  24877.       INCLUDE rin:TEXT.BLK
  24878. C
  24879. C  PURPOSE:   ZERO OUT AN ARRAY
  24880. C
  24881. C  PARAMETERS:
  24882. C         ARRAY---ARRAY TO BE ZEROED OUT
  24883. C         NWDS----NUMBER OF WORDS IN THE ARRAY
  24884. C
  24885.       INTEGER ARRAY(*)
  24886.       DO 100 I=1,NWDS
  24887.       ARRAY(I) = 0
  24888.   100 CONTINUE
  24889.       RETURN
  24890.       END
  24891.