*DECK DCCONSUB
       IDENTIFICATION DIVISION. 
       PROGRAM-ID. CONSUB.
*CALL COPYRIGHT 
      *    THIS PROGRAM EXPLODES CDCS SUBSCHEMA ENTRIES AS PART OF
      *    THE DATA CATALOGUE CONVERSION. 
       ENVIRONMENT DIVISION.
       CONFIGURATION SECTION. 
       SOURCE-COMPUTER. CYBER.
       OBJECT-COMPUTER. CYBER.
       INPUT-OUTPUT SECTION.
       FILE-CONTROL.
           SELECT SYSPRINT ASSIGN TO "OUTPUT".
           SELECT OPTIONAL SUB-FILE ASSIGN TO SUBFIL
               USE "RT=Z".
           SELECT IS-FILE 
               ASSIGN TO ISFILE, XNISFIL
               ORGANIZATION IS INDEXED
               RECORD KEY IS IS-PKEY
               ALTERNATE RECORD KEY IS IS-ALTKEY
                   WITH DUPLICATES. 
       DATA DIVISION. 
       FILE SECTION.
       FD  SUB-FILE 
           LABEL RECORDS ARE OMITTED
           RECORD CONTAINS 80 CHARACTERS
           DATA RECORDS ARE SUB-IN. 
       01  SUB-IN.
           02  SUB-LINE                    PICTURE X OCCURS 73 TIMES. 
           02  SUB-ID                      PICTURE X(7).
*CALL SYSPRTFD
*CALL ISFILFD 
       COMMON-STORAGE SECTION.
       77  RETURN-CODE                     PICTURE XX.
*CALL CVTBL 
       01  CDCS-CVTBL REDEFINES CVTBL.
           02  AD-TBL.
               03  AD-ENTRY OCCURS 20 TIMES.
                   04  AD-ENTITY-TYPE      PICTURE XX.
                   04  AD-OLD-NEW-NAME. 
                       05  AD-OLD-NAME     PICTURE X(30). 
                       05  AD-NEW-NAME     PICTURE X(30). 
                   04  AD-NAME-ARRAY REDEFINES AD-OLD-NEW-NAME. 
                       05  AD-NAME         PICTURE X(30) OCCURS 2 TIMES.
                   04  AD-OLD-QUAL         PICTURE X(30). 
                   04  AD-NEW-QUAL         PICTURE X(30) OCCURS 5 TIMES.
               03  AD-PREVIOUS-BLOCK-PTR   PICTURE 9(10) USAGE COMP-1.
           02  KEY-TBL. 
               03  KEY-ARRAY. 
                   04  KEY-ENTRY OCCURS 20 TIMES. 
                       05  KEY-NAME        PICTURE X(30). 
                       05  KEY-QUAL-ARRAY.
                           06  KEY-QUAL    PICTURE X(30) OCCURS 5 TIMES.
                       05  KEY-STCR        PICTURE 9(7).
                       05  KEY-ORDER       PICTURE X. 
               03  KEY-NEXT-BLOCK-PTR      PICTURE 9(10) USAGE COMP-1.
       01  PRINT-CTL-TBL. 
*CALL WKPRINT 
       01  WRKF-FUNCTION-CODE              PICTURE X. 
*CALL WRKFHDR 
*CALL WRKREDEF
       WORKING-STORAGE SECTION. 
       01  CDCS-NAME. 
           03  CDCS-NAME-CHAR              PICTURE X OCCURS 32 TIMES. 
       01  COMMENT-AREA.
           03  COMMENT-A                   PICTURE X OCCURS 67 TIMES. 
       01  ERROR-MSG. 
           02  MSG-10                      PICTURE X(40) VALUE
           "DCCVT-10-W ERROR * ENDING PERIOD ASSUMED".
           02  MSG-25                      PICTURE X(51) VALUE
           "DCCVT-25-W ERROR * TOKEN TRUNCATED TO 30 CHARACTERS". 
           02  MSG-30                      PICTURE X(41) VALUE
           "DCCVT-30-S ERROR * SEARCHING FOR A PERIOD". 
           02  MSG-35                      PICTURE X(45) VALUE
           "DCCVT-35-S ERROR * PERIOD FOUND. SCAN RESUMES". 
           02  MSG-40.
               03  FILLER                  PICTURE X(28) VALUE
               "DCCVT-40-S ERROR * KEYWORD *".
               03  SKIPPED-TO-KEYWORD      PICTURE X(10). 
               03  FILLER                  PICTURE X(21) VALUE
               "* FOUND. SCAN RESUMES". 
           02  MSG-45.
               03  FILLER                  PICTURE X(36) VALUE
               "DCCVT-45-S ERROR * UNKNOWN KEYWORD *".
               03  UNKNOWN-KEYWORD         PICTURE X(10). 
               03  FILLER                  PICTURE X(30) VALUE
               "*. SEARCHING FOR KNOWN KEYWORD".
           02  MSG-50                      PICTURE X(43) VALUE
           "DCCVT-50-S ERROR * KEYWORD *WITHIN* MISSING". 
           02  MSG-85                      PICTURE X(38) VALUE
           "DCCVT-85-S ERROR * RECORD-NAME UNKNOWN".
           02  MSG-105                     PICTURE X(40) VALUE
           "DCCVT-105-S ERROR * LEVEL TABLE EXCEEDED".
           02  MSG-130                     PICTURE X(39) VALUE
           "DCCVT-130-S ERROR * KEYWORD *)* MISSING". 
           02  MSG-140                     PICTURE X(57) VALUE
           "DCCVT-140-S ERROR * SUBSCRIPT CONTAINS MORE THAN 4 DIGITS". 
           02  MSG-160                     PICTURE X(37) VALUE
           "DCCVT-160-S ERROR * INVALID SUBSCRIPT". 
           02  MSG-165                     PICTURE X(65) VALUE
           "DCCVT-165-W ERROR * NONNUMERIC LITERAL TRUNCATED TO 30 CHARA
      -    "CTERS". 
           02  MSG-170                     PICTURE X(45) VALUE
           "DCCVT-170-W ERROR * TERMINATING QUOTE ASSUMED". 
           02  MSG-175                     PICTURE X(66) VALUE
           "DCCVT-175-S ERROR * KEYWORD *TITLE* MISSING. SEARCHING FOR *
      -    "TITLE*".
           02  MSG-180                     PICTURE X(46) VALUE
           "DCCVT-180-S ERROR * KEYWORD *DIVISION* MISSING".
           02  MSG-185                     PICTURE X(40) VALUE
           "DCCVT-185-S ERROR * KEYWORD *SS* MISSING".
           02  MSG-190                     PICTURE X(39) VALUE
           "DCCVT-190-S ERROR * UNKNOWN SCHEMA NAME". 
           02  MSG-195                     PICTURE X(64) VALUE
           "DCCVT-195-S ERROR * KEYWORD *REALM*, *RECORD*, OR *DATA* MIS
      -    "SING".
           02  MSG-200                     PICTURE X(45) VALUE
           "DCCVT-200-S ERROR * KEYWORD *BECOMES* MISSING". 
           02  MSG-205                     PICTURE X(52) VALUE
           "DCCVT-205-S ERROR * MORE THAN 5 QUALIFIERS ARE GIVEN".
           02  MSG-210                     PICTURE X(40) VALUE
           "DCCVT-210-S ERROR * KEYWORD *RD* MISSING".
           02  MSG-215. 
               03  FILLER                  PICTURE X(27) VALUE
               "DCCVT-215-S ERROR * REALM *". 
               03  UNKNOWN-AREA            PICTURE X(30). 
               03  FILLER                  PICTURE X(19) VALUE
               "* UNKNOWN IN SCHEMA". 
           02  MSG-220                     PICTURE X(43) VALUE
           "DCCVT-220-S ERROR * KEYWORD *REALM* MISSING". 
           02  MSG-225                     PICTURE X(44) VALUE
           "DCCVT-225-S ERROR * KEYWORD *RECORD* MISSING".
           02  MSG-230                     PICTURE X(49) VALUE
           "DCCVT-230-S ERROR * RECORD NAME UNKNOWN IN SCHEMA". 
           02  MSG-235                     PICTURE X(65) VALUE
           "DCCVT-235-S ERROR * CORRESPONDING REALM NOT INCLUDED IN SUBS
      -    "CHEMA". 
           02  MSG-240. 
               03  FILLER                  PICTURE X(31) VALUE
               "DCCVT-240-S ERROR * DATA ITEM *". 
               03  UNKNOWN-ITEM            PICTURE X(30). 
               03  FILLER                  PICTURE X(19) VALUE
               "* UNKNOWN IN SCHEMA". 
           02  MSG-245                     PICTURE X(54) VALUE
           "DCCVT-245-S ERROR * ILLEGAL OR NO PICTURE FOR *FILLER*".
           02  MSG-250                     PICTURE X(53) VALUE
           "DCCVT-250-S ERROR * KEYWORD *RIGHT* OR *LEFT* MISSING". 
           02  MSG-255                     PICTURE X(33) VALUE
           "DCCVT-255-S ERROR * UNKNOWN USAGE". 
           02  MSG-260                     PICTURE X(56) VALUE
           "DCCVT-260-W ERROR * CONDITION TRUNCATED TO 63 CHARACTERS".
           02  MSG-265. 
               03  FILLER                  PICTURE X(31) VALUE
               "DCCVT-265-S ERROR * DATA ITEM *". 
               03  UNKNOWN-SS-ITEM         PICTURE X(30). 
               03  FILLER                  PICTURE X(22) VALUE
               "* UNKNOWN IN SUBSCHEMA".
           02  MSG-270                     PICTURE X(45) VALUE
           "DCCVT-270-S ERROR * KEYWORD *RENAMES* MISSING". 
           02  MSG-275                     PICTURE X(59) VALUE
          "DCCVT-275-S ERROR * RENAMES CLAUSE IS ONLY PERMITTED CLAUSE".
           02  MSG-280                     PICTURE X(67) VALUE
           "DCCVT-280-S ERROR * LEVEL 66 ENTRIES MUST BE LAST ENTRIES IN
      -    " RECORD". 
           02  MSG-285                     PICTURE X(35) VALUE
           "DCCVT-285-S ERROR * INVALID INTEGER". 
           02  MSG-290                     PICTURE X(47) VALUE
           "DCCVT-290-S ERROR * KEYWORD *DEPENDING* MISSING". 
           02  MSG-295                     PICTURE X(44) VALUE
           "DCCVT-295-W ERROR * KEY QUALIFIERS DISCARDED".
           02  MSG-300                     PICTURE X(55) VALUE
           "DCCVT-300-S ERROR * RECORD-NAME NOT UNIQUE IN SUBSCHEMA". 
           02  MSG-305                     PICTURE X(47) VALUE
           "DCCVT-305-S ERROR * UNKNOWN RELATIONAL OPERATOR". 
           02  MSG-385. 
               03  FILLER                  PICTURE X(26) VALUE
               "DCCVT-385-S ERROR * FILE *".
               03  EMPTY-FILE-NAME         PICTURE X(7).
               03  FILLER                  PICTURE X(10) VALUE
               "* IS EMPTY".
           02  MSG-490                     PICTURE X(54) VALUE
           "DCCVT-490-W ERROR * PICTURE TRUNCATED TO 25 CHARACTERS".
       01  FIND-IS-ALTKEY.
           03  FIND-IS-ENTITY-TYPE         PICTURE XX.
           03  FIND-IS-SCHEMA-ORDINAL      PICTURE 9999.
           03  FIND-IS-CDCS-NAME           PICTURE X(30). 
       01  HEADING-LITS.
           03  CONV-SUB-TITLE          PICTURE X(50) VALUE
           "      SUBSCHEMA      CONVERSION      REPORT       ".
           03  END-REPORT-MSG             PICTURE X(37) 
               VALUE "***END SUBSCHEMA CONVERSION REPORT***". 
       01  HOLD-ATTRIBUTE.
           02  HOLD-LENGTH                 PICTURE X(10). 
           02  HOLD-FORMAT                 PICTURE XXX. 
           02  HOLD-PICTURE                PICTURE X(25). 
           02  HOLD-JUST                   PICTURE X. 
           02  HOLD-SYNC                   PICTURE X. 
       01  HOLD-IS-REC. 
           02  HOLD-IS-PKEY.
               03  HOLD-IS-CATNAME         PICTURE X(32). 
               03  HOLD-IS-ALIAS-NO        PICTURE 9(4).
               03  HOLD-IS-SEQ-NO          PICTURE 9(4).
           02  HOLD-IS-ALTKEY.
               03  HOLD-IS-ENTITY-TYPE     PICTURE XX.
               03  HOLD-IS-SCHEMA-ORDINAL  PICTURE 9999.
               03  HOLD-IS-CDCS-NAME       PICTURE X(30). 
       01  HOLD-STRUCTURE.
           02  HOLD-REDEFINE               PICTURE X(32). 
           02  HOLD-RDALIAS                PICTURE X(4).
           02  HOLD-USAGE                  PICTURE X(7).
           02  HOLD-FILLER                 PICTURE X(4).
           02  FILLER-LENGTH REDEFINES HOLD-FILLER PICTURE 9(4).
  
       01  LEVEL-TABLE. 
           02  LEV-TAB                     OCCURS 11 TIMES. 
               03  LEVT-CATNAME            PICTURE X(32). 
               03  LEVT-CDCS-NAME          PICTURE X(30). 
               03  LEVT-GRP-ELE            PICTURE X. 
               03  LEVT-LEVEL-NO           PICTURE 99.
               03  LEVT-EALIASOF-FLAG      PICTURE X. 
       01  LINE1. 
           03  FILLER                      PICTURE X. 
           03  LINE1A                      PICTURE X(10). 
           03  FILLER                      PICTURE X(9).
           03  LINE1B                      PICTURE X(32). 
           03  FILLER                      PICTURE XX.
           03  LINE1C                      PICTURE X(80). 
       01  NOTE-CDCS-REC. 
           03  NOTE-ENTRY-TYPE             PICTURE XX.
           03  NOTE-99-GROUP               PICTURE 99.
           03  NOTE-EALIASOF-FLAG          PICTURE X. 
           03  NOTE-CATNAME                PICTURE X(32). 
           03  NOTE-CATEGORY-TYPE          PICTURE XXX. 
           03  NOTE-CDCS-NAME              PICTURE X(30). 
       01  NOTE-HOLD-CDCS-REC.
           03  FILLER                      PICTURE X(127).
           03  HOLD-LARGEST-REC            PICTURE X(469).
       01  PICTURE-AREA.
           02  PICA                        PICTURE X OCCURS 26 TIMES. 
       01  PICTURE-AREA-NUM REDEFINES PICTURE-AREA. 
           02  PIC-NUM                     PICTURE 9 OCCURS 26 TIMES. 
       01  QUAL-TABLE.
           02  QUAL-NAME-ARRAY. 
               03  QUAL-NAME               PICTURE X(30) OCCURS 5 TIMES.
           02  QUAL-CATNAME-ARRAY.
               03  QUAL-CATNAME            PICTURE X(32) OCCURS 5 TIMES.
       01  SEQNO-ARRAY. 
           02  SEQNO-ARRAY-COMP-1.
               03  SEQNO-COMP-1            PICTURE 9(4) COMP-1
                                           OCCURS 4 TIMES.
           02  SEQNO REDEFINES SEQNO-ARRAY-COMP-1.
               03  SEQNO-CHAR              PICTURE X OCCURS 40 TIMES. 
       01  SEQ-DIGIT-ARRAY. 
           02  SEQ-DIGIT-COMP-1            PICTURE 9(4) COMP-1
                                           VALUE IS 0.
           02  SEQ-DIGIT-CHAR-ARRAY REDEFINES SEQ-DIGIT-COMP-1. 
               03  SEQ-DIGIT               PICTURE X OCCURS 10 TIMES. 
       01  SKIP-UNTIL-TOKEN-ARRAY.
           02  SKIP-UNTIL-TOKEN            PICTURE X(10)
               OCCURS 1 TO 4 TIMES DEPENDING ON SKIP-UNTIL-TOKEN-COUNT. 
  
       01  WORK-AREA. 
           02  WORKA                       PICTURE X OCCURS 72 TIMES. 
       77  AD-SUB                          PICTURE 99.
       77  AREA-CATNAME                    PICTURE X(32). 
       77  ALIAS-NO                        PICTURE 9999.
       77  ALIAS-WITH-SAME-ATT             PICTURE S9999. 
       77  CDCS-NAME-LEN-PLUS1             PICTURE 99.
       77  CHAR-COUNT                      PICTURE 99.
       77  CHAR-SUB                        PICTURE 99.
       77  CMP-SUB                         PICTURE 9. 
       77  CMT-SUB                         PICTURE 99.
       77  DATA-ITEM-WAITING               PICTURE X. 
       77  DONE                            PICTURE X. 
       77  DONE1                           PICTURE X. 
       77  END-SW                          PICTURE X. 
           88 EOF VALUE "E".
       77  END-LOOP                        PICTURE X. 
       77  ENTITY-TYPE                     PICTURE XX.
       77  FIND-ALIAS-NO                   PICTURE X(4).
       77  FIND-CATNAME                    PICTURE X(32). 
       77  FIND-DATA-NAME                  PICTURE X(30). 
       77  FIND-ENTITY-TYPE                PICTURE XX.
       77  FIND-RECORD-CATNAME             PICTURE X(32). 
       77  HOLD-COMMENT                    PICTURE X(66). 
       77  IN-SUB                          PICTURE 9999.
       77  KEY-OUT-REC                     PICTURE X(127).
       77  KEY-LEVEL                       PICTURE 99.
       77  KEY-SUB                         PICTURE 99 VALUE 0.
       77  KEY-TABLE-WAITING               PICTURE X VALUE SPACE. 
       77  LEVEL-NO                        PICTURE 99.
       77  LEVEL-66-ENCOUNTERED            PICTURE X. 
       77  L-SUB                           PICTURE 99.
       77  LV-SUB                          PICTURE 99.
       77  LV-SUB-M1                       PICTURE 99.
       77  MAY-BE-COBOL-NAME               PICTURE X VALUE SPACE. 
       77  NAME-TO-MATCH                   PICTURE X(30). 
       77  NEW-OLD-NAME-FLAG               PICTURE X. 
       77  NEW-OLD-SUB                     PICTURE 9. 
       77  OCCURS-TO                       PICTURE X(32). 
       77  OUTSTANDING-PERIOD              PICTURE X. 
       77  PARTIAL-LENGTH                  PICTURE 9(4).
       77  PIC-CHAR                        PICTURE X. 
       77  PIC-SUB                         PICTURE 99.
       77  QUAL-MATCHES                    PICTURE X. 
       77  QUAL-SUB                        PICTURE 9. 
       77  PAREN-TERM                      PICTURE X. 
       77  READ-COUNT                      PICTURE 9(4).
       77  READ-SUB                        PICTURE 9(4).
       77  READ-END-SW                     PICTURE X. 
       77  REDEFINES-ITEM                  PICTURE X. 
       77  REDEFINES-LEVEL                 PICTURE 99 VALUE 0.
       77  RELATION-NAME                   PICTURE X(30). 
       77  SAVE-STRUCT                     PICTURE 9(7).
       77  SCHEMA-CATNAME                  PICTURE X(32). 
       77  SCHEMA-ITEM-FOUND               PICTURE X. 
       77  SCHEMA-NAME                     PICTURE X(30). 
       77  SCHEMA-ORD                      PICTURE 9999.
       77  SCHEMA-RECORD-CATNAME           PICTURE X(32). 
       77  SCHEMA-RECORD-CDCS-NAME         PICTURE X(30). 
       77  SEQ-NO                          PICTURE S9999. 
       77  SEQNO-LEN                       PICTURE 99.
       77  SKIP-FLAG                       PICTURE X. 
       77  SKIP-SUB                        PICTURE 9. 
       77  SKIP-UNTIL-TOKEN-COUNT          PICTURE 9. 
       77  SUBSCRIPT                       PICTURE X(16). 
       77  SUBSCRIPT-COUNT                 PICTURE 9. 
       77  SUB-SUB                         PICTURE 99.
       77  SUB-88                          PICTURE 99.
       77  SUBSCHEMA-CATNAME               PICTURE X(32). 
       77  SUBSCHEMA-NAME                  PICTURE X(30). 
       77  SUBSCHEMA-ORD                   PICTURE 9999 VALUE 0.
       77  WK-SUB                          PICTURE 9999.
  
       77  BLOCK-FWA                       PICTURE 9(10) USAGE IS COMP-1
                                           VALUE 0. 
       77  BLOCK-SIZE                      PICTURE 9(10) USAGE IS COMP-1
                                           VALUE 485. 
       77  GROUP-ID                        PICTURE 9(10) USAGE IS COMP-1
                                           VALUE 0. 
       77  KEY-FIRST-BLOCK-PTR             PICTURE 9(10) USAGE IS COMP-1
                                           VALUE 0. 
       77  KEY-BLOCK-SIZE                  PICTURE 9(10) USAGE IS COMP-1
                                           VALUE 377. 
       77  KEY-PREVIOUS-BLOCK-PTR          PICTURE 9(10) USAGE IS COMP-1
                                           VALUE 0. 
       77  SIZE-CODE                       PICTURE 9(10) USAGE IS COMP-1
                                           VALUE 0. 
  
       PROCEDURE DIVISION.
  
      ******************************************************************
      * 
      *    MAIN DRIVING ROUTINE 
      * 
      *    INITIALIZE SOME DATA ITEMS AND I-O.  THEN ENTER MAIN LOOP. 
      *    CALL ROUTINES TO PROCESS EACH DIVISION OF THE SUBSCHEMA
      *    AND EACH RECORD WITHIN THE RECORD DIVISION.  THE DIVISIONS 
      *    ARE PROCESSED IN THE FOLLOWING ORDER:  ONE TITLE DIVISION, 
      *    AN OPTIONAL ALIAS DIVISION, ONE REALM DIVISION, ONE RECORD 
      *    DIVISION, ANY NUMBER OF RECORD DESCRIPTIONS, AND AN OPTIONAL 
      *    RELATION DIVISION.  IF KEYWORD "TITLE" IS ENCOUNTERED, GO TO 
      *    THE TOP OF THE MAIN LOOP.  CONTINUE PROCESSING UNTIL END OF
      *    FILE ON SUBFIL.
      * 
      ******************************************************************
  
       BEGIN-PARA.
           OPEN INPUT SUB-FILE. 
           OPEN OUTPUT SYSPRINT.
           OPEN I-O IS-FILE.
           MOVE 1 TO SEQNO-LEN. 
           MOVE 0 TO SEQNO-COMP-1 (1), SEQNO-COMP-1 (2),
             SEQNO-COMP-1 (3), SEQNO-COMP-1 (4).
           MOVE SPACES TO END-SW, NOTE-CDCS-REC, SKIP-FLAG. 
           MOVE SPACE TO ACTUAL-PRT-CTL, READ-END-SW. 
           MOVE SPACE TO OUTSTANDING-PERIOD.
           MOVE SPACE TO PAREN-TERM.
           MOVE CONV-SUB-TITLE TO REPORT-TITLE-LONG.
           MOVE 99 TO LINE-CT.
           MOVE 1 TO PRT-CTL. 
           MOVE SPACES TO STD-REPORT-REC. 
           PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.
           PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.
           PERFORM READ-SUBFIL THRU READ-SUBFIL-EXIT. 
           IF READ-END-SW IS EQUAL TO "E" 
               MOVE "SUBFIL" TO EMPTY-FILE-NAME 
               MOVE MSG-385 TO STD-REPORT-REC 
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
               GO TO SUB-END
           END-IF.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO SUB-END. 
       MAIN-TITLE.
           IF WORK-AREA IS EQUAL TO "TITLE" 
               PERFORM RELEASE-CMM-BLOCKS THRU RELEASE-CMM-BLOCKS-EXIT
               PERFORM TITLE-SUB THRU TITLE-EXIT
               IF SKIP-FLAG IS EQUAL TO "S" 
                   MOVE "TITLE" TO SKIP-UNTIL-TOKEN (1) 
                   MOVE 1 TO SKIP-UNTIL-TOKEN-COUNT 
                   PERFORM SKIP THRU SKIP-EXIT
                   GO TO MAIN-TITLE 
               END-IF 
           ELSE 
               MOVE MSG-175 TO STD-REPORT-REC 
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
               MOVE "S" TO SKIP-FLAG
               MOVE 1 TO SKIP-UNTIL-TOKEN-COUNT 
               MOVE "TITLE" TO SKIP-UNTIL-TOKEN (1) 
               PERFORM SKIP THRU SKIP-EXIT
               GO TO MAIN-TITLE 
           END-IF.
       MAIN-ALIAS.
           IF EOF 
               GO TO SUB-END. 
           IF WORK-AREA IS EQUAL TO "TITLE" 
               GO TO MAIN-TITLE.
           IF WORK-AREA IS EQUAL TO "ALIAS" 
               PERFORM ALIAS-SUB THRU ALIAS-EXIT
               IF SKIP-FLAG IS EQUAL TO "S" 
                   MOVE 2 TO SKIP-UNTIL-TOKEN-COUNT 
                   MOVE "TITLE" TO SKIP-UNTIL-TOKEN (1) 
                   MOVE "REALM" TO SKIP-UNTIL-TOKEN (2) 
                   PERFORM SKIP THRU SKIP-EXIT
                   GO TO MAIN-ALIAS 
               END-IF 
           END-IF.
       MAIN-REALM.
           IF EOF 
               GO TO SUB-END. 
           IF WORK-AREA IS EQUAL TO "TITLE" 
               GO TO MAIN-TITLE.
           IF WORK-AREA IS EQUAL TO "REALM" 
               PERFORM REALM-SUB THRU REALM-EXIT
               IF SKIP-FLAG IS EQUAL TO "S" 
                   MOVE 1 TO SKIP-UNTIL-TOKEN-COUNT 
                   MOVE "TITLE" TO SKIP-UNTIL-TOKEN (1) 
                   PERFORM SKIP THRU SKIP-EXIT
                   GO TO MAIN-TITLE 
               END-IF 
           ELSE 
               MOVE MSG-220 TO STD-REPORT-REC 
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
               MOVE 2 TO SKIP-UNTIL-TOKEN-COUNT 
               MOVE "TITLE" TO SKIP-UNTIL-TOKEN (1) 
               MOVE "REALM" TO SKIP-UNTIL-TOKEN (2) 
               PERFORM SKIP THRU SKIP-EXIT
               IF WORK-AREA IS EQUAL TO "TITLE" 
                   GO TO MAIN-TITLE 
               ELSE 
                   GO TO MAIN-REALM 
               END-IF 
           END-IF.
       MAIN-RECORD. 
           IF EOF 
               GO TO SUB-END. 
           IF WORK-AREA IS EQUAL TO "TITLE" 
               GO TO MAIN-TITLE.
           IF WORK-AREA IS EQUAL TO "RECORD"
               PERFORM RECORD-SUB THRU RECORD-EXIT
               IF SKIP-FLAG IS EQUAL TO "S" 
                   MOVE 1 TO SKIP-UNTIL-TOKEN-COUNT 
                   MOVE "TITLE" TO SKIP-UNTIL-TOKEN (1) 
                   PERFORM SKIP THRU SKIP-EXIT
                   GO TO MAIN-TITLE 
               END-IF 
           ELSE 
               MOVE MSG-225 TO STD-REPORT-REC 
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
               MOVE 2 TO SKIP-UNTIL-TOKEN-COUNT 
               MOVE "TITLE" TO SKIP-UNTIL-TOKEN (1) 
               MOVE "RECORD" TO SKIP-UNTIL-TOKEN (2)
               PERFORM SKIP THRU SKIP-EXIT
               GO TO MAIN-RECORD
           END-IF.
       MAIN-01. 
           IF EOF 
               GO TO SUB-END. 
           IF WORK-AREA IS EQUAL TO "TITLE" 
               GO TO MAIN-TITLE.
           IF WORK-AREA IS EQUAL TO "01"
             OR WORK-AREA IS EQUAL TO "1" 
               PERFORM RECORD-DESC THRU RECORD-DESC-EXIT
               IF SKIP-FLAG IS EQUAL TO "S" 
                   MOVE 4 TO SKIP-UNTIL-TOKEN-COUNT 
                   MOVE "TITLE" TO SKIP-UNTIL-TOKEN (1) 
                   MOVE "1" TO SKIP-UNTIL-TOKEN (2) 
                   MOVE "01" TO SKIP-UNTIL-TOKEN (3)
                   MOVE "RELATION" TO SKIP-UNTIL-TOKEN (4)
                   PERFORM SKIP THRU SKIP-EXIT
                   END-IF 
               GO TO MAIN-01
           END-IF.
       MAIN-RELATION. 
           IF EOF 
               GO TO SUB-END. 
           IF WORK-AREA IS EQUAL TO "TITLE" 
               GO TO MAIN-TITLE.
           IF WORK-AREA IS EQUAL TO "RELATION"
               PERFORM RELATION-SUB THRU RELATION-EXIT
               GO TO MAIN-TITLE 
           END-IF.
           MOVE WORK-AREA TO UNKNOWN-KEYWORD. 
           MOVE MSG-45 TO STD-REPORT-REC. 
           PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT. 
           MOVE "S" TO SKIP-FLAG. 
           MOVE "TITLE" TO SKIP-UNTIL-TOKEN (1).
           MOVE 1 TO SKIP-UNTIL-TOKEN-COUNT.
           PERFORM SKIP THRU SKIP-EXIT. 
           GO TO MAIN-RELATION. 
       SUB-END. 
           PERFORM RELEASE-CMM-BLOCKS THRU RELEASE-CMM-BLOCKS-EXIT. 
           PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.
           MOVE END-REPORT-MSG TO STD-REPORT-REC. 
           PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.
           CLOSE SYSPRINT.
           CLOSE IS-FILE. 
           CLOSE SUB-FILE.
           EXIT PROGRAM.
  
      ******************************************************************
      * 
      *    AD-QUAL THRU AD-QUAL-EXIT
      * 
      *    SCANS NEW NAME QUALIFIER IN AD CLAUSE. STORES QUALIFIER
      *    IN AD-NEW-QUAL (AD-SUB, QUAL-SUB)
      * 
      *    ON INPUT 
      *    WORK-AREA = "IN" OR "OF" 
      *    QUAL-SUB, AD-SUB SET UP
      * 
      *    ON OUTPUT
      *    WORK-AREA = 1ST TOKEN AFTER "IN" OR "OF" 
      *    IF NEXT TOKEN IS NEITHER END-OF-FILE OR "."
      *        AD-NEW-QUAL (AD-SUB, QUAL-SUB) = NEXT TOKEN
      * 
      ******************************************************************
  
       AD-QUAL. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO SUB-END. 
           IF WORK-AREA IS EQUAL TO "." 
               GO TO AD-QUAL-EXIT.
           MOVE WORK-AREA TO AD-NEW-QUAL (AD-SUB, QUAL-SUB).
       AD-QUAL-EXIT.
           EXIT.
  
  
      ******************************************************************
      * 
      *    AD-SUBROUTINE THRU AD-EXIT 
      * 
      *    SCANS AD CLAUSE, PREPARES AD-ENTRY (AD-SUB)
      * 
      *    ON INPUT 
      *    WORK-AREA = "AD" 
      *    AD-SUB, BLOCK-FWA SET UP 
      * 
      *    ON OUTPUT
      *    AD-SUB UPDATED 
      *    IF NO ERROR
      *        WORK-AREA = 1ST TOKEN AFTER  AD CLAUSE 
      *        AD-ENTRY (AD-SUB) INITIALIZED
      *        CMM BLOCK ALLOCATED AND AD-TBL WRITTEN TO IT, IF 
      *          NECESSARY
      *        SKIP-FLAG = SPACE
      *    IF ERROR AND REST OF AD CLAUSE MUST BE SKIPPED 
      *        SKIP-FLAG = "S"
      * 
      ******************************************************************
  
       AD-SUBROUTINE. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO AD-EXIT. 
           ADD 1 TO AD-SUB. 
           IF AD-SUB IS GREATER THAN 20 
               MOVE BLOCK-FWA TO AD-PREVIOUS-BLOCK-PTR
               ENTER "CMMALF" USING BLOCK-SIZE, SIZE-CODE,
                 GROUP-ID, BLOCK-FWA
               ENTER "C.CMMMV" USING AD-TBL, BLOCK-FWA
               MOVE 1 TO AD-SUB 
               MOVE SPACES TO AD-TBL
               MOVE ZERO TO AD-PREVIOUS-BLOCK-PTR 
           END-IF.
           IF WORK-AREA IS EQUAL TO "REALM" 
               MOVE "22" TO AD-ENTITY-TYPE (AD-SUB) 
           ELSE 
               IF WORK-AREA IS EQUAL TO "RECORD"
                   MOVE "13" TO AD-ENTITY-TYPE (AD-SUB) 
               ELSE 
                   IF WORK-AREA IS EQUAL TO "DATA"
                       MOVE "05" TO AD-ENTITY-TYPE (AD-SUB) 
                   ELSE 
                       MOVE MSG-195 TO STD-REPORT-REC 
                       PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
                       MOVE "S" TO SKIP-FLAG
                       GO TO AD-EXIT
                   END-IF 
               END-IF 
           END-IF.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
               GO TO AD-20. 
           MOVE WORK-AREA TO AD-OLD-NAME (AD-SUB).
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
               GO TO AD-20. 
           IF WORK-AREA IS EQUAL TO "IN"
             OR WORK-AREA IS EQUAL TO "OF"
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
               IF EOF 
                 OR WORK-AREA IS EQUAL TO "." 
                   GO TO AD-20
               END-IF 
               MOVE WORK-AREA TO AD-OLD-QUAL (AD-SUB) 
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
               IF EOF 
                 OR WORK-AREA IS EQUAL TO "." 
                   GO TO AD-20
               END-IF 
           END-IF.
           IF WORK-AREA IS NOT EQUAL TO "BECOMES" 
               MOVE MSG-200 TO STD-REPORT-REC 
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
               MOVE "S" TO SKIP-FLAG
               GO TO AD-EXIT
           END-IF.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
               GO TO AD-20. 
           MOVE WORK-AREA TO AD-NEW-NAME (AD-SUB).
           MOVE 0 TO QUAL-SUB.
       AD-10. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO AD-EXIT. 
           IF WORK-AREA IS EQUAL TO "IN"
             OR WORK-AREA IS EQUAL TO "OF"
               ADD 1 TO QUAL-SUB
               IF QUAL-SUB IS GREATER THAN 5
                   MOVE MSG-205 TO STD-REPORT-REC 
                   PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
                   MOVE "S" TO SKIP-FLAG
                   GO TO AD-EXIT
               ELSE 
                   PERFORM AD-QUAL THRU AD-QUAL-EXIT
                   IF WORK-AREA IS NOT EQUAL TO "." 
                       GO TO AD-10
                   END-IF 
               END-IF 
           END-IF.
       AD-20. 
           IF EOF 
               GO TO AD-EXIT. 
           IF WORK-AREA IS EQUAL TO "." 
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
           ELSE 
               MOVE MSG-10 TO STD-REPORT-REC
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
           END-IF.
       AD-EXIT. 
           EXIT.
  
      ******************************************************************
      * 
      *    ALIAS-SUB THRU ALIAS-EXIT
      * 
      *    SCANS ALIAS DIVISION, CALLS AD-SUBROUTINE TO CREATE ENTRY IN 
      *    AD-TBL FOR EACH AD CLAUSE. 
      * 
      *    ON INPUT 
      *    WORK-AREA = "ALIAS"
      * 
      *    ON OUTPUT
      *    IF NO ERROR
      *        WORK-AREA = 1ST TOKEN AFTER LAST AD CLAUSE 
      *        SKIP-FLAG = SPACE
      *    IF ERROR AND REST OF ALIAS DIVISION AND AD CLAUSES MUST BE 
      *      SKIPPED
      *        SKIP-FLAG = "S"
      * 
      ******************************************************************
  
       ALIAS-SUB. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO SUB-END. 
           IF WORK-AREA IS NOT EQUAL TO "DIVISION"
               MOVE MSG-180 TO STD-REPORT-REC 
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
               MOVE "S" TO SKIP-FLAG
               GO TO ALIAS-EXIT 
           END-IF.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO SUB-END. 
           IF WORK-AREA IS NOT EQUAL TO "." 
               MOVE MSG-10 TO STD-REPORT-REC
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
           ELSE 
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
               IF EOF 
                   GO TO SUB-END
               END-IF 
           END-IF.
       ALIAS-10.
           IF WORK-AREA IS EQUAL TO "AD"
               PERFORM AD-SUBROUTINE THRU AD-EXIT 
               IF SKIP-FLAG IS EQUAL TO "S" 
                   MOVE SPACES TO AD-ENTRY (AD-SUB) 
                   SUBTRACT 1 FROM AD-SUB 
                   PERFORM SKIP-PAST-PERIOD THRU SKIP-PAST-PERIOD-EXIT
                   GO TO ALIAS-10 
               END-IF 
               IF EOF 
                   GO TO SUB-END
               ELSE 
                   GO TO ALIAS-10 
               END-IF 
           END-IF.
           IF BLOCK-FWA IS NOT EQUAL TO ZERO
               MOVE BLOCK-FWA TO AD-PREVIOUS-BLOCK-PTR
               ENTER "CMMALF" USING BLOCK-SIZE, SIZE-CODE,
                 GROUP-ID, BLOCK-FWA
               ENTER "C.CMMMV" USING AD-TBL, BLOCK-FWA
           END-IF.
       ALIAS-EXIT.
           EXIT.
  
      ******************************************************************
      * 
      *    CHECK-FOR-INTEGER THRU CHECK-FOR-INTEGER-EXIT
      * 
      *    CHECKS WHETHER TOKEN IN WORK-AREA IS AN INTEGER OF 4 DIGITS
      *    OR LESS.  IF SO, IT RETURNS.  IF NOT, IT DISPLAYS MSG-285
      *    AND SETS SKIP-FLAG = S.
      * 
      *    ON INPUT 
      *    WORK-AREA = TOKEN
      * 
      *    ON OUTPUT
      *    IF TOKEN IS INTEGER OF 4 DIGITS OR LESS
      *        SKIP-FLAG = SPACE
      *    IF TOKEN IS NOT INTEGER OF 4 DIGITS OR LESS
      *        SKIP-FLAG = "S"
      * 
      ******************************************************************
  
       CHECK-FOR-INTEGER. 
           IF WK-SUB IS GREATER THAN 4
               GO TO CHECK-FOR-INTEGER-10.
           IF WK-SUB IS GREATER THAN 0
             AND (WORKA (1) IS LESS THAN "0"
             OR WORKA (1) IS GREATER THAN "9")
               GO TO CHECK-FOR-INTEGER-10.
           IF WK-SUB IS GREATER THAN 1
             AND (WORKA (2) IS LESS THAN "0"
             OR WORKA (2) IS GREATER THAN "9")
               GO TO CHECK-FOR-INTEGER-10.
           IF WK-SUB IS GREATER THAN 2
             AND (WORKA (3) IS LESS THAN "0"
             OR WORKA (3) IS GREATER THAN "9")
               GO TO CHECK-FOR-INTEGER-10.
           IF WK-SUB IS GREATER THAN 3
             AND (WORKA (4) IS LESS THAN "0"
             OR WORKA (4) IS GREATER THAN "9")
               GO TO CHECK-FOR-INTEGER-10.
           GO TO CHECK-FOR-INTEGER-EXIT.
       CHECK-FOR-INTEGER-10.
           MOVE MSG-285 TO STD-REPORT-REC.
           PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT. 
           MOVE "S" TO SKIP-FLAG. 
       CHECK-FOR-INTEGER-EXIT.
           EXIT.
  
      ******************************************************************
      * 
      *    COMMENTER THRU COMMENTER-EXIT
      * 
      *    SPACE OVER SCHEMA-STYLE COMMENTS.  CALL WRITE-NOTE TO WRITE
      *    SCHEMA-STYLE COMMENTS TO WRKFILE.
      * 
      *    ON INPUT 
      *    SUB-LINE (IN-SUB) = 1ST CHARACTER AFTER "/*" 
      * 
      *    ON OUTPUT
      *    SUB-LINE (IN-SUB) = 1ST CHARACTER AFTER "*/" 
      *    COMMENT HAS BEEN PROCESSED 
      * 
      ******************************************************************
       COMMENTER. 
           MOVE 1 TO CMT-SUB. 
           MOVE SPACES TO COMMENT-AREA. 
       COMMENT-10.
           IF SUB-IN (IN-SUB : 2) EQUAL TO "*/" 
               GO TO COMMENT-30.
       COMMENT-20.
           MOVE SUB-LINE (IN-SUB) TO COMMENT-A (CMT-SUB). 
           ADD 1 TO CMT-SUB.
           IF CMT-SUB IS GREATER THAN 66
               MOVE COMMENT-AREA TO HOLD-COMMENT
               PERFORM WRITE-NOTE THRU WRITE-NOTE-EXIT
               MOVE 1 TO CMT-SUB
               MOVE SPACES TO COMMENT-AREA
           END-IF.
           ADD 1 TO IN-SUB. 
           IF IN-SUB IS GREATER THAN 72 
               PERFORM READ-SUBFIL THRU READ-SUBFIL-EXIT
               IF END-SW IS EQUAL TO "E"
                   IF CMT-SUB IS NOT EQUAL TO 1 
                       MOVE COMMENT-AREA TO HOLD-COMMENT
                       PERFORM WRITE-NOTE THRU WRITE-NOTE-EXIT
                   END-IF 
                   GO TO COMMENTER-EXIT 
               END-IF 
           END-IF.
           GO TO COMMENT-10.
       COMMENT-30.
           IF CMT-SUB IS NOT EQUAL TO 1 
               MOVE COMMENT-AREA TO HOLD-COMMENT
               PERFORM WRITE-NOTE THRU WRITE-NOTE-EXIT
           END-IF.
           ADD 2 TO IN-SUB. 
           IF IN-SUB IS GREATER THAN 72 
               PERFORM READ-SUBFIL THRU READ-SUBFIL-EXIT
           END-IF.
       COMMENTER-EXIT.
           EXIT.
  
      ******************************************************************
      * 
      *    COMPARE-AD-QUAL THRU COMPARE-AD-QUAL-EXIT
      * 
      *    COMPARES CURRENT SCHEMA RECORD NAME WITH NAME IN 
      *    AD-OLD-QUAL (AD-SUB).  COMPARES SUCCESSIVE PARENTS 
      *    IN LEVEL-TABLE WITH ARRAY OF AD-NEW-QUAL.  IF QUALIFICATION
      *    MATCHES, RETURN QUAL-MATCHES = "M", ELSE QUAL-MATCHES = SPACE
      * 
      *    ON INPUT 
      *    AD-SUB = INDEX WITHIN AD-TBL WHERE AD-OLD-NAME = 
      *      LEVT-CDCS-NAME (LV-SUB)
      *    LEVEL-TABLE, LV-SUB SET UP 
      * 
      *    ON OUTPUT
      *    IF QUALIFICATION MATCHES 
      *        QUAL-MATCHES = "M" 
      *    IF QUALIFICATION DOES NOT MATCH
      *        QUAL-MATCHES = SPACE 
      * 
      ******************************************************************
  
       COMPARE-AD-QUAL. 
           MOVE SPACE TO QUAL-MATCHES.
           IF AD-OLD-QUAL (AD-SUB) IS NOT EQUAL TO SPACES 
             AND AD-OLD-QUAL (AD-SUB) IS NOT EQUAL TO 
             SCHEMA-RECORD-CDCS-NAME
               GO TO COMPARE-AD-QUAL-EXIT.
           MOVE SPACE TO DONE.
           MOVE LV-SUB TO L-SUB.
           PERFORM VARYING CMP-SUB FROM 1 BY 1 UNTIL DONE 
             IS EQUAL TO "D"
               IF CMP-SUB IS GREATER THAN 5 
                 OR AD-NEW-QUAL (AD-SUB, CMP-SUB) IS EQUAL TO SPACE 
                   MOVE "M" TO QUAL-MATCHES 
                   GO TO COMPARE-AD-QUAL-EXIT 
               END-IF 
               MOVE SPACE TO DONE1
               PERFORM UNTIL DONE1 IS EQUAL TO "D"
                   SUBTRACT 1 FROM L-SUB
                   IF L-SUB IS LESS THAN 1
                       GO TO COMPARE-AD-QUAL-EXIT 
                   END-IF 
                   IF AD-NEW-QUAL (AD-SUB, CMP-SUB) IS EQUAL TO 
                     LEVT-CDCS-NAME (L-SUB) 
                       MOVE "D" TO DONE1
                   END-IF 
               END-PERFORM
           END-PERFORM. 
       COMPARE-AD-QUAL-EXIT.
           EXIT.
  
      ******************************************************************
      * 
      *    COMPARE-QUAL THRU COMPARE-QUAL-EXIT
      * 
      *    COMPARES SUCCESSIVE PARENTS IN IS-FILE WITH QUALIFIERS 
      *    IN QUAL-TABLE.  IF QUALIFICATION MATCHES, RETURN 
      *    QUAL-MATCHES = "M", ELSE QUAL-MATCHES = SPACE
      * 
      *    ON INPUT 
      *    IS-REC = RECORD OF DATA NAME WHICH IS QUALIFIED
      *    QUAL-TABLE SET UP
      * 
      *    ON OUTPUT
      *    IF QUALIFICATION MATCHES 
      *        QUAL-MATCHES = "M" 
      *    IF QUALIFICATION DOES NOT MATCH
      *        QUAL-MATCHES = SPACE 
      * 
      ******************************************************************
  
       COMPARE-QUAL.
           MOVE SPACE TO QUAL-MATCHES, DONE, QUAL-CATNAME-ARRAY.
           PERFORM VARYING CMP-SUB FROM 1 BY 1 UNTIL DONE 
             IS EQUAL TO "D"
               IF CMP-SUB IS GREATER THAN 5 
                 OR QUAL-NAME (CMP-SUB) IS EQUAL TO SPACE 
                   MOVE "M" TO QUAL-MATCHES 
                   GO TO COMPARE-QUAL-EXIT
               END-IF 
               MOVE SPACE TO DONE1
               MOVE ZERO TO IS-SEQ-NO, IS-ALIAS-NO
               PERFORM UNTIL DONE1 IS EQUAL TO "D"
                   IF IS-ENTITY-TYPE IS EQUAL TO "13" 
                       GO TO COMPARE-QUAL-EXIT
                   END-IF 
                   IF IS-ELE-PARENT-CATNAME IS EQUAL
                     TO "***ERROR***" 
                       GO TO COMPARE-QUAL-EXIT
                   END-IF 
                   MOVE IS-ELE-PARENT-CATNAME TO IS-CATNAME 
                   START IS-FILE KEY IS EQUAL TO IS-PKEY
                   READ IS-FILE 
                   IF QUAL-NAME (CMP-SUB) IS EQUAL TO IS-CDCS-NAME
                       MOVE "D" TO DONE1
                       MOVE IS-CATNAME TO QUAL-CATNAME (CMP-SUB)
                   END-IF 
               END-PERFORM
           END-PERFORM. 
       COMPARE-QUAL-EXIT. 
           EXIT.
  
      ******************************************************************
      * 
      *    DATA-DESC THRU DATA-DESC-EXIT
      * 
      *    SCAN DATA DESCRIPTION ENTRY. 
      * 
      *    CALL APPROPRIATE ROUTINE TO PROCESS JUSTIFIED, OCCURS, 
      *    PICTURE, REDEFINES, SYNCHRONIZED, AND USAGE CLAUSES. 
      *    BECAUSE DATA-DESC CANNOT DETERMINE WHETHER AN ITEM IS AN 
      *    ELEMENT OR A GROUP, IT CANNOT WRITE ENTITY TO IS-FILE
      *    OR WORK-FILE.  INSTEAD IT STORES ALL INFO IN MEMORY. 
      *    RECORD-DESC WILL CALL WRITE-PREVIOUS-DATA TO WRITE ENTITY
      *    AFTER IT HAS READ LEVEL NUMBER OF NEXT ITEM AND HAS
      *    DETERMINED WHETHER THIS ITEM IS AN ELEMENT OR GROUP. 
      * 
      *    MAINTAIN ALL PARENTS OF CURRENT DATA ITEM IN LEVEL-TABLE.
      *    LEV-TAB (1) DESCRIBES RECORD.  LEV-TAB (LV-SUB) DESCRIBES
      *    CURRENT ITEM.  LEV-TAB (LV-SUB-M1) DESCRIBES IMMEDIATE 
      *    PARENT.  LEVT-LEVEL-NO (N) < LEVT-LEVEL-NO (N+1).  THIS
      *    TABLE IS USED TO WRITE STRUCTURE RECORDS.
      * 
      *    ON INPUT 
      *    LEVEL-TABLE SET UP 
      *    LEVEL-NO = LEVEL NUMBER
      *    LV-SUB = INDEX WITHIN LEVEL-TABLE OF PREVIOUS DATA ITEM
      *    WORK-AREA = LEVEL NUMBER (2 - 49)
      * 
      *    ON OUTPUT
      *    IF NO ERROR ENCOUNTERED
      *        WORK-AREA = "."
      *        NOTE-CDCS-REC DESCRIBES STRUCTURE CATEGORY OF ELEMENT'S
      *          PARENT 
      *        LEVEL-TABLE, LV-SUB UPDATED
      *        SKIP-FLAG = SPACE
      *    IF ERROR AND REST OF DATA DESCRIPTION ENTRY MUST BE SKIPPED
      *        SKIP-FLAG = "S". 
      * 
      ******************************************************************
  
       DATA-DESC. 
           IF LEVEL-NO IS NOT GREATER THAN REDEFINES-LEVEL
               MOVE SPACE TO REDEFINES-ITEM.
           IF LEVEL-NO IS EQUAL TO LEVT-LEVEL-NO (LV-SUB) 
               GO TO DATA-DESC-10.
           IF LEVEL-NO IS GREATER THAN LEVT-LEVEL-NO (LV-SUB) 
               IF LV-SUB IS GREATER THAN 10 
                   MOVE MSG-105 TO STD-REPORT-REC 
                   PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
                   MOVE "S" TO SKIP-FLAG
                   GO TO DATA-DESC-EXIT 
               END-IF 
               MOVE LV-SUB TO LV-SUB-M1 
               ADD 1 TO LV-SUB
           ELSE 
               PERFORM VARYING LV-SUB FROM LV-SUB BY -1 
                 UNTIL LEVEL-NO IS NOT LESS THAN
                 LEVT-LEVEL-NO (LV-SUB) 
                   IF LV-SUB IS NOT EQUAL TO 1
                       MOVE SPACES TO LEV-TAB (LV-SUB)
                   END-IF 
               END-PERFORM
               IF LV-SUB IS EQUAL TO 1
                   MOVE 2 TO LV-SUB 
                   MOVE 1 TO LV-SUB-M1
               ELSE 
                   SUBTRACT 1 FROM LV-SUB GIVING LV-SUB-M1
               END-IF 
           END-IF.
       DATA-DESC-10.
           MOVE SPACES TO LEV-TAB (LV-SUB). 
           IF LV-SUB IS EQUAL TO 2
               MOVE "13" TO NOTE-ENTRY-TYPE 
               MOVE 0 TO NOTE-99-GROUP
           ELSE 
               MOVE "10" TO NOTE-ENTRY-TYPE 
               SUBTRACT LEVT-LEVEL-NO (LV-SUB-M1) FROM
                 99 GIVING NOTE-99-GROUP
           END-IF.
           MOVE "T" TO DATA-ITEM-WAITING. 
           MOVE LEVT-EALIASOF-FLAG (LV-SUB-M1) TO 
             NOTE-EALIASOF-FLAG.
           MOVE LEVT-CATNAME (LV-SUB-M1) TO NOTE-CATNAME. 
           MOVE "300" TO NOTE-CATEGORY-TYPE.
           MOVE LEVT-CDCS-NAME (LV-SUB-M1) TO NOTE-CDCS-NAME. 
           MOVE SPACES TO LEVT-CATNAME (LV-SUB).
           MOVE LEVEL-NO TO LEVT-LEVEL-NO (LV-SUB). 
           MOVE SPACES TO HOLD-ATTRIBUTE, HOLD-STRUCTURE, OCCURS-TO.
           ADD 1 TO STRUCT-COUNT. 
           MOVE STRUCT-COUNT TO SAVE-STRUCT.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
               GO TO DATA-DESC-EXIT.
           MOVE WORK-AREA TO LEVT-CDCS-NAME (LV-SUB). 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
       DATA-DESC-20.
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
               GO TO DATA-DESC-EXIT.
           IF WORK-AREA IS EQUAL TO "JUSTIFIED" 
             OR WORK-AREA IS EQUAL TO "JUST"
               PERFORM JUST-SUB THRU JUST-EXIT
               GO TO DATA-DESC-30 
           END-IF.
           IF WORK-AREA IS EQUAL TO "OCCURS"
               PERFORM OCCURS-SUB THRU OCCURS-EXIT
               GO TO DATA-DESC-30 
           END-IF.
           IF WORK-AREA IS EQUAL TO "PIC" 
             OR WORK-AREA IS EQUAL TO "PICTURE" 
               PERFORM PIC-SUBROUTINE THRU PIC-EXIT 
               GO TO DATA-DESC-20 
           END-IF.
           IF WORK-AREA IS EQUAL TO "REDEFINES" 
               PERFORM REDEFINES-SUB THRU REDEFINES-EXIT
               GO TO DATA-DESC-30 
           END-IF.
           IF WORK-AREA IS EQUAL TO "SYNCHRONIZED"
             OR WORK-AREA IS EQUAL TO "SYNC"
               PERFORM SYNC-SUB THRU SYNC-EXIT
               GO TO DATA-DESC-30 
           END-IF.
           IF WORK-AREA IS EQUAL TO "USAGE" 
               PERFORM USAGE-SUB THRU USAGE-EXIT
               GO TO DATA-DESC-30 
           END-IF.
           MOVE WORK-AREA TO UNKNOWN-KEYWORD. 
           MOVE MSG-45 TO STD-REPORT-REC. 
           PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT. 
           MOVE "S" TO SKIP-FLAG. 
       DATA-DESC-30.
           IF SKIP-FLAG IS EQUAL TO SPACE 
               GO TO DATA-DESC-20 
           END-IF.
           MOVE "***ERROR***" TO LEVT-CATNAME (LV-SUB). 
           MOVE SPACE TO DATA-ITEM-WAITING. 
       DATA-DESC-EXIT.
           EXIT.
  
*CALL DISPLAYLN 
*CALL WRITELN 
  
      ******************************************************************
      * 
      *    FIND-AD-ENTRY THRU FIND-AD-ENTRY-EXIT
      * 
      *    SCAN ALL BLOCKS OF AD-TBL UNTIL A MATCH IS FOUND ON
      *    ENTITY-TYPE AND NAME GIVEN IN NAME-TO-MATCH. 
      * 
      *    ON INPUT 
      *    NAME-TO-MATCH = NAME TO BE FOUND IN AD-TBL 
      *    IF NAME SHOULD BE MATCHED AGAINST AD-OLD-NAME (SCHEMA) 
      *        NEW-OLD-NAME-FLAG = "O"
      *    IF NAME SHOULD BE MATCHED AGAINST AD-NEW-NAME (SUBSCHEMA)
      *        NEW-OLD-NAME-FLAG = "N"
      *    ENTITY-TYPE, BLOCK-FWA, AD-TBL SET UP
      * 
      *    ON OUTPUT
      *    IF NAME FOUND IN AD-TBL
      *        AD-TBL CONTAINS BLOCK WHICH CONTAINS ENTRY 
      *        AD-SUB = INDEX WITHIN AD-TBL OF ENTRY
      *    IF NAME NOT FOUND IN ANY BLOCK OF AD-TBL 
      *        AD-SUB = 0 
      * 
      ******************************************************************
  
       FIND-AD-ENTRY. 
           IF NEW-OLD-NAME-FLAG IS EQUAL TO "O" 
               MOVE 1 TO NEW-OLD-SUB
           ELSE 
               MOVE 2 TO NEW-OLD-SUB
           END-IF.
           MOVE 1 TO AD-SUB.
           IF BLOCK-FWA IS NOT EQUAL TO ZERO
               ENTER "C.CMMMV" USING BLOCK-FWA, AD-TBL. 
       FIND-AD-ENTRY-10.
           IF ENTITY-TYPE IS EQUAL TO AD-ENTITY-TYPE (AD-SUB) 
             AND NAME-TO-MATCH IS EQUAL TO AD-NAME (AD-SUB, NEW-OLD-SUB)
               IF ENTITY-TYPE IS EQUAL TO "05"
                   PERFORM COMPARE-AD-QUAL THRU COMPARE-AD-QUAL-EXIT
                   IF QUAL-MATCHES IS NOT EQUAL TO SPACE
                       GO TO FIND-AD-ENTRY-EXIT 
                   END-IF 
               ELSE 
                   GO TO FIND-AD-ENTRY-EXIT 
               END-IF 
           END-IF.
           ADD 1 TO AD-SUB. 
           IF AD-SUB IS LESS THAN 21
             AND AD-ENTITY-TYPE (AD-SUB) IS NOT EQUAL TO SPACE
               GO TO FIND-AD-ENTRY-10.
           IF AD-PREVIOUS-BLOCK-PTR IS NOT EQUAL TO ZERO
               ENTER "C.CMMMV" USING AD-PREVIOUS-BLOCK-PTR, AD-TBL
               MOVE 1 TO AD-SUB 
               GO TO FIND-AD-ENTRY-10 
           END-IF.
           MOVE 0 TO AD-SUB.
       FIND-AD-ENTRY-EXIT.
           EXIT.
  
  
      ******************************************************************
      * 
      *    FIND-AREA-EALIAS THRU FIND-AREA-EALIAS-EXIT
      * 
      *    CALL FIND-AD-ENTRY TO DETERMINE SCHEMA AREA NAME GIVEN 
      *    SUBSCHEMA REALM NAME IN WORK-AREA.  READ IS-FILE 
      *    TO DETERMINE CATNAME FOR SCHEMA AREA NAME. 
      * 
      *    ON INPUT 
      *    WORK-AREA = SUBSCHEMA REALM NAME 
      * 
      *    ON OUTPUT
      *    IF SCHEMA AREA CATNAME FOUND 
      *        OUT-EALIASOF-FLAG = "E"
      *        OUT-EALIASOF-NAME = SCHEMA AREA CATNAME
      *    IF SCHEMA AREA CATNAME NOT FOUND 
      *        OUT-EALIASOF-FLAG = SPACE
      * 
      ******************************************************************
  
       FIND-AREA-EALIAS.
           MOVE SPACE TO OUT-EALIASOF-FLAG. 
           MOVE "22" TO ENTITY-TYPE.
           MOVE "N" TO NEW-OLD-NAME-FLAG. 
           MOVE WORK-AREA TO NAME-TO-MATCH. 
           PERFORM FIND-AD-ENTRY THRU FIND-AD-ENTRY-EXIT. 
           IF AD-SUB IS EQUAL TO ZERO 
               MOVE WORK-AREA TO IS-CDCS-NAME 
           ELSE 
               MOVE AD-OLD-NAME (AD-SUB) TO IS-CDCS-NAME
           END-IF.
           MOVE "22" TO IS-ENTITY-TYPE. 
           MOVE SCHEMA-ORD TO IS-SCHEMA-ORDINAL.
           MOVE IS-ALTKEY TO HOLD-IS-ALTKEY.
           START IS-FILE KEY IS EQUAL TO IS-ALTKEY
               INVALID KEY GO TO FIND-AREA-EALIAS-EXIT. 
       FIND-AREA-EALIAS-10. 
           READ IS-FILE.
           IF IS-ALTKEY IS NOT EQUAL TO HOLD-IS-ALTKEY
               GO TO FIND-AREA-EALIAS-EXIT. 
           IF IS-AREA-SSCH-ORDINAL IS NOT EQUAL TO ZERO 
               GO TO FIND-AREA-EALIAS-10. 
           MOVE "E" TO OUT-EALIASOF-FLAG. 
           MOVE IS-CATNAME TO OUT-EALIASOF-NAME.
       FIND-AREA-EALIAS-EXIT. 
           EXIT.
  
      ******************************************************************
      * 
      *    FIND-IDEN-CATNAME THRU FIND-IDEN-CATNAME-EXIT
      * 
      *    READ IS-FILE TO FIND CATNAME AND ALIAS-NO OF DATANAME IN 
      *    FIND-DATA-NAME AND CATNAMES OF ALL QUALIFIERS IN QUAL-TABLE. 
      * 
      *    ON INPUT 
      *    FIND-DATA-NAME, FIND-RECORD-CATNAME, QUAL-NAME-ARRAY SET UP
      *    IS-ENTITY-TYPE = "05" TO SEARCH FOR ELEMENT OR "10" TO SEARCH
      *        FOR GROUP
      * 
      *    ON OUTPUT
      *    IF DATA NAME CATNAME FOUND 
      *        FIND-CATNAME = CATNAME 
      *        FIND-ALIAS-NO = ALIAS NUMBER 
      *        QUAL-TABLE UPDATED 
      *    IF DATA NAME CATNAME NOT FOUND 
      *        FIND-CATNAME = SPACE 
      * 
      ******************************************************************
  
       FIND-IDEN-CATNAME. 
           MOVE ZERO TO READ-COUNT. 
           MOVE SCHEMA-ORD TO IS-SCHEMA-ORDINAL.
           MOVE FIND-DATA-NAME TO IS-CDCS-NAME. 
           MOVE IS-ALTKEY TO HOLD-IS-ALTKEY.
           MOVE SPACE TO FIND-CATNAME.
           START IS-FILE KEY IS EQUAL TO IS-ALTKEY
               INVALID KEY GO TO FIND-IDEN-CATNAME-EXIT.
       FIND-IDEN-CATNAME-10.
           ADD 1 TO READ-COUNT. 
           READ IS-FILE.
           IF IS-ALTKEY IS NOT EQUAL TO HOLD-IS-ALTKEY
               GO TO FIND-IDEN-CATNAME-EXIT.
           IF IS-ELE-SSCH-ORDINAL IS NOT EQUAL TO SUBSCHEMA-ORD 
             OR IS-ELE-RECORD-CATNAME IS NOT EQUAL TO 
             FIND-RECORD-CATNAME
               GO TO FIND-IDEN-CATNAME-10.
       FIND-IDEN-CATNAME-20.
           MOVE IS-CATNAME TO FIND-CATNAME. 
           MOVE IS-ALIAS-NO TO FIND-ALIAS-NO. 
           MOVE IS-ENTITY-TYPE TO FIND-ENTITY-TYPE. 
           IF QUAL-NAME (1) IS EQUAL TO SPACE 
               GO TO FIND-IDEN-CATNAME-EXIT.
           PERFORM COMPARE-QUAL THRU COMPARE-QUAL-EXIT. 
           IF QUAL-MATCHES IS NOT EQUAL TO SPACE
               GO TO FIND-IDEN-CATNAME-EXIT.
           MOVE 0 TO READ-SUB.
           MOVE SPACE TO FIND-CATNAME.
           MOVE HOLD-IS-ALTKEY TO IS-ALTKEY.
           START IS-FILE KEY IS EQUAL TO IS-ALTKEY
               INVALID KEY GO TO FIND-IDEN-CATNAME-EXIT.
       FIND-IDEN-CATNAME-30.
           READ IS-FILE.
           ADD 1 TO READ-SUB. 
           IF READ-SUB IS LESS THAN READ-COUNT
               GO TO FIND-IDEN-CATNAME-30.
       FIND-IDEN-CATNAME-40.
           READ IS-FILE.
           ADD 1 TO READ-COUNT. 
           IF IS-ALTKEY IS NOT EQUAL TO HOLD-IS-ALTKEY
               GO TO FIND-IDEN-CATNAME-EXIT.
           IF IS-ELE-SSCH-ORDINAL IS NOT EQUAL TO SUBSCHEMA-ORD 
             OR IS-ELE-RECORD-CATNAME IS NOT EQUAL TO 
             FIND-RECORD-CATNAME
               GO TO FIND-IDEN-CATNAME-40.
           GO TO FIND-IDEN-CATNAME-20.
       FIND-IDEN-CATNAME-EXIT.
           EXIT.
  
      ******************************************************************
      * 
      *    GEN-NAME THRU GEN-NAME-EXIT
      * 
      *    APPEND A SEQUENCE NUMBER TO A CDCS NAME IN ORDER TO GENERATE 
      *    A UNIQUE CATNAME 
      * 
      *    ON INPUT 
      *    CDCS-NAME = CDCS NAME
      *    SEQNO = CURRENT SEQUENCE NUMBER
      *    SEQNO-LEN = NUMBER OF CHARACTERS IN SEQUENCE NUMBER
      * 
      *    ON OUTPUT
      *    CDCS-NAME = CDCS NAME WITH SEQUENCE NUMBER APPENDED.  THIS 
      *                NAME MAY OR MAY NOT BE A UNIQUE CATNAME. 
      *    SEQNO, SEQNO-LEN UPDATED TO REFLECT NEW SEQUENCE NUMBER
      * 
      *    LOGIC
      *    GENERATE NEW SEQUENCE NUMBER IN SEQNO.  THE SEQUENCE IS A, B,
      *    ..., Z, 0, 1, ..., 9, AA, BA, ..., 9A, AB, BB, ..., 9B, ..., 
      *    99, AAA, BAA, ..., 999.  IF THE LENGTH OF NAME PLUS LENGTH 
      *    OF SEQUENCE NUMBER IS 32 OR LESS, THE SEQUENCE NUMBER IS 
      *    APPENDED TO THE NAME, FOR EXAMPLE, JOB WILL BE CHANGED TO
      *    JOBA.  OTHERWISE THE NAME WILL BE TRUNCATED ON THE RIGHT TO
      *    ALLOW THE FULL SEQUENCE NUMBER TO BE APPENDED. 
      * 
      ******************************************************************
  
       GEN-NAME.
           PERFORM VARYING CHAR-SUB FROM 1 BY 1 
             UNTIL CDCS-NAME-CHAR (CHAR-SUB) IS EQUAL TO SPACE
               MOVE "F" TO END-LOOP 
           END-PERFORM. 
           MOVE CHAR-SUB TO CDCS-NAME-LEN-PLUS1.
           MOVE "F" TO END-LOOP.
           PERFORM VARYING CHAR-SUB FROM 1 BY 1 
             UNTIL END-LOOP IS EQUAL TO "T" 
               IF SEQNO-CHAR (CHAR-SUB) IS EQUAL TO "9" 
                   MOVE "A" TO SEQNO-CHAR (CHAR-SUB)
               ELSE 
                   MOVE SEQNO-CHAR (CHAR-SUB) TO SEQ-DIGIT (10) 
                   ADD 1 TO SEQ-DIGIT-COMP-1
                   MOVE "T" TO END-LOOP 
                   MOVE SEQ-DIGIT (10) TO SEQNO-CHAR (CHAR-SUB) 
                   IF CHAR-SUB IS GREATER THAN SEQNO-LEN
                       MOVE CHAR-SUB TO SEQNO-LEN 
                   END-IF 
               END-IF 
           END-PERFORM. 
           IF SEQNO-LEN + CDCS-NAME-LEN-PLUS1 IS NOT GREATER THAN 32
               MOVE SEQNO (1 : SEQNO-LEN) TO
                 CDCS-NAME (CDCS-NAME-LEN-PLUS1 : SEQNO-LEN)
           ELSE 
               MOVE SEQNO (1 : SEQNO-LEN) TO
                 CDCS-NAME (32 - SEQNO-LEN : SEQNO-LEN) 
           END-IF.
       GEN-NAME-EXIT. 
           EXIT.
  
      ******************************************************************
      * 
      *    GET-LEVEL THRU GET-LEVEL-EXIT
      * 
      *    SCAN CURRENT TOKEN FOR LEVEL NUMBER
      * 
      *    ON INPUT 
      *    WORK-AREA = CURRENT TOKEN WHICH MAY OR MAY NOT BE LEVEL
      *      NUMBER 
      *    WK-SUB = NUMBER OF CHARACTERS IN CURRENT TOKEN 
      * 
      *    ON OUTPUT
      *    IF WORK-AREA IS VALID LEVEL NUMBER (2-49, 66, OR 88) 
      *        LEVEL-NO = LEVEL NUMBER
      *    IF WORK-AREA IS NOT A VALID LEVEL NUMBER 
      *        LEVEL-NO = 0 
      * 
      ******************************************************************
  
       GET-LEVEL. 
           IF WK-SUB IS EQUAL TO 1
               IF WORKA (1) IS LESS THAN "0"
                 OR WORKA (1) IS GREATER THAN "9" 
                   GO TO GET-LEVEL-10 
               END-IF 
               MOVE "0" TO LEVEL-NO 
               MOVE WORKA (1) TO LEVEL-NO (2 : 1) 
               GO TO GET-LEVEL-EXIT 
           END-IF.
           IF WK-SUB IS EQUAL TO 2
               IF WORKA (1) IS LESS THAN "0"
                 OR WORKA (1) IS GREATER THAN "9" 
                 OR WORKA (2) IS LESS THAN "0"
                 OR WORKA (2) IS GREATER THAN "9" 
                   GO TO GET-LEVEL-10 
               END-IF 
               MOVE WORK-AREA TO LEVEL-NO 
               IF LEVEL-NO IS EQUAL TO 66 
                 OR LEVEL-NO IS EQUAL TO 88 
                   GO TO GET-LEVEL-EXIT 
               END-IF 
               IF LEVEL-NO IS GREATER THAN 1
                 AND LEVEL-NO IS LESS THAN 50 
                   GO TO GET-LEVEL-EXIT 
               END-IF 
           END-IF.
       GET-LEVEL-10.
           MOVE 0 TO LEVEL-NO.
       GET-LEVEL-EXIT.
           EXIT.
  
      ******************************************************************
      * 
      *    GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
      * 
      *    GET THE NEXT TOKEN.
      * 
      *    ON INPUT 
      *    SUB-LINE (IN-SUB) = 1ST CHARACTER AFTER LAST TOKEN 
      * 
      *    ON OUTPUT
      *    IF END-OF-FILE ENCOUNTERED 
      *        END-SW = "E" 
      *    IF END-OF-FILE NOT ENCOUNTERED 
      *        WORK-AREA = TOKEN
      * 
      ******************************************************************
  
       GET-NEXT-TOKEN.
           IF OUTSTANDING-PERIOD IS EQUAL TO SPACE
               PERFORM SPACER THRU SPACER-EXIT. 
           PERFORM SCAN THRU SCAN-EXIT. 
       GET-NEXT-TOKEN-EXIT. 
           EXIT.
  
      ******************************************************************
      * 
      *    IDEN-SUB THRU IDEN-EXIT
      * 
      *    SCAN IDENTIFIER CLAUSE.  SET UP QUAL-TABLE AND SUBSCRIPT.
      *    CALL FIND-CATNAME TO FIND CATNAME AND ALIAS NUMBER OF
      *    IDENTIFIER AND CATNAMES OF ALL QUALIFIERS. 
      * 
      *    ON INPUT 
      *    IF IDENTIFIER CLAUSE CAN HAVE SUBSCRIPT
      *        PAREN-TERM = "T".  THIS PARAMETER IS PASSED ALONG
      *        TO SCAN WHICH TREATS "(" AND ")" AS SEPARATE TOKENS. 
      *    IF IDENTIFIER CLAUSE CANNOT HAVE SUBSCRIPT 
      *        PAREN-TERM = SPACE 
      *    IF NAME MUST BE FOUND IN IS-FILE 
      *        MAY-BE-COBOL-NAME = SPACE
      *    IF NAME NEED NOT BE FOUND IN IS-FILE 
      *        MAY-BE-COBOL-NAME = "T"
      *    WORK-AREA = 1ST DATA NAME OF IDENTIFIER
      *    FIND-RECORD-CATNAME = CATNAME OF RECORD OF WHICH THIS
      *      IDENTIFIER IS A PART 
      * 
      *    ON OUTPUT
      *    IF NO SYNTAX ERRORS IN IDENTIFIER CLAUSE 
      *        WORK-AREA = 1ST TOKEN AFTER IDENTIFIER 
      *        SUBSCRIPT = SUBSCRIPT ENCLOSED IN BRACKETS 
      *    IF SYNTAX ERROR IN IDENTIFIER CLAUSE 
      *        FIND-CATNAME = SPACE 
      *        WORK-AREA IS UNDEFINED 
      *        SKIP-FLAG = "S"
      *        DIAGNOSTIC ISSUED
      *    IF CATNAME AND ALIAS-NO OF IDENTIFIER FOUND
      *        FIND-CATNAME = CATNAME 
      *        FIND-ALIAS-NO = ALIAS NUMBER 
      *        QUAL-TABLE SET UP
      *        SKIP-FLAG = SPACE
      *    IF NAME NOT FOUND AND MAY-BE-COBOL-NAME = SPACE
      *        FIND-CATNAME = SPACE 
      *        SKIP-FLAG = "S"
      *        DIAGNOSTIC ISSUED
      *    IF NAME NOT FOUND AND MAY-BE-COBOL-NAME = "T"
      *        FIND-CATNAME = SPACE 
      *        SKIP-FLAG = SPACE
      *        NO DIAGNOSTIC ISSUED 
      * 
      ******************************************************************
  
       IDEN-SUB.
           MOVE WORK-AREA TO FIND-DATA-NAME.
           MOVE 0 TO QUAL-SUB.
           MOVE SPACES TO DONE, SUBSCRIPT, QUAL-TABLE.
           PERFORM UNTIL DONE IS EQUAL TO "D" 
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
               IF EOF 
                 OR WORK-AREA IS EQUAL TO "." 
                   GO TO IDEN-10
               END-IF 
               IF WORK-AREA IS NOT EQUAL TO "OF"
                 AND WORK-AREA IS NOT EQUAL TO "IN" 
                   MOVE "D" TO DONE 
               ELSE 
                   ADD 1 TO QUAL-SUB
                   PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
                   IF EOF 
                     OR WORK-AREA IS EQUAL TO "." 
                       GO TO IDEN-10
                   END-IF 
                   IF QUAL-SUB IS GREATER THAN 5
                       MOVE MSG-205 TO STD-REPORT-REC 
                       GO TO IDEN-20
                   ELSE 
                       MOVE WORK-AREA TO QUAL-NAME (QUAL-SUB) 
                   END-IF 
               END-IF 
           END-PERFORM. 
           IF WORK-AREA IS NOT EQUAL TO "(" 
               GO TO IDEN-10. 
           MOVE 0 TO SUBSCRIPT-COUNT. 
           MOVE "[" TO SUBSCRIPT. 
           MOVE 2 TO SUB-SUB. 
           MOVE SPACE TO DONE.
           PERFORM UNTIL DONE IS EQUAL TO "D" 
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
               IF NOT EOF 
                 AND WORK-AREA IS NOT EQUAL TO "."
                 AND WORK-AREA IS NOT EQUAL TO ")"
                 AND SUBSCRIPT-COUNT IS LESS THAN 3 
                   IF (WORKA (1) IS LESS THAN "0" 
                     OR WORKA (1) IS GREATER THAN "9")
                     AND WORK-AREA IS NOT EQUAL TO "ANY"
                       MOVE MSG-160 TO STD-REPORT-REC 
                       GO TO IDEN-20
                   END-IF 
                   IF WK-SUB IS GREATER THAN 4
                       MOVE MSG-140 TO STD-REPORT-REC 
                       GO TO IDEN-20
                   END-IF 
                   MOVE WORK-AREA TO SUBSCRIPT (SUB-SUB : END)
                   ADD 1 TO SUBSCRIPT-COUNT 
                   ADD WK-SUB TO SUB-SUB
                   MOVE "," TO SUBSCRIPT (SUB-SUB : 1)
                   ADD 1 TO SUB-SUB 
               ELSE 
                   MOVE "D" TO DONE 
               END-IF 
           END-PERFORM. 
           SUBTRACT 1 FROM SUB-SUB. 
           IF SUBSCRIPT (SUB-SUB : 1) IS NOT EQUAL TO "," 
               ADD 1 TO SUB-SUB.
           MOVE "]" TO SUBSCRIPT (SUB-SUB : 1). 
           IF WORK-AREA IS NOT EQUAL TO ")" 
               MOVE MSG-130 TO STD-REPORT-REC 
               GO TO IDEN-20
           ELSE 
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
           END-IF.
       IDEN-10. 
           MOVE "05" TO IS-ENTITY-TYPE. 
           PERFORM FIND-IDEN-CATNAME THRU FIND-IDEN-CATNAME-EXIT. 
           IF FIND-CATNAME IS EQUAL TO SPACE
               MOVE "10" TO IS-ENTITY-TYPE
               PERFORM FIND-IDEN-CATNAME THRU FIND-IDEN-CATNAME-EXIT
           END-IF.
           IF FIND-CATNAME IS NOT EQUAL TO SPACE
             OR MAY-BE-COBOL-NAME IS EQUAL TO "T" 
               GO TO IDEN-EXIT. 
           MOVE FIND-DATA-NAME TO UNKNOWN-SS-ITEM.
           MOVE MSG-265 TO STD-REPORT-REC.
       IDEN-20. 
           PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT. 
           MOVE "S" TO SKIP-FLAG. 
       IDEN-EXIT. 
           EXIT.
  
      ******************************************************************
      * 
      *    JUST-SUB THRU JUST-EXIT
      * 
      *    SCAN JUSTIFIED CLAUSE.  STORE "R" IN HOLD-JUST.
      * 
      *    ON INPUT 
      *    WORK-AREA = "JUST" OR "JUSTIFIED"
      * 
      *    ON OUTPUT
      *    HOLD-JUST = "R"
      *    WORK-AREA = 1ST TOKEN AFTER JUSTIFIED CLAUSE 
      * 
      ******************************************************************
  
       JUST-SUB.
           MOVE "R" TO HOLD-JUST. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF WORK-AREA IS EQUAL TO "RIGHT" 
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
       JUST-EXIT. 
           EXIT.
  
      ******************************************************************
      * 
      *    LEVEL-66 THRU LEVEL-66-EXIT
      * 
      *    SCAN LEVEL 66 CLAUSE.  CALL WRITE-ENTITY TO WRITE
      *    OUT-REC.  CALL WRITE-PARENT-STRUCTURE TO WRITE 
      *    OUT-GRPS-REC.  PREPARE AND WRITE OUT-GRPS-RENAMES-REC
      *    AND OUT-GRPS-THRU-REC. 
      * 
      *    ON INPUT 
      *    WORK-AREA = "66" 
      * 
      *    ON OUTPUT
      *    IF NO ERROR
      *        WORK-AREA = "."
      *        SKIP-FLAG = SPACE
      *        SPECIFIED RECORDS WRITTEN
      *        NOTE-CDCS-REC DESCRIBES STRUCTURE CATEGORY OF RECORD 
      *    IF ERROR AND REST OF RENAMES CLAUSE MUST BE SKIPPED
      *        SKIP-FLAG = "S"
      * 
      ******************************************************************
  
       LEVEL-66.
           MOVE "T" TO LEVEL-66-ENCOUNTERED.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
               GO TO LEVEL-66-EXIT. 
           MOVE 2 TO LV-SUB.
           MOVE 1 TO LV-SUB-M1. 
           MOVE WORK-AREA TO LEVT-CDCS-NAME (2).
           MOVE LEVT-CATNAME (1) TO FIND-RECORD-CATNAME, NOTE-CATNAME.
           MOVE "13" TO NOTE-ENTRY-TYPE.
           MOVE ZERO TO NOTE-99-GROUP.
           MOVE LEVT-EALIASOF-FLAG (1) TO NOTE-EALIASOF-FLAG. 
           MOVE "300" TO NOTE-CATEGORY-TYPE.
           MOVE LEVT-CDCS-NAME (1) TO NOTE-CDCS-NAME. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
               GO TO LEVEL-66-EXIT. 
           IF WORK-AREA IS NOT EQUAL TO "RENAMES" 
               MOVE MSG-270 TO STD-REPORT-REC 
               GO TO LEVEL-66-10
           ELSE 
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
               IF EOF 
                 OR WORK-AREA IS EQUAL TO "." 
                   GO TO LEVEL-66-EXIT
               END-IF 
           END-IF.
           PERFORM IDEN-SUB THRU IDEN-EXIT. 
           IF SKIP-FLAG IS EQUAL TO "S" 
               GO TO LEVEL-66-EXIT. 
           MOVE SPACES TO OUT-EALIASOF-FLAG, OUT-EALIASOF-NAME. 
           MOVE ZERO TO OUT-99-GROUP. 
           ADD 1 TO STRUCT-COUNT. 
           MOVE STRUCT-COUNT TO OUT-STCR. 
           MOVE FIND-ENTITY-TYPE TO IS-ENTITY-TYPE. 
           MOVE SCHEMA-ORD TO IS-SCHEMA-ORDINAL.
           MOVE LEVT-CDCS-NAME (2) TO IS-CDCS-NAME. 
           PERFORM WRITE-ENTITY THRU WRITE-ENTITY-EXIT. 
           MOVE SUBSCHEMA-ORD TO IS-ELE-SSCH-ORDINAL. 
           MOVE 66 TO IS-ELE-LEVEL-NO.
           IF IS-ENTITY-TYPE IS EQUAL TO "05" 
               MOVE SPACES TO IS-ELE-ATTRIBUTE, IS-ELE-PRO-VAL, 
                 IS-ELE-LEVEL88, IS-ELE-EALIASOF-FLAG 
               WRITE IS-ELE-REC 
           ELSE 
               WRITE IS-GRP-REC 
           END-IF.
           MOVE ZERO TO ALIAS-NO. 
           MOVE SPACES TO HOLD-STRUCTURE. 
           MOVE IS-CATNAME TO LEVT-CATNAME (2). 
           ADD 1 TO STRUCT-COUNT. 
           MOVE STRUCT-COUNT TO SAVE-STRUCT.
           PERFORM WRITE-PARENT-STRUCTURE THRU
             WRITE-PARENT-STRUCTURE-EXIT. 
           ADD 1 TO STRUCT-COUNT. 
           MOVE STRUCT-COUNT TO OUT-STCR. 
           MOVE "75" TO OUT-FIELD-TYPE. 
           MOVE SPACES TO OUT-FILLER. 
           MOVE FIND-CATNAME TO OUT-GRPS-RENAMES. 
           MOVE FIND-ALIAS-NO TO OUT-GRPS-RNALIAS.
           MOVE QUAL-CATNAME-ARRAY TO OUT-GRPS-RNQUAL.
           CALL "WRKFOUT".
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
               GO TO LEVEL-66-EXIT. 
           IF WORK-AREA IS NOT EQUAL TO "THROUGH" 
             AND WORK-AREA IS NOT EQUAL TO "THRU" 
               MOVE MSG-275 TO STD-REPORT-REC 
               GO TO LEVEL-66-10
           END-IF.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
               GO TO LEVEL-66-EXIT. 
           PERFORM IDEN-SUB THRU IDEN-EXIT. 
           IF SKIP-FLAG IS EQUAL TO "S" 
               GO TO LEVEL-66-EXIT. 
           ADD 1 TO STRUCT-COUNT. 
           MOVE STRUCT-COUNT TO OUT-STCR. 
           MOVE "87" TO OUT-FIELD-TYPE. 
           MOVE SPACES TO OUT-FILLER. 
           MOVE FIND-CATNAME TO OUT-GRPS-THRU.
           MOVE FIND-ALIAS-NO TO OUT-GRPS-THALIAS.
           MOVE QUAL-CATNAME-ARRAY TO OUT-GRPS-TNQUAL.
           CALL "WRKFOUT".
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
               GO TO LEVEL-66-EXIT. 
           MOVE MSG-275 TO STD-REPORT-REC.
       LEVEL-66-10. 
           PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT. 
           MOVE "S" TO SKIP-FLAG. 
       LEVEL-66-EXIT. 
           EXIT.
  
  
      ******************************************************************
      * 
      *    LEVEL-88 THRU LEVEL-88-EXIT
      * 
      *    SCAN LEVEL 88 CLAUSE.  PREPARE AND WRITE OUT-ELEO-REC
      * 
      *    ON INPUT 
      *    WORK-AREA = "88" 
      * 
      *    ON OUTPUT
      *    OUT-ELEO-REC WRITTEN 
      *    IF CONDITION FITS WITHIN 63 CHARACTERS 
      *        WORK-AREA = "."
      *    IF CONDITION IS MORE THAN 63 CHARACTERS
      *        OUT-ELEO-REC CONTAINS FIRST 63 CHARACTERS OF CONDITION 
      *        SKIP-FLAG = "S"
      * 
      ******************************************************************
  
       LEVEL-88.
           MOVE SPACES TO OUT-FILLER. 
           MOVE 1 TO SUB-88.
       LEVEL-88-10. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
               GO TO LEVEL-88-20. 
           IF SUB-88 IS GREATER THAN 63 
               GO TO LEVEL-88-ERROR.
           MOVE WORK-AREA TO OUT-ELEO-88LEVEL (SUB-88 : END). 
           ADD WK-SUB TO SUB-88.
           IF SUB-88 IS GREATER THAN 64 
               GO TO LEVEL-88-ERROR.
           ADD 1 TO SUB-88. 
           GO TO LEVEL-88-10. 
       LEVEL-88-ERROR.
           MOVE MSG-260 TO STD-REPORT-REC.
           PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT. 
       LEVEL-88-20. 
           IF OUT-ELEO-88LEVEL IS NOT EQUAL TO SPACES 
               MOVE "05" TO OUT-ENTRY-TYPE
               MOVE LEVT-EALIASOF-FLAG (LV-SUB) TO OUT-EALIASOF-FLAG
               MOVE ZERO TO OUT-99-GROUP
               MOVE LEVT-CATNAME (LV-SUB) TO OUT-CATNAME
               MOVE "900" TO OUT-CATEGORY-TYPE
               ADD 1 TO STRUCT-COUNT
               MOVE STRUCT-COUNT TO OUT-STCR
               MOVE LEVT-CDCS-NAME (LV-SUB) TO OUT-CDCS-NAME
               MOVE "10" TO OUT-FIELD-TYPE
               MOVE SPACE TO OUT-EALIASOF-NAME
               CALL "WRKFOUT" 
           END-IF.
           IF EOF 
               GO TO LEVEL-88-EXIT. 
           IF WORK-AREA IS NOT EQUAL TO "." 
               MOVE "S" TO SKIP-FLAG
           END-IF.
       LEVEL-88-EXIT. 
           EXIT.
  
      ******************************************************************
      * 
      *    OCCURS-SUB THRU OCCURS-EXIT
      * 
      *    SCAN OCCURS CLAUSE.  STORE OCCURS INFORMATION IN OCCURS-TO.
      *    WRITE OUT-GRPS-OCCUR-REC.
      * 
      *    PROCESS KEY PHRASE.  KEY DATA NAMES CANNOT BE PROCESSED HERE 
      *    BECAUSE THEY WILL BE ENCOUNTERED AFTER THIS ITEM AND BEFORE
      *    1) END OF RECORD DESCRIPTION, 2) NEXT ITEM WITH OCCURS 
      *    CLAUSE, OR 3) NEXT ITEM WHOSE LEVEL IS LESS THAN OR EQUAL TO 
      *    THIS ITEM, WHICHEVER OCCURS FIRST.  THEREFORE, STORE KEY DATA
      *    NAMES IN KEY-TBL AND SET FLAG KEY-TABLE-WAITING SO THAT
      *    KEY-TBL WILL BE PROCESSED BY DATA-DESC OR OCCURS-SUB (THE
      *    NEXT TIME IT IS CALLED) CALLING WRITE-KEY-REC THE FIRST TIME 
      *    ONE OF THESE SITUATIONS OCCURS.
      * 
      *    PROCESS INDEXED BY PHRASE, WRITE OUT-GRPS-INDEX-REC. 
      * 
      *    ON INPUT 
      *    WORK-AREA = "OCCURS" 
      * 
      *    ON OUTPUT
      *    IF NO ERROR
      *        OCCURS-TO SET UP.
      *        WORK-AREA = 1ST TOKEN AFTER OCCURS CLAUSE
      *        KEY-TBL, KEY-FIRST-BLOCK-PTR, KEY-LEVEL, 
      *          KEY-TABLE-WAITING, KEY-OUT-REC SET UP
      *        OUT-GRPS-OCCUR-REC, OUT-GRPS-INDEX-REC WRITTEN 
      *        SKIP-FLAG = SPACE
      *    IF ERROR AND REST OF DATA DESCRIPTION ENTRY MUST BE SKIPPED
      *        SKIP-FLAG = "S"
      * 
      ******************************************************************
  
       OCCURS-SUB.
           IF KEY-TABLE-WAITING IS EQUAL TO "T" 
               PERFORM WRITE-KEY-REC THRU WRITE-KEY-REC-EXIT
           END-IF.
           MOVE SPACES TO OUT-EALIASOF-NAME, OUT-FILLER.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
               GO TO OCCURS-EXIT. 
           PERFORM CHECK-FOR-INTEGER THRU CHECK-FOR-INTEGER-EXIT. 
           IF SKIP-FLAG IS EQUAL TO "S" 
               GO TO OCCURS-EXIT. 
           MOVE WORK-AREA TO OUT-GRPS-TO. 
           MOVE LEVT-CATNAME (1) TO FIND-RECORD-CATNAME.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF WORK-AREA IS NOT EQUAL TO "TO"
               IF WORK-AREA IS EQUAL TO "TIMES" 
                   PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
               END-IF 
               GO TO OCCURS-30
           END-IF.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
               GO TO OCCURS-30. 
           PERFORM CHECK-FOR-INTEGER THRU CHECK-FOR-INTEGER-EXIT. 
           IF SKIP-FLAG IS EQUAL TO "S" 
               GO TO OCCURS-EXIT. 
           MOVE OUT-GRPS-TO TO OUT-GRPS-FROM. 
           MOVE WORK-AREA TO OUT-GRPS-TO. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF WORK-AREA IS NOT EQUAL TO "TIMES" 
               GO TO OCCURS-10. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
       OCCURS-10. 
           IF EOF 
               GO TO OCCURS-EXIT. 
           IF WORK-AREA IS NOT EQUAL TO "DEPENDING" 
               MOVE MSG-290 TO STD-REPORT-REC 
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
               MOVE "S" TO SKIP-FLAG
               GO TO OCCURS-EXIT
           END-IF.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF WORK-AREA IS NOT EQUAL TO "ON"
               GO TO OCCURS-20. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
       OCCURS-20. 
           IF EOF 
               GO TO OCCURS-EXIT. 
           PERFORM IDEN-SUB THRU IDEN-EXIT. 
           IF SKIP-FLAG IS EQUAL TO "S" 
               GO TO OCCURS-EXIT. 
           MOVE FIND-CATNAME TO OUT-GRPS-DEPEND.
           MOVE FIND-ALIAS-NO TO OUT-GRPS-DALIAS. 
           MOVE QUAL-CATNAME-ARRAY TO OUT-GRPS-DNQUAL.
       OCCURS-30. 
           IF LV-SUB IS EQUAL TO 2
               MOVE "13" TO OUT-ENTRY-TYPE
               MOVE 0 TO OUT-99-GROUP 
           ELSE 
               MOVE "10" TO OUT-ENTRY-TYPE
               SUBTRACT LEVT-LEVEL-NO (LV-SUB-M1) FROM 99 
                 GIVING OUT-99-GROUP
           END-IF.
           MOVE LEVT-EALIASOF-FLAG (LV-SUB-M1) TO OUT-EALIASOF-FLAG.
           MOVE LEVT-CATNAME (LV-SUB-M1) TO OUT-CATNAME.
           MOVE "300" TO OUT-CATEGORY-TYPE. 
           ADD 1 TO STRUCT-COUNT. 
           MOVE STRUCT-COUNT TO OUT-STCR. 
           MOVE LEVT-CDCS-NAME (LV-SUB-M1) TO OUT-CDCS-NAME.
           MOVE "10" TO OUT-FIELD-TYPE. 
           CALL "WRKFOUT".
       OCCURS-40. 
           IF WORK-AREA IS NOT EQUAL TO "ASCENDING" 
             AND WORK-AREA IS NOT EQUAL TO "DESCENDING" 
               GO TO OCCURS-INDEX.
      * 
      *    PROCESS ASCENDING/DESCENDING KEY PHRASE
      * 
           MOVE LEVEL-NO TO KEY-LEVEL.
           MOVE SPACES TO KEY-ARRAY.
           MOVE ZERO TO KEY-SUB, KEY-FIRST-BLOCK-PTR, KEY-NEXT-BLOCK-PTR. 
           MOVE LEVEL-NO TO KEY-LEVEL.
           MOVE "60" TO OUT-FIELD-TYPE. 
           MOVE OUT-REC TO KEY-OUT-REC. 
           MOVE "T" TO KEY-TABLE-WAITING. 
       OCCURS-KEY.
           IF EOF 
               GO TO OCCURS-EXIT. 
           IF WORK-AREA IS EQUAL TO "." 
             OR WORK-AREA IS EQUAL TO "INDEXED" 
             OR WORK-AREA IS EQUAL TO "JUSTIFIED" 
             OR WORK-AREA IS EQUAL TO "JUST"
             OR WORK-AREA IS EQUAL TO "OCCURS"
             OR WORK-AREA IS EQUAL TO "PICTURE" 
             OR WORK-AREA IS EQUAL TO "PIC" 
             OR WORK-AREA IS EQUAL TO "REDEFINES" 
             OR WORK-AREA IS EQUAL TO "SYNCHRONIZED"
             OR WORK-AREA IS EQUAL TO "SYNC"
             OR WORK-AREA IS EQUAL TO "USAGE" 
               GO TO OCCURS-KEY-40. 
           ADD 1 TO KEY-SUB.
           IF KEY-SUB IS GREATER THAN 20
               IF KEY-FIRST-BLOCK-PTR IS EQUAL TO ZERO
                   ENTER "CMMALF" USING KEY-BLOCK-SIZE, SIZE-CODE,
                     GROUP-ID, KEY-FIRST-BLOCK-PTR
                   MOVE KEY-FIRST-BLOCK-PTR TO KEY-PREVIOUS-BLOCK-PTR 
               END-IF 
               ENTER "CMMALF" USING KEY-BLOCK-SIZE, SIZE-CODE,
                 GROUP-ID, KEY-NEXT-BLOCK-PTR 
               ENTER "C.CMMMV" USING KEY-TBL, KEY-PREVIOUS-BLOCK-PTR
               MOVE 1 TO KEY-SUB
               MOVE SPACES TO KEY-ARRAY 
               MOVE KEY-NEXT-BLOCK-PTR TO KEY-PREVIOUS-BLOCK-PTR
               MOVE ZERO TO KEY-NEXT-BLOCK-PTR
           END-IF.
           IF WORK-AREA IS EQUAL TO "ASCENDING" 
               MOVE "A" TO KEY-ORDER (KEY-SUB)
               GO TO OCCURS-KEY-10
           END-IF.
           IF WORK-AREA IS NOT EQUAL TO "DESCENDING"
               GO TO OCCURS-KEY-20
           END-IF.
           MOVE "D" TO KEY-ORDER (KEY-SUB). 
       OCCURS-KEY-10. 
           SUBTRACT 1 FROM KEY-SUB. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF WORK-AREA IS EQUAL TO "KEY" 
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
           END-IF.
           IF WORK-AREA IS EQUAL TO "IS"
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
           END-IF.
           GO TO OCCURS-KEY.
       OCCURS-KEY-20. 
           ADD 1 TO STRUCT-COUNT. 
           MOVE STRUCT-COUNT TO KEY-STCR (KEY-SUB). 
           MOVE WORK-AREA TO KEY-NAME (KEY-SUB).
           MOVE 0 TO QUAL-SUB.
       OCCURS-KEY-30. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO OCCURS-KEY-40. 
           IF WORK-AREA IS EQUAL TO "IN"
             OR WORK-AREA IS EQUAL TO "OF"
               ADD 1 TO QUAL-SUB
               IF QUAL-SUB IS GREATER THAN 5
                   MOVE MSG-205 TO STD-REPORT-REC 
                   PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
                   PERFORM RELEASE-KEY-CMM THRU RELEASE-KEY-CMM-EXIT
                   MOVE SPACE TO KEY-TABLE-WAITING
                   MOVE "S" TO SKIP-FLAG
                   GO TO OCCURS-EXIT
               ELSE 
                   PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
                   IF EOF 
                       GO TO OCCURS-EXIT
                   END-IF 
                   IF WORK-AREA IS EQUAL TO "." 
                       GO TO OCCURS-KEY-40
                   END-IF 
                   MOVE WORK-AREA TO KEY-QUAL (KEY-SUB, QUAL-SUB) 
                   GO TO OCCURS-KEY-30
               END-IF 
           END-IF.
           IF QUAL-SUB IS NOT EQUAL TO 0
               MOVE MSG-295 TO STD-REPORT-REC 
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
           END-IF.
           GO TO OCCURS-KEY.
       OCCURS-KEY-40. 
           IF KEY-FIRST-BLOCK-PTR IS NOT EQUAL TO ZERO
               ENTER "C.CMMMV" USING KEY-TBL, KEY-PREVIOUS-BLOCK-PTR
           END-IF.
       OCCURS-INDEX.
           IF WORK-AREA IS NOT EQUAL TO "INDEXED" 
               GO TO OCCURS-EXIT. 
      * 
      *    PROCESS INDEXED BY PHRASE
      * 
           MOVE "35" TO OUT-FIELD-TYPE. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF WORK-AREA IS EQUAL TO "BY"
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
       OCCURS-INDEX-10. 
           IF WORK-AREA IS EQUAL TO "ASCENDING" 
             OR WORK-AREA IS EQUAL TO "DESCENDING"
               GO TO OCCURS-40. 
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
             OR WORK-AREA IS EQUAL TO "JUSTIFIED" 
             OR WORK-AREA IS EQUAL TO "JUST"
             OR WORK-AREA IS EQUAL TO "OCCURS"
             OR WORK-AREA IS EQUAL TO "PICTURE" 
             OR WORK-AREA IS EQUAL TO "PIC" 
             OR WORK-AREA IS EQUAL TO "REDEFINES" 
             OR WORK-AREA IS EQUAL TO "SYNCHRONIZED"
             OR WORK-AREA IS EQUAL TO "SYNC"
             OR WORK-AREA IS EQUAL TO "USAGE" 
               GO TO OCCURS-EXIT. 
           MOVE SPACES TO OUT-FILLER. 
           MOVE WORK-AREA TO OUT-GRPS-INDEX.
           ADD 1 TO STRUCT-COUNT. 
           MOVE STRUCT-COUNT TO OUT-STCR. 
           CALL "WRKFOUT".
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           GO TO OCCURS-INDEX-10. 
       OCCURS-EXIT. 
           EXIT.
  
      ******************************************************************
      * 
      *    PIC-LENGTH THRU PIC-LENGTH-EXIT
      * 
      *    SCAN PICTURE IN HOLD-PICTURE.  CALCULATE NUMBER OF CHARACTERS
      *    IN ITEM AND STORE IN FILLER-LENGTH.
      * 
      *    ON INPUT 
      *    HOLD-PICTURE CONTAINS PICTURE
      * 
      *    ON OUTPUT
      *    IF NO ERROR IN PICTURE 
      *        FILLER-LENGTH = NUMBER OF CHARACTERS IN ITEM 
      *        SKIP-FLAG = SPACE
      *    IF ERROR AND FILLER WILL BE SKIPPED
      *        SKIP-FLAG = "S"
      * 
      ******************************************************************
  
       PIC-LENGTH.
           MOVE ZERO TO FILLER-LENGTH.
           MOVE 1 TO PIC-SUB. 
           IF HOLD-PICTURE IS EQUAL TO SPACE
               GO TO PIC-LENGTH-ERROR-EXIT
           END-IF.
           MOVE HOLD-PICTURE TO PICTURE-AREA. 
       PIC-LENGTH-10. 
           MOVE PICA (PIC-SUB) TO PIC-CHAR. 
           IF PIC-CHAR IS EQUAL TO SPACE
               GO TO PIC-LENGTH-EXIT. 
           IF PIC-CHAR IS EQUAL TO "S"
             OR PIC-CHAR IS EQUAL TO "V"
               ADD 1 TO PIC-SUB 
               GO TO PIC-LENGTH-10
           END-IF.
           IF PIC-CHAR IS NOT EQUAL TO "9"
             AND PIC-CHAR IS NOT EQUAL TO "P" 
             AND PIC-CHAR IS NOT EQUAL TO "A" 
             AND PIC-CHAR IS NOT EQUAL TO "X" 
               GO TO PIC-LENGTH-ERROR-EXIT
           END-IF.
           ADD 1 TO PIC-SUB.
           IF PICA (PIC-SUB) IS NOT EQUAL TO "("
               ADD 1 TO FILLER-LENGTH 
               GO TO PIC-LENGTH-10
           END-IF.
           MOVE 0 TO PARTIAL-LENGTH.
           ADD 1 TO PIC-SUB.
       PIC-LENGTH-20. 
           IF PICA (PIC-SUB) IS EQUAL TO ")"
               ADD 1 TO PIC-SUB 
               IF PIC-CHAR IS NOT EQUAL TO "P"
                   ADD PARTIAL-LENGTH TO FILLER-LENGTH
               END-IF 
               GO TO PIC-LENGTH-10
           END-IF.
           IF PICA (PIC-SUB) IS LESS THAN "0" 
             OR PICA (PIC-SUB) IS GREATER THAN "9"
               GO TO PIC-LENGTH-ERROR-EXIT
           END-IF.
           MULTIPLY PARTIAL-LENGTH BY 10 GIVING PARTIAL-LENGTH. 
           ADD PIC-NUM (PIC-SUB) TO PARTIAL-LENGTH. 
           ADD 1 TO PIC-SUB.
           GO TO PIC-LENGTH-20. 
       PIC-LENGTH-ERROR-EXIT. 
           MOVE MSG-245 TO STD-REPORT-REC.
           PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT. 
           MOVE "S" TO SKIP-FLAG. 
       PIC-LENGTH-EXIT. 
           EXIT.
  
      ******************************************************************
      * 
      *    PIC-SUBROUTINE THRU PIC-EXIT 
      * 
      *    SCAN PICTURE CLAUSE.  STORE PICTURE IN HOLD-PICTURE. 
      * 
      *    ON INPUT 
      *    WORK-AREA = "PIC" OR "PICTURE" 
      *    LEVEL-TABLE, LV-SUB SET UP 
      * 
      *    ON OUTPUT
      *    HOLD-PICTURE CONTAINS PICTURE, TRUNCATED TO 25 CHARACTERS
      *      IF NECESSARY 
      *    WORK-AREA = 1ST TOKEN AFTER PICTURE CLAUSE 
      * 
      ******************************************************************
  
       PIC-SUBROUTINE.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
               GO TO PIC-EXIT.
           IF WORK-AREA IS NOT EQUAL TO "IS"
               GO TO PIC-10.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
               GO TO PIC-EXIT.
       PIC-10.
           IF WK-SUB IS GREATER THAN 27 
               MOVE MSG-490 TO STD-REPORT-REC 
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
               MOVE 25 TO WK-SUB
           END-IF.
           MOVE WORK-AREA TO HOLD-PICTURE.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
       PIC-EXIT.
           EXIT.
  
  
      ******************************************************************
      * 
      *    PROCESS-ERROR THRU PROCESS-ERROR-EXIT
      * 
      *    PRINTS ERROR MESSAGE.  SETS RETURN-CODE TO 8.
      * 
      *    ON INPUT 
      *    STD-REPORT-REC CONTAINS ERROR MESSAGE
      * 
      *    ON OUTPUT
      *    ERROR MESSAGE PRINTED
      *    RETURN-CODE = 8
      * 
      ******************************************************************
  
       PROCESS-ERROR. 
           PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.
           MOVE 8 TO RETURN-CODE. 
       PROCESS-ERROR-EXIT.
           EXIT.
  
  
      ******************************************************************
      * 
      *    RD-SUB THRU RD-EXIT
      * 
      *    SCANS RD CLAUSE.  IF RD ALL, READ IS-FILE TO FIND ALL
      *    SCHEMA AREAS.  FOR EVERY SCHEMA AREA, ACCESS AD-TBL TO FIND
      *    CORRESPONDING SUBSCHEMA REALM NAME AND CALL WRITE-REALM
      *    TO WRITE REALM ENTITY TO IS-FILE AND WORK-FILE.  IF
      *    RD REALM-NAME, CALL FIND-AREA-EALIAS TO FIND CORRESPONDING 
      *    SCHEMA AREA-NAME.  CALL WRITE-REALM TO WRITE REALM ENTITY
      *    TO IS-FILE AND WORK-FILE FOR SUBSCHEMA REALM.
      * 
      *    ON INPUT 
      *    WORK-AREA = "RD" 
      * 
      *    ON OUTPUT
      *    IF NO ERROR
      *        WORK-AREA = 1ST TOKEN AFTER RD CLAUSE
      *        OUT-REC, OUT-SSCHS-REC WRITTEN FOR EVERY REALM 
      *        SKIP-FLAG = SPACE
      *    IF ERROR AND REST OF RD CLAUSE MUST BE SKIPPED 
      *        SKIP-FLAG = "S"
      * 
      ******************************************************************
  
       RD-SUB.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO RD-EXIT. 
           IF WORK-AREA IS NOT EQUAL TO "ALL" 
               GO TO RD-20. 
      * 
      *    PROCESS RD ALL 
      * 
           MOVE "22" TO IS-ENTITY-TYPE. 
           MOVE SCHEMA-ORD TO IS-SCHEMA-ORDINAL.
           MOVE SPACES TO IS-CDCS-NAME. 
           GO TO RD-ALL-07. 
       RD-ALL-05. 
           MOVE HOLD-IS-ALTKEY TO IS-ALTKEY 
       RD-ALL-07. 
           START IS-FILE KEY IS GREATER THAN IS-ALTKEY
               INVALID KEY GO TO RD-ALL-20. 
       RD-ALL-10. 
           READ IS-FILE.
           MOVE IS-ALTKEY TO HOLD-IS-ALTKEY.
           IF IS-ENTITY-TYPE IS NOT EQUAL TO "22" 
             OR IS-SCHEMA-ORDINAL IS NOT EQUAL TO SCHEMA-ORD
               GO TO RD-ALL-20. 
           IF IS-AREA-SSCH-ORDINAL IS NOT EQUAL TO ZERO 
               GO TO RD-ALL-10. 
           MOVE IS-CDCS-NAME TO NAME-TO-MATCH.
           MOVE "22" TO ENTITY-TYPE.
           MOVE "O" TO NEW-OLD-NAME-FLAG. 
           PERFORM FIND-AD-ENTRY THRU FIND-AD-ENTRY-EXIT. 
           IF AD-SUB IS NOT EQUAL TO ZERO 
               MOVE AD-NEW-NAME (AD-SUB) TO IS-CDCS-NAME
           END-IF.
           MOVE "E" TO OUT-EALIASOF-FLAG. 
           MOVE IS-CATNAME TO OUT-EALIASOF-NAME.
           PERFORM WRITE-REALM THRU WRITE-REALM-EXIT. 
           GO TO RD-ALL-05. 
       RD-ALL-20. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO RD-EXIT. 
           IF WORK-AREA IS EQUAL TO "." 
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
           ELSE 
               MOVE MSG-10 TO STD-REPORT-REC
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
           END-IF.
           GO TO RD-EXIT. 
      * 
      *    PROCESS RD REALM-NAME1 ... 
      * 
       RD-10. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO RD-EXIT. 
           IF WORK-AREA IS EQUAL TO "." 
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
               GO TO RD-EXIT
           END-IF.
       RD-20. 
           PERFORM FIND-AREA-EALIAS THRU FIND-AREA-EALIAS-EXIT. 
           IF OUT-EALIASOF-FLAG IS EQUAL TO SPACE 
               MOVE WORK-AREA TO UNKNOWN-AREA 
               MOVE MSG-215 TO STD-REPORT-REC 
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
           ELSE 
               MOVE WORK-AREA TO IS-CDCS-NAME 
               PERFORM WRITE-REALM THRU WRITE-REALM-EXIT
           END-IF.
           GO TO RD-10. 
       RD-EXIT. 
           EXIT.
  
      ******************************************************************
      * 
      *    READ-SUBFIL THRU READ-SUBFIL-EXIT
      * 
      *    READ NEXT RECORD OF SUBFIL, PROCESS COBOL-STYLE COMMENTS 
      * 
      *    ON OUTPUT
      *    IF END-OF-FILE ENCOUNTERED 
      *        READ-END-SW = "E"
      *        IN-SUB = 8 
      *    IF END-OF-FILE NOT ENCOUNTERED 
      *        SUB-IN CONTAINS NEXT NON-COMMENT RECORD
      *        ALL RECORDS READ WRITTEN TO OUTPUT FILE
      *        IF NEXT NON-COMMENT LINE IS CONTINUATION LINE
      *            IN-SUB = 12
      *        ELSE 
      *            IN-SUB = 8 
      * 
      ******************************************************************
  
       READ-SUBFIL. 
           IF READ-END-SW IS EQUAL TO "E" 
               GO TO READ-SUBFIL-EXIT.
           READ SUB-FILE AT END 
               MOVE "E" TO READ-END-SW
               MOVE 8 TO IN-SUB 
               GO TO READ-SUBFIL-EXIT.
           MOVE SUB-IN TO STD-REPORT-REC. 
           PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.
           IF SUB-LINE (7) IS EQUAL TO "*"
               MOVE SUB-IN (8 : 65) TO HOLD-COMMENT 
               PERFORM WRITE-NOTE THRU WRITE-NOTE-EXIT
               GO TO READ-SUBFIL
           END-IF.
           IF SUB-LINE (7) IS EQUAL TO "-"
               MOVE 12 TO IN-SUB
           ELSE 
               MOVE 8 TO IN-SUB 
           END-IF.
           MOVE SPACES TO SUB-LINE (73).
       READ-SUBFIL-EXIT.
           EXIT.
  
  
      ******************************************************************
      * 
      *    REALM-SUB THRU REALM-EXIT
      * 
      *    SCANS REALM DIVISION.  CALLS RD-SUB FOR EVERY RD CLAUSE. 
      * 
      *    ON INPUT 
      *    WORK-AREA = "REALM"
      * 
      *    ON OUTPUT
      *    IF NO ERROR
      *        WORK-AREA = 1ST TOKEN AFTER LAST RD CLAUSE (CLAUSE 
      *          INCLUDES ".")
      *        OUT-REC, OUT-SSCHS-REC WRITTEN FOR EVERY REALM 
      *        SKIP-FLAG = SPACE
      *    IF ERROR AND REST OF REALM DIVISION AND RD CLAUSE MUST BE
      *      SKIPPED
      *        SKIP-FLAG = "S"
      * 
      ******************************************************************
  
       REALM-SUB. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO SUB-END. 
           IF WORK-AREA IS NOT EQUAL TO "DIVISION"
               MOVE MSG-180 TO STD-REPORT-REC 
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
               MOVE "S" TO SKIP-FLAG
               GO TO REALM-EXIT 
           END-IF.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO SUB-END. 
           IF WORK-AREA IS NOT EQUAL TO "." 
               MOVE MSG-10 TO STD-REPORT-REC
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
           ELSE 
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
               IF EOF 
                   GO TO SUB-END
               END-IF 
           END-IF.
           IF WORK-AREA IS NOT EQUAL TO "RD"
               MOVE MSG-210 TO STD-REPORT-REC 
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
               MOVE "S" TO SKIP-FLAG
               GO TO REALM-EXIT 
           END-IF.
       REALM-10.
           IF WORK-AREA IS EQUAL TO "RD"
               PERFORM RD-SUB THRU RD-EXIT
               IF SKIP-FLAG IS EQUAL TO "S" 
                   PERFORM SKIP-PAST-PERIOD THRU SKIP-PAST-PERIOD-EXIT
                   GO TO REALM-10 
               END-IF 
               IF EOF 
                  GO TO SUB-END 
               ELSE 
                   GO TO REALM-10 
               END-IF 
           END-IF.
       REALM-EXIT.
           EXIT.
  
      ******************************************************************
      * 
      *    RECORD-DESC THRU RECORD-DESC-EXIT
      * 
      *    SCANS 01 RECORD-NAME.  CALLS WRITE-ENTITY TO WRITE 
      *    OUT-REC FOR SUBSCHEMA RECORD.  WRITES IS-REC-REC.
      *    DETERMINES SUBSCHEMA REALM WHICH IS PARENT OF THIS RECORD. 
      *    WRITES OUT-AREAS-REC FOR PARENT REALM. 
      * 
      *    CALLS ROUTINE TO PROCESS EACH DATA DESCRIPTION ENTRY IN
      *    RECORD: LEVEL-66 FOR LEVEL 66, RENAMES; LEVEL-88 FOR 
      *    LEVEL 88, CONDITION; OR DATA-DESC FOR LEVEL 2-49.  DATA-DESC 
      *    CANNOT DETERMINE WHETHER THE ITEM IT IS PROCESSING IS AN 
      *    ELEMENT OR A GROUP.  IF THE ITEM IS THE LAST ITEM IN THE 
      *    RECORD, IS FOLLOWED BY A LEVEL 66 OR LEVEL 88 ITEM, OR IS
      *    FOLLOWED BY AN ITEM WITH THE SAME OR SMALLER LEVEL NUMBER, 
      *    IT IS AN ELEMENT, OTHERWISE IT IS A GROUP.  THEREFORE, 
      *    DATA-DESC CANNOT WRITE THE ENTITY TO IS-FILE AND WORK-FILE.
      *    INSTEAD, IT SETS UP WORKING STORAGE DESCRIBING THE ITEM
      *    AND SETS A FLAG, DATA-ITEM-WAITING.  IN ITS DATA 
      *    DESCRIPTION LOOP, RECORD-DESC READS THE LEVEL NUMBER OF THE
      *    NEXT DATA ITEM OR DETERMINES THAT THERE ARE NO MORE DATA 
      *    ITEMS.  IF DATA-ITEM-WAITING INDICATES A PREVIOUS ITEM NEEDS 
      *    TO BE WRITTEN TO IS-FILE AND WORK-FILE, IT CALLS 
      *    WRITE-PREVIOUS-DATA TO DO THAT.  THEN IF KEY-TABLE-WAITING 
      *    AND LEVEL NUMBERS INDICATE A KEY TABLE MUST BE PROCESSED 
      *    (SEE OCCURS-SUB) IT CALLS WRITE-KEY-REC TO DO THAT.  THEN IT 
      *    CALLS LEVEL-66, LEVEL-88, OR DATA-DESC FOR THE NEXT ITEM.
      * 
      *    ON INPUT 
      *    WORK-AREA = "1" OR "01"
      * 
      *    ON OUTPUT
      *    IF NO ERROR
      *        WORK-AREA = 1ST TOKEN AFTER 01 RECORD-NAME.
      *        OUT-REC, IS-REC-REC, OUT-AREAS-REC WRITTEN 
      *        ALL DATA ITEMS OF THIS RECORD PROCESSED
      *        SKIP-FLAG = SPACE
      *    IF ERROR AND REST OF RECORD DESCRIPTION, INCLUDING ALL 
      *      DATA ITEMS MUST BE SKIPPED 
      *        SKIP-FLAG = "S"
      * 
      ******************************************************************
  
       RECORD-DESC. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO SUB-END. 
      * 
      *    DETERMINE IF THIS SUBSCHEMA ALREADY HAS A RECORD WITH THE
      *    SAME NAME
      * 
           MOVE "13" TO IS-ENTITY-TYPE. 
           MOVE SCHEMA-ORD TO IS-SCHEMA-ORDINAL.
           MOVE WORK-AREA TO IS-CDCS-NAME.
           MOVE IS-ALTKEY TO HOLD-IS-ALTKEY 
           START IS-FILE KEY IS EQUAL TO IS-ALTKEY
               INVALID KEY GO TO RECORD-DESC-07.
       RECORD-DESC-05.
           READ IS-FILE.
           IF IS-ALTKEY IS NOT EQUAL TO HOLD-IS-ALTKEY
               GO TO RECORD-DESC-07.
           IF IS-REC-SSCH-ORDINAL IS NOT EQUAL TO SUBSCHEMA-ORD 
               GO TO RECORD-DESC-05.
           MOVE MSG-300 TO STD-REPORT-REC.
           GO TO RECORD-DESC-50.
       RECORD-DESC-07.
      * 
      *    DETERMINE CORRESPONDING SCHEMA RECORD NAME 
      * 
           MOVE "13" TO ENTITY-TYPE.
           MOVE "N" TO NEW-OLD-NAME-FLAG. 
           MOVE WORK-AREA TO NAME-TO-MATCH. 
           PERFORM FIND-AD-ENTRY THRU FIND-AD-ENTRY-EXIT. 
           IF AD-SUB IS EQUAL TO ZERO 
               MOVE WORK-AREA TO IS-CDCS-NAME 
           ELSE 
               MOVE AD-OLD-NAME (AD-SUB) TO IS-CDCS-NAME
           END-IF.
      * 
      *    READ CORRESPONDING SCHEMA RECORD ON IS-FILE
      * 
           MOVE "13" TO IS-ENTITY-TYPE. 
           MOVE SCHEMA-ORD TO IS-SCHEMA-ORDINAL.
           MOVE IS-ALTKEY TO HOLD-IS-ALTKEY.
           START IS-FILE KEY IS EQUAL TO IS-ALTKEY
               INVALID KEY GO TO RECORD-DESC-30.
       RECORD-DESC-10.
           READ IS-FILE.
           IF IS-ALTKEY IS NOT EQUAL TO HOLD-IS-ALTKEY
               GO TO RECORD-DESC-30.
           IF IS-REC-SSCH-ORDINAL IS NOT EQUAL TO ZERO
               GO TO RECORD-DESC-10.
      * 
      *    WRITE SUBSCHEMA RECORD ENTITY TO IS-FILE AND WORK-FILE 
      * 
           MOVE IS-CATNAME TO SCHEMA-RECORD-CATNAME.
           MOVE IS-CDCS-NAME TO SCHEMA-RECORD-CDCS-NAME.
           MOVE IS-REC-PARENT-CATNAME TO AREA-CATNAME.
           MOVE "E" TO OUT-EALIASOF-FLAG, NOTE-EALIASOF-FLAG. 
           MOVE ZERO TO OUT-99-GROUP. 
           ADD 1 TO STRUCT-COUNT. 
           MOVE STRUCT-COUNT TO OUT-STCR. 
           MOVE IS-CATNAME TO OUT-EALIASOF-NAME.
           MOVE "13" TO IS-ENTITY-TYPE, NOTE-ENTRY-TYPE.
           MOVE SCHEMA-ORD TO IS-SCHEMA-ORDINAL.
           MOVE WORK-AREA TO IS-CDCS-NAME, NOTE-CDCS-NAME,
             LEVT-CDCS-NAME (1).
           PERFORM WRITE-ENTITY THRU WRITE-ENTITY-EXIT. 
           MOVE ZERO TO NOTE-99-GROUP.
           MOVE IS-CATNAME TO NOTE-CATNAME, LEVT-CATNAME (1). 
           MOVE 1 TO LV-SUB.
           MOVE "R" TO LEVT-GRP-ELE (1).
           MOVE 1 TO LEVT-LEVEL-NO (1). 
           MOVE "E" TO LEVT-EALIASOF-FLAG (1).
           MOVE "001" TO NOTE-CATEGORY-TYPE.
           MOVE SUBSCHEMA-ORD TO IS-REC-SSCH-ORDINAL. 
           MOVE 0 TO IS-REC-OUT-STCR. 
           MOVE SPACES TO IS-REC-PARENT-CATNAME.
           WRITE IS-REC-REC.
      * 
      *    READ CORRESPONDING SCHEMA AREA 
      * 
           MOVE AREA-CATNAME TO IS-CATNAME. 
           MOVE ZERO TO IS-ALIAS-NO, IS-SEQ-NO. 
           START IS-FILE KEY IS EQUAL TO IS-PKEY
               INVALID KEY GO TO RECORD-DESC-40.
           READ IS-FILE.
      * 
      *    DETERMINE NAME OF CORRESPONDING SUBSCHEMA REALM, PARENT
      *    OF RECORD
      * 
           MOVE "22" TO ENTITY-TYPE.
           MOVE IS-CDCS-NAME TO NAME-TO-MATCH.
           MOVE "O" TO NEW-OLD-NAME-FLAG. 
           PERFORM FIND-AD-ENTRY THRU FIND-AD-ENTRY-EXIT. 
           IF AD-SUB IS EQUAL TO ZERO 
               MOVE NAME-TO-MATCH TO IS-CDCS-NAME 
           ELSE 
               MOVE AD-NEW-NAME (AD-SUB) TO IS-CDCS-NAME
           END-IF.
           MOVE "22" TO IS-ENTITY-TYPE. 
           MOVE SCHEMA-ORD TO IS-SCHEMA-ORDINAL.
           MOVE IS-ALTKEY TO HOLD-IS-ALTKEY.
      * 
      *    READ SUBSCHEMA REALM IS-AREA-REC 
      * 
           START IS-FILE KEY IS EQUAL TO IS-ALTKEY
               INVALID KEY GO TO RECORD-DESC-40.
       RECORD-DESC-20.
           READ IS-FILE.
           IF IS-ALTKEY IS NOT EQUAL TO HOLD-IS-ALTKEY
               GO TO RECORD-DESC-40.
           IF IS-REC-SSCH-ORDINAL IS NOT EQUAL TO SUBSCHEMA-ORD 
               GO TO RECORD-DESC-20.
      * 
      *    WRITE STRUCTURE RECORD FOR SUBSCHEMA REALM CONTAINS
      *    SUBSCHEMA RECORD 
      * 
           MOVE "22" TO OUT-ENTRY-TYPE. 
           MOVE "E" TO OUT-EALIASOF-FLAG. 
           MOVE ZERO TO OUT-99-GROUP. 
           MOVE IS-CATNAME TO OUT-CATNAME.
           MOVE "300" TO OUT-CATEGORY-TYPE. 
           ADD 1 TO STRUCT-COUNT. 
           MOVE STRUCT-COUNT TO OUT-STCR. 
           MOVE IS-CDCS-NAME TO OUT-CDCS-NAME.
           MOVE "05" TO OUT-FIELD-TYPE. 
           MOVE SPACE TO OUT-EALIASOF-NAME. 
           MOVE LEVT-CATNAME (1) TO OUT-AREAS-CATNAME.
           CALL "WRKFOUT".
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF WORK-AREA IS EQUAL TO "." 
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
               IF EOF 
                   GO TO SUB-END
               END-IF 
           ELSE 
               MOVE MSG-10 TO STD-REPORT-REC
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
           END-IF.
           MOVE SPACE TO DATA-ITEM-WAITING, LEVEL-66-ENCOUNTERED. 
           GO TO RECORD-DESC-DATA-LOOP-10.
       RECORD-DESC-DATA-LOOP. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
       RECORD-DESC-DATA-LOOP-10.
           IF NOT EOF 
               PERFORM GET-LEVEL THRU GET-LEVEL-EXIT. 
           IF DATA-ITEM-WAITING IS NOT EQUAL TO SPACE 
      * 
      *    IF AN ENTITY SHOULD BE WRITTEN TO IS-FILE AND WORK-FILE
      *    FOR THE PREVIOUS ITEM
      * 
               PERFORM WRITE-PREVIOUS-DATA
                 THRU WRITE-PREVIOUS-DATA-EXIT
               IF SKIP-FLAG IS EQUAL TO "S" 
                   MOVE SPACE TO SKIP-FLAG
                   MOVE WORK-AREA TO SKIPPED-TO-KEYWORD 
                   MOVE MSG-40 TO STD-REPORT-REC
                   PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
               END-IF 
           END-IF.
           IF KEY-TABLE-WAITING IS EQUAL TO "T" 
             AND (EOF 
             OR LEVEL-NO IS NOT GREATER THAN KEY-LEVEL) 
      * 
      *    IF KEY-TABLE SHOULD BE PROCESSED 
      * 
               PERFORM WRITE-KEY-REC THRU WRITE-KEY-REC-EXIT. 
           IF EOF 
             OR LEVEL-NO IS EQUAL TO ZERO 
      * 
      *    IF CURRENT TOKEN IS NOT START OF DATA DESCRIPTION ENTRY
      * 
               GO TO RECORD-DESC-EXIT.
           IF LEVEL-NO IS EQUAL TO 66 
               PERFORM LEVEL-66 THRU LEVEL-66-EXIT
           ELSE 
               IF LEVEL-66-ENCOUNTERED IS EQUAL TO "T"
                   MOVE MSG-280 TO STD-REPORT-REC 
                   PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
                   MOVE "S" TO SKIP-FLAG
               ELSE 
                   IF LEVEL-NO IS EQUAL TO 88 
                       PERFORM LEVEL-88 THRU LEVEL-88-EXIT
                   ELSE 
                       PERFORM DATA-DESC THRU DATA-DESC-EXIT
                   END-IF 
               END-IF 
           END-IF.
           IF SKIP-FLAG IS EQUAL TO "S" 
               PERFORM SKIP-PAST-PERIOD THRU SKIP-PAST-PERIOD-EXIT
               GO TO RECORD-DESC-DATA-LOOP-10 
           END-IF.
           GO TO RECORD-DESC-DATA-LOOP. 
       RECORD-DESC-30.
           MOVE MSG-230 TO STD-REPORT-REC.
           GO TO RECORD-DESC-50.
       RECORD-DESC-40.
           MOVE MSG-235 TO STD-REPORT-REC.
       RECORD-DESC-50.
           PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT. 
           MOVE "S" TO SKIP-FLAG. 
       RECORD-DESC-EXIT.
           EXIT.
  
      ******************************************************************
      * 
      *    RECORD-SUB THRU RECORD-EXIT
      * 
      *    SCANS "RECORD DIVISION." 
      * 
      *    ON INPUT 
      *    WORK-AREA = "RECORD" 
      * 
      *    ON OUTPUT
      *    IF NO ERROR
      *        WORK-AREA = 1ST TOKEN AFTER "RECORD DIVISION." 
      *        SKIP-FLAG = SPACE
      *    IF ERROR AND REST OF SUBSCHEMA MUST BE SKIPPED 
      *        SKIP-FLAG = "S"
      * 
      ******************************************************************
  
       RECORD-SUB.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO SUB-END. 
           IF WORK-AREA IS NOT EQUAL TO "DIVISION"
               MOVE MSG-180 TO STD-REPORT-REC 
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
               MOVE "S" TO SKIP-FLAG
               GO TO RECORD-EXIT
           END-IF.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO SUB-END. 
           IF WORK-AREA IS NOT EQUAL TO "." 
               MOVE MSG-10 TO STD-REPORT-REC
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
           ELSE 
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
               IF EOF 
                   GO TO SUB-END
               END-IF 
           END-IF.
       RECORD-EXIT. 
           EXIT.
  
      ******************************************************************
      * 
      *    REDEFINES-FIND THRU REDEFINES-EXIT 
      * 
      *    SEARCH IS-FILE FOR MOST RECENTLY WRITTEN SUBSCHEMA ITEM
      *    (LAST ENCOUNTERED WHEN SEQUENTIALLY READING BY ALTERNATE KEY)
      *    WHICH IS PART OF THE CURRENT RECORD AND HAS THE SAME LEVEL 
      *    NUMBER AS THE CURRENT ITEM.
      * 
      *    ON INPUT 
      *    LEVEL-TABLE, LV-SUB, SCHEMA-ORD, SUBSCHEMA-ORD SET UP
      *    WORK-AREA = NAME TO SEARCH FOR 
      *    IS-ENTITY-TYPE = "05" TO SEARCH FOR ELEMENT OR "10" TO SEARCH
      *      FOR GROUP
      * 
      *    ON OUTPUT
      *    IF SUBSCHEMA ITEM FOUND
      *        SEQ-NO = IS-SEQ-NO 
      *        HOLD-REDEFINE = CATNAME
      *        HOLD-RDALIAS = IS-ALIAS-NO 
      *    IF NO SUBSCHEMA ITEM FOUND 
      *        SEQ-NO RETAINS ORIGINAL VALUE
      * 
      ******************************************************************
  
       REDEFINES-FIND.
           MOVE SCHEMA-ORD TO IS-SCHEMA-ORDINAL.
           MOVE WORK-AREA TO IS-CDCS-NAME.
           MOVE IS-ALTKEY TO HOLD-IS-ALTKEY.
           START IS-FILE KEY IS EQUAL TO IS-ALTKEY
               INVALID KEY GO TO REDEFINES-FIND-EXIT. 
       REDEFINES-FIND-10. 
           READ IS-FILE.
           IF IS-ALTKEY IS NOT EQUAL TO HOLD-IS-ALTKEY
               GO TO REDEFINES-FIND-EXIT. 
           IF IS-ELE-SSCH-ORDINAL IS NOT EQUAL TO SUBSCHEMA-ORD 
             OR IS-ELE-RECORD-CATNAME IS NOT EQUAL TO LEVT-CATNAME (1)
             OR IS-ELE-LEVEL-NO IS NOT EQUAL TO LEVT-LEVEL-NO (LV-SUB)
               GO TO REDEFINES-FIND-10. 
           MOVE IS-CATNAME TO HOLD-REDEFINE.
           MOVE IS-ALIAS-NO TO HOLD-RDALIAS.
           MOVE IS-SEQ-NO TO SEQ-NO.
           GO TO REDEFINES-FIND-10. 
       REDEFINES-FIND-EXIT. 
           EXIT.
  
  
  
      ******************************************************************
      * 
      *    REDEFINES-SUB THRU REDEFINES-EXIT
      * 
      *    SCANS REDEFINES CLAUSE.  SETS UP HOLD-REDEFINE AND 
      *    HOLD-RDALIAS.  CALLS REDEFINES-FIND TWICE, ONCE TO SEARCH
      *    FOR ELEMENT, ONCE TO SEARCH FOR GROUP. 
      * 
      *    ON INPUT 
      *    WORK-AREA = NAME TO SEARCH FOR 
      *    IF REDEFINES ALREADY IN EFFECT 
      *        REDEFINES-ITEM = "T" 
      * 
      *    ON OUTPUT
      *    IF SUBSCHEMA ITEM FOUND
      *        HOLD-REDEFINE, HOLD-RDALIAS SET UP 
      *        WORK-AREA = 1ST TOKEN AFTER REDEFINES CLAUSE 
      *        REDEFINES-ITEM = "T" 
      *        REDEFINES-LEVEL = SMALLEST REDEFINES LEVEL 
      *        SKIP-FLAG = SPACE
      *    IF NO SUBSCHEMA ITEM FOUND AND REST OF DATA DESCRIPTION MUST 
      *      BE SKIPPED 
      *        SKIP-FLAG = "S"
      * 
      ******************************************************************
  
       REDEFINES-SUB. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
               GO TO REDEFINES-EXIT.
           IF REDEFINES-ITEM IS EQUAL TO SPACE
               MOVE "T" TO REDEFINES-ITEM 
               MOVE LEVT-LEVEL-NO (LV-SUB) TO REDEFINES-LEVEL 
           END-IF.
           MOVE -1 TO SEQ-NO. 
           MOVE "05" TO IS-ENTITY-TYPE. 
           PERFORM REDEFINES-FIND THRU REDEFINES-FIND-EXIT. 
           IF SEQ-NO IS EQUAL TO -1 
               MOVE "10" TO IS-ENTITY-TYPE
               PERFORM REDEFINES-FIND THRU REDEFINES-FIND-EXIT
               IF SEQ-NO IS EQUAL TO -1 
                   MOVE WORK-AREA TO UNKNOWN-SS-ITEM
                   MOVE MSG-265 TO STD-REPORT-REC 
                   PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
                   MOVE "S" TO SKIP-FLAG
                   GO TO REDEFINES-EXIT 
               END-IF 
           END-IF.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
       REDEFINES-EXIT.
           EXIT.
  
      ******************************************************************
      * 
      *    RELATION-SUB THRU RELATION-EXIT
      * 
      *    SCANS RELATION DIVISION, CALLS RN-SUBROUTINE FOR EACH RELATION 
      *    DESCRIPTION ENTRY
      * 
      *    ON INPUT 
      *    WORK-AREA = "RELATION" 
      * 
      *    ON OUTPUT
      *    IF NO ERROR
      *        WORK-AREA = 1ST TOKEN AFTER LAST RELATION DESCRIPTION
      *          ENTRY (ENTRY INCLUDES ".") 
      *        SKIP-FLAG = SPACE
      *        NOTE-CDCS-REC DESCRIBES SUBSCHEMA RELATION 
      *    IF ERROR AND REST OF RELATION DIVISION AND RN CLAUSES MUST BE
      *      SKIPPED
      *        SKIP-FLAG = "S"
      * 
      ******************************************************************
  
       RELATION-SUB.
           MOVE "24" TO OUT-ENTRY-TYPE, NOTE-ENTRY-TYPE.
           MOVE SPACE TO OUT-EALIASOF-FLAG, NOTE-EALIASOF-FLAG, 
             OUT-EALIASOF-NAME. 
           MOVE 0 TO OUT-99-GROUP, NOTE-99-GROUP. 
           MOVE SUBSCHEMA-CATNAME TO OUT-CATNAME, NOTE-CATNAME. 
           MOVE "525" TO OUT-CATEGORY-TYPE, NOTE-CATEGORY-TYPE. 
           MOVE SUBSCHEMA-NAME TO OUT-CDCS-NAME, NOTE-CDCS-NAME.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO SUB-END. 
           IF WORK-AREA IS NOT EQUAL TO "DIVISION"
               MOVE MSG-180 TO STD-REPORT-REC 
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
               MOVE "S" TO SKIP-FLAG
               GO TO RELATION-EXIT
           END-IF.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO SUB-END. 
           IF WORK-AREA IS NOT EQUAL TO "." 
               MOVE MSG-10 TO STD-REPORT-REC
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
           ELSE 
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
               IF EOF 
                   GO TO SUB-END
               END-IF 
           END-IF.
       RELATION-10. 
           IF WORK-AREA IS EQUAL TO "RN"
               PERFORM RN-SUBROUTINE THRU RN-EXIT 
               IF SKIP-FLAG IS EQUAL TO "S" 
                   PERFORM SKIP-PAST-PERIOD THRU SKIP-PAST-PERIOD-EXIT
                   GO TO RELATION-10
               END-IF 
               IF EOF 
                   GO TO SUB-END
               ELSE 
                   GO TO RELATION-10
               END-IF 
           END-IF.
       RELATION-EXIT. 
           EXIT.
  
      ******************************************************************
      * 
      *    RELEASE-CMM-BLOCKS THRU RELEASE-CMM-BLOCKS-EXIT
      * 
      *    RELEASES CMM BLOCKS ALLOCATED FOR AD CLAUSES 
      * 
      *    ON INPUT 
      *    BLOCK-FWA = ADDRESS OF LAST CMM BLOCK ALLOCATED
      * 
      *    ON OUTPUT
      *    ALL CMM BLOCKS RELEASED
      *    BLOCK-FWA = 0
      *    AD-SUB = 0 
      * 
      ******************************************************************
  
       RELEASE-CMM-BLOCKS.
           IF BLOCK-FWA IS EQUAL TO ZERO
               GO TO RELEASE-CMM-BLOCKS-20. 
       RELEASE-CMM-BLOCKS-10. 
           ENTER "C.CMMMV" USING BLOCK-FWA, AD-TBL. 
           ENTER "CMMFRF" USING BLOCK-FWA.
           MOVE AD-PREVIOUS-BLOCK-PTR TO BLOCK-FWA. 
           IF BLOCK-FWA IS NOT EQUAL TO ZERO
               GO TO RELEASE-CMM-BLOCKS-10. 
       RELEASE-CMM-BLOCKS-20. 
           MOVE SPACES TO AD-TBL. 
           MOVE ZERO TO AD-PREVIOUS-BLOCK-PTR, AD-SUB.
       RELEASE-CMM-BLOCKS-EXIT. 
           EXIT.
  
      ******************************************************************
      * 
      *    RELEASE-KEY-CMM THRU RELEASE-KEY-CMM-EXIT
      * 
      *    RELEASES CMM BLOCKS ALLOCATED FOR KEY CLAUSES
      * 
      *    ON INPUT 
      *    KEY-FIRST-BLOCK-FWA = ADDRESS OF FIRST CMM BLOCK ALLOCATED 
      * 
      *    ON OUTPUT
      *    ALL CMM BLOCKS RELEASED
      * 
      ******************************************************************
  
       RELEASE-KEY-CMM. 
           MOVE KEY-FIRST-BLOCK-PTR TO KEY-NEXT-BLOCK-PTR.
       RELEASE-KEY-CMM-10.
           IF KEY-NEXT-BLOCK-PTR IS EQUAL TO ZERO 
               GO TO RELEASE-KEY-CMM-EXIT.
           MOVE KEY-NEXT-BLOCK-PTR TO KEY-PREVIOUS-BLOCK-PTR. 
           ENTER "C.CMMMV" USING KEY-NEXT-BLOCK-PTR, KEY-TBL. 
           ENTER "CMMFRF" USING KEY-PREVIOUS-BLOCK-PTR. 
           GO TO RELEASE-KEY-CMM-10.
       RELEASE-KEY-CMM-EXIT.
           EXIT.
  
      ******************************************************************
      * 
      *    RESTRICT-SUB THRU RESTRICT-EXIT
      * 
      *    SCANS RESTRICT CLAUSE.  PREPARES AND WRITES
      *    OUT-SSCHR-RNAME-REC AND AS MANY OUT-SSCHR-EXP-REC'S AS 
      *    NECESSARY. 
      * 
      *    ON INPUT 
      *    WORK-AREA = "RESTRICT" 
      *    RELATION-NAME = RELATION NAME
      * 
      *    ON OUTPUT
      *    IF NO ERROR
      *        OUT-SSCHR-RNAME-REC, OUT-SSCHR-EXP-REC'S WRITTEN 
      *        WORK-AREA = 1ST TOKEN AFTER RESTRICT CLAUSE
      *          (RESTRICT CLAUSE DOES NOT INCLUDE ".") 
      *        SKIP-FLAG = SPACE
      *    IF ERROR AND REST OF RELATION DESCRIPTION ENTRY MUST BE
      *      SKIPPED
      *        SKIP-FLAG = "S"
      * 
      ******************************************************************
  
       RESTRICT-SUB.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
               GO TO RESTRICT-EXIT. 
      * 
      *    FIND RECORD NAME ON IS-FILE
      * 
           MOVE "13" TO IS-ENTITY-TYPE. 
           MOVE SCHEMA-ORD TO IS-SCHEMA-ORDINAL.
           MOVE WORK-AREA TO IS-CDCS-NAME.
           MOVE IS-ALTKEY TO HOLD-IS-ALTKEY.
           START IS-FILE KEY IS EQUAL TO IS-ALTKEY
               INVALID KEY GO TO RESTRICT-ERROR.
       RESTRICT-10. 
           READ IS-FILE.
           IF IS-ALTKEY IS NOT EQUAL TO HOLD-IS-ALTKEY
               GO TO RESTRICT-ERROR.
           IF IS-REC-SSCH-ORDINAL IS NOT EQUAL TO SUBSCHEMA-ORD 
               GO TO RESTRICT-10. 
           MOVE SPACES TO OUT-FILLER. 
           MOVE RELATION-NAME TO OUT-SSCHR-RNAME. 
           MOVE IS-CATNAME TO FIND-RECORD-CATNAME, OUT-SSCHR-RESTRICT.
           ADD 1 TO STRUCT-COUNT. 
           MOVE STRUCT-COUNT TO OUT-STCR. 
           MOVE "02" TO OUT-FIELD-TYPE. 
           CALL "WRKFOUT".
           MOVE SPACES TO OUT-SSCHR-EXP-AREA, RELATION-NAME.
           MOVE ZERO TO OUT-SSCHR-LEFT-PAREN, OUT-SSCHR-RIGHT-PAREN.
           MOVE "T" TO PAREN-TERM.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF WORK-AREA IS EQUAL TO "WHERE" 
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
               GO TO RESTRICT-CLEAR-PAREN.
           IF WORK-AREA IS NOT EQUAL TO "NOT" 
               GO TO RESTRICT-30. 
           MOVE "NOT" TO OUT-SSCHR-PRELOP.
       RESTRICT-20. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
       RESTRICT-30. 
      * 
      *    PROCESS 1ST IDENTIFIER WHICH MUST BE A PREVIOUSLY DEFINED
      *    ELEMENT OR GROUP.
      * 
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
               GO TO RESTRICT-CLEAR-PAREN.
           IF WORK-AREA IS EQUAL TO "(" 
               ADD 1 TO OUT-SSCHR-LEFT-PAREN
               GO TO RESTRICT-20
           END-IF.
           PERFORM IDEN-SUB THRU IDEN-EXIT. 
           IF SKIP-FLAG IS EQUAL TO "S" 
               GO TO RESTRICT-CLEAR-PAREN.
           MOVE FIND-CATNAME TO OUT-SSCHR-ID1.
           MOVE FIND-ALIAS-NO TO OUT-SSCHR-A1ID.
           MOVE QUAL-CATNAME-ARRAY TO OUT-SSCHR-ANQUAL. 
           MOVE SUBSCRIPT TO OUT-SSCHR-SUBSCRIPT1.
           IF EOF 
               GO TO RESTRICT-CLEAR-PAREN.
      * 
      *    PROCESS RELATIONAL OPERATOR
      * 
           IF WORK-AREA IS EQUAL TO "EQ"
               MOVE "EQ" TO OUT-SSCHR-ROP 
           ELSE 
               IF WORK-AREA IS EQUAL TO "NQ"
                 OR WORK-AREA IS EQUAL TO "NE"
                   MOVE "NQ" TO OUT-SSCHR-ROP 
               ELSE 
                   IF WORK-AREA IS EQUAL TO "GR"
                     OR WORK-AREA IS EQUAL TO "GT"
                       MOVE "GT" TO OUT-SSCHR-ROP 
                   ELSE 
                       IF WORK-AREA IS EQUAL TO "LS"
                         OR WORK-AREA IS EQUAL TO "LT"
                           MOVE "LT" TO OUT-SSCHR-ROP 
                       ELSE 
                           IF WORK-AREA IS EQUAL TO "GQ"
                             OR WORK-AREA IS EQUAL TO "GE"
                               MOVE "GE" TO OUT-SSCHR-ROP 
                           ELSE 
                               IF WORK-AREA IS EQUAL TO "LQ"
                                 OR WORK-AREA IS EQUAL TO "LE"
                                   MOVE "LE" TO OUT-SSCHR-ROP 
                               ELSE 
                                   MOVE MSG-305 TO STD-REPORT-REC 
                                   GO TO RESTRICT-ERROR-10
                               END-IF 
                           END-IF 
                       END-IF 
                   END-IF 
               END-IF 
           END-IF.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
               GO TO RESTRICT-CLEAR-PAREN.
      * 
      *    PROCESS 2ND IDENTIFIER WHICH MAY BE A PREVIOUSLY DEFINED 
      *    ELEMENT OR GROUP, A COBOL DATA NAME WHICH HAS NOT BEEN 
      *    PREVIOUSLY DEFINED, OR A LITERAL.
      * 
           MOVE "T" TO MAY-BE-COBOL-NAME. 
           MOVE WORK-AREA TO OUT-SSCHR-ID2. 
           PERFORM IDEN-SUB THRU IDEN-EXIT. 
           MOVE SPACE TO MAY-BE-COBOL-NAME. 
           IF SKIP-FLAG IS EQUAL TO "S" 
               GO TO RESTRICT-CLEAR-PAREN.
           IF FIND-CATNAME IS NOT EQUAL TO SPACE
               MOVE FIND-CATNAME TO OUT-SSCHR-ID2 
               MOVE FIND-ALIAS-NO TO OUT-SSCHR-A2ID 
               MOVE QUAL-CATNAME-ARRAY TO OUT-SSCHR-BNQUAL
           END-IF.
           MOVE SUBSCRIPT TO OUT-SSCHR-SUBSCRIPT2.
       RESTRICT-40. 
           MOVE "05" TO OUT-FIELD-TYPE. 
           ADD 1 TO STRUCT-COUNT. 
           MOVE STRUCT-COUNT TO OUT-STCR. 
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
               CALL "WRKFOUT" 
               GO TO RESTRICT-CLEAR-PAREN 
           END-IF.
           IF WORK-AREA IS EQUAL TO ")" 
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
               ADD 1 TO OUT-SSCHR-RIGHT-PAREN 
               GO TO RESTRICT-40
           END-IF.
      * 
      *    PROCESS LOGICAL OPERATOR 
      * 
           IF WORK-AREA IS EQUAL TO "AND" 
             OR WORK-AREA IS EQUAL TO "OR"
             OR WORK-AREA IS EQUAL TO "XOR" 
               MOVE WORK-AREA TO OUT-SSCHR-LOP
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
               IF WORK-AREA IS EQUAL TO "NOT" 
                   IF OUT-SSCHR-LOP IS EQUAL TO "OR"
                       MOVE "NOT" TO OUT-SSCHR-LOP (3 : END)
                   ELSE 
                       MOVE "NOT" TO OUT-SSCHR-LOP (4 : END)
                   END-IF 
                   PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
               END-IF 
               CALL "WRKFOUT" 
               MOVE SPACES TO OUT-SSCHR-EXP-AREA
               MOVE ZERO TO OUT-SSCHR-LEFT-PAREN, OUT-SSCHR-RIGHT-PAREN 
               GO TO RESTRICT-30
           END-IF.
           CALL "WRKFOUT".
           GO TO RESTRICT-CLEAR-PAREN.
       RESTRICT-ERROR.
           MOVE MSG-85 TO STD-REPORT-REC. 
       RESTRICT-ERROR-10. 
           PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT. 
           MOVE "S" TO SKIP-FLAG. 
       RESTRICT-CLEAR-PAREN.
           MOVE SPACE TO PAREN-TERM.
       RESTRICT-EXIT. 
           EXIT.
  
      ******************************************************************
      * 
      *    RN-SUBROUTINE THRU RN-EXIT 
      * 
      *    SCANS RN CLAUSE.  INITIALIZES RELATION-NAME.  IF RELATION
      *    DESCRIPTION ENTRY CONTAINS RESTRICT CLAUSES, CALL
      *    RESTRICT-SUB TO PROCESS EACH RESTRICT CLAUSE AND TO
      *    WRITE OUT-SSCHR-RNAME-REC AND AS MANY OUT-SSCHR-EXP-REC'S
      *    AS NECESSARY.  ELSE WRITE OUT-SSCHR-RNAME-REC. 
      * 
      *    ON INPUT 
      *    WORK-AREA = "RN" 
      * 
      *    ON OUTPT 
      *    IF NO ERROR
      *        WORK-AREA = 1ST TOKEN AFTER RELATION DESCRIPTION ENTRY 
      *          (ENTRY INCLUDES ".") 
      *        OUT-SSCHR-RNAME-REC, OUT-SSCHR-EXP-REC'S WRITTEN 
      *        SKIP-FLAG = SPACE
      *    IF ERROR AND REST OF RN CLAUSE MUST BE SKIPPED 
      *        SKIP-FLAG = "S"
      * 
      ******************************************************************
  
       RN-SUBROUTINE. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF WORK-AREA IS EQUAL TO "IS"
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
               GO TO RN-EXIT. 
           MOVE WORK-AREA TO RELATION-NAME. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF WORK-AREA IS EQUAL TO "RESTRICT"
               GO TO RN-10. 
           ADD 1 TO STRUCT-COUNT. 
           MOVE STRUCT-COUNT TO OUT-STCR. 
           MOVE "02" TO OUT-FIELD-TYPE. 
           MOVE SPACES TO OUT-FILLER. 
           MOVE RELATION-NAME TO OUT-SSCHR-RNAME. 
           CALL "WRKFOUT".
           IF WORK-AREA IS EQUAL TO "." 
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
           ELSE 
               MOVE MSG-10 TO STD-REPORT-REC
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
           END-IF.
           GO TO RN-EXIT. 
       RN-10. 
           IF WORK-AREA IS EQUAL TO "RESTRICT"
               PERFORM RESTRICT-SUB THRU RESTRICT-EXIT
               IF SKIP-FLAG IS EQUAL TO "S" 
                   GO TO RN-EXIT
               END-IF 
               IF EOF 
                   GO TO RN-EXIT
               END-IF 
               IF WORK-AREA IS EQUAL TO "." 
                   PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
                   GO TO RN-EXIT
               END-IF 
               GO TO RN-10
           END-IF.
       RN-EXIT. 
           EXIT.
  
      ******************************************************************
      * 
      *    SCAN THRU SCAN-EXIT
      * 
      *    COPY NEXT TOKEN TO WORK-AREA 
      * 
      *    ON INPUT 
      *    SUB-LINE (IN-SUB) = 1ST CHARACTER OF TOKEN 
      *    IF "(" OR ")" IS A TOKEN IN ITSELF 
      *        PAREN-TERM = "T" 
      *    IF "(" OR ")" IS PART OF A TOKEN, FOR EXAMPLE, X(10) 
      *        PAREN-TERM = SPACE 
      * 
      *    ON OUTPUT
      *    SUB-LINE (IN-SUB) = 1ST CHARACTER AFTER TOKEN
      *    WORK-AREA (1 : WK-SUB) = TOKEN 
      *    NON-LITERAL TOKEN MAY BE (, ), (IF PAREN-TERM = "T"), PERIOD 
      *    (IF PERIOD FOLLOWED BY SPACE IS ENCOUNTERED), OR SERIES OF 
      *    CHARACTERS TERMINATED BY ONE OF THE PREVIOUS SPECIAL 
      *    CHARACTERS OR SPACE.  IF THE TOKEN IS A SERIES OF CHARACTERS 
      *    TERMINATED BY (, ), OR PERIOD, THE TERMINATING 
      *    CHARACTER WILL NOT BE PART OF THE TOKEN, BUT WILL BE RETURNED
      *    AS THE TOKEN BY THE NEXT CALL TO SCAN. 
      * 
      ******************************************************************
  
       SCAN.
           IF OUTSTANDING-PERIOD IS EQUAL TO "."
               MOVE "." TO WORK-AREA
               MOVE SPACE TO OUTSTANDING-PERIOD 
               GO TO SCAN-EXIT
           END-IF.
           IF READ-END-SW IS EQUAL TO "E" 
               MOVE "E" TO END-SW 
               GO TO SCAN-EXIT
           END-IF.
           MOVE 1 TO WK-SUB.
           MOVE SPACES TO WORK-AREA.
           IF SUB-LINE (IN-SUB) IS EQUAL TO QUOTE 
               GO TO SCAN-LIT.
           MOVE SUB-LINE (IN-SUB) TO WORKA (WK-SUB).
           IF PAREN-TERM IS EQUAL TO "T"
               IF SUB-LINE (IN-SUB) IS EQUAL TO "(" 
                 OR SUB-LINE (IN-SUB) IS EQUAL TO ")" 
                   ADD 1 TO IN-SUB
                   IF IN-SUB IS GREATER THAN 72 
                       PERFORM READ-SUBFIL THRU READ-SUBFIL-EXIT
                   END-IF 
                   GO TO SCAN-EXIT
               END-IF 
           END-IF.
           IF SUB-LINE (IN-SUB) IS EQUAL TO "." 
               ADD 1 TO IN-SUB
               IF IN-SUB IS GREATER THAN 72 
                   PERFORM READ-SUBFIL THRU READ-SUBFIL-EXIT
                   IF IN-SUB IS EQUAL TO 8
                       GO TO SCAN-EXIT
                   END-IF 
               END-IF 
               IF SUB-LINE (IN-SUB) IS EQUAL TO SPACE 
                   GO TO SCAN-EXIT
               END-IF 
               SUBTRACT 1 FROM IN-SUB 
           END-IF.
       SCAN-LOOP. 
           ADD 1 TO IN-SUB. 
           IF IN-SUB IS GREATER THAN 72 
               PERFORM READ-SUBFIL THRU READ-SUBFIL-EXIT
               IF IN-SUB IS EQUAL TO 8
                   GO TO SCAN-LOOP-END
               END-IF 
           END-IF.
           IF SUB-LINE (IN-SUB) IS EQUAL TO SPACE 
             OR SUB-LINE (IN-SUB) IS EQUAL TO "," 
             OR SUB-LINE (IN-SUB) IS EQUAL TO ";" 
               GO TO SCAN-LOOP-END
           END-IF.
           IF PAREN-TERM IS EQUAL TO "T"
               IF SUB-LINE (IN-SUB) IS EQUAL TO "(" 
                 OR SUB-LINE (IN-SUB) IS EQUAL TO ")" 
                   GO TO SCAN-LOOP-END
               END-IF 
           END-IF.
           IF SUB-LINE (IN-SUB) IS EQUAL TO "." 
               ADD 1 TO IN-SUB
               IF IN-SUB IS GREATER THAN 72 
                   PERFORM READ-SUBFIL THRU READ-SUBFIL-EXIT
                   IF IN-SUB IS EQUAL TO 8
                       MOVE "." TO OUTSTANDING-PERIOD 
                       GO TO SCAN-LOOP-END
                   END-IF 
               END-IF 
               IF SUB-LINE (IN-SUB) IS EQUAL TO SPACE 
                   MOVE "." TO OUTSTANDING-PERIOD 
                   GO TO SCAN-LOOP-END
               END-IF 
               ADD 1 TO WK-SUB
               MOVE "." TO WORKA (WK-SUB) 
               SUBTRACT 1 FROM IN-SUB 
               GO TO SCAN-LOOP
           END-IF.
           ADD 1 TO WK-SUB. 
           MOVE SUB-LINE (IN-SUB) TO WORKA (WK-SUB).
           GO TO SCAN-LOOP. 
       SCAN-LOOP-END. 
           IF WK-SUB IS GREATER THAN 30 
               MOVE MSG-25 TO STD-REPORT-REC
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
               MOVE 30 TO WK-SUB
               MOVE SPACES TO WORK-AREA (31 : END)
           END-IF.
           GO TO SCAN-EXIT. 
       SCAN-LIT.
           MOVE 0 TO CHAR-COUNT.
           MOVE SUB-LINE (IN-SUB) TO WORKA (WK-SUB).
       SCAN-LIT-LOOP. 
           ADD 1 TO IN-SUB WK-SUB.
           IF IN-SUB IS GREATER THAN 72 
               PERFORM READ-SUBFIL THRU READ-SUBFIL-EXIT
               IF READ-END-SW IS EQUAL TO "E" 
                 OR IN-SUB IS EQUAL TO 8
                   MOVE 6 TO IN-SUB 
                   MOVE QUOTE TO SUB-LINE (6) 
                   MOVE SPACE TO SUB-LINE (7) 
                   MOVE MSG-170 TO STD-REPORT-REC 
                   PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
               END-IF 
           END-IF.
           MOVE SUB-LINE (IN-SUB) TO WORKA (WK-SUB).
           IF SUB-LINE (IN-SUB) IS NOT EQUAL TO QUOTE 
               ADD 1 TO CHAR-COUNT
               IF CHAR-COUNT IS GREATER THAN 30 
                   MOVE MSG-165 TO STD-REPORT-REC 
                   PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
                   GO TO SCAN-LIT-DISCARD 
               END-IF 
               GO TO SCAN-LIT-LOOP
           END-IF.
           ADD 1 TO IN-SUB WK-SUB.
           IF IN-SUB IS GREATER THAN 72 
               PERFORM READ-SUBFIL THRU READ-SUBFIL-EXIT
               IF READ-END-SW IS EQUAL TO "E" 
                   MOVE SPACES TO SUB-LINE (8)
               END-IF 
           END-IF 
           IF SUB-LINE (IN-SUB) IS EQUAL TO QUOTE 
               ADD 1 TO CHAR-COUNT
               IF CHAR-COUNT IS GREATER THAN 30 
                   MOVE MSG-165 TO STD-REPORT-REC 
                   PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
                   GO TO SCAN-LIT-DISCARD-LOOP
               END-IF 
               MOVE SUB-LINE (IN-SUB) TO WORKA (WK-SUB) 
               GO TO SCAN-LIT-LOOP
           END-IF.
           SUBTRACT 1 FROM WK-SUB.
           GO TO SCAN-EXIT. 
       SCAN-LIT-DISCARD.
           MOVE QUOTE TO WORKA (WK-SUB).
       SCAN-LIT-DISCARD-LOOP. 
           ADD 1 TO IN-SUB. 
           IF IN-SUB IS GREATER THAN 72 
               PERFORM READ-SUBFIL THRU READ-SUBFIL-EXIT
               IF READ-END-SW IS EQUAL TO "E" 
                   GO TO SCAN-EXIT
               END-IF 
           END-IF.
           IF SUB-LINE (IN-SUB) IS NOT EQUAL TO QUOTE 
               GO TO SCAN-LIT-DISCARD-LOOP
           END-IF.
           ADD 1 TO IN-SUB. 
           IF IN-SUB IS GREATER THAN 72 
               PERFORM READ-SUBFIL THRU READ-SUBFIL-EXIT
               IF READ-END-SW IS EQUAL TO "E" 
                   GO TO SCAN-EXIT
               END-IF 
           END-IF.
           IF SUB-LINE (IN-SUB) IS EQUAL TO QUOTE 
               GO TO SCAN-LIT-DISCARD-LOOP
           END-IF.
       SCAN-EXIT. 
           EXIT.
  
  
      ******************************************************************
      * 
      *    SKIP THRU SKIP-EXIT. 
      * 
      *    SKIP TOKENS UNTIL END-OF-FILE OR UNTIL TOKEN IS EQUAL
      *    TO TOKEN IN SKIP-UNTIL-TOKEN ARRAY 
      * 
      *    ON INPUT 
      *    SKIP-UNTIL-TOKEN AND SKIP-UNTIL-TOKEN-COUNT SET UP 
      *    WORK-AREA = TOKEN WHICH WAS BEING PROCESSED WHEN ERROR WAS 
      *      ENCOUNTERED
      * 
      *    ON OUTPUT
      *    IF END-OF-FILE ENCOUNTERED BEFORE CORRECT TOKEN FOUND
      *        RETURNS TO SUB-END, NOT TO CALLER
      *    IF CORRECT TOKEN FOUND 
      *        WORK-AREA = CORRECT TOKEN
      * 
      ******************************************************************
  
       SKIP.
           PERFORM VARYING SKIP-SUB FROM 1 BY 1 
             UNTIL SKIP-SUB IS GREATER THAN SKIP-UNTIL-TOKEN-COUNT
               IF WORK-AREA IS EQUAL TO SKIP-UNTIL-TOKEN (SKIP-SUB) 
                   MOVE WORK-AREA TO SKIPPED-TO-KEYWORD 
                   MOVE MSG-40 TO STD-REPORT-REC
                   PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
                   MOVE SPACE TO SKIP-FLAG
                   GO TO SKIP-EXIT
               END-IF 
           END-PERFORM. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF END-SW IS NOT EQUAL TO "E"
               GO TO SKIP 
           ELSE 
               GO TO SUB-END
           END-IF.
       SKIP-EXIT. 
           EXIT.
  
  
      ******************************************************************
      * 
      *    SKIP-PAST-PERIOD THRU SKIP-PAST-PERIOD-EXIT
      * 
      *    SKIP TOKENS UNTIL PERIOD IS ENCOUNTERED.  THEN CALL
      *    GET-NEXT-TOKEN TO GET TOKEN AFTER PERIOD 
      * 
      *    ON INPUT 
      *    WORK-AREA = TOKEN WHICH WAS BEING PROCESSED WHEN ERROR WAS 
      *      ENCOUNTERED
      * 
      *    ON OUTPUT
      *    IF END-OF-FILE ENCOUNTERED BEFORE PERIOD FOUND 
      *        RETURNS TO SUB-END, NOT TO CALLER
      *    IF PERIOD FOUND
      *        WORK-AREA = 1ST TOKEN AFTER PERIOD 
      * 
      ******************************************************************
  
       SKIP-PAST-PERIOD.
           MOVE MSG-30 TO STD-REPORT-REC. 
           PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT. 
       SKIP-PAST-PERIOD-10. 
           IF WORK-AREA IS EQUAL TO "." 
               MOVE MSG-35 TO STD-REPORT-REC
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
               MOVE SPACE TO SKIP-FLAG
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
               IF EOF 
                   GO TO SUB-END
               END-IF 
               GO TO SKIP-PAST-PERIOD-EXIT
           END-IF.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO SUB-END. 
           GO TO SKIP-PAST-PERIOD-10. 
       SKIP-PAST-PERIOD-EXIT. 
           EXIT.
  
  
      ******************************************************************
      * 
      *    SPACER THRU SPACER-EXIT
      * 
      *    SPACE OVER BLANKS, COMMAS, AND SEMICOLONS.  CALL COMMENTER 
      *    TO PROCESS SCHEMA-STYLE COMMENTS.
      * 
      *    ON OUTPUT
      *    SUB-LINE (IN-SUB) = FIRST CHARACTER OF NEXT TOKEN
      * 
      ******************************************************************
  
       SPACER.
           IF SUB-LINE (IN-SUB) IS NOT EQUAL TO SPACE 
             AND SUB-LINE (IN-SUB) IS NOT EQUAL TO ","
             AND SUB-LINE (IN-SUB) IS NOT EQUAL TO ";"
               GO TO SPACER-10. 
           ADD 1 TO IN-SUB. 
           IF IN-SUB LESS THAN 73 GO TO SPACER. 
           PERFORM READ-SUBFIL THRU READ-SUBFIL-EXIT. 
           IF END-SW IS NOT EQUAL TO "E"
               GO TO SPACER 
           ELSE 
               GO TO SUB-END
           END-IF.
       SPACER-10. 
           IF SUB-IN (IN-SUB : 2) IS NOT EQUAL TO "/*"
               GO TO SPACER-EXIT. 
           ADD 2 TO IN-SUB. 
           IF IN-SUB IS GREATER THAN 72 
               PERFORM READ-SUBFIL THRU READ-SUBFIL-EXIT
               IF EOF 
                   GO TO SPACER-EXIT
               END-IF 
           END-IF.
           PERFORM COMMENTER THRU COMMENTER-EXIT. 
           IF NOT EOF 
               GO TO SPACER.
       SPACER-EXIT. 
           EXIT.
  
  
      ******************************************************************
      * 
      *    SYNC-SUB THRU SYNC-EXIT
      * 
      *    SCANS SYNCHRONIZED CLAUSE.  STORES "R" OR "L" IN HOLD-SYNC 
      * 
      *    ON INPUT 
      *    WORK-AREA = "SYNC" OR "SYNCHRONIZED" 
      * 
      *    ON OUTPUT
      *    IF NO ERROR
      *        WORK-AREA = 1ST TOKEN AFTER SYNCHRONIZED CLAUSE
      *        HOLD-SYNC = SET
      *        SKIP-FLAG = SPACE
      *    IF ERROR AND REST OF DATA DESCRIPTION MUST BE SKIPPED
      *        SKIP-FLAG = "S"
      * 
      ******************************************************************
  
       SYNC-SUB.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF WORK-AREA IS EQUAL TO "LEFT"
               MOVE "L" TO HOLD-SYNC
           ELSE 
               IF WORK-AREA IS EQUAL TO "RIGHT" 
                   MOVE "R" TO HOLD-SYNC
               ELSE 
                   MOVE MSG-250 TO STD-REPORT-REC 
                   PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
                   MOVE "S" TO SKIP-FLAG
                   GO TO SYNC-EXIT
               END-IF 
           END-IF.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
       SYNC-EXIT. 
           EXIT.
  
      ******************************************************************
      * 
      *    TITLE-SUB THRU TITLE-EXIT
      * 
      *    SCANS TITLE DIVISION, DETERMINES SCHEMA ORDINAL, 
      *    CALLS WRITE-ENTITY TO WRITE OUT-REC FOR SUBSCHEMA, 
      *    WRITES SCHEMA STRUCTURE RECORD 
      * 
      *    ON INPUT 
      *    WORK-AREA = "TITLE"
      * 
      *    ON OUTPUT
      *    IF NO ERROR
      *        WORK-AREA = 1ST TOKEN AFTER SS CLAUSE (CLAUSE
      *          CONTAINS ".")
      *        NOTE-CDCS-REC DESCRIBES SUBSCHEMA
      *        OUT-REC, OUT-SCHS-REC WRITTEN
      *        SKIP-FLAG = SPACE
      *    IF ERROR AND REST OF TITLE DIVISION AND SS CLAUSE MUST BE
      *      SKIPPED
      *        SKIP-FLAG = "S"
      * 
      ******************************************************************
  
       TITLE-SUB. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO SUB-END. 
           IF WORK-AREA IS NOT EQUAL TO "DIVISION"
               MOVE MSG-180 TO STD-REPORT-REC 
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
               MOVE "S" TO SKIP-FLAG
               GO TO TITLE-EXIT 
           END-IF.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO SUB-END. 
           IF WORK-AREA IS NOT EQUAL TO "." 
               MOVE MSG-10 TO STD-REPORT-REC
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
           ELSE 
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
               IF EOF 
                   GO TO SUB-END
               END-IF 
           END-IF.
           IF WORK-AREA IS NOT EQUAL TO "SS"
               MOVE MSG-185 TO STD-REPORT-REC 
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
               MOVE "S" TO SKIP-FLAG
               GO TO TITLE-EXIT 
           END-IF.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO SUB-END. 
           MOVE WORK-AREA TO SUBSCHEMA-NAME.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO SUB-END. 
           IF WORK-AREA IS NOT EQUAL TO "WITHIN"
               MOVE MSG-50 TO STD-REPORT-REC
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
               MOVE "S" TO SKIP-FLAG
               GO TO TITLE-EXIT 
           END-IF.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO SUB-END. 
           MOVE WORK-AREA TO SCHEMA-NAME. 
      * 
      *    FIND SCHEMA NAME ON IS-FILE TO DETERMINE SCHEMA ORDINAL
      * 
           MOVE "26" TO IS-ENTITY-TYPE. 
           MOVE SPACES TO IS-CDCS-NAME. 
           MOVE ZERO TO IS-SCHEMA-ORDINAL.
           START IS-FILE KEY IS GREATER THAN IS-ALTKEY
               INVALID KEY GO TO TITLE-20.
       TITLE-10.
           READ IS-FILE 
               AT END GO TO TITLE-20. 
           IF IS-CDCS-NAME IS NOT EQUAL TO SCHEMA-NAME
               GO TO TITLE-10.
      * 
      *    WRITE SUBSCHEMA ENTITY TO IS-FILE AND WORK-FILE
      * 
           MOVE IS-CATNAME TO SCHEMA-CATNAME. 
           MOVE IS-SCHEMA-ORDINAL TO SCHEMA-ORD.
           MOVE SPACE TO NOTE-EALIASOF-FLAG, OUT-EALIASOF-FLAG, 
             OUT-EALIASOF-NAME. 
           MOVE 0 TO OUT-99-GROUP, NOTE-99-GROUP. 
           ADD 1 TO STRUCT-COUNT. 
           MOVE STRUCT-COUNT TO OUT-STCR. 
           MOVE "24" TO IS-ENTITY-TYPE, NOTE-ENTRY-TYPE.
           MOVE SUBSCHEMA-NAME TO IS-CDCS-NAME. 
           PERFORM WRITE-ENTITY THRU WRITE-ENTITY-EXIT. 
           MOVE OUT-CATNAME TO SUBSCHEMA-CATNAME, NOTE-CATNAME. 
           MOVE SUBSCHEMA-NAME TO NOTE-CDCS-NAME. 
           MOVE "001" TO NOTE-CATEGORY-TYPE.
           ADD 1 TO SUBSCHEMA-ORD.
           MOVE SUBSCHEMA-ORD TO IS-SSCH-SSCH-ORDINAL.
           WRITE IS-SSCH-REC. 
      * 
      *    WRITE SCHEMA STRUCTURE RECORD TO WORK-FILE 
      * 
           MOVE "26" TO OUT-ENTRY-TYPE. 
           MOVE SPACES TO OUT-EALIASOF-FLAG, OUT-EALIASOF-NAME. 
           MOVE ZERO TO OUT-99-GROUP. 
           MOVE SCHEMA-CATNAME TO OUT-CATNAME.
           MOVE "300" TO OUT-CATEGORY-TYPE. 
           ADD 1 TO STRUCT-COUNT. 
           MOVE STRUCT-COUNT TO OUT-STCR. 
           MOVE SCHEMA-NAME TO OUT-CDCS-NAME. 
           MOVE "05" TO OUT-FIELD-TYPE. 
           MOVE SUBSCHEMA-CATNAME TO OUT-SCHS-CATNAME.
           MOVE "S" TO OUT-SCHS-CTYPE.
           MOVE SPACES TO OUT-SCHS-AVERS. 
           CALL "WRKFOUT".
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
               GO TO SUB-END. 
           IF WORK-AREA IS EQUAL TO "." 
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT
           ELSE 
               MOVE MSG-10 TO STD-REPORT-REC
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
           END-IF.
           GO TO TITLE-EXIT.
       TITLE-20.
           MOVE MSG-190 TO STD-REPORT-REC.
           PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT. 
           MOVE "S" TO SKIP-FLAG. 
       TITLE-EXIT.
           EXIT.
  
  
      ******************************************************************
      * 
      *    USAGE-SUB THRU USAGE-EXIT
      * 
      *    SCANS USAGE CLAUSE.  STORES USAGE IN HOLD-USAGE
      * 
      *    ON INPUT 
      *    WORK-AREA = "USAGE"
      * 
      *    ON OUTPUT
      *    IF NO ERROR
      *        WORK-AREA = 1ST TOKEN AFTER USAGE CLAUSE 
      *        HOLD-USAGE SET UP
      *        SKIP-FLAG = SPACE
      *    IF ERROR AND REST OF DATA DESCRIPTION MUST BE SKIPPED
      *        SKIP-FLAG = "S"
      * 
      ******************************************************************
  
       USAGE-SUB. 
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF WORK-AREA IS EQUAL TO "IS"
               PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
           IF EOF 
             OR WORK-AREA IS EQUAL TO "." 
               GO TO USAGE-EXIT.
           IF WORK-AREA IS EQUAL TO "COMPUTATIONAL" 
             OR WORK-AREA IS EQUAL TO "COMP"
               MOVE "COMP" TO HOLD-USAGE
               GO TO USAGE-10 
           END-IF.
           IF WORK-AREA IS EQUAL TO "COMPUTATIONAL-1" 
             OR WORK-AREA IS EQUAL TO "COMP-1"
               MOVE "COMP1" TO HOLD-USAGE 
               GO TO USAGE-10 
           END-IF.
           IF WORK-AREA IS EQUAL TO "COMPUTATIONAL-2" 
             OR WORK-AREA IS EQUAL TO "COMP-2"
               MOVE "COMP2" TO HOLD-USAGE 
               GO TO USAGE-10 
           END-IF.
           IF WORK-AREA IS EQUAL TO "DISPLAY" 
               MOVE "DISPLAY" TO HOLD-USAGE 
               GO TO USAGE-10 
           END-IF.
           IF WORK-AREA IS EQUAL TO "INDEX" 
               MOVE "INDEX" TO HOLD-USAGE 
               GO TO USAGE-10 
           END-IF.
           MOVE MSG-255 TO STD-REPORT-REC.
           PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT. 
           MOVE "S" TO SKIP-FLAG. 
           GO TO USAGE-EXIT.
       USAGE-10.
           PERFORM GET-NEXT-TOKEN THRU GET-NEXT-TOKEN-EXIT. 
       USAGE-EXIT.
           EXIT.
  
  
       USER-ROUTINE.
           GO TO USER-ROUTINE-XIT.
       USER-ROUTINE-XIT.
           EXIT.
  
      ******************************************************************
      * 
      *    WRITE-ATTRIBUTE THRU WRITE-ATTRIBUTE-EXIT
      * 
      *    WRITE OUT-ELEAT-REC FOR ELEMENT OR GROUP.
      * 
      *    ON INPUT 
      *    HOLD-ATTRIBUTE, LEVEL-TABLE, LV-SUB SET UP 
      * 
      *    ON OUTPUT
      *    OUT-ELEAT-REC WRITTEN
      * 
      ******************************************************************
  
       WRITE-ATTRIBUTE. 
           IF HOLD-ATTRIBUTE IS EQUAL TO SPACE
               GO TO WRITE-ATTRIBUTE-EXIT.
           MOVE LEVT-EALIASOF-FLAG (LV-SUB) TO OUT-EALIASOF-FLAG. 
           IF LEVT-GRP-ELE (LV-SUB) IS EQUAL TO "E" 
               MOVE "05" TO OUT-ENTRY-TYPE
               MOVE ZERO TO OUT-99-GROUP
           ELSE 
               MOVE "10" TO OUT-ENTRY-TYPE
               SUBTRACT LEVT-LEVEL-NO (LV-SUB) FROM 
                 99 GIVING OUT-99-GROUP 
           END-IF.
           MOVE LEVT-CATNAME (LV-SUB) TO OUT-CATNAME. 
           MOVE "210" TO OUT-CATEGORY-TYPE. 
           ADD 1 TO STRUCT-COUNT. 
           MOVE STRUCT-COUNT TO OUT-STCR. 
           MOVE LEVT-CDCS-NAME (LV-SUB) TO OUT-CDCS-NAME. 
           MOVE "05" TO OUT-FIELD-TYPE. 
           MOVE SPACE TO OUT-EALIASOF-NAME, OUT-FILLER. 
           MOVE HOLD-ATTRIBUTE TO OUT-ELEAT-ATTRIBUTE.
           CALL "WRKFOUT".
       WRITE-ATTRIBUTE-EXIT.
           EXIT.
  
      ******************************************************************
      * 
      *    WRITE-ENTITY THRU WRITE-ENTITY-EXIT
      * 
      *    DETERMINE A UNIQUE CATNAME FOR CDCS NAME.  WRITE OUT-REC 
      * 
      *    ON INPUT, THE FOLLOWING FIELDS ARE SET 
      *        OUT-EALIASOF-FLAG
      *        OUT-99-GROUP 
      *        OUT-STCR 
      *        OUT-EALIASOF-NAME
      *        IS-ALTKEY
      * 
      *    ON OUTPUT, THE FOLLOWING FIELDS ARE SET UP 
      *        OUT-ENTRY-TYPE 
      *        OUT-CATNAME
      *        OUT-CATEGORY-TYPE
      *        OUT-CDCS-NAME
      *        OUT-FIELD-TYPE 
      *        IS-PKEY
      *    OUT-REC IS WRITTEN.
      *    IS-REC IS SET UP.
      *    OUT-FILLER = SPACES
      * 
      *    LOGIC
      *    FORM IS-PKEY.  READ IS-FILE TO DETERMINE IF CATNAME ALREADY
      *    EXITS.  IF NOT, CALL GEN-NAME TO APPEND SEQUENCE NUMBER TO 
      *    HOPEFULLY GENERATE A UNIQUE CATNAME AND READ IS-FILE TO
      *    DETERMINE IF NEW CATNAME ALREADY EXISTS.  REPEAT UNTIL UNIQUE
      *    CATNAME IS GENERATED.  WRITE OUT-REC.
      * 
      ******************************************************************
  
       WRITE-ENTITY.
           MOVE IS-CDCS-NAME TO IS-CATNAME. 
           MOVE ZERO TO IS-SEQ-NO, IS-ALIAS-NO. 
           MOVE IS-ENTITY-TYPE TO OUT-ENTRY-TYPE. 
           MOVE "000" TO OUT-CATEGORY-TYPE. 
           MOVE IS-CDCS-NAME TO OUT-CDCS-NAME.
           MOVE "00" TO OUT-FIELD-TYPE. 
           MOVE "S" TO OUT-LANG-CODE. 
           MOVE SPACES TO OUT-FILLER. 
       WRITE-ENTITY-10. 
           START IS-FILE KEY IS EQUAL TO IS-PKEY
               INVALID KEY GO TO WRITE-ENTITY-20. 
           MOVE IS-CDCS-NAME TO CDCS-NAME.
           PERFORM GEN-NAME THRU GEN-NAME-EXIT. 
           MOVE CDCS-NAME TO IS-CATNAME.
           GO TO WRITE-ENTITY-10. 
       WRITE-ENTITY-20. 
           MOVE IS-CATNAME TO OUT-CATNAME.
           CALL "WRKFOUT".
       WRITE-ENTITY-EXIT. 
           EXIT.
  
      ******************************************************************
      * 
      *    WRITE-KEY-REC THRU WRITE-KEY-REC-EXIT
      * 
      *    READ ALL BLOCKS OF KEY-TBL.  FOR EACH ENTRY, CALL
      *    FIND-IDEN-CATNAME TO FIND CATNAME CORRESPONDING TO KEY NAME. 
      *    AND WRITE OUT-GRPS-KEY-REC.  IF NO CATNAME CAN BE FOUND, 
      *    THAT ENTRY IS SKIPPED, BUT THE SUCCEEDING ENTRIES ARE
      *    PROCESSED. 
      * 
      *    ON INPUT 
      *    KEY-TBL SET UP 
      *    KEY-OUT-REC SET UP 
      *    KEY-FIRST-BLOCK-PTR SET UP 
      * 
      *    ON OUTPUT
      *    OUT-GRPS-KEY-REC WRITTEN FOR EACH ENTRY
      *    KEY-TABLE-WAITING = SPACE
      *    KEY-TBL CMM BLOCKS RELEASED, IF ANY
      * 
      ******************************************************************
  
       WRITE-KEY-REC. 
           MOVE 1 TO KEY-SUB. 
           MOVE KEY-OUT-REC TO OUT-REC. 
           MOVE SPACE TO KEY-TABLE-WAITING, OUT-FILLER. 
           MOVE LEVT-CATNAME (1) TO FIND-RECORD-CATNAME.
           IF KEY-FIRST-BLOCK-PTR IS NOT EQUAL TO ZERO
               ENTER "C.CMMMV" USING KEY-FIRST-BLOCK-PTR, KEY-TBL.
       WRITE-KEY-REC-10.
           MOVE "05" TO IS-ENTITY-TYPE. 
           MOVE KEY-NAME (KEY-SUB) TO FIND-DATA-NAME. 
           MOVE KEY-QUAL-ARRAY (KEY-SUB) TO QUAL-NAME-ARRAY.
           PERFORM FIND-IDEN-CATNAME THRU FIND-IDEN-CATNAME-EXIT. 
           IF FIND-CATNAME IS EQUAL TO SPACE
               MOVE "10" TO IS-ENTITY-TYPE
               PERFORM FIND-IDEN-CATNAME THRU FIND-IDEN-CATNAME-EXIT
           END-IF.
           IF FIND-CATNAME IS EQUAL TO SPACE
               MOVE FIND-DATA-NAME TO UNKNOWN-SS-ITEM 
               MOVE MSG-265 TO STD-REPORT-REC 
               PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT
           ELSE 
               MOVE KEY-STCR (KEY-SUB) TO OUT-STCR
               MOVE KEY-ORDER (KEY-SUB) TO OUT-GRPS-KORDER
               MOVE FIND-CATNAME TO OUT-GRPS-KNAME
               MOVE FIND-ALIAS-NO TO OUT-GRPS-KALIAS
               CALL "WRKFOUT" 
           END-IF.
           ADD 1 TO KEY-SUB.
           IF KEY-SUB IS LESS THAN 21 
             AND KEY-NAME (KEY-SUB) IS NOT EQUAL TO SPACE 
               GO TO WRITE-KEY-REC-10.
           IF KEY-NEXT-BLOCK-PTR IS NOT EQUAL TO ZERO 
               ENTER "C.CMMMV" USING KEY-NEXT-BLOCK-PTR, KEY-TBL
               MOVE 1 TO KEY-SUB
               GO TO WRITE-KEY-REC-10 
           END-IF.
           PERFORM RELEASE-KEY-CMM THRU RELEASE-KEY-CMM-EXIT. 
       WRITE-KEY-REC-EXIT.
           EXIT.
  
      ******************************************************************
      * 
      *    WRITE-NOTE THRU WRITE-NOTE-EXIT
      * 
      *    IF "INCLUDE NOTES" WAS NOT SPECIFIED, IF SOURCE IS BEING 
      *    SKIPPED DUE TO AN ERROR, OR IF NO ENTITY HAS BEEN IDENTIFIED,
      *    EXIT.  SAVE CURRENT RECORD AREA.  FILL IN OUT-NOTE-REC 
      *    FROM NOTE-CDCS-REC AND HOLD-COMMENT.  WRITE OUT-NOTE-REC.
      *    RESTORE CURRENT RECORD AREA.  NOTE-CDCS-REC IS SET UP ON 
      *    THE ASSUMPTION THAT COMMENTS ARE PART OF OR FOLLOW ENTRIES 
      *    THAT THEY DESCRIBE.
      * 
      *    ON INPUT 
      *    NOTE-CDCS-REC DESCRIBES ENTRY WHICH THIS COMMENT DESCRIBES 
      *    HOLD-COMMENT CONTAINS COMMENT
      * 
      *    ON OUTPUT
      *    OUT-NOTE-REC WRITTEN TO WRKFILE
      * 
      ******************************************************************
  
       WRITE-NOTE.
           IF SKIP-FLAG IS EQUAL TO "S" 
             OR NOTE-ENTRY-TYPE IS EQUAL TO SPACE 
             OR INCLUDE-NOTES IS EQUAL TO SPACE 
               GO TO WRITE-NOTE-EXIT. 
           MOVE OUT-SSCHR-EXP-REC TO NOTE-HOLD-CDCS-REC.
           MOVE NOTE-ENTRY-TYPE TO OUT-ENTRY-TYPE.
           MOVE NOTE-EALIASOF-FLAG TO OUT-EALIASOF-FLAG.
           MOVE NOTE-99-GROUP TO OUT-99-GROUP.
           MOVE NOTE-CATNAME TO OUT-CATNAME.
           MOVE NOTE-CATEGORY-TYPE TO OUT-CATEGORY-TYPE.
           ADD 1 TO STRUCT-COUNT. 
           MOVE STRUCT-COUNT TO OUT-STCR. 
           MOVE NOTE-CDCS-NAME TO OUT-CDCS-NAME.
           MOVE "01" TO OUT-FIELD-TYPE. 
           MOVE SPACES TO OUT-FILLER. 
           MOVE HOLD-COMMENT TO OUT-NOTE. 
           CALL "WRKFOUT".
           MOVE NOTE-HOLD-CDCS-REC TO OUT-SSCHR-EXP-REC.
       WRITE-NOTE-EXIT. 
           EXIT.
  
      ******************************************************************
      * 
      *    WRITE-PARENT-STRUCTURE THRU WRITE-PARENT-STRUCTURE-EXIT
      * 
      *    WRITE OUT-GRPS-REC 
      * 
      *    ON INPUT 
      *    LEVEL-TABLE SET UP.
      *    LV-SUB IS INDEX OF CURRENT ELEMENT OR GROUP
      *    LV-SUB-M1 IS INDEX OF ITS PARENT 
      *    HOLD-STRUCTURE, ALIAS-NO, SAVE-STRUCT SET UP 
      * 
      *    ON OUTPUT
      *    OUT-GRPS-REC WRITTEN 
      * 
      ******************************************************************
  
       WRITE-PARENT-STRUCTURE.
           MOVE LEVT-EALIASOF-FLAG (LV-SUB-M1) TO OUT-EALIASOF-FLAG.
           MOVE LEVT-CATNAME (LV-SUB-M1) TO OUT-CATNAME.
           MOVE "300" TO OUT-CATEGORY-TYPE. 
           MOVE SAVE-STRUCT TO OUT-STCR.
           MOVE LEVT-CDCS-NAME (LV-SUB-M1) TO OUT-CDCS-NAME.
           MOVE "05" TO OUT-FIELD-TYPE. 
           MOVE SPACES TO OUT-EALIASOF-NAME, OUT-FILLER.
           MOVE LEVT-CATNAME (LV-SUB) TO OUT-GRPS-CATNAME.
           MOVE ALIAS-NO TO OUT-GRPS-ALIAS. 
           MOVE HOLD-STRUCTURE TO OUT-GRPS-STRUCTURE. 
           IF LV-SUB IS EQUAL TO 2
               MOVE "13" TO OUT-ENTRY-TYPE
               MOVE 0 TO OUT-99-GROUP 
           ELSE 
               MOVE "10" TO OUT-ENTRY-TYPE
               SUBTRACT LEVT-LEVEL-NO (LV-SUB-M1) FROM
                   99 GIVING OUT-99-GROUP 
           END-IF.
           CALL "WRKFOUT".
       WRITE-PARENT-STRUCTURE-EXIT. 
           EXIT.
  
      ******************************************************************
      * 
      *    WRITE-PREVIOUS-DATA THRU WRITE-PREVIOUS-DATA-EXIT
      * 
      *    DETERMINE IF PREVIOUS ITEM, POINTED TO BY LV-SUB, IS AN
      *    ELEMENT OR GROUP.  IF PREVIOUS ITEM IS NAMED "FILLER"
      *    CALL PIC-LENGTH TO DETERMINE LENGTH OF ITEM BASED ON 
      *    ITS PICTURE, CALL WRITE-PARENT-STRUCTURE TO WRITE
      *    OUT-GRPS-REC, AND EXIT.  PROCESS OTHER ELEMENTS AND
      *    GROUPS AS FOLLOWS: 
      * 
      *    ELEMENT WITH LEVEL 88 INFORMATION OR GROUP 
      * 
      *    CREATE A NEW ENTITY.  IF ITEM IS A NONREPEATING GROUP, OR
      *    IF IT REDEFINES ANOTHER SUBSCHEMA ITEM, IT WILL NOT BE 
      *    AN EALIAS OF A SCHEMA ITEM.  OTHERWISE, FIND ITS 
      *    CORRESPONDING SCHEMA ITEM, AND MAKE IT THE EALIAS OF 
      *    THAT SCHEMA ITEM.
      * 
      *    ELEMENT WITH NO LEVEL 88 INFO THAT REDEFINES ANOTHER ITEM
      * 
      *    ITEM HAS NO CORRESPONDING SCHEMA ITEM. 
      *    SCAN IS-FILE FOR ELEMENT OF THE SAME NAME AND NO LEVEL 88
      *    INFO.  EITHER USE THE ENTITY, USE AN EXISTING ALIAS OF 
      *    THE ENTITY, OR CREATE A NEW ALIAS OF THE ENTITY. 
      * 
      *    ELEMENT WITH NO LEVEL 88 INFO THAT DOES NOT REDEFINE 
      *    ANOTHER SUBSCHEMA ITEM.
      * 
      *    SCAN IS-FILE FOR CORRESPONDING SCHEMA ITEM.  EITHER USE
      *    THE ENTITY, USE AN EXISTING ALIAS OF THE ENTITY, OR CREATE 
      *    A NEW ALIAS OF THE ENTITY. 
      * 
      *    ON INPUT 
      *    LV-SUB, LV-SUB-M1, LEVEL-TABLE SET UP
      *    SCHEMA-RECORD-CATNAME SET UP 
      * 
      *    ON OUTPUT
      *    DATA-ITEM-WAITING = SPACE
      *    IF ERROR AND MSG-40 (SCAN RESUMES MSG) SHOULD BE ISSUED
      *        SKIP-FLAG = "S".  NO SKIPPING WILL TAKE PLACE. 
      * 
      ******************************************************************
  
       WRITE-PREVIOUS-DATA. 
           MOVE SPACE TO SCHEMA-ITEM-FOUND, DATA-ITEM-WAITING.
      * 
      *    DETERMINE IF ITEM IS ELEMENT OR GROUP
      * 
           IF LEVEL-NO IS EQUAL TO 66 
             OR LEVEL-NO IS EQUAL TO 88 
               MOVE "E" TO LEVT-GRP-ELE (LV-SUB)
           ELSE 
               IF LEVEL-NO IS GREATER THAN LEVT-LEVEL-NO (LV-SUB) 
                   MOVE "G" TO LEVT-GRP-ELE (LV-SUB)
               ELSE 
                   MOVE "E" TO LEVT-GRP-ELE (LV-SUB)
               END-IF 
           END-IF.
           IF LEVT-CDCS-NAME (LV-SUB) IS EQUAL TO "FILLER"
               PERFORM PIC-LENGTH THRU PIC-LENGTH-EXIT
               IF SKIP-FLAG IS EQUAL TO "S" 
                   GO TO WRITE-PREVIOUS-DATA-EXIT 
               END-IF 
               MOVE SPACE TO LEVT-CATNAME (LV-SUB), 
                 LEVT-EALIASOF-FLAG (LV-SUB)
               MOVE ZERO TO ALIAS-NO
               PERFORM WRITE-PARENT-STRUCTURE THRU
                 WRITE-PARENT-STRUCTURE-EXIT
               GO TO WRITE-PREVIOUS-DATA-EXIT 
           END-IF.
           IF REDEFINES-ITEM IS EQUAL TO "T"
               GO TO WRITE-PREVIOUS-DATA-20.
      * 
      *    FIND NAME OF CORRESPONDING SCHEMA ITEM 
      * 
           MOVE "05" TO ENTITY-TYPE.
           MOVE "N" TO NEW-OLD-NAME-FLAG. 
           MOVE LEVT-CDCS-NAME (LV-SUB) TO NAME-TO-MATCH. 
           PERFORM FIND-AD-ENTRY THRU FIND-AD-ENTRY-EXIT. 
           IF AD-SUB IS EQUAL TO ZERO 
               MOVE NAME-TO-MATCH TO IS-CDCS-NAME 
           ELSE 
               MOVE AD-OLD-NAME (AD-SUB) TO IS-CDCS-NAME
           END-IF.
      * 
      *    READ CORRESPONDING SCHEMA ITEM ON IS-FILE. 
      * 
           IF LEVT-GRP-ELE (LV-SUB) IS EQUAL TO "E" 
               MOVE "05" TO IS-ENTITY-TYPE
           ELSE 
               MOVE "10" TO IS-ENTITY-TYPE
           END-IF.
           MOVE SCHEMA-ORD TO IS-SCHEMA-ORDINAL.
           MOVE IS-ALTKEY TO HOLD-IS-ALTKEY.
           START IS-FILE KEY IS EQUAL TO IS-ALTKEY
               INVALID KEY GO TO WRITE-PREVIOUS-DATA-20.
       WRITE-PREVIOUS-DATA-10.
           READ IS-FILE.
           IF IS-ALTKEY IS NOT EQUAL TO HOLD-IS-ALTKEY
               GO TO WRITE-PREVIOUS-DATA-20.
           IF IS-ELE-RECORD-CATNAME IS NOT EQUAL TO 
             SCHEMA-RECORD-CATNAME
               GO TO WRITE-PREVIOUS-DATA-10.
           MOVE "T" TO SCHEMA-ITEM-FOUND. 
       WRITE-PREVIOUS-DATA-20.
           IF LEVT-GRP-ELE (LV-SUB) IS EQUAL TO "G" 
               GO TO WRITE-PREVIOUS-GROUP.
      * 
      *    ELEMENTARY ITEM
      * 
           IF SCHEMA-ITEM-FOUND IS EQUAL TO SPACE 
             AND REDEFINES-ITEM IS EQUAL TO SPACE 
               GO TO WRITE-PREVIOUS-ERROR-EXIT
           END-IF.
           IF LEVEL-NO IS EQUAL TO 88 
      * 
      *    IF ELEMENT HAS LEVEL 88 INFO, IT MAY NOT USE OR BE THE ALIAS 
      *    OF ANOTHER ITEM, HENCE CALL WRITE-ENTITY AND WRITE-ATTRIBUTE 
      *    TO CREATE A NEW ENTITY.
      * 
               IF REDEFINES-ITEM IS EQUAL TO SPACE
                   MOVE "E" TO OUT-EALIASOF-FLAG, 
                     LEVT-EALIASOF-FLAG (LV-SUB), 
                     IS-ELE-EALIASOF-FLAG 
                   MOVE IS-CATNAME TO OUT-EALIASOF-NAME 
               ELSE 
                   MOVE SPACE TO OUT-EALIASOF-FLAG, 
                     OUT-EALIASOF-NAME, 
                     LEVT-EALIASOF-FLAG (LV-SUB), 
                     IS-ELE-EALIASOF-FLAG 
               END-IF 
               MOVE 0 TO OUT-99-GROUP 
               ADD 1 TO STRUCT-COUNT
               MOVE STRUCT-COUNT TO OUT-STCR
               MOVE "05" TO IS-ENTITY-TYPE
               MOVE SCHEMA-ORD TO IS-SCHEMA-ORDINAL 
               MOVE LEVT-CDCS-NAME (LV-SUB) TO IS-CDCS-NAME 
               PERFORM WRITE-ENTITY THRU WRITE-ENTITY-EXIT
               MOVE OUT-CATNAME TO LEVT-CATNAME (LV-SUB)
               MOVE 0 TO ALIAS-NO 
               MOVE "T" TO IS-ELE-LEVEL88 
               PERFORM WRITE-ATTRIBUTE THRU WRITE-ATTRIBUTE-EXIT
               GO TO WRITE-PREVIOUS-DATA-50 
           END-IF.
           IF REDEFINES-ITEM IS EQUAL TO SPACE
               GO TO WRITE-PREVIOUS-DATA-25.
      * 
      *    ITEM REDEFINES ANOTHER ITEM, THEREFORE IT HAS
      *    NO CORRESPONDING SCHEMA ITEM.  DETERMINE ENTITY OF THE SAME
      *    NAME FOR PREVIOUS ITEM TO USE OR BE ALIAS OF.
      * 
           MOVE "05" TO IS-ENTITY-TYPE. 
           MOVE SCHEMA-ORD TO IS-SCHEMA-ORDINAL.
           MOVE LEVT-CDCS-NAME (LV-SUB) TO IS-CDCS-NAME.
           MOVE IS-ALTKEY TO HOLD-IS-ALTKEY.
           MOVE ZERO TO ALIAS-NO. 
           MOVE -1 TO ALIAS-WITH-SAME-ATT.
           MOVE SPACE TO HOLD-IS-CATNAME. 
           START IS-FILE KEY IS EQUAL TO IS-ALTKEY
               INVALID KEY GO TO WRITE-REDEFINES-20.
       WRITE-REDEFINES-10.
      * 
      *    FIRST PASS THROUGH IS-FILE DETERMINES CATNAME
      * 
           READ IS-FILE.
           IF IS-ALTKEY IS NOT EQUAL TO HOLD-IS-ALTKEY
               GO TO WRITE-REDEFINES-20.
           IF IS-ELE-LEVEL88 IS EQUAL TO "T"
               GO TO WRITE-REDEFINES-10.
           IF HOLD-IS-CATNAME IS EQUAL TO SPACE 
               MOVE IS-CATNAME TO HOLD-IS-CATNAME 
           END-IF.
           IF IS-CDCS-NAME IS EQUAL TO LEVT-CDCS-NAME (LV-SUB)
             AND IS-ELE-ATTRIBUTE IS EQUAL TO HOLD-ATTRIBUTE
               MOVE IS-ALIAS-NO TO ALIAS-WITH-SAME-ATT
               MOVE IS-CATNAME TO HOLD-IS-CATNAME 
               GO TO WRITE-REDEFINES-20 
           END-IF.
           GO TO WRITE-REDEFINES-10.
       WRITE-REDEFINES-20.
      * 
      *    NO SUITABLE ENTRY FOUND FOR PREVIOUS ITEM TO USE OR BE ALIAS 
      *    OF.  CREATE NEW ENTITY.
      * 
           IF HOLD-IS-CATNAME IS EQUAL TO SPACE 
               MOVE SPACE TO OUT-EALIASOF-FLAG, OUT-EALIASOF-NAME,
                 LEVT-EALIASOF-FLAG (LV-SUB)
               MOVE ZERO TO OUT-99-GROUP
               ADD 1 TO STRUCT-COUNT
               MOVE STRUCT-COUNT TO OUT-STCR
               MOVE "05" TO IS-ENTITY-TYPE
               MOVE SCHEMA-ORD TO IS-SCHEMA-ORDINAL 
               MOVE LEVT-CDCS-NAME (LV-SUB) TO IS-CDCS-NAME 
               PERFORM WRITE-ENTITY THRU WRITE-ENTITY-EXIT
               MOVE OUT-CATNAME TO LEVT-CATNAME (LV-SUB)
               PERFORM WRITE-ATTRIBUTE THRU WRITE-ATTRIBUTE-EXIT
               GO TO WRITE-PREVIOUS-DATA-50 
           END-IF.
      * 
      *    THE CATNAME OF A SUITABLE ENTITY HAS BEEN FOUND FOR THE
      *    PREVIOUS ITEM TO USE OR BE ALIAS OF. 
      * 
           MOVE ZERO TO SEQ-NO, ALIAS-NO. 
           MOVE HOLD-IS-CATNAME TO IS-CATNAME.
           MOVE ZERO TO IS-SEQ-NO, IS-ALIAS-NO. 
           START IS-FILE KEY IS EQUAL TO IS-PKEY
               INVALID KEY GO TO WRITE-PREVIOUS-DATA-40.
       WRITE-REDEFINES-30.
      * 
      *    SECOND PASS THROUGH IS-FILE DETERMINES HIGHEST VALUES
      *    OF IS-SEQ-NO AND IS-ALIAS-NO FOR THAT CATNAME. 
      * 
           READ IS-FILE 
               AT END GO TO WRITE-PREVIOUS-DATA-40. 
           IF IS-CATNAME IS NOT EQUAL TO HOLD-IS-CATNAME
               GO TO WRITE-PREVIOUS-DATA-40.
           IF IS-SEQ-NO IS GREATER THAN SEQ-NO
               MOVE IS-SEQ-NO TO SEQ-NO.
           IF IS-ALIAS-NO IS GREATER THAN ALIAS-NO
               MOVE IS-ALIAS-NO TO ALIAS-NO.
           GO TO WRITE-REDEFINES-30.
       WRITE-PREVIOUS-DATA-25.
      * 
      *    PREVIOUS ITEM DOES NOT REDEFINE ANOTHER SUBSCHEMA ITEM.
      *    CORRESPONDING SCHEMA ITEM HAS ALREADY BEEN READ.  DETERMINE
      *    IF PREVIOUS ITEM SHOULD USE SCHEMA ITEM, EXISTING ALIAS OF 
      *    SCHEMA ITEM, OR CREATE NEW ALIAS OF SCHEMA ITEM. 
      * 
           MOVE IS-CATNAME TO HOLD-IS-CATNAME.
           MOVE ZERO TO SEQ-NO, IS-SEQ-NO, ALIAS-NO, IS-ALIAS-NO, 
             IS-SEQ-NO. 
           MOVE -1 TO ALIAS-WITH-SAME-ATT.
           START IS-FILE KEY IS EQUAL TO IS-PKEY. 
       WRITE-PREVIOUS-DATA-30.
           READ IS-FILE 
               AT END GO TO WRITE-PREVIOUS-DATA-40. 
           IF IS-CATNAME IS NOT EQUAL TO HOLD-IS-CATNAME
               GO TO WRITE-PREVIOUS-DATA-40.
           IF IS-SEQ-NO IS GREATER THAN SEQ-NO
               MOVE IS-SEQ-NO TO SEQ-NO.
           IF IS-ALIAS-NO IS GREATER THAN ALIAS-NO
               MOVE IS-ALIAS-NO TO ALIAS-NO.
           IF IS-CDCS-NAME IS EQUAL TO LEVT-CDCS-NAME (LV-SUB)
             AND IS-ELE-ATTRIBUTE IS EQUAL TO HOLD-ATTRIBUTE
               MOVE ALIAS-NO TO ALIAS-WITH-SAME-ATT.
           GO TO WRITE-PREVIOUS-DATA-30.
       WRITE-PREVIOUS-DATA-40.
           MOVE HOLD-IS-CATNAME TO IS-CATNAME, LEVT-CATNAME (LV-SUB). 
           IF ALIAS-WITH-SAME-ATT IS LESS THAN ZERO 
      * 
      *    CREATE NEW ALIAS OF SCHEMA ITEM. 
      * 
               ADD 1 TO ALIAS-NO
               MOVE ZERO TO IS-SEQ-NO, IS-ALIAS-NO
               START IS-FILE KEY IS EQUAL TO IS-PKEY
               READ IS-FILE 
               MOVE "05" TO OUT-ENTRY-TYPE
               MOVE IS-ELE-EALIASOF-FLAG TO OUT-EALIASOF-FLAG 
               MOVE ZERO TO OUT-99-GROUP
               MOVE IS-CATNAME TO OUT-CATNAME 
               MOVE "211" TO OUT-CATEGORY-TYPE
               ADD 1 TO STRUCT-COUNT
               MOVE STRUCT-COUNT TO OUT-STCR
               MOVE IS-CDCS-NAME TO OUT-CDCS-NAME 
               MOVE "05" TO OUT-FIELD-TYPE
               MOVE SPACE TO OUT-EALIASOF-NAME, OUT-FILLER
               MOVE HOLD-ATTRIBUTE TO OUT-ELEAL-ATTRIBUTE 
               MOVE ALIAS-NO TO OUT-ELEAL-CATEGORY-LINE 
               IF LEVT-CDCS-NAME (LV-SUB) IS NOT EQUAL TO OUT-CDCS-NAME 
                   MOVE LEVT-CDCS-NAME (LV-SUB) TO OUT-ELEAL-ADATANAM 
               ELSE 
                   MOVE SPACES TO OUT-ELEAL-ADATANAM
               END-IF 
               CALL "WRKFOUT" 
           ELSE 
      * 
      *    USE SCHEMA ITEM OR EXISTING ALIAS OF SCHEMA ITEM.
      * 
               MOVE ALIAS-WITH-SAME-ATT TO ALIAS-NO 
           END-IF.
           MOVE ALIAS-NO TO IS-ALIAS-NO.
           ADD 1, SEQ-NO GIVING IS-SEQ-NO.
           MOVE "05" TO IS-ENTITY-TYPE. 
           MOVE SCHEMA-ORD TO IS-SCHEMA-ORDINAL.
           MOVE LEVT-CDCS-NAME (LV-SUB) TO IS-CDCS-NAME.
           MOVE SPACE TO IS-ELE-EALIASOF-FLAG, IS-ELE-LEVEL88.
       WRITE-PREVIOUS-DATA-50.
           MOVE SUBSCHEMA-ORD TO IS-ELE-SSCH-ORDINAL. 
           MOVE LEVT-CATNAME (1) TO IS-ELE-RECORD-CATNAME.
           MOVE LEVT-CATNAME (LV-SUB-M1) TO IS-ELE-PARENT-CATNAME.
           MOVE LEVT-LEVEL-NO (LV-SUB) TO IS-ELE-LEVEL-NO.
           MOVE HOLD-ATTRIBUTE TO IS-ELE-ATTRIBUTE. 
           MOVE SPACE TO IS-ELE-PRO-VAL.
           WRITE IS-ELE-REC.
           PERFORM WRITE-PARENT-STRUCTURE THRU
             WRITE-PARENT-STRUCTURE-EXIT. 
           GO TO WRITE-PREVIOUS-DATA-EXIT.
       WRITE-PREVIOUS-ERROR-EXIT. 
           MOVE "***ERROR***" TO LEVT-CATNAME (LV-SUB). 
           MOVE SPACE TO DATA-ITEM-WAITING. 
           MOVE HOLD-IS-CDCS-NAME TO UNKNOWN-ITEM.
           MOVE MSG-240 TO STD-REPORT-REC.
           PERFORM PROCESS-ERROR THRU PROCESS-ERROR-EXIT. 
           MOVE "S" TO SKIP-FLAG. 
           GO TO WRITE-PREVIOUS-DATA-EXIT.
      * 
      *    GROUP ITEM 
      * 
       WRITE-PREVIOUS-GROUP.
      * 
      *    SET OUT-EALIASOF-FLAG = "E" BECAUSE ALL SUBSCHEMA GROUPS 
      *    MUST BE SORTED TOGETHER AFTER THE SCHEMA GROUPS (EVEN IF THEY
      *    DO NOT HAVE A CORRESPONDING SCHEMA GROUP) BECAUSE A
      *    SUBSCHEMA GROUP MAY REFERENCE ANOTHER SCHEMA GROUP.
      * 
           MOVE "E" TO OUT-EALIASOF-FLAG, LEVT-EALIASOF-FLAG (LV-SUB).
           IF SCHEMA-ITEM-FOUND IS EQUAL TO SPACE 
               IF OCCURS-TO IS NOT EQUAL TO SPACE 
                 AND REDEFINES-ITEM IS EQUAL TO SPACE 
                   GO TO WRITE-PREVIOUS-ERROR-EXIT
               END-IF 
      * 
      *    PREVIOUS ITEM IS NON-REPEATING GROUP WHICH DOES NOT APPEAR IN
      *    SCHEMA OR IT REDEFINES ANOTHER ITEM. 
      * 
               MOVE SPACE TO OUT-EALIASOF-NAME
           ELSE 
               MOVE IS-CATNAME TO OUT-EALIASOF-NAME 
           END-IF.
      * 
      *    CREATE ENTITY FOR GROUP
      * 
           SUBTRACT LEVT-LEVEL-NO (LV-SUB) FROM 99 GIVING OUT-99-GROUP. 
           ADD 1 TO STRUCT-COUNT. 
           MOVE STRUCT-COUNT TO OUT-STCR. 
           MOVE "10" TO IS-ENTITY-TYPE. 
           MOVE SCHEMA-ORD TO IS-SCHEMA-ORDINAL.
           MOVE LEVT-CDCS-NAME (LV-SUB) TO IS-CDCS-NAME.
           PERFORM WRITE-ENTITY THRU WRITE-ENTITY-EXIT. 
           MOVE OUT-CATNAME TO LEVT-CATNAME (LV-SUB). 
           MOVE SUBSCHEMA-ORD TO IS-GRP-SSCH-ORDINAL. 
           MOVE LEVT-CATNAME (1) TO IS-GRP-RECORD-CATNAME.
           MOVE LEVT-CATNAME (LV-SUB-M1) TO IS-GRP-PARENT-CATNAME.
           MOVE LEVT-LEVEL-NO (LV-SUB) TO IS-GRP-LEVEL-NO.
           WRITE IS-GRP-REC.
           PERFORM WRITE-ATTRIBUTE THRU WRITE-ATTRIBUTE-EXIT. 
           MOVE ZERO TO ALIAS-NO. 
           PERFORM WRITE-PARENT-STRUCTURE 
             THRU WRITE-PARENT-STRUCTURE-EXIT.
       WRITE-PREVIOUS-DATA-EXIT.
           EXIT.
  
      ******************************************************************
      * 
      *    WRITE-REALM THRU WRITE-REALM-EXIT
      * 
      *    CALL WRITE-ENTITY TO WRITE OUT-REC FOR REALM.
      *    WRITE IS-AREA-REC AND OUT-SSCHS-REC. 
      * 
      *    ON INPUT 
      *    IS-CDCS-NAME = REALM NAME
      *    OUT-EALIASOF-FLAG, OUT-EALIASOF-NAME SET UP
      * 
      *    ON OUTPUT
      *    OUT-REC, IS-AREA-REC, OUT-SSCHS-REC WRITTEN
      * 
      ******************************************************************
  
       WRITE-REALM. 
           MOVE ZERO TO OUT-99-GROUP. 
           ADD 1 TO STRUCT-COUNT. 
           MOVE STRUCT-COUNT TO OUT-STCR. 
           MOVE "22" TO IS-ENTITY-TYPE. 
           MOVE SCHEMA-ORD TO IS-SCHEMA-ORDINAL.
           PERFORM WRITE-ENTITY THRU WRITE-ENTITY-EXIT. 
           MOVE SUBSCHEMA-ORD TO IS-AREA-SSCH-ORDINAL.
           MOVE SPACE TO IS-AREA-MASTER, IS-AREA-XN-CATNAME.
           WRITE IS-AREA-REC. 
           MOVE "24" TO OUT-ENTRY-TYPE. 
           MOVE SPACES TO OUT-EALIASOF-FLAG, OUT-EALIASOF-NAME, 
             OUT-FILLER.
           MOVE OUT-CATNAME TO OUT-SSCHS-CATNAME. 
           MOVE ZERO TO OUT-99-GROUP. 
           MOVE SUBSCHEMA-CATNAME TO OUT-CATNAME. 
           MOVE "300" TO OUT-CATEGORY-TYPE. 
           ADD 1 TO STRUCT-COUNT. 
           MOVE STRUCT-COUNT TO OUT-STCR. 
           MOVE SUBSCHEMA-NAME TO OUT-CDCS-NAME.
           MOVE "05" TO OUT-FIELD-TYPE. 
           CALL "WRKFOUT".
       WRITE-REALM-EXIT.
           EXIT.
  
  
