*DECK DCDMS326
       IDENTIFICATION DIVISION. 
       PROGRAM-ID.   DMS326.
  
      ******************************************************************
      * 
      *    THIS MODULE PROCESSES THE GENERATION OF A CDCS (DMS-170) 
      *    SCHEMA.  ALL INPUT/OUTPUT IS DONE THROUGH A TEMPORARY EXIT 
      *    BACK TO "DMS300".
      * 
      ******************************************************************
  
       ENVIRONMENT DIVISION.
  
       CONFIGURATION SECTION. 
       SOURCE-COMPUTER.   CYBER.
       OBJECT-COMPUTER.   CYBER.
  
      ******************************************************************
      * 
       DATA DIVISION. 
  
  
      ******************************************************************
      * 
*CALL GENCS 
  
  
      ******************************************************************
      * 
       WORKING-STORAGE SECTION. 
*CALL DATAGEN 
  
      ******************************************************************
      * 
      * ITEMS SPECIFIC TO SCHEMA GENERATION.
  
      ******************************************************************
      * 
      * VALUES RELATING TO INDENTATION OF SCHEMA LINES. 
       01  INDENT-VALUES. 
           03  INDENT-INIT        PICTURE 99     VALUE 5. 
           03  INDENT-INC         PICTURE 99     VALUE 4. 
           03  INDENT-MAX         PICTURE 99     VALUE 40.
  
      ******************************************************************
      * 
      * FIELDS USED TO GENERATE TIME AND OPTION PHRASES OF "CALL DBP" 
      * CLAUSE. 
  
       01  CALL-FIELDS. 
           03  CALL-OPTION        PICTURE X(9). 
           03  CALL-TIME          PICTURE X(5). 
           03  PICK-IDX           PICTURE 99. 
  
      * SET TO "Y" IF CORRESPONDING FLAG SET IN OPTION FIELD OF 
      * PROCESS CATEGORY -- "N" IF NOT. 
      * 
       01  OPT-FLAGS. 
           03  OPT-C              PICTURE X.
           03  OPT-O              PICTURE X.
           03  OPT-R              PICTURE X.
           03  OPT-U              PICTURE X.
  
      ******************************************************************
      * 
      * FIELDS USED BY ELEM-DATA-DESCR. 
      * 
       01  ELEM-FIELDS. 
           03  CHECK-DBP          PICTURE X(32).
           03  ELEM-FORMAT        PICTURE X(3). 
           03  ELEM-LENGTH        PICTURE X(10).
           03  ELEM-PICTURE       PICTURE X(25).
           03  SAVE-ALIAS         PICTURE X(4). 
           03  SAVE-COL-OUT       PICTURE 99. 
           03  THRU-FLAG          PICTURE X.
  
      ******************************************************************
      * 
       01  MISCELLANEOUS. 
           03  SAVE-DUPES         PICTURE X.
           03  SAVE-USING         PICTURE X.
  
      ******************************************************************
      * 
      * LIST OF KEYWORDS/PHRASES USED IN DMS SCHEMA GENERATION. 
      * 
       01  KEYWORD-LIST.
           03  KW-ACCESS          PICTURE X(19)  VALUE
                                  "ACCESS-CONTROL LOCK".
           03  KW-ACCESS-LEN      PICTURE 99     VALUE 19.
           03  KW-ACTUAL          PICTURE X(9)   VALUE "IS ACTUAL". 
           03  KW-ACTUAL-LEN      PICTURE 99     VALUE 9. 
           03  KW-AFTER           PICTURE X(5)   VALUE "AFTER". 
           03  KW-AFTER-LEN       PICTURE 99     VALUE 5. 
           03  KW-ALLOWED         PICTURE X(7)   VALUE "ALLOWED". 
           03  KW-ALLOWED-LEN     PICTURE 99     VALUE 7. 
           03  KW-ALTERNATE       PICTURE X(9)   VALUE "ALTERNATE". 
           03  KW-ALTERNATE-LEN   PICTURE 99     VALUE 9. 
           03  KW-ALWAYS          PICTURE X(6)   VALUE "ALWAYS".
           03  KW-ALWAYS-LEN      PICTURE 99     VALUE 6. 
           03  KW-AREA            PICTURE X(7)   VALUE "AREA IS". 
           03  KW-AREA-LEN        PICTURE 99     VALUE 7. 
           03  KW-ASCII           PICTURE X(5)   VALUE "ASCII". 
           03  KW-ASCII-LEN       PICTURE 99     VALUE 5. 
           03  KW-BEFORE          PICTURE X(6)   VALUE "BEFORE".
           03  KW-BEFORE-LEN      PICTURE 99     VALUE 6. 
           03  KW-CALL            PICTURE X(4)   VALUE "CALL".
           03  KW-CALL-LEN        PICTURE 99     VALUE 4. 
           03  KW-CHAR            PICTURE X(9)   VALUE "CHARACTER". 
           03  KW-CHAR-LEN        PICTURE 99     VALUE 9. 
           03  KW-CHECK           PICTURE X(8)   VALUE "CHECK IS".
           03  KW-CHECK-LEN       PICTURE 99     VALUE 8. 
           03  KW-CLOSE           PICTURE X(5)   VALUE "CLOSE". 
           03  KW-CLOSE-LEN       PICTURE 99     VALUE 5. 
           03  KW-COBOL           PICTURE X(5)   VALUE "COBOL". 
           03  KW-COBOL-LEN       PICTURE 99     VALUE 5. 
           03  KW-COMPLEX         PICTURE X(7)   VALUE "COMPLEX". 
           03  KW-COMPLEX-LEN     PICTURE 99     VALUE 7. 
           03  KW-COMPRESSION     PICTURE X(11)  VALUE "COMPRESSION". 
           03  KW-COMPRESSION-LEN PICTURE 99     VALUE 11.
           03  KW-CONSTRAINT      PICTURE X(13)  VALUE "CONSTRAINT IS". 
           03  KW-CONSTRAINT-LEN  PICTURE 99     VALUE 13.
           03  KW-DATACON         PICTURE X(13)  VALUE "DATA CONTROL.". 
           03  KW-DATACON-LEN     PICTURE 99     VALUE 13.
           03  KW-DECIMAL         PICTURE X(7)   VALUE "DECIMAL". 
           03  KW-DECIMAL-LEN     PICTURE 99     VALUE 7. 
           03  KW-DECOD           PICTURE X(8)   VALUE "DECODING".
           03  KW-DECOD-LEN       PICTURE 99     VALUE 8. 
           03  KW-DECOMP          PICTURE X(13)  VALUE "DECOMPRESSION". 
           03  KW-DECOMP-LEN      PICTURE 99     VALUE 13.
           03  KW-DELETE          PICTURE X(6)   VALUE "DELETE".
           03  KW-DELETE-LEN      PICTURE 99     VALUE 6. 
           03  KW-DEPENDS         PICTURE X(10)  VALUE "DEPENDS ON".
           03  KW-DEPENDS-LEN     PICTURE 99     VALUE 10.
           03  KW-DISPLAY         PICTURE X(7)   VALUE "DISPLAY". 
           03  KW-DISPLAY-LEN     PICTURE 99     VALUE 7. 
           03  KW-DUPARE          PICTURE X(14)  VALUE "DUPLICATES ARE".
           03  KW-DUPARE-LEN      PICTURE 99     VALUE 14.
           03  KW-ENCOD           PICTURE X(8)   VALUE "ENCODING".
           03  KW-ENCOD-LEN       PICTURE 99     VALUE 8. 
           03  KW-EQ              PICTURE X(2)   VALUE "EQ".
           03  KW-EQ-LEN          PICTURE 99     VALUE 2. 
           03  KW-FIND            PICTURE X(4)   VALUE "FIND".
           03  KW-FIND-LEN        PICTURE 99     VALUE 4. 
           03  KW-FIRST           PICTURE X(5)   VALUE "FIRST". 
           03  KW-FIRST-LEN       PICTURE 99     VALUE 5. 
           03  KW-FIXED           PICTURE X(5)   VALUE "FIXED". 
           03  KW-FIXED-LEN       PICTURE 99     VALUE 5. 
           03  KW-FX-R-DEC        PICTURE X(18)  VALUE
                                  "FIXED REAL DECIMAL". 
           03  KW-FX-R-DEC-LEN    PICTURE 99     VALUE 18.
           03  KW-FLOAT           PICTURE X(5)   VALUE "FLOAT". 
           03  KW-FLOAT-LEN       PICTURE 99     VALUE 5. 
           03  KW-FL-R-DEC        PICTURE X(18)  VALUE
                                  "FLOAT REAL DECIMAL". 
           03  KW-FL-R-DEC-LEN    PICTURE 99     VALUE 18.
           03  KW-FOR             PICTURE X(3)   VALUE "FOR". 
           03  KW-FOR-LEN         PICTURE 99     VALUE 3. 
           03  KW-GET             PICTURE X(3)   VALUE "GET". 
           03  KW-GET-LEN         PICTURE 99     VALUE 3. 
           03  KW-INDEXED         PICTURE X(7)   VALUE "INDEXED". 
           03  KW-INDEXED-LEN     PICTURE 99     VALUE 7. 
           03  KW-IS              PICTURE XX     VALUE "IS".
           03  KW-IS-LEN          PICTURE 99     VALUE 2. 
           03  KW-JOIN            PICTURE X(10)  VALUE "JOIN WHERE".
           03  KW-JOIN-LEN        PICTURE 99     VALUE 10.
           03  KW-KEYIDIS         PICTURE X(9)   VALUE "KEY ID IS". 
           03  KW-KEYIDIS-LEN     PICTURE 99     VALUE 9. 
           03  KW-KEYIS           PICTURE X(6)   VALUE "KEY IS".
           03  KW-KEYIS-LEN       PICTURE 99     VALUE 6. 
           03  KW-MODIFY          PICTURE X(6)   VALUE "MODIFY".
           03  KW-MODIFY-LEN      PICTURE 99     VALUE 6. 
           03  KW-NOTALLOW        PICTURE X(11)  VALUE "NOT ALLOWED". 
           03  KW-NOTALLOW-LEN    PICTURE 99     VALUE 11.
           03  KW-OCCURS          PICTURE X(6)   VALUE "OCCURS".
           03  KW-OCCURS-LEN      PICTURE 99     VALUE 6. 
           03  KW-OF              PICTURE XX     VALUE "OF".
           03  KW-OF-LEN          PICTURE 99     VALUE 2. 
           03  KW-ONERR           PICTURE X(15)  VALUE
                                  "ON ERROR DURING".
           03  KW-ONERR-LEN       PICTURE 99     VALUE 15.
           03  KW-OPEN            PICTURE X(4)   VALUE "OPEN".
           03  KW-OPEN-LEN        PICTURE 99     VALUE 4. 
           03  KW-OR              PICTURE X(2)   VALUE "OR".
           03  KW-OR-LEN          PICTURE 99     VALUE 2. 
           03  KW-PICTURE         PICTURE X(7)   VALUE "PICTURE". 
           03  KW-PICTURE-LEN     PICTURE 99     VALUE 7. 
           03  KW-PROCEDURE       PICTURE X(9)   VALUE "PROCEDURE". 
           03  KW-PROCEDURE-LEN   PICTURE 99     VALUE 9. 
           03  KW-RCBY            PICTURE X(17)  VALUE
                                  "RECORD CODE IS BY".
           03  KW-RCBY-LEN        PICTURE 99     VALUE 17.
           03  KW-RCPROC          PICTURE X(24)  VALUE
                                  "RECORD CODE IS PROCEDURE". 
           03  KW-RCPROC-LEN      PICTURE 99     VALUE 24.
           03  KW-REAL            PICTURE X(4)   VALUE "REAL".
           03  KW-REAL-LEN        PICTURE 99     VALUE 4. 
           03  KW-RECORD          PICTURE X(9)   VALUE "RECORD IS". 
           03  KW-RECORD-LEN      PICTURE 99     VALUE 9. 
           03  KW-RELATION        PICTURE X(11)  VALUE "RELATION IS". 
           03  KW-RELATION-LEN    PICTURE 99     VALUE 11.
           03  KW-RES-OF          PICTURE X(9)   VALUE "RESULT OF". 
           03  KW-RES-OF-LEN      PICTURE 99     VALUE 9. 
           03  KW-RETRIEVAL       PICTURE X(9)   VALUE "RETRIEVAL". 
           03  KW-RETRIEVAL-LEN   PICTURE 99     VALUE 9. 
           03  KW-SCHEMA          PICTURE X(9)   VALUE "SCHEMA IS". 
           03  KW-SCHEMA-LEN      PICTURE 99     VALUE 9. 
           03  KW-SEQUENCE        PICTURE X(11)  VALUE "SEQUENCE IS". 
           03  KW-SEQUENCE-LEN    PICTURE 99     VALUE 11.
           03  KW-STORE           PICTURE X(5)   VALUE "STORE". 
           03  KW-STORE-LEN       PICTURE 99     VALUE 5. 
           03  KW-SYSTEM          PICTURE X(6)   VALUE "SYSTEM".
           03  KW-SYSTEM-LEN      PICTURE 99     VALUE 6. 
           03  KW-THRU            PICTURE X(4)   VALUE "THRU".
           03  KW-THRU-LEN        PICTURE 99     VALUE 4. 
           03  KW-TIMES           PICTURE X(5)   VALUE "TIMES". 
           03  KW-TIMES-LEN       PICTURE 99     VALUE 5. 
           03  KW-TYPE            PICTURE X(4)   VALUE "TYPE".
           03  KW-TYPE-LEN        PICTURE 99     VALUE 4. 
           03  KW-UPDATE          PICTURE X(6)   VALUE "UPDATE".
           03  KW-UPDATE-LEN      PICTURE 99     VALUE 6. 
           03  KW-USE             PICTURE X(3)   VALUE "USE". 
           03  KW-USE-LEN         PICTURE 99     VALUE 3. 
           03  KW-USING           PICTURE X(5)   VALUE "USING". 
           03  KW-USING-LEN       PICTURE 99     VALUE 5. 
           03  KW-VALFOR          PICTURE X(9)   VALUE "VALUE FOR". 
           03  KW-VALFOR-LEN      PICTURE 99     VALUE 9. 
           03  KW-VALNOT          PICTURE X(9)   VALUE "VALUE NOT". 
           03  KW-VALNOT-LEN      PICTURE 99     VALUE 9. 
           03  KW-VALUE           PICTURE X(5)   VALUE "VALUE". 
           03  KW-VALUE-LEN       PICTURE 99     VALUE 5. 
           03  KW-VIRTUAL         PICTURE X(10)  VALUE "IS VIRTUAL".
           03  KW-VIRTUAL-LEN     PICTURE 99     VALUE 10.
           03  KW-WITHIN          PICTURE X(6)   VALUE "WITHIN".
           03  KW-WITHIN-LEN      PICTURE 99     VALUE 6. 
*CALL DATAIO
*CALL DATADD
*CALL DATSAV1 
*CALL DATSAV2 
*CALL DATSAV3 
*CALL DATSAV5 
           03  HOLD-GROUP         OCCURS 4 TIMES. 
               05  GRP-CON-LINE   PICTURE X(41).
               05  GRP-NAME       PICTURE X(32).
               05  GRP-NEXT-REC   PICTURE 9(4). 
               05  GRP-CAT        PICTURE X(3). 
               05  GRP-LINE-NO    PICTURE X(4). 
               05  GRP-LINETYPE   PICTURE X.
               05  GRP-DRCODE     PICTURE X.
               05  GRP-COL-IN     PICTURE 9(4). 
               05  GRP-DTL-LEN    PICTURE 9(3). 
               05  GRP-SKIP-COM   PICTURE X.
               05  GRP-LEV-NO     PICTURE 99. 
*CALL DATCON1 
*CALL DATCON2 
*CALL DATCONSCH 
  
*CALL MAST1WS 
  
*CALL TESTWACOM 
  
*CALL DCDPTRS 
  
*CALL DCDWA03 
  
*CALL DCDWA05 
  
*CALL DCDWA10 
  
*CALL DCDWA13 
  
*CALL DCDWA22 
  
*CALL DCDWA26 
      /*****************************************************************
      * 
       PROCEDURE DIVISION.
  
      ******************************************************************
      * 
      * INITIALIZATION. 
  
       000-INITIALIZE.
  
      * FIRST CHECK IF RETURNING TO MODULE FROM INPUT/OUTPUT REQUEST. 
           IF GTBL-REQ = REQ-INPUT
           THEN 
             GO TO READ-RETURN
           END-IF 
  
           IF GTBL-REQ = REQ-OUTPUT 
           THEN 
             GO TO OUTPUT-RETURN
           END-IF 
  
      * INITIAL ENTRY OF MODULE --- SO INITIALIZE.
           MOVE GTBL-SEL-CNAME TO SCHEMA-CATNAME. 
           MOVE INDENT-INIT TO INDENT.
           MOVE SPACES TO DMS-LINE. 
           PERFORM CLEAR-DATA-ENTRY THRU CLEAR-DATA-ENTRY-XIT.
           MOVE "N" TO DATANAME-OK. 
  
  
      ******************************************************************
      * THIS SECTION OF PROCEDURES ACCESSES PRIMARILY THE SCHEMA ENTITY 
      ******************************************************************
  
  
      ******************************************************************
      * 
      * SCHEMA DESCRIPTION ENTRY. 
  
       100-SCHEMA-DESCRIPTION.
  
      * START SCHEMA DESCRIPTION WITH KEYWORD "SCHEMA" ON A NEW LINE. 
           MOVE KW-SCHEMA TO OUT-FIELD. 
           MOVE KW-SCHEMA-LEN TO OUT-LEN. 
           PERFORM START-STMT THRU STMT-XIT.
  
      * READ FIRST RECORD OF SCHEMA ENTRY INTO "DATA-RECORD". 
           MOVE SCHEMA-CATNAME TO DATA-ENTRY-NAME.
           PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT.
  
      * IF SCHEMA ENTRY MISSING, DIAGNOSE AND GIVE UP.
           IF DATA-RETURN-CODE NOT = ZERO 
           THEN 
             MOVE IDX-500 TO MSG-IDX
             PERFORM ERROR-TYPE1 THRU ERROR-TYPE1-XIT 
             GO TO 150-NORMAL-TERMINATION 
           END-IF 
  
      * MOVE NAMES CATEGORY OF SCHEMA ENTRY INTO "CAT-WORK".
           MOVE CAT-NO-NAMES TO DATA-ENTRY-CAT. 
           PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT.
           MOVE "N" TO SKIP-COMMENTS. 
           PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT.
  
      * IF NO DMSNAME GIVEN, ASSUME THE CATNAME.
           IF DATA-RETURN-CODE NOT = ZERO 
             OR NAME-SCH-DMS = SPACES 
           THEN 
             MOVE SCHEMA-CATNAME (1 : 30) TO OUT-FIELD
           ELSE 
             MOVE NAME-SCH-DMS (1 : 30) TO OUT-FIELD
           END-IF 
  
      * OUTPUT ANY REMAINING COMMENTS IN NAMES CATEGORY.
           PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT.
  
      * FIND LENGTH OF SCHEMA-NAME, MOVE SCHEMA-NAME TO STATEMENT,
      * AND END STATEMENT WITH PERIOD.
           PERFORM FIND-LENGTH THRU FIND-LENGTH-XIT.
           PERFORM ADD-TO-STMT THRU STMT-XIT. 
           MOVE "." TO DMS-LINE (COLUMN-OUT - 1 : 1). 
  
  
      ******************************************************************
      * 
      * AREA AND RECORD DESCRIPTION ENTRIES 
      * 
      * FOR EACH AREA TO BE INCLUDED IN THE SCHEMA, GENERATE AN AREA
      * DESCRIPTION ENTRY AND RECORD DESCRIPTION ENTRIES. 
  
      * MOVE SCHEMA'S FIRST STRUCTURE LINE INTO "CAT-WORK". 
           MOVE CAT-NO-STC TO DATA-ENTRY-CAT. 
           PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT.
           MOVE "N" TO SKIP-COMMENTS. 
           PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT.
           MOVE "N" TO FOUND-AREA.
  
      * LOOP THROUGH SCHEMA'S STRUCTURE LINES TO GENERATE DESCRIPTION 
      * ENTRIES.
           PERFORM UNTIL DATA-RETURN-CODE NOT = ZERO
  
      * CONSOLIDATE THE STRUCTURE LINE IF NEEDED. 
             PERFORM CON-SCH-STC THRU CON-SCH-STC-XIT 
  
             IF SCH-STC-CNAME NOT = SPACES
               AND SCH-STC-INCL NOT = "N" 
               AND SCH-STC-CTYPE = "A"
               AND SCH-STC-AVERS = SPACES OR "MASTER" 
             THEN 
               MOVE "Y" TO FOUND-AREA 
               MOVE SCH-STC-CNAME TO AREA-CATNAME 
               PERFORM AREA-DESCRIPTION THRU AREA-DESCRIPTION-XIT 
             END-IF 
           END-PERFORM
  
       110-END-SCHEMA-STC.
  
      * CHECK THAT AT LEAST ONE AREA EXISTS FOR THE SCHEMA. CANNOT
      * CONTINUE IF NOT.
           IF FOUND-AREA = "N"
           THEN 
             MOVE IDX-600 TO MSG-IDX
             PERFORM ERROR-TYPE1 THRU ERROR-TYPE1-XIT 
             GO TO 150-NORMAL-TERMINATION 
           END-IF 
  
  
      ******************************************************************
      * 
      * DATA CONTROL ENTRY. 
      * 
      * FOR EACH AREA TO BE INCLUDED IN THE SCHEMA, GENERATE AN AREA
      * CONTROL ENTRY.
  
      * START WITH OUTPUTTING A BLANK LINE FOLLOWED BY THE DATA CONTROL 
      * HEADER. 
           MOVE ZERO TO OUT-LEN.
           PERFORM START-STMT THRU STMT-XIT.
           MOVE KW-DATACON TO OUT-FIELD.
           MOVE KW-DATACON-LEN TO OUT-LEN.
           PERFORM START-STMT THRU STMT-XIT.
  
      * MOVE SCHEMA'S FIRST STRUCTURE LINE INTO "CAT-WORK". 
           PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT.
           MOVE "Y" TO SKIP-COMMENTS. 
           PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT.
  
      * LOOP THROUGH THE SCHEMA'S STRUCTURE LINES AGAIN, THIS TIME TO 
      * GENERATE AREA CONTROL ENTRIES.
           PERFORM UNTIL DATA-RETURN-CODE NOT = ZERO
  
      * CONSOLIDATE THE STRUCTURE LINE IF NEEDED. 
             PERFORM CON-SCH-STC THRU CON-SCH-STC-XIT 
  
             IF SCH-STC-CNAME NOT = SPACES
               AND SCH-STC-CTYPE = "A"
               AND SCH-STC-INCL NOT = "N" 
               AND SCH-STC-AVERS = SPACES OR "MASTER" 
             THEN 
               MOVE SCH-STC-CNAME TO AREA-CATNAME 
               PERFORM AREA-CONTROL THRU AREA-CONTROL-XIT 
             END-IF 
           END-PERFORM
  
       120-END-SCHEMA-STC.
  
  
      ******************************************************************
      * 
      * CONSTRAINT ENTRY
      * 
      * FOR EACH CONSTRAINT ASSOCIATED WITH SCHEMA, GENERATE A
      * CONSTRAINT CLAUSE.
  
      * INSERT A BLANK LINE BEFORE THE CONSTRAINT ENTRY.
           MOVE ZERO TO OUT-LEN.
           PERFORM START-STMT THRU STMT-XIT.
  
      * MOVE SCHEMA'S FIRST CONSTRAINT LINE INTO "CAT-WORK".
           MOVE CAT-NO-BOND TO DATA-ENTRY-CAT.
           PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT.
           MOVE "N" TO SKIP-COMMENTS. 
           PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT.
  
      * LOOP THROUGH SCHEMA'S CONSTRAINT LINES TO GENERATE CONSTRAINT 
      * CLAUSES.
           PERFORM UNTIL DATA-RETURN-CODE NOT = ZERO
  
      * LINETYPE "N" MUST COME BEFORE "O".
             IF CAT-LINE-TYPE = "N" 
             THEN 
  
      * CONSOLIDATE THE TYPE "N" CONSTRAINT LINE IF NEEDED. 
               PERFORM CON-SCH-NBOND THRU CON-SCH-NBOND-XIT 
  
               IF SCH-BOND-NAME NOT = SPACES
               THEN 
                 PERFORM CONSTRAINT THRU CONSTRAINT-XIT 
               END-IF 
  
      * ERROR IF LINETYPES OUT OF ORDER.
             ELSE 
               MOVE IDX-705 TO MSG-IDX
               MOVE "SCHEMA-BOND" TO MSG-NAME 
               PERFORM ERROR-TYPE2 THRU ERROR-TYPE2-XIT 
  
      * SKIP ERRONEOUS LINE.
               PERFORM MOVE-NEXT-LINE THRU MOVE-NEXT-LINE-XIT 
               PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT 
             END-IF 
           END-PERFORM
  
       130-END-SCHEMA-CON.
  
  
      ******************************************************************
      * 
      * RELATION ENTRY. 
      * 
      * FOR EACH JOIN ASSOCIATED WITH SCHEMA, GENERATE A RELATION 
      * CLAUSE. 
  
      * INSERT A BLANK LINE BEFORE THE RELATION ENTRY.
           MOVE ZERO TO OUT-LEN.
           PERFORM START-STMT THRU STMT-XIT.
  
      * MOVE SCHEMA'S FIRST JOINS LINE INTO "CAT-WORK". 
           MOVE CAT-NO-JOIN TO DATA-ENTRY-CAT.
           PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT.
           MOVE "N" TO SKIP-COMMENTS. 
           PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT.
  
      * LOOP THROUGH SCHEMA'S JOIN LINES TO GENERATE RELATION CLAUSES.
           PERFORM UNTIL DATA-RETURN-CODE NOT = ZERO
             IF CAT-LINE-TYPE = "A" 
             THEN 
               IF JOIN-SCH-NAME NOT = SPACES
               THEN 
                 PERFORM RELATION THRU RELATION-XIT 
  
      * ERROR IF RELATION NAME MISSING. 
               ELSE 
                 MOVE IDX-710 TO MSG-IDX
                 MOVE "SCHEMA-JOIN-RELNAME" TO MSG-NAME 
                 PERFORM ERROR-TYPE2 THRU ERROR-TYPE2-XIT 
  
                 PERFORM MOVE-NEXT-LINE THRU MOVE-NEXT-LINE-XIT 
                 PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT 
               END-IF 
  
      * ERROR IF LINETYPES OUT OF ORDER.
             ELSE 
               MOVE IDX-705 TO MSG-IDX
               MOVE "SCHEMA-JOIN" TO MSG-NAME 
               PERFORM ERROR-TYPE2 THRU ERROR-TYPE2-XIT 
  
      * SKIP OVER ERRONEOUS LINE. 
               PERFORM MOVE-NEXT-LINE THRU MOVE-NEXT-LINE-XIT 
               PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT 
             END-IF 
           END-PERFORM
  
       140-END-SCHEMA-JOINS.
  
  
      ******************************************************************
      * 
      * TIME FOR NORMAL TERMINATION.
      * SET FLAG TO TELL "DMS300" THAT AND EXIT.
  
       150-NORMAL-TERMINATION.
           PERFORM OUTPUT-DMS THRU OUTPUT-DMS-XIT.
           MOVE REQ-TERMINATE TO GTBL-REQ.
           EXIT PROGRAM.
      /*****************************************************************
      ******************************************************************
      * 
      * CONSTRAINT ENTRY GENERATION.
      * 
      * INPUT:   CONSOLID-LINE    - SCHEMA BOND, LINETYPE "N" 
      * 
      * OUTPUT:  CAT-WORK         - SCHEMA BOND, NEXT LINETYPE "N" IF IT
      *                             EXISTS
  
       CONSTRAINT.
  
      * START EACH CONSTRAINT ON A NEW LINE.
           MOVE KW-CONSTRAINT TO OUT-FIELD. 
           MOVE KW-CONSTRAINT-LEN TO OUT-LEN. 
           PERFORM START-STMT THRU STMT-XIT.
  
      * ADD THE CONSTRAINT NAME TO THE LINE.
           MOVE SCH-BOND-NAME TO OUT-FIELD. 
           MOVE 30 TO OUT-LEN.
           PERFORM ADD-TO-STMT THRU STMT-XIT. 
  
      * PUT THE DATANAMES INDENTED ON A NEW LINE. 
           ADD INDENT-INC TO INDENT.
           MOVE ZERO TO OUT-LEN.
           PERFORM START-STMT THRU STMT-XIT.
  
      * ADD THE FIRST DATANAME TO THE LINE. 
           IF SCH-BOND-CNAME NOT = SPACES 
           THEN 
             PERFORM CONSTR-DATANAME THRU CONSTR-DATANAME-XIT 
  
      * ERROR IF DATANAME MISSING.
           ELSE 
             MOVE IDX-710 TO MSG-IDX
             MOVE "SCHEMA-BOND-CNAME" TO MSG-NAME 
             PERFORM ERROR-TYPE2 THRU ERROR-TYPE2-XIT 
           END-IF 
  
      * ADD KEYWORDS "DEPENDS ON" TO LINE.
           MOVE KW-DEPENDS TO OUT-FIELD.
           MOVE KW-DEPENDS-LEN TO OUT-LEN.
           PERFORM ADD-TO-STMT THRU STMT-XIT. 
  
      * SECOND DATANAME FOUND IN LINETYPE "O".
           IF DATA-RETURN-CODE = ZERO 
           THEN 
             IF CAT-LINE-TYPE = "O" 
             THEN 
               PERFORM CON-SCH-OBOND THRU CON-SCH-OBOND-XIT 
  
      * ADD SECOND DATANAME TO LINE.
               IF SCH-BOND-CNAME NOT = SPACES 
               THEN 
                 PERFORM CONSTR-DATANAME THRU CONSTR-DATANAME-XIT 
               END-IF 
  
      * ERROR IF NOT LINETYPE "O".
             ELSE 
               MOVE IDX-705 TO MSG-IDX
               MOVE "SCHEMA-BOND" TO MSG-NAME 
               PERFORM ERROR-TYPE2 THRU ERROR-TYPE2-XIT 
             END-IF 
  
      * ERROR IF NEXT BOND LINE DOES NOT EXIST. 
           ELSE 
             MOVE IDX-725 TO MSG-IDX
             MOVE "SCHEMA-BOND" TO MSG-NAME 
             PERFORM ERROR-TYPE2 THRU ERROR-TYPE2-XIT 
           END-IF 
  
      * END CONSTRAINT ENTRY WITH A PERIOD. 
           MOVE "." TO DMS-LINE (COLUMN-OUT - 1 : 1). 
           MOVE INDENT-INIT TO INDENT.
  
       CONSTRAINT-XIT.
           EXIT.
  
  
      ******************************************************************
      * 
      * ADD CONSTRAINT DATANAME.
      * 
      * ADD THE NAME FOUND IN THE "SCH-BOND" CONSOLIDATED LINE TO THE 
      * CURRENT OUTPUT LINE.  IT MAY BE EITHER A KEY-ID LITERAL OR THE
      * CATNAME OF A GROUP OR ELEMENT.
      * 
      * INPUT:   CON'-LINE        - SCHEMA BOND, TYPE "N" OR "O"
  
       CONSTR-DATANAME. 
           PERFORM SAVE-SCH-INFO THRU SAVE-SCH-INFO-XIT.
  
      * READ FIRST RECORD OF DATANAME.
           PERFORM CLEAR-DATA-ENTRY THRU CLEAR-DATA-ENTRY-XIT.
           MOVE SCH-BOND-CNAME TO DATA-ENTRY-NAME.
           MOVE "Y" TO DATANAME-OK. 
           PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT.
  
      * IF NO CATALOGUE ENTRY FOR DATANAME, IT MUST BE A KEY-ID.  JUST
      * COPY IT TO LINE.
           IF DATA-RETURN-CODE NOT = ZERO 
           THEN 
             MOVE SCH-BOND-CNAME TO OUT-FIELD 
             PERFORM FIND-LENGTH THRU FIND-LENGTH-XIT 
             PERFORM ADD-TO-STMT THRU STMT-XIT
             GO TO CONSTR-DATANAME-XIT
           END-IF 
  
      * DETERMINE WHETHER DATANAME IS A GROUP OR ELEMENT AND ADD NAME 
      * ACCORDINGLY.
           IF DATA-HDR-ENT-ID = ENT-ID-GROUP
           THEN 
             MOVE SCH-BOND-CNAME TO GROUP-CATNAME 
             PERFORM ADD-GRP-NAME THRU ADD-GRP-NAME-XIT 
  
           ELSE 
             IF DATA-HDR-ENT-ID = ENT-ID-ELEM 
             THEN 
               MOVE SCH-BOND-CNAME TO ELEM-CATNAME
               MOVE SCH-BOND-ALIAS TO ELEM-ALIAS
               PERFORM ADD-ELEM-NAME THRU ADD-ELEM-NAME-XIT 
  
      * ERROR IF NEITHER GROUP NOR ELEMENT. 
             ELSE 
               MOVE IDX-525 TO MSG-IDX
               PERFORM ERROR-TYPE1 THRU ERROR-TYPE1-XIT 
               GO TO 160-END-DATANAME 
             END-IF 
           END-IF 
  
      * ADD QUALIFYING RECORD NAME IF GIVEN.
           IF SCH-BOND-QUAL NOT = SPACES
           THEN 
             MOVE SCH-BOND-QUAL TO QUAL-CATNAME 
             PERFORM ADD-QUAL-NAME THRU ADD-QUAL-NAME-XIT 
           END-IF 
  
       160-END-DATANAME.
           PERFORM RESTORE-SCH-INFO THRU RESTORE-SCH-INFO-XIT.
  
       CONSTR-DATANAME-XIT. 
           EXIT.
      /*****************************************************************
      ******************************************************************
      * 
      * RELATION ENTRY GENERATION.
      * 
      * INPUT:   CAT-WORK         - SCHEMA JOIN, LINETYPE "A" 
      * 
      * OUTPUT:  CAT-WORK         - SCHEMA JOIN, NEXT LINETYPE "A" IF IT
      *                             EXISTS
  
       RELATION.
  
      * START EACH RELATION ON A NEW LINE.
           MOVE KW-RELATION TO OUT-FIELD. 
           MOVE KW-RELATION-LEN TO OUT-LEN. 
           PERFORM START-STMT THRU STMT-XIT.
  
      * COPY RELATION NAME TO LINE. 
           MOVE JOIN-SCH-NAME TO OUT-FIELD. 
           MOVE 30 TO OUT-LEN.
           PERFORM ADD-TO-STMT THRU STMT-XIT. 
  
      * START JOIN CLAUSE ON A NEW LINE, INDENTED.
           ADD INDENT-INC TO INDENT.
           MOVE KW-JOIN TO OUT-FIELD. 
           MOVE KW-JOIN-LEN TO OUT-LEN. 
           PERFORM START-STMT THRU STMT-XIT.
  
      * MOVE NEXT JOIN LINE INTO "CAT-WORK" -- AT LEAST ONE ID PAIR 
      * MUST EXIST. 
           PERFORM MOVE-NEXT-LINE THRU MOVE-NEXT-LINE-XIT.
           PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT.
  
           IF DATA-RETURN-CODE NOT = ZERO 
           THEN 
             MOVE IDX-725 TO MSG-IDX
             MOVE "SCHEMA-JOIN" TO MSG-NAME 
             PERFORM ERROR-TYPE2 THRU ERROR-TYPE2-XIT 
             GO TO 170-END-RELATION 
           END-IF 
  
      * ADD THE ID PAIR TO JOIN LINE. 
           PERFORM JOIN-ID-PAIR THRU JOIN-ID-PAIR-XIT.
  
      * REPEAT FOR ALL ID PAIRS THAT REMAIN, IF ANY.
           ADD INDENT-INC TO INDENT.
           PERFORM UNTIL DATA-RETURN-CODE NOT = ZERO
             OR CAT-LINE-TYPE NOT = "B" 
  
      * PUT EACH ID PAIR ON A NEW LINE. 
             MOVE ZERO TO OUT-LEN 
             PERFORM START-STMT THRU STMT-XIT 
             PERFORM JOIN-ID-PAIR THRU JOIN-ID-PAIR-XIT 
           END-PERFORM
  
       170-END-RELATION.
           MOVE INDENT-INIT TO INDENT.
           MOVE "." TO DMS-LINE (COLUMN-OUT - 1 : 1). 
  
       RELATION-XIT.
           EXIT.
  
  
      ******************************************************************
      * 
      * JOIN-ID-PAIR. 
      * 
      * ADD A PAIR OF JOIN-IDS TO THE CURRENT OUTPUT LINE OF A RELATION 
      * ENTRY.
      * 
      * INPUT:   CAT-WORK         - SCHEMA JOIN, LINETYPE "B" 
      * 
      * OUTPUT:  CAT-WORK         - SCHEMA JOIN, NEXT LINETYPE "B" IF IT
      *                             EXISTS
  
       JOIN-ID-PAIR.
  
      * ADD FIRST JOIN-ID TO OUTPUT LINE. 
           IF CAT-LINE-TYPE = "B" 
           THEN 
             PERFORM CON-SCH-BJOIN THRU CON-SCH-BJOIN-XIT 
             IF SCH-JOIN-ID NOT = SPACES
             THEN 
               PERFORM ADD-JOIN-ID THRU ADD-JOIN-ID-XIT 
             END-IF 
  
      * ERROR IF LINETYPES OUT OF ORDER.
           ELSE 
             MOVE IDX-705 TO MSG-IDX
             MOVE "SCHEMA-JOIN" TO MSG-NAME 
             PERFORM ERROR-TYPE2 THRU ERROR-TYPE2-XIT 
           END-IF 
  
      * ADD KEYWORD TO LINE.
           MOVE KW-EQ TO OUT-FIELD. 
           MOVE KW-EQ-LEN TO OUT-LEN. 
           PERFORM ADD-TO-STMT THRU STMT-XIT. 
  
      * SECOND ID'S JOIN LINE SHOULD NOW BE IN "CAT-WORK".
           IF CAT-LINE-TYPE = "C" 
           THEN 
             PERFORM CON-SCH-CJOIN THRU CON-SCH-CJOIN-XIT 
  
      * ADD SECOND JOIN-ID TO OUTPUT LINE.
             IF SCH-JOIN-ID NOT = SPACES
             THEN 
               PERFORM ADD-JOIN-ID THRU ADD-JOIN-ID-XIT 
             END-IF 
  
      * ERROR IF LINETYPES OUT OF ORDER.
           ELSE 
             MOVE IDX-705 TO MSG-IDX
             MOVE "SCHEMA-JOIN" TO MSG-NAME 
             PERFORM ERROR-TYPE2 THRU ERROR-TYPE2-XIT 
           END-IF 
  
       JOIN-ID-PAIR-XIT.
           EXIT.
  
  
      ******************************************************************
      * 
      * ADD RELATION JOIN-ID. 
      * 
      * INPUT:   CAT-WORK         - SCHEMA JOIN, LINETYPE "B" OR "C"
  
       ADD-JOIN-ID. 
           PERFORM SAVE-SCH-INFO THRU SAVE-SCH-INFO-XIT.
  
      * READ FIRST RECORD OF ID INTO "DATA-RECORD". 
           PERFORM CLEAR-DATA-ENTRY THRU CLEAR-DATA-ENTRY-XIT.
           MOVE SCH-JOIN-ID TO DATA-ENTRY-NAME. 
           MOVE "Y" TO DATANAME-OK. 
           PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT.
  
      * IF NO CATALOGUE ENTRY FOR NAME, IT MUST BE A KEY-ID.  JUST
      * COPY IT TO LINE.
           IF DATA-RETURN-CODE NOT = ZERO 
           THEN 
             MOVE SCH-JOIN-ID TO OUT-FIELD
             PERFORM FIND-LENGTH THRU FIND-LENGTH-XIT 
             PERFORM ADD-TO-STMT THRU STMT-XIT
             GO TO ADD-JOIN-ID-XIT
           END-IF 
  
      * DETERMINE WHETHER ID IS A GROUP OR ELEMENT AND ADD NAME 
      * ACCORDINGLY.
           IF DATA-HDR-ENT-ID = ENT-ID-GROUP
           THEN 
             MOVE SCH-JOIN-ID TO GROUP-CATNAME
             PERFORM ADD-GRP-NAME THRU ADD-GRP-NAME-XIT 
  
           ELSE 
             IF DATA-HDR-ENT-ID = ENT-ID-ELEM 
             THEN 
               MOVE SCH-JOIN-ID TO ELEM-CATNAME 
               MOVE SCH-JOIN-ALIAS TO ELEM-ALIAS
               PERFORM ADD-ELEM-NAME THRU ADD-ELEM-NAME-XIT 
  
      * ERROR IF NEITHER GROUP NOR ELEMENT. 
             ELSE 
               MOVE IDX-525 TO MSG-IDX
               PERFORM ERROR-TYPE1 THRU ERROR-TYPE1-XIT 
               GO TO 180-END-ADD-JOIN-ID
             END-IF 
           END-IF 
  
      * ADD SUBSCRIPT(S) IF GIVEN, ENCLOSED IN PAREN'S AND SEPARATED BY 
      * COMMAS. 
           IF SCH-JOIN-SUB1 NOT = SPACES
             AND NOT = ZERO 
           THEN 
             MOVE "(" TO OUT-FIELD
             MOVE SCH-JOIN-SUB1 TO OUT-FIELD (2 : 4)
             PERFORM FIND-LENGTH THRU FIND-LENGTH-XIT 
             ADD 1 TO OUT-LEN 
  
      * EITHER END WITH RIGHT PAREN OR ADD SECOND SUBSCRIPT.
             IF SCH-JOIN-SUB2 = SPACES OR ZERO
               OR SCH-JOIN-SUB1 = "ANY" 
             THEN 
               MOVE ")" TO OUT-FIELD (OUT-LEN : 1)
             ELSE 
               MOVE "," TO OUT-FIELD (OUT-LEN : 1)
               MOVE SCH-JOIN-SUB2 TO OUT-FIELD (OUT-LEN + 1 : 4)
               PERFORM FIND-LENGTH THRU FIND-LENGTH-XIT 
               ADD 1 TO OUT-LEN 
  
      * EITHER END WITH RIGHT PAREN OR ADD THIRD SUBSCRIPT. 
               IF SCH-JOIN-SUB3 = SPACES OR ZERO
               THEN 
                 MOVE ")" TO OUT-FIELD (OUT-LEN : 1)
               ELSE 
                 MOVE "," TO OUT-FIELD (OUT-LEN : 1)
                 MOVE SCH-JOIN-SUB3 TO OUT-FIELD (OUT-LEN + 1 : 4)
                 PERFORM FIND-LENGTH THRU FIND-LENGTH-XIT 
                 ADD 1 TO OUT-LEN 
                 MOVE ")" TO OUT-FIELD (OUT-LEN : 1)
               END-IF 
             END-IF 
  
      * ADD WHOLE SUBSCRIPT TO LINE.
             PERFORM ADD-TO-STMT THRU STMT-XIT
           END-IF 
  
      * ADD QUALIFYING RECORD NAME IF GIVEN.
           IF SCH-JOIN-QUAL NOT = SPACES
           THEN 
             MOVE SCH-JOIN-QUAL TO QUAL-CATNAME 
             PERFORM ADD-QUAL-NAME THRU ADD-QUAL-NAME-XIT 
           END-IF 
  
       180-END-ADD-JOIN-ID. 
           PERFORM RESTORE-SCH-INFO THRU RESTORE-SCH-INFO-XIT.
  
       ADD-JOIN-ID-XIT. 
           EXIT.
      /*****************************************************************
      * THIS SECTION OF PROCEDURES ACCESSES PRIMARILY THE AREA ENTITY.
      ******************************************************************
  
  
      ******************************************************************
      ******************************************************************
      * 
      * AREA DESCRIPTION GENERATION.
      * 
      * GENERATE AN AREA DESCRIPTION FOR THE GIVEN AREA AND A RECORD
      * DESCRIPTION FOR EACH RECORD INCLUDED IN THE AREA'S STRUCTURE. 
      * 
      * INPUT:   AREA-CATNAME     - CATNAME OF THE AREA TO BE PROCESSED 
      *          CAT-WORK         - SCHEMA STRUCTURE
  
  
       AREA-DESCRIPTION.
           PERFORM SAVE-SCH-INFO THRU SAVE-SCH-INFO-XIT.
  
      * START AREA DESCRIPTION WITH A BLANK LINE AND THE KEYWORD "AREA" 
      * ON A NEW LINE.
           MOVE ZERO TO OUT-LEN.
           PERFORM START-STMT THRU STMT-XIT.
           MOVE KW-AREA TO OUT-FIELD. 
           MOVE KW-AREA-LEN TO OUT-LEN. 
           PERFORM START-STMT THRU STMT-XIT.
  
      * ADD THE AREA-NAME TO OUTPUT LINE.  IF ENTRY FOR AREA MISSING, 
      * IT HAS ALREADY BEEN DIAGNOSED, JUST RETURN. 
           PERFORM ADD-AREA-NAME THRU ADD-AREA-NAME-XIT.
           IF FOUND-ENTITY = "N"
           THEN 
             GO TO 280-END-AREA-DESCR 
           END-IF 
  
  
      ******************************************************************
      * 
      * AREA CALL CLAUSE. 
      * 
      * GENERATE A CALL CLAUSE FOR EACH DATABASE PROCEDURE OF TYPE
      * "CALL" ASSOCIATED WITH THIS AREA. 
  
      * MOVE AREA'S FIRST TYPE "P" PROCESS LINE INTO "CAT-WORK".
           MOVE CAT-NO-PRO TO DATA-ENTRY-CAT. 
           MOVE "P" TO DATA-ENTRY-LINETYPE. 
           PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT.
  
      * FOR EACH PROCESS ENTRY FOR A CALL-TYPE DATABASE PROCEDURE,
      * GENERATE A CALL CLAUSE.  IF NONE AT ALL, NO PROBLEM.
           PERFORM UNTIL DATA-RETURN-CODE NOT = ZERO
             PERFORM CON-AREA-PPRO THRU CON-AREA-PPRO-XIT 
             IF A-PRO-DBP NOT = SPACES
               AND A-PRO-PTYPE = "CA" 
             THEN 
               MOVE A-PRO-DBP TO DBP-CATNAME
               PERFORM AREA-CALL-CLAUSE THRU AREA-CALL-CLAUSE-XIT 
             END-IF 
           END-PERFORM
  
       210-END-AREA-PROCESS.
           MOVE SPACES TO DATA-ENTRY-LINETYPE.
  
  
      ******************************************************************
      * 
      * ACCESS-CONTROL CLAUSE.
      * 
      * IF ANY ACCESS-CONTROL LOCKS EXIST FOR THIS AREA, GENERATE AN
      * ACCESS-CONTROL CLAUSE FOR EACH MODE/LOCK SET. 
  
      * MOVE FIRST LINE OF AREA'S ACCESS CATEGORY TO "CAT-WORK".
           MOVE CAT-NO-ACC TO DATA-ENTRY-CAT. 
           PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT.
           MOVE "Y" TO SKIP-COMMENTS. 
           PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT.
  
      * IF NO ACCESS-CONTROL LOCKS, SKIP TO END OF AREA DESCRIPTION 
      * ENTRY.
           IF DATA-RETURN-CODE NOT = ZERO 
           THEN 
             GO TO 260-END-AREA-DESCR 
           END-IF 
  
           ADD INDENT-INC TO INDENT.
  
       220-START-ACC-CLAUSE.
  
      * START ACCESS-CONTROL CLAUSE ON A NEW LINE.
           MOVE KW-ACCESS TO OUT-FIELD. 
           MOVE KW-ACCESS-LEN TO OUT-LEN. 
           PERFORM START-STMT THRU STMT-XIT.
  
      * IF NO ACCESS MODE GIVEN, OMIT THE "FOR" PHRASE. 
           IF CAT-LINE-TYPE = "L" 
           THEN 
             GO TO 230-ACCESS-LOCK
           END-IF 
  
      * START THE "FOR" PHRASE ON THE SAME LINE.
           MOVE KW-FOR TO OUT-FIELD.
           MOVE KW-FOR-LEN TO OUT-LEN.
           PERFORM ADD-TO-STMT THRU STMT-XIT. 
  
      * DETERMINE THE ACCESS MODE(S). 
           PERFORM VARYING PICK-IDX FROM 1 BY 2 
             UNTIL PICK-IDX > 3 
  
             IF ACC-A-MODE (PICK-IDX : 1) = "U" 
             THEN 
               MOVE KW-UPDATE TO OUT-FIELD
               MOVE KW-UPDATE-LEN TO OUT-LEN
               PERFORM ADD-TO-STMT THRU STMT-XIT
             END-IF 
  
             IF ACC-A-MODE (PICK-IDX : 1) = "R" 
             THEN 
               MOVE KW-RETRIEVAL TO OUT-FIELD 
               MOVE KW-RETRIEVAL-LEN TO OUT-LEN 
               PERFORM ADD-TO-STMT THRU STMT-XIT
             END-IF 
           END-PERFORM
  
      * MOVE THE NEXT ACCESS LINE INTO "CAT-WORK".  IT MUST BE OF 
      * LINETYPE "L". 
           PERFORM MOVE-NEXT-LINE THRU MOVE-NEXT-LINE-XIT.
           MOVE "Y" TO SKIP-COMMENTS. 
           PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT.
           IF DATA-RETURN-CODE NOT = ZERO 
             OR CAT-LINE-TYPE NOT = "L" 
           THEN 
             MOVE IDX-705 TO MSG-IDX
             MOVE "AREA-ACCESS" TO MSG-NAME 
             PERFORM ERROR-TYPE2 THRU ERROR-TYPE2-XIT 
             GO TO 260-END-AREA-DESCR 
           END-IF 
  
       230-ACCESS-LOCK. 
  
      * PUT FIRST ACCESS LOCK ON NEW LINE PREFACED WITH "IS". 
           ADD INDENT-INC TO INDENT.
           MOVE KW-IS TO OUT-FIELD. 
           MOVE KW-IS-LEN TO OUT-LEN. 
           PERFORM START-STMT THRU STMT-XIT.
  
       240-SET-LOCK.
           IF ACC-A-LOCK = SPACES 
           THEN 
             GO TO 250-NEXT-LOCK
           END-IF 
  
      * IF ACCESS LOCK IS A PROCEDURE, LOOK UP ITS NAME IN CATALOGUE. 
           IF ACC-A-TYPE = "P"
           THEN 
             MOVE KW-PROCEDURE TO OUT-FIELD 
             MOVE KW-PROCEDURE-LEN TO OUT-LEN 
             PERFORM ADD-TO-STMT THRU STMT-XIT
  
             MOVE ACC-A-LOCK TO DBP-CATNAME 
             PERFORM ADD-DBP-NAME THRU ADD-DBP-NAME-XIT 
  
      * IF ACCESS LOCK IS A LITERAL, JUST MOVE IT TO OUTPUT LINE. 
           ELSE 
             MOVE ACC-A-LOCK (1 : 30) TO OUT-FIELD
             PERFORM FIND-LENGTH THRU FIND-LENGTH-XIT 
             MOVE "Y" TO OUT-QUOTE
             PERFORM ADD-TO-STMT THRU STMT-XIT
             MOVE "N" TO OUT-QUOTE
           END-IF 
  
       250-NEXT-LOCK. 
  
      * LOOK FOR NEXT LINE OF ACCESS CATEGORY.
           PERFORM MOVE-NEXT-LINE THRU MOVE-NEXT-LINE-XIT.
           PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT.
           IF DATA-RETURN-CODE NOT = ZERO 
           THEN 
             GO TO 260-END-AREA-DESCR 
           END-IF 
  
      * IF A NEW ACCESS MODE IS GIVEN, A NEW ACCESS-CONTROL CLAUSE MUST 
      * BE STARTED. 
           IF CAT-LINE-TYPE = "M" 
           THEN 
             SUBTRACT INDENT-INC FROM INDENT
             GO TO 220-START-ACC-CLAUSE 
           END-IF 
  
      * ADDITIONAL LOCKS EACH GO ON A NEW LINE PREFACED WITH "OR".
           MOVE KW-OR TO OUT-FIELD. 
           MOVE KW-OR-LEN TO OUT-LEN. 
           PERFORM START-STMT THRU STMT-XIT.
           GO TO 240-SET-LOCK.
  
       260-END-AREA-DESCR.
  
      * END THE AREA DESCRIPTION ENTRY WITH A PERIOD. 
           MOVE "." TO DMS-LINE (COLUMN-OUT - 1 : 1). 
           MOVE INDENT-INIT TO INDENT.
  
  
      ******************************************************************
      * 
      * RECORD DESCRIPTION ENTRY. 
      * 
      * FOR EACH RECORD INCLUDED IN THE AREA, GENERATE A RECORD 
      * DESCRIPTION ENTRY.
  
      * MOVE AREA'S FIRST STRUCTURE LINE INTO "CAT-WORK". 
           MOVE CAT-NO-STC TO DATA-ENTRY-CAT. 
           PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT.
           MOVE "N" TO SKIP-COMMENTS. 
           PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT.
           MOVE "N" TO FOUND-RECORD.
  
      * LOOP THROUGH AREA'S STRUCTURE LINES TO GENERATE DESCRIPTION 
      * ENTRIES.
           PERFORM UNTIL DATA-RETURN-CODE NOT = ZERO
             PERFORM CON-AREA-STC THRU CON-AREA-STC-XIT 
  
             IF A-STC-CNAME NOT = SPACES
               AND A-STC-INCL NOT = "N" 
             THEN 
               MOVE "Y" TO FOUND-RECORD 
               MOVE A-STC-CNAME TO RECORD-CATNAME 
               PERFORM RECORD-DESCRIPTION THRU RECORD-DESCRIPTION-XIT 
             END-IF 
           END-PERFORM
  
       270-END-AREA-STC.
  
      * CHECK THAT AT LEAST ONE RECORD EXISTS FOR THE AREA. 
           IF FOUND-RECORD = "N"
           THEN 
             MOVE IDX-600 TO MSG-IDX
             PERFORM ERROR-TYPE1 THRU ERROR-TYPE1-XIT 
           END-IF 
  
  
      ******************************************************************
      * 
       280-END-AREA-DESCR.
           PERFORM RESTORE-SCH-INFO THRU RESTORE-SCH-INFO-XIT.
  
       AREA-DESCRIPTION-XIT.
           EXIT.
      /*****************************************************************
      ******************************************************************
      * 
      * SUBROUTINES TO AREA-DESCRIPTION.
  
  
      ******************************************************************
      * 
      * AREA CALL CLAUSE GENERATION.
      * 
      * GENERATE A CALL CLAUSE FOR THE GIVEN DATABASE PROCEDURE FROM THE
      * AREA'S PROCESS CATEGORY.
      * 
      * INPUT:   DBP-CATNAME      - CATNAME OF THE DATABASE PROCEDURE TO
      *                             BE PROCESSED
      *          CAT-WORK         - AREA PROCESS, LINETYPE "P"
  
  
       AREA-CALL-CLAUSE.
  
      * START CALL CLAUSE ON A NEW STATEMENT. 
           ADD INDENT-INC TO INDENT.
           MOVE KW-CALL TO OUT-FIELD. 
           MOVE KW-CALL-LEN TO OUT-LEN. 
           PERFORM START-STMT THRU STMT-XIT.
  
           PERFORM ADD-DBP-NAME THRU ADD-DBP-NAME-XIT.
           IF FOUND-ENTITY = "N"
           THEN 
             GO TO 290-END-AREA-CALL-CLAUSE 
           END-IF 
  
      * ADD THE TIME OF PROCESSING TO STATEMENT.
           MOVE A-PRO-TIME TO CALL-TIME.
           PERFORM ADD-CALL-TIME THRU ADD-CALL-TIME-XIT.
  
      * ADD THE PROCESSING OPTIONS IF ANY GIVEN,
           IF A-PRO-OPT = SPACES
           THEN 
             GO TO 290-END-AREA-CALL-CLAUSE 
           END-IF 
  
           MOVE ALL "N" TO OPT-FLAGS. 
           PERFORM VARYING PICK-IDX FROM 1 BY 2 
             UNTIL PICK-IDX > 7 
  
             IF A-PRO-OPT (PICK-IDX : 1) = "O"
             THEN 
               MOVE "Y" TO OPT-O
             END-IF 
  
             IF A-PRO-OPT (PICK-IDX : 1) = "C"
             THEN 
               MOVE "Y" TO OPT-C
             END-IF 
  
             IF A-PRO-OPT (PICK-IDX : 1) = "U"
             THEN 
               MOVE "Y" TO OPT-U
             END-IF 
  
             IF A-PRO-OPT (PICK-IDX : 1) = "R"
             THEN 
               MOVE "Y" TO OPT-R
             END-IF 
  
           END-PERFORM
  
      * MOVE EACH OPTION TO OUTPUT LINE.
           IF OPT-O = "Y" 
           THEN 
             MOVE KW-OPEN TO OUT-FIELD
             MOVE KW-OPEN-LEN TO OUT-LEN
             PERFORM ADD-TO-STMT THRU STMT-XIT
           END-IF 
  
           IF OPT-U = "Y" 
             OR OPT-R = "Y" 
           THEN 
             MOVE KW-FOR TO OUT-FIELD 
             MOVE KW-FOR-LEN TO OUT-LEN 
             PERFORM ADD-TO-STMT THRU STMT-XIT
           END-IF 
  
           IF OPT-U = "Y" 
           THEN 
             MOVE KW-UPDATE TO OUT-FIELD
             MOVE KW-UPDATE-LEN TO OUT-LEN
             PERFORM ADD-TO-STMT THRU STMT-XIT
           END-IF 
  
           IF OPT-R = "Y" 
           THEN 
             MOVE KW-RETRIEVAL TO OUT-FIELD 
             MOVE KW-RETRIEVAL-LEN TO OUT-LEN 
             PERFORM ADD-TO-STMT THRU STMT-XIT
           END-IF 
  
           IF OPT-C = "Y" 
           THEN 
             MOVE KW-CLOSE TO OUT-FIELD 
             MOVE KW-CLOSE-LEN TO OUT-LEN 
             PERFORM ADD-TO-STMT THRU STMT-XIT
           END-IF 
  
       290-END-AREA-CALL-CLAUSE.
           MOVE INDENT-INIT TO INDENT.
  
       AREA-CALL-CLAUSE-XIT.
           EXIT.
      /*****************************************************************
      ******************************************************************
      * 
      * AREA CONTROL ENTRY. 
      * 
      * GENERATE AN AREA CONTROL CLAUSE FOR THE GIVEN AREA. 
      * 
      * INPUT:   AREA-CATNAME     - CATNAME OF THE AREA TO BE PROCESSED 
      *          CAT-WORK         - SCHEMA STRUCTURE
  
  
       AREA-CONTROL.
           PERFORM SAVE-SCH-INFO THRU SAVE-SCH-INFO-XIT.
  
      * START AREA CONTROL ENTRY WITH A BLANK LINE FOLLOWED BY KEYWORD
      * "AREA" ON A NEW LINE. 
           MOVE ZERO TO OUT-LEN.
           PERFORM START-STMT THRU STMT-XIT.
           MOVE KW-AREA TO OUT-FIELD. 
           MOVE KW-AREA-LEN TO OUT-LEN. 
           PERFORM START-STMT THRU STMT-XIT.
  
      * ADD AREA NAME TO OUTPUT LINE. IF ENTRY MISSING FOR AREA, IT HAS 
      * ALREADY BEEN DIAGNOSED, SO JUST RETURN. 
           PERFORM ADD-AREA-NAME THRU ADD-AREA-NAME-XIT.
           IF FOUND-ENTITY = "N"
           THEN 
             GO TO 340-END-AREA-CONTROL 
           END-IF 
  
           ADD INDENT-INC TO INDENT.
  
  
      ******************************************************************
      * 
      * FOR CLAUSE. 
      * 
      * FOR EACH COMPRESSION/DECOMPRESSION PROCEDURE ASSOCIATED WITH
      * AREA, GENERATE A FOR-CLAUSE.  IF NONE, MOVE ON TO KEY-CLAUSE. 
  
      * MOVE AREA'S FIRST TYPE "P" PROCESS LINE INTO "CAT-WORK".
           MOVE CAT-NO-PRO TO DATA-ENTRY-CAT. 
           MOVE "P" TO DATA-ENTRY-LINETYPE. 
           PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT.
  
      * LOOP THROUGH AREA'S PROCESS LINES, LOOKING FOR COMPRESSION OR 
      * DECOMPRESSION TYPES.
           PERFORM UNTIL DATA-RETURN-CODE NOT = ZERO
             PERFORM CON-AREA-PPRO THRU CON-AREA-PPRO-XIT 
  
             IF A-PRO-DBP NOT = SPACES
               AND A-PRO-PTYPE = "CP" OR "DP" 
             THEN 
  
      * START FOR-CLAUSE ON A NEW LINE. 
               MOVE KW-FOR TO OUT-FIELD 
               MOVE KW-FOR-LEN TO OUT-LEN 
               PERFORM START-STMT THRU STMT-XIT 
  
      * DETERMINE WHETHER COMPRESSION OR DECOMPRESSION. 
               IF A-PRO-PTYPE = "CP"
               THEN 
                 MOVE KW-COMPRESSION TO OUT-FIELD 
                 MOVE KW-COMPRESSION-LEN TO OUT-LEN 
                 PERFORM ADD-TO-STMT THRU STMT-XIT
  
               ELSE 
                 MOVE KW-DECOMP TO OUT-FIELD
                 MOVE KW-DECOMP-LEN TO OUT-LEN
                 PERFORM ADD-TO-STMT THRU STMT-XIT
               END-IF 
  
               MOVE KW-USE TO OUT-FIELD 
               MOVE KW-USE-LEN TO OUT-LEN 
               PERFORM ADD-TO-STMT THRU STMT-XIT
  
      * DETERMINE WHETHER SYSTEM OR USER PROC.
               IF A-PRO-DBP = "SYSTEM"
               THEN 
                 MOVE KW-SYSTEM TO OUT-FIELD
                 MOVE KW-SYSTEM-LEN TO OUT-LEN
                 PERFORM ADD-TO-STMT THRU STMT-XIT
  
               ELSE 
                 MOVE KW-PROCEDURE TO OUT-FIELD 
                 MOVE KW-PROCEDURE-LEN TO OUT-LEN 
                 PERFORM ADD-TO-STMT THRU STMT-XIT
  
                 MOVE A-PRO-DBP TO DBP-CATNAME
                 PERFORM ADD-DBP-NAME THRU ADD-DBP-NAME-XIT 
               END-IF 
             END-IF 
           END-PERFORM
  
       300-END-AREA-PRO.
           MOVE SPACES TO DATA-ENTRY-LINETYPE.
  
  
      ******************************************************************
      * 
      * KEY CLAUSE. 
      * 
      * FOR EACH KEY ASSOCIATED WITH THE AREA, GENERATE A KEY OR KEY-ID 
      * CLAUSE. 
  
      * MOVE AREA'S FIRST AREAKEYS LINE INTO "CAT-WORK".
           MOVE CAT-NO-AKEY TO DATA-ENTRY-CAT.
           PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT.
           MOVE "Y" TO SKIP-COMMENTS. 
           PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT.
  
      * LOOP THROUGH AREA'S AREAKEYS LINES. 
           PERFORM UNTIL DATA-RETURN-CODE NOT = ZERO
  
      * DETERMINE WHETHER KEY IS STANDARD OR CONCATENATED AND PROCESS 
      * ACCORDINGLY.
             IF CAT-LINE-TYPE = "K" 
             THEN 
               PERFORM KEY-CLAUSE THRU KEY-CLAUSE-XIT 
  
             ELSE 
               IF CAT-LINE-TYPE = "C" 
               THEN 
                 PERFORM KEY-ID-CLAUSE THRU KEY-ID-CLAUSE-XIT 
  
      * ERROR IF LINETYPES OUT OF ORDER.
               ELSE 
                 MOVE IDX-705 TO MSG-IDX
                 MOVE "AREA-AREAKEYS" TO MSG-NAME 
                 PERFORM ERROR-TYPE2 THRU ERROR-TYPE2-XIT 
  
      * SKIP ERRONEOUS LINE.
                 PERFORM MOVE-NEXT-LINE THRU MOVE-NEXT-LINE-XIT 
                 PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT 
               END-IF 
             END-IF 
           END-PERFORM
  
       310-END-AREA-AKEYS.
  
  
      ******************************************************************
      * 
      * SEQUENCE CLAUSE.
      * 
      * SET THE COLLATING SEQUENCE IF SPECIFIED.
  
      * MOVE AREA'S ATTRIBUTES CATEGORY INTO "CAT-WORK".
           MOVE CAT-NO-ATT TO DATA-ENTRY-CAT. 
           PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT.
           MOVE "Y" TO SKIP-COMMENTS. 
           PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT.
           PERFORM CON-AREA-ATT THRU CON-AREA-ATT-XIT.
  
      * IF THE SEQUENCE IS SET, GENERATE A SEQUENCE CLAUSE FOR IT ON A
      * NEW LINE. 
           IF A-ATT-SEQ = SPACES
           THEN 
             GO TO 320-END-AREA-SEQ 
           END-IF 
  
           MOVE KW-SEQUENCE TO OUT-FIELD
           MOVE KW-SEQUENCE-LEN TO OUT-LEN
           PERFORM START-STMT THRU STMT-XIT 
  
           IF A-ATT-SEQ = "A" 
           THEN 
             MOVE KW-ASCII TO OUT-FIELD 
             MOVE KW-ASCII-LEN TO OUT-LEN 
             PERFORM ADD-TO-STMT THRU STMT-XIT
             GO TO 320-END-AREA-SEQ 
           END-IF 
  
           IF A-ATT-SEQ = "C" 
           THEN 
             MOVE KW-COBOL TO OUT-FIELD 
             MOVE KW-COBOL-LEN TO OUT-LEN 
             PERFORM ADD-TO-STMT THRU STMT-XIT
             GO TO 320-END-AREA-SEQ 
           END-IF 
  
           IF A-ATT-SEQ = "D" 
           THEN 
             MOVE KW-DISPLAY TO OUT-FIELD 
             MOVE KW-DISPLAY-LEN TO OUT-LEN 
             PERFORM ADD-TO-STMT THRU STMT-XIT
           END-IF 
  
       320-END-AREA-SEQ.
  
  
      ******************************************************************
      * 
      * RECORD CODE CLAUSE. 
  
      * MOVE AREA'S FIRST PROCESS LINE INTO "CAT-WORK". 
           MOVE CAT-NO-PRO TO DATA-ENTRY-CAT. 
           PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT.
           MOVE "Y" TO SKIP-COMMENTS. 
           PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT.
           MOVE "N" TO FOUND-RCODE. 
  
      * LOOP THROUGH AREA'S PROCESS LINES TO LOOK FOR A RECORD-CODE 
      * SPECIFICATION.
           PERFORM UNTIL DATA-RETURN-CODE NOT = ZERO
             OR FOUND-CODE = "Y"
  
      * IF THE PROCESS LINE SPECIFIES A PROCEDURE TO DETERMINE RECORD 
      * CODE, START THE "RECORD CODE IS PROCEDURE" CLAUSE.
             IF CAT-LINE-TYPE = "P" 
             THEN 
               PERFORM CON-AREA-PPRO THRU CON-AREA-PPRO-XIT 
  
               IF A-PRO-DBP NOT = SPACES
                 AND A-PRO-PTYPE = "RC" 
               THEN 
                 MOVE "Y" TO FOUND-RCODE
                 MOVE KW-RCPROC TO OUT-FIELD
                 MOVE KW-RCPROC-LEN TO OUT-LEN
                 PERFORM START-STMT THRU STMT-XIT 
  
                 MOVE A-PRO-DBP TO DBP-CATNAME
                 PERFORM ADD-DBP-NAME THRU ADD-DBP-NAME-XIT 
               END-IF 
  
      * IF THE PROCESS LINE GIVES A DATANAME FOR RECORD-CODE
      * DETERMINATION, START THE "RECORD CODE IS BY" CLAUSE.
             ELSE 
               PERFORM CON-AREA-RPRO THRU CON-AREA-RPRO-XIT 
  
               IF A-PRO-RCDATA NOT = SPACES 
               THEN 
                 MOVE "Y" TO FOUND-RCODE
                 MOVE KW-RCBY TO OUT-FIELD
                 MOVE KW-RCBY-LEN TO OUT-LEN
                 PERFORM START-STMT THRU STMT-XIT 
  
                 MOVE A-PRO-RCDATA TO ELEM-CATNAME
                 MOVE A-PRO-ALIAS TO ELEM-ALIAS 
                 MOVE A-PRO-QUAL TO QUAL-CATNAME
                 PERFORM SAVE-AREA-INFO THRU SAVE-AREA-INFO-XIT 
                 PERFORM ADD-ELEM-NAME THRU ADD-ELEM-NAME-XIT 
                 PERFORM RESTORE-AREA-INFO THRU RESTORE-AREA-INFO-XIT 
  
                 IF QUAL-CATNAME NOT = SPACES 
                 THEN 
                   PERFORM ADD-QUAL-NAME THRU ADD-QUAL-NAME-XIT 
                 END-IF 
               END-IF 
             END-IF 
           END-PERFORM
  
       330-END-AREA-PRO.
  
      * IF NO RECORD CODE SPECIFIED, END THE AREA CONTROL ENTRY.
           IF FOUND-RCODE = "N" 
           THEN 
             GO TO 340-END-AREA-CONTROL 
           END-IF 
  
      * COMPLETE THE RECORD-CODE CLAUSE. MOVE AREA'S FIRST STRUCTURE
      * LINE INTO "CAT-WORK". 
           MOVE CAT-NO-STC TO DATA-ENTRY-CAT. 
           PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT.
           MOVE "Y" TO SKIP-COMMENTS. 
           PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT.
           ADD INDENT-INC TO INDENT.
  
      * LOOP THROUGH AREA'S STRUCTURE LINES TO FIND A RECORD CODE 
      * VALUE FOR EACH RECORD.
           PERFORM UNTIL DATA-RETURN-CODE NOT = ZERO
             PERFORM CON-AREA-STC THRU CON-AREA-STC-XIT 
             IF A-STC-CNAME = SPACES
             THEN 
               GO TO 340-END-AREA-CONTROL 
             END-IF 
  
      * ERROR IF RECORD-CODE VALUE MISSING FOR ANY RECORD.
             IF A-STC-RCVAL = SPACES
             THEN 
               MOVE IDX-710 TO MSG-IDX
               MOVE "AREA-STRUCTURE-RCVALUE" TO MSG-NAME
               PERFORM ERROR-TYPE2 THRU ERROR-TYPE2-XIT 
  
      * INSERT RECORD-NAME AND ITS RECORD-CODE VALUE INTO VALUE-FOR 
      * PHRASE. 
             ELSE 
               MOVE KW-VALFOR TO OUT-FIELD
               MOVE KW-VALFOR-LEN TO OUT-LEN
               PERFORM START-STMT THRU STMT-XIT 
  
               MOVE A-STC-CNAME TO RECORD-CATNAME 
               PERFORM SAVE-AREA-INFO THRU SAVE-AREA-INFO-XIT 
               PERFORM ADD-REC-NAME THRU ADD-REC-NAME-XIT 
               PERFORM RESTORE-AREA-INFO THRU RESTORE-AREA-INFO-XIT 
  
               MOVE KW-IS TO OUT-FIELD
               MOVE KW-IS-LEN TO OUT-LEN
               PERFORM ADD-TO-STMT THRU STMT-XIT
  
               MOVE A-STC-RCVAL TO OUT-FIELD
               PERFORM FIND-LENGTH THRU FIND-LENGTH-XIT 
               IF A-STC-RCTYPE = "L"
               THEN 
                 MOVE "Y" TO OUT-QUOTE
               END-IF 
               PERFORM ADD-TO-STMT THRU STMT-XIT
             END-IF 
           END-PERFORM
  
  
      ******************************************************************
      * 
       340-END-AREA-CONTROL.
           MOVE "." TO DMS-LINE (COLUMN-OUT - 1 : 1). 
           MOVE INDENT-INIT TO INDENT.
           PERFORM RESTORE-SCH-INFO THRU RESTORE-SCH-INFO-XIT.
  
       AREA-CONTROL-XIT.
           EXIT.
      /*****************************************************************
      ******************************************************************
      * 
      * SUBROUTINES TO AREA-CONTROL.
  
  
      ******************************************************************
      * 
      * KEY CLAUSE GENERATION.
      * 
      * INPUT:   CAT-WORK         - AREA AREAKEYS, LINETYPE "K" 
      * 
      * OUTPUT:  CAT-WORK         - AREA AREAKEYS, NEXT LINETYPE
  
  
       KEY-CLAUSE.
  
      * CONSOLIDATE AREAKEY LINE IF NEEDED. 
           PERFORM CON-AREA-KKEY THRU CON-AREA-KKEY-XIT.
           IF A-KEY-KNAME = SPACES
           THEN 
             GO TO KEY-CLAUSE-XIT 
           END-IF 
  
      * START KEY-CLAUSE ON A NEW LINE. 
           MOVE KW-KEYIS TO OUT-FIELD.
           MOVE KW-KEYIS-LEN TO OUT-LEN.
           PERFORM START-STMT THRU STMT-XIT.
  
      * STATE IF AN ALTERNATE KEY.
           IF A-KEY-KTYPE = "A" 
           THEN 
             MOVE KW-ALTERNATE TO OUT-FIELD 
             MOVE KW-ALTERNATE-LEN TO OUT-LEN 
             PERFORM ADD-TO-STMT THRU STMT-XIT
           END-IF 
  
      * ADD GROUP/ELEMENT NAME TO KEY-CLAUSE. 
           MOVE A-KEY-KNAME TO ITEM-CATNAME.
           MOVE A-KEY-ALIAS TO ITEM-ALIAS.
           PERFORM ADD-ITEM-NAME THRU ADD-ITEM-NAME-XIT.
  
      * IF KEY WAS FOUND AND IS QUALIFIED, ADD ITS QUALIFIER. 
           IF FOUND-ENTITY = "Y"
             AND A-KEY-QUAL NOT = SPACES
           THEN 
             MOVE A-KEY-QUAL TO QUAL-CATNAME
             PERFORM ADD-QUAL-NAME THRU ADD-QUAL-NAME-XIT 
           END-IF 
  
           ADD INDENT-INC TO INDENT.
  
      * GENERATE USING-PHRASE IF SPECIFIED. 
           IF A-KEY-USING = "Y" 
           THEN 
             PERFORM USING-PHRASE THRU USING-PHRASE-XIT 
           END-IF 
  
      * GENERATE DUPLICATES-PHRASE IF SPECIFIED.
           IF A-KEY-DUPES NOT = SPACES
           THEN 
             MOVE A-KEY-DUPES TO SAVE-DUPES 
             PERFORM DUPLICATES-PHRASE THRU DUPLICATES-PHRASE-XIT 
           END-IF 
  
           SUBTRACT INDENT-INC FROM INDENT. 
  
       KEY-CLAUSE-XIT.
           EXIT.
  
  
      ******************************************************************
      * 
      * KEY-ID CLAUSE GENERATION. 
      * 
      * INPUT:   CAT-WORK         - AREA AREAKEYS, LINETYPE "C" 
      * 
      * OUTPUT:  CAT-WORK         - AREA AREAKEYS, LINETYPE AFTER "I"'S 
  
  
       KEY-ID-CLAUSE. 
  
      * CONSOLIDATE AREAKEY LINE IF NEEDED. 
           PERFORM CON-AREA-CKEY THRU CON-AREA-CKEY-XIT.
           IF A-KEY-ID = SPACES 
           THEN 
             GO TO KEY-ID-CLAUSE-XIT
           END-IF 
  
      * START KEY-ID CLAUSE ON A NEW LINE.
           MOVE KW-KEYIDIS TO OUT-FIELD.
           MOVE KW-KEYIDIS-LEN TO OUT-LEN.
           PERFORM START-STMT THRU STMT-XIT.
  
      * STATE IF ALTERNATE KEY. 
           IF A-KEY-CTYPE = "A" 
           THEN 
             MOVE KW-ALTERNATE TO OUT-FIELD 
             MOVE KW-ALTERNATE-LEN TO OUT-LEN 
             PERFORM ADD-TO-STMT THRU STMT-XIT
           END-IF 
  
      * MOVE CONCATENATED KEY'S ID TO OUTPUT LINE.
           MOVE A-KEY-ID TO OUT-FIELD.
           PERFORM FIND-LENGTH THRU FIND-LENGTH-XIT.
           PERFORM ADD-TO-STMT THRU STMT-XIT. 
  
      * LIST KEY'S COMPONENTS WITHIN ANGLE BRACKETS.
           ADD INDENT-INC TO INDENT.
           MOVE "<" TO OUT-FIELD. 
           MOVE 1 TO OUT-LEN. 
           PERFORM START-STMT THRU STMT-XIT.
  
      * SAVE DUPES AND USING FLAGS FOR LATER. 
           MOVE A-KEY-CDUPES TO SAVE-DUPES. 
           MOVE A-KEY-CUSING TO SAVE-USING. 
  
      * FIRST COMPONENT SHOULD NOW BE IN "CAT-WORK".
           IF CAT-LINE-TYPE NOT = "I" 
           THEN 
             MOVE IDX-725 TO MSG-IDX
             MOVE "AREA-AREAKEYS" TO MSG-NAME 
             PERFORM ERROR-TYPE2 THRU ERROR-TYPE2-XIT 
           END-IF 
  
      * LOOP THROUGH AREAKEY LINES FOR COMPONENTS, ADDING EACH ONE TO 
      * KEY-ID CLAUSE. ALSO ADD THE COMPONENT'S QUALIFIER IF ONE EXISTS.
           PERFORM UNTIL CAT-LINE-TYPE NOT = "I"
             PERFORM CON-AREA-IKEY THRU CON-AREA-IKEY-XIT 
  
             IF A-KEY-COMPONENT NOT = SPACES
             THEN 
               MOVE A-KEY-COMPONENT TO ELEM-CATNAME 
               MOVE A-KEY-CALIAS TO ELEM-ALIAS
               PERFORM SAVE-AREA-INFO THRU SAVE-AREA-INFO-XIT 
               PERFORM ADD-ELEM-NAME THRU ADD-ELEM-NAME-XIT 
               PERFORM RESTORE-AREA-INFO THRU RESTORE-AREA-INFO-XIT 
  
               IF A-KEY-CQUAL NOT = SPACES
               THEN 
                 MOVE A-KEY-CQUAL TO QUAL-CATNAME 
                 PERFORM ADD-QUAL-NAME THRU ADD-QUAL-NAME-XIT 
               END-IF 
             END-IF 
           END-PERFORM
  
       350-END-AREAKEYS.
  
      * MOVE ENDING ANGLE BRACKET TO COMPONENT LIST.
           MOVE ">" TO OUT-FIELD. 
           MOVE 1 TO OUT-LEN. 
           PERFORM ADD-TO-STMT THRU STMT-XIT. 
  
      * GENERATE USING PHRASE IF SPECIFIED. 
           IF SAVE-USING = "Y"
           THEN 
             PERFORM USING-PHRASE THRU USING-PHRASE-XIT 
           END-IF 
  
      * GENERATE DUPLICATES PHRASE IF SPECIFIED.
           IF SAVE-DUPES NOT = SPACES 
           THEN 
             PERFORM DUPLICATES-PHRASE THRU DUPLICATES-PHRASE-XIT 
           END-IF 
  
           SUBTRACT INDENT-INC FROM INDENT. 
  
       KEY-ID-CLAUSE-XIT. 
           EXIT.
  
  
      ******************************************************************
      * 
      * USING PHRASE GENERATION 
  
       USING-PHRASE.
  
      * START NEW LINE WITH KEYWORD "USING".
           MOVE KW-USING TO OUT-FIELD.
           MOVE KW-USING-LEN TO OUT-LEN.
           PERFORM START-STMT THRU STMT-XIT.
  
      * MOVE AREA'S FIRST TYPE "P" PROCESS LINE INTO "CAT-WORK".
           PERFORM SAVE-AREA-INFO THRU SAVE-AREA-INFO-XIT.
           MOVE CAT-NO-PRO TO DATA-ENTRY-CAT. 
           MOVE "P" TO DATA-ENTRY-LINETYPE. 
           PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT.
           MOVE "N" TO FOUND-USING. 
  
      * LOOP THROUGH AREA'S PROCESS LINES TO LOOK FOR THE USING-TYPE
      * (IE, HASHING) DATABASE PROCEDURE, AND ADD ITS NAME TO THE 
      * USING-PHRASE. 
           PERFORM UNTIL DATA-RETURN-CODE NOT = ZERO
             OR FOUND-USING = "Y" 
  
             PERFORM CON-AREA-PPRO THRU CON-AREA-PPRO-XIT 
  
             IF A-PRO-DBP NOT = SPACES
               AND A-PRO-PTYPE = "US" 
             THEN 
               MOVE "Y" TO FOUND-USING
               MOVE A-PRO-DBP TO DBP-CATNAME
               PERFORM ADD-DBP-NAME THRU ADD-DBP-NAME-XIT 
             END-IF 
           END-PERFORM
  
       360-END-AREA-USING.
           PERFORM RESTORE-AREA-INFO THRU RESTORE-AREA-INFO-XIT.
  
      * ERROR IF NO USING-PROC SPECIFIED. 
           IF FOUND-USING = "N" 
           THEN 
             MOVE IDX-710 TO MSG-IDX
             MOVE "AREA-PROCESS-TYPEPROC=US" TO MSG-NAME
             PERFORM ERROR-TYPE2 THRU ERROR-TYPE2-XIT 
           END-IF 
  
       USING-PHRASE-XIT.
  
  
      ******************************************************************
      * 
      * DUPLICATES PHRASE GENERATION. 
  
       DUPLICATES-PHRASE. 
  
      * START NEW LINE WITH KEYWORDS "DUPLICATES ARE".
           MOVE KW-DUPARE TO OUT-FIELD. 
           MOVE KW-DUPARE-LEN TO OUT-LEN. 
           PERFORM START-STMT THRU STMT-XIT.
  
      * MOVE CORRECT OPTION TO DUPLICATES-PHRASE. 
           IF SAVE-DUPES = "A"
           THEN 
             MOVE KW-ALLOWED TO OUT-FIELD 
             MOVE KW-ALLOWED-LEN TO OUT-LEN 
           END-IF 
  
           IF SAVE-DUPES = "I"
           THEN 
             MOVE KW-INDEXED TO OUT-FIELD 
             MOVE KW-INDEXED-LEN TO OUT-LEN 
           END-IF 
  
           IF SAVE-DUPES = "F"
           THEN 
             MOVE KW-FIRST TO OUT-FIELD 
             MOVE KW-FIRST-LEN TO OUT-LEN 
           END-IF 
  
           IF SAVE-DUPES = "N"
           THEN 
             MOVE KW-NOTALLOW TO OUT-FIELD
             MOVE KW-NOTALLOW-LEN TO OUT-LEN
           END-IF 
  
           PERFORM ADD-TO-STMT THRU STMT-XIT. 
  
       DUPLICATES-PHRASE-XIT. 
      /*****************************************************************
      * THIS SECTION OF PROCEDURES ACCESSES PRIMARILY THE RECORD ENTITY.
      ******************************************************************
  
  
      ******************************************************************
      ******************************************************************
      * 
      * RECORD DESCRIPTION GENERATION.
      * 
      * GENERATE A RECORD DESCRIPTION FOR THE GIVEN RECORD.  FOR EACH 
      * GROUP AND ELEMENT ASSOCIATED WITH THE RECORD, CREATE A DATA 
      * DESCRIPTION ENTRY.
      * 
      * INPUT:   CAT-WORK         - AREA STRUCTURE
      *          RECORD-CATNAME   - NAME OF RECORD TO BE DESCRIBED
  
       RECORD-DESCRIPTION.
           PERFORM SAVE-AREA-INFO THRU SAVE-AREA-INFO-XIT.
  
      * START RECORD DESCRIPTION ENTRY WITH A BLANK LINE AND THE KEYWORD
      * "RECORD" ON A NEW LINE. 
           MOVE ZERO TO OUT-LEN.
           PERFORM START-STMT THRU STMT-XIT.
           MOVE KW-RECORD TO OUT-FIELD. 
           MOVE KW-RECORD-LEN TO OUT-LEN. 
           PERFORM START-STMT THRU STMT-XIT.
  
      * ADD THE RECORD NAME TO OUTPUT LINE. IF ENTRY FOR RECORD MISSING,
      * IT HAS ALREADY BEEN DIAGNOSED, JUST RETURN. 
           PERFORM ADD-REC-NAME THRU ADD-REC-NAME-XIT.
           IF FOUND-ENTITY = "N"
           THEN 
             GO TO 420-END-RECORD-DESCR 
           END-IF 
  
      * ADD THE WITHIN-CLAUSE TO THE SAME LINE. 
           MOVE KW-WITHIN TO OUT-FIELD. 
           MOVE KW-WITHIN-LEN TO OUT-LEN. 
           PERFORM ADD-TO-STMT THRU STMT-XIT. 
  
           MOVE AREA-DNAME TO OUT-FIELD.
           MOVE AREA-DNAME-LEN TO OUT-LEN.
           PERFORM ADD-TO-STMT THRU STMT-XIT. 
  
           ADD INDENT-INC TO INDENT.
  
  
      ******************************************************************
      * 
      * RECORD CALL CLAUSE. 
      * 
      * FOR EACH DATABASE PROCEDURE ASSOCIATED WITH THE RECORD, GENERATE
      * A CALL-CLAUSE.
  
      * MOVE RECORD'S FIRST PROCESS LINE INTO "CAT-WORK". 
           MOVE CAT-NO-PRO TO DATA-ENTRY-CAT. 
           PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT.
           MOVE "Y" TO SKIP-COMMENTS. 
           PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT.
  
      * LOOP THROUGH PROCESS LINES, IF ANY, TO GENERATE CALL-CLAUSES. 
      * RECORDS ARE ALLOWED ONLY "CALL-TYPE" DBPROCS. 
           PERFORM UNTIL DATA-RETURN-CODE NOT = ZERO
             PERFORM CON-REC-PRO THRU CON-REC-PRO-XIT 
  
             IF R-PRO-DBP NOT = SPACES
             THEN 
               IF R-PRO-PTYPE = "CA"
               THEN 
                 MOVE R-PRO-DBP TO DBP-CATNAME
                 PERFORM REC-CALL-CLAUSE THRU REC-CALL-CLAUSE-XIT 
  
               ELSE 
                 MOVE IDX-715 TO MSG-IDX
                 MOVE "RECORD-PROCESS-TYPEPROC" TO MSG-NAME 
                 PERFORM ERROR-TYPE2 THRU ERROR-TYPE2-XIT 
               END-IF 
             END-IF 
           END-PERFORM
  
       400-END-REC-PRO. 
           MOVE "." TO DMS-LINE (COLUMN-OUT - 1 : 1). 
  
  
      ******************************************************************
      * 
      * DATA DESCRIPTION ENTRY. 
      * 
      * FOR EACH GROUP OR ELEMENT INCLUDED IN THE RECORD, GENERATE A
      * DATA DESCRIPTION ENTRY. 
  
      * MOVE RECORD'S FIRST STRUCTURE LINE INTO "CAT-WORK". 
           MOVE CAT-NO-STC TO DATA-ENTRY-CAT. 
           PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT.
           MOVE "N" TO SKIP-COMMENTS. 
           PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT.
           MOVE "N" TO FOUND-ITEM.
  
      * LOOP THROUGH RECORD'S STRUCTURE LINES, GENERATING A DATA
      * DESCRIPTION ENTRY FOR EACH INCLUDED GROUP OR ELEMENT. 
           PERFORM UNTIL DATA-RETURN-CODE NOT = ZERO
  
      * CHECK THAT LINE IS FOR AN INCLUDED ITEM.
             IF CAT-LINE-TYPE = "A" 
             THEN 
               PERFORM CON-RG-ASTC THRU CON-RG-ASTC-XIT 
  
               IF RG-STC-CNAME NOT = SPACES 
                 AND RG-STC-INCL NOT = "N"
               THEN 
                 MOVE "Y" TO FOUND-ITEM 
                 MOVE GTBL-OPT-LEVEL TO LEVEL-NO
                 MOVE 1 TO LEVEL-IDX
  
      * READ DATA ITEM'S FIRST RECORD INTO "DATA-RECORD". 
                 PERFORM SAVE-REC-INFO THRU SAVE-REC-INFO-XIT 
                 PERFORM CLEAR-DATA-ENTRY THRU CLEAR-DATA-ENTRY-XIT 
                 MOVE RG-STC-CNAME TO DATA-ENTRY-NAME 
                 PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT 
                 IF DATA-RETURN-CODE NOT = ZERO 
                 THEN 
                   MOVE IDX-500 TO MSG-IDX
                   PERFORM ERROR-TYPE1 THRU ERROR-TYPE1-XIT 
  
      * DETERMINE WHETHER DATA ITEM IS A GROUP OR ELEMENT AND PROCESS 
      * ACCORDINGLY.
                 ELSE 
                   IF DATA-HDR-ENT-ID = ENT-ID-GROUP
                   THEN 
                     MOVE RG-STC-CNAME TO GROUP-CATNAME 
                     PERFORM GRP-DATA-DESCR THRU GRP-DATA-DESCR-XIT 
  
                   ELSE 
                     IF DATA-HDR-ENT-ID = ENT-ID-ELEM 
                     THEN 
                       MOVE RG-STC-CNAME TO ELEM-CATNAME
                       MOVE RG-STC-ALIAS TO ELEM-ALIAS
                       PERFORM ELEM-DATA-DESCR THRU ELEM-DATA-DESCR-XIT 
  
      * ERROR IF OTHER THAN GROUP OR ELEMENT. 
                     ELSE 
                       MOVE IDX-525 TO MSG-IDX
                       PERFORM ERROR-TYPE1 THRU ERROR-TYPE1-XIT 
                     END-IF 
                   END-IF 
                 END-IF 
  
                 PERFORM RESTORE-REC-INFO THRU RESTORE-REC-INFO-XIT 
               END-IF 
  
      * ERROR IF LINE-TYPES OUT OF ORDER. 
             ELSE 
               MOVE IDX-705 TO MSG-IDX
               MOVE "RECORD-STRUCTURE" TO MSG-NAME
               PERFORM ERROR-TYPE2 THRU ERROR-TYPE2-XIT 
  
      * SKIP THE ERRONEOUS LINE.
               PERFORM MOVE-NEXT-LINE THRU MOVE-NEXT-LINE-XIT 
               PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT 
             END-IF 
           END-PERFORM
  
      * CHECK THAT AT LEAST ONE ITEM EXISTS FOR THE RECORD. 
           IF FOUND-ITEM = "N"
           THEN 
             MOVE IDX-600 TO MSG-IDX
             PERFORM ERROR-TYPE1 THRU ERROR-TYPE1-XIT 
           END-IF 
  
       410-END-REC-STC. 
           MOVE INDENT-INIT TO INDENT.
  
  
      ******************************************************************
      * 
       420-END-RECORD-DESCR.
           PERFORM RESTORE-AREA-INFO THRU RESTORE-AREA-INFO-XIT.
  
       RECORD-DESCRIPTION-XIT.
           EXIT.
  
  
      ******************************************************************
      * 
      * RECORD CALL CLAUSE GENERATION.
      * 
      * INPUT:   CAT-WORK         - RECORD PROCESS
  
  
       REC-CALL-CLAUSE. 
  
      * START CALL CLAUSE ON A NEW STATEMENT. 
           MOVE KW-CALL TO OUT-FIELD. 
           MOVE KW-CALL-LEN TO OUT-LEN. 
           PERFORM START-STMT THRU STMT-XIT.
  
      * ADD THE DBPROC NAME TO OUTPUT LINE. IF ENTRY FOR DBPROC MISSING,
      * IT HAS ALREADY BEEN DIAGNOSED, SO JUST RETURN.
           PERFORM ADD-DBP-NAME THRU ADD-DBP-NAME-XIT.
           IF FOUND-ENTITY = "N"
           THEN 
             GO TO REC-CALL-CLAUSE-XIT
           END-IF 
  
      * ADD THE TIME OF PROCESSING TO STATEMENT.
           MOVE R-PRO-TIME TO CALL-TIME.
           PERFORM ADD-CALL-TIME THRU ADD-CALL-TIME-XIT.
  
      * ADD THE PROCESSING OPTIONS IF ANY GIVEN.
           MOVE R-PRO-OPT TO CALL-OPTION. 
           PERFORM ADD-CALL-OPTION THRU ADD-CALL-OPTION-XIT.
  
       REC-CALL-CLAUSE-XIT. 
           EXIT.
      /*****************************************************************
      * THIS SECTION OF PROCEDURES ACCESSES PRIMARILY THE GROUP ENTITY
      ******************************************************************
  
  
      ******************************************************************
      ******************************************************************
      * 
      * GRP-DATA-DESCR. 
      * 
      * GENERATE A DATA DESCRIPTION ENTRY FOR THE GIVEN GROUP -- MAY
      * BE CALLED FROM RECORD OR GROUP LEVEL. 
      * 
      * INPUT:   GRP-CATNAME      - CATNAME OF GROUP TO BE DESCRIBED
      *          LEVEL-IDX        - INDEX INTO THE "HOLD-GRP" AREA -- 
      *                             ALSO USED TO DETERMINE WHETHER
      *                             CALLED FROM RECORD OR GROUP 
      *          LEVEL-NO         - LEVEL NUMBER OF GROUP 
      *          CAT-WORK         - BLANK 
      *          DATA-RECORD      - GROUP 
      *          GRP/REC-CON-LINE - RECORD STRUCTURE, LINETYPE "A"
      *          GRP/REC-CAT-WORK - RECORD STRUCTURE, LINE AFTER "A"
      * 
      * OUTPUT:  GRP/REC-CON-LINE - RECORD STRUCTURE, LINETYPE "A"/"O"
      *          GRP/REC-CAT-WORK - RECORD STRUCTURE, NEXT LINE 
  
       GRP-DATA-DESCR.
  
      * START A NEW LINE WITH THE GROUP'S LEVEL NUMBER. 
           MOVE LEVEL-NO TO OUT-FIELD.
           MOVE 3 TO OUT-LEN. 
           PERFORM START-STMT THRU STMT-XIT.
  
      * ADD THE GROUP NAME TO THE OUTPUT LINE.  IF ENTRY FOR GROUP
      * MISSING, IT HAS ALREADY BEEN DIAGNOSED, SO JUST RETURN. 
           PERFORM ADD-GRP-NAME THRU ADD-GRP-NAME-XIT.
           IF FOUND-ENTITY = "N"
           THEN 
             GO TO 500-EXPAND-GRP-STC 
           END-IF 
  
      * OCCURS IS THE ONLY CLAUSE ALLOWED FOR A SCHEMA GROUP.  OUTPUT 
      * IT, IF GIVEN, STARTING IN MIDDLE OF LINE. 
           PERFORM SAVE-GRP-INFO THRU SAVE-GRP-INFO-XIT.
           MOVE "Y" TO OUT-CLAUSE.
           PERFORM OCCURS-CLAUSE THRU OCCURS-CLAUSE-XIT.
           MOVE "N" TO OUT-CLAUSE.
           PERFORM RESTORE-GRP-INFO THRU RESTORE-GRP-INFO-XIT.
  
      * END THE DATA DESCRIPTION ENTRY WITH A PERIOD. 
           MOVE "." TO DMS-LINE (COLUMN-OUT - 1 : 1). 
  
      * MOVE GROUP'S FIRST STRUCTURE LINE INTO "CAT-WORK".
           MOVE CAT-NO-STC TO DATA-ENTRY-CAT. 
           PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT.
           MOVE "N" TO SKIP-COMMENTS. 
           PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT.
           MOVE "N" TO FOUND-GRP (LEVEL-IDX). 
  
       500-EXPAND-GRP-STC.
  
      * LOOP THROUGH GROUP'S STRUCTURE LINES, GENERATING A DATA 
      * DESCRIPTION ENTRY FOR EACH INCLUDED GROUP OR ELEMENT. 
  
      * NO MORE STRUCTURE LINES MEANS FINISHED WITH CURRENT LEVEL.
           IF DATA-RETURN-CODE NOT = ZERO 
           THEN 
  
      * IF INITIAL LEVEL, EXIT. 
             IF LEVEL-IDX = 1 
             THEN 
               GO TO 510-END-GRP-STC
  
      * IF SUBORDINATE LEVEL, BACK UP A LEVEL AND CONTINUE FROM THERE.
             ELSE 
               IF FOUND-GRP (LEVEL-IDX) = "N" 
               THEN 
                 MOVE IDX-600 TO MSG-IDX
                 PERFORM ERROR-TYPE1 THRU ERROR-TYPE1-XIT 
               END-IF 
  
               SUBTRACT GTBL-OPT-INCLEV FROM LEVEL-NO 
               SUBTRACT 1 FROM LEVEL-IDX
               SUBTRACT INDENT-INC FROM INDENT
               PERFORM RESTORE-GRP-INFO THRU RESTORE-GRP-INFO-XIT 
               GO TO 500-EXPAND-GRP-STC 
             END-IF 
           END-IF 
  
      * CHECK THAT LINE IS FOR AN INCLUDED ITEM.
           IF CAT-LINE-TYPE = "A" 
           THEN 
             PERFORM CON-RG-ASTC THRU CON-RG-ASTC-XIT 
  
             IF RG-STC-CNAME NOT = SPACES 
               AND RG-STC-INCL NOT = "N"
             THEN 
               MOVE "Y" TO FOUND-GRP (LEVEL-IDX)
  
      * PREPARE TO MOVE DOWN A LEVEL. 
               PERFORM SAVE-GRP-INFO THRU SAVE-GRP-INFO-XIT 
               ADD GTBL-OPT-INCLEV TO LEVEL-NO
               ADD 1 TO LEVEL-IDX 
               ADD INDENT-INC TO INDENT 
  
      * READ DATA ITEM'S FIRST RECORD INTO "DATA-RECORD". 
               PERFORM CLEAR-DATA-ENTRY THRU CLEAR-DATA-ENTRY-XIT 
               MOVE RG-STC-CNAME TO DATA-ENTRY-NAME 
               PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT 
               IF DATA-RETURN-CODE NOT = ZERO 
               THEN 
                 MOVE IDX-500 TO MSG-IDX
                 PERFORM ERROR-TYPE1 THRU ERROR-TYPE1-XIT 
  
      * DETERMINE WHETHER ITEM IS A GROUP OR ELEMENT AND PROCESS
      * ACCORDINGLY.  DIAGNOSE IF LEVEL NUMBER TOO DEEP.
               ELSE 
                 IF DATA-HDR-ENT-ID = ENT-ID-GROUP
                 THEN 
                   IF LEVEL-NO > 98 
                     OR LEVEL-IDX > 4 
                   THEN 
                     MOVE IDX-550 TO MSG-IDX
                     PERFORM ERROR-TYPE0 THRU ERROR-TYPE0-XIT 
                   ELSE 
                     MOVE RG-STC-CNAME TO GROUP-CATNAME 
                     GO TO GRP-DATA-DESCR 
                   END-IF 
                 END-IF 
  
                 IF DATA-HDR-ENT-ID = ENT-ID-ELEM 
                 THEN 
                   IF LEVEL-NO > 99 
                   THEN 
                     MOVE IDX-550 TO MSG-IDX
                     PERFORM ERROR-TYPE0 THRU ERROR-TYPE0-XIT 
                   ELSE 
                     MOVE RG-STC-CNAME TO ELEM-CATNAME
                     MOVE RG-STC-ALIAS TO ELEM-ALIAS
                     PERFORM ELEM-DATA-DESCR THRU ELEM-DATA-DESCR-XIT 
                   END-IF 
  
      * ERROR IF OTHER THAN GROUP OR ELEMENT. 
                 ELSE 
                   MOVE IDX-525 TO MSG-IDX
                   PERFORM ERROR-TYPE1 THRU ERROR-TYPE1-XIT 
                 END-IF 
               END-IF 
  
      * MOVE BACK UP A LEVEL. 
               SUBTRACT GTBL-OPT-INCLEV FROM LEVEL-NO 
               SUBTRACT 1 FROM LEVEL-IDX
               SUBTRACT INDENT-INC FROM INDENT
               PERFORM RESTORE-GRP-INFO THRU RESTORE-GRP-INFO-XIT 
             END-IF 
  
      * ERROR IF LINE-TYPES OUT OF ORDER. 
           ELSE 
             MOVE IDX-705 TO MSG-IDX
             MOVE "GROUP-STRUCTURE" TO MSG-NAME 
             PERFORM ERROR-TYPE2 THRU ERROR-TYPE2-XIT 
  
      * SKIP OVER ERRONEOUS LINE. 
             PERFORM MOVE-NEXT-LINE THRU MOVE-NEXT-LINE-XIT 
             PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT 
           END-IF 
  
      * LOOP BACK TO LOOK AT NEXT STRUCTURE LINE. 
           GO TO 500-EXPAND-GRP-STC.
  
       510-END-GRP-STC. 
  
      * CHECK THAT AT LEAST ONE ITEM EXISTS FOR THE GROUP.
           IF FOUND-GRP (LEVEL-IDX) = "N" 
           THEN 
             MOVE IDX-600 TO MSG-IDX
             PERFORM ERROR-TYPE1 THRU ERROR-TYPE1-XIT 
           END-IF 
  
       GRP-DATA-DESCR-XIT.
           EXIT.
      /*****************************************************************
      * THIS SECTION OF PROCEDURES ACCESSES PRIMARILY THE ELEMENT ENTITY
      ******************************************************************
  
  
      ******************************************************************
      ******************************************************************
      * 
      * ELEM-DATA-DESCR.
      * 
      * GENERATE A DATA DESCRIPTION ENTRY FOR THE GIVEN ELEMENT -- MAY
      * BE CALLED FROM RECORD OR GROUP LEVEL. 
      * 
      * INPUT:   ELEM-CATNAME     - CATNAME OF ELEMENT TO BE DESCRIBED
      *          ELEM-ALIAS       - ALIAS NUMBER OF ELEMENT 
      *          LEVEL-IDX        - INDEX INTO "HOLD-GRP" AREA -- ALSO
      *                             USED TO DETERMINE WHETHER CALLED
      *                             FROM RECORD OR GROUP
      *          LEVEL-NO         - LEVEL NUMBER OF ELEMENT 
      *          CAT-WORK         - BLANK 
      *          DATA-RECORD      - ELEMENT 
      *          GRP/REC-CON-LINE - RECORD STRUCTURE, LINETYPE "A"
      *          GRP/REC-CAT-WORK - RECORD STRUCTURE, LINE AFTER "A"
      * 
      * OUTPUT:  GRP/REC-CON-LINE - RECORD STRUCTURE, LINETYPE "A"/"O"
      *          GRP/REC-CAT-WORK - RECORD STRUCTURE, NEXT LINE 
  
       ELEM-DATA-DESCR. 
  
      * START A NEW LINE WITH THE ELEMENT'S LEVEL NUMBER. 
           MOVE LEVEL-NO TO OUT-FIELD.
           MOVE 3 TO OUT-LEN. 
           PERFORM START-STMT THRU STMT-XIT.
  
      * ADD THE ELEMENT NAME TO THE OUTPUT LINE.  IF ENTRY FOR ELEMENT
      * MISSING, IT HAS ALREADY BEEN DIAGNOSED, SO JUST RETURN. 
           MOVE ELEM-ALIAS TO SAVE-ALIAS. 
           PERFORM ADD-ELEM-NAME THRU ADD-ELEM-NAME-XIT.
           IF FOUND-ENTITY = "N"
           THEN 
             GO TO ELEM-DATA-DESCR-XIT
           END-IF 
  
      * MAKE SURE THAT ALL CLAUSES START IN THE MIDDLE OF THE LINE. 
           MOVE "Y" TO OUT-CLAUSE.
  
  
      ******************************************************************
      * 
      * PICTURE/TYPE CLAUSE.
  
      * PREPARE TO ADD THE PICTURE/TYPE CLAUSE. 
           MOVE SPACES TO ELEM-FORMAT.
           MOVE SPACES TO ELEM-LENGTH.
           MOVE SPACES TO ELEM-PICTURE. 
  
      * IF USING ALIAS OF ELEMENT, PICK UP THE ALIAS PICTURE/TYPE.
           IF USE-ALIAS = "Y" 
           THEN 
  
      * MAKE SURE THE ALIAS LINE IS STILL IN "CAT-WORK".
             MOVE SAVE-ALIAS TO DATA-ENTRY-LINE 
             MOVE CAT-NO-ALIAS TO DATA-ENTRY-CAT
             PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT 
             MOVE ZERO TO DATA-ENTRY-LINE 
  
      * IF FORMAT GIVEN, OUTPUT TYPE CLAUSE AND IGNORE ANY PICTURE. 
             IF ALY-FORMAT NOT = SPACES 
             THEN 
               MOVE ALY-FORMAT TO ELEM-FORMAT 
               MOVE ALY-LENGTH TO ELEM-LENGTH 
               PERFORM ELEM-TYPE-CLAUSE THRU ELEM-TYPE-CLAUSE-XIT 
               GO TO 600-END-ELEM-ATT 
             END-IF 
  
      * IF NO FORMAT, USE ALIAS PICTURE IF GIVEN. 
             IF ALY-PIC NOT = SPACES
             THEN 
               MOVE ALY-PIC TO ELEM-PICTURE 
               PERFORM ELEM-PIC-CLAUSE THRU ELEM-PIC-CLAUSE-XIT 
               GO TO 600-END-ELEM-ATT 
             END-IF 
           END-IF 
  
      * IF NOT USING ALIAS OR IF NO ALIAS PICTURE/TYPE GIVEN, MOVE
      * ELEMENT'S ATTRIBUTE CATEGORY INTO "CAT-WORK". 
           MOVE CAT-NO-ATT TO DATA-ENTRY-CAT. 
           PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT.
           MOVE "Y" TO SKIP-COMMENTS. 
           PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT.
  
      * IF ELEMENT HAS ATTRIBUTES, CONSOLIDATE ATTRIBUTE LINE IF NEEDED.
           IF DATA-RETURN-CODE = ZERO 
           THEN 
             PERFORM CON-ELEM-ATT THRU CON-ELEM-ATT-XIT 
  
      * LOOK FIRST FOR FORMAT.
             IF E-ATT-FORMAT NOT = SPACES 
             THEN 
               MOVE E-ATT-FORMAT TO ELEM-FORMAT 
               MOVE E-ATT-LENGTH TO ELEM-LENGTH 
               PERFORM ELEM-TYPE-CLAUSE THRU ELEM-TYPE-CLAUSE-XIT 
               GO TO 600-END-ELEM-ATT 
             END-IF 
  
      * IF NONE, LOOK FOR PICTURE.
             IF E-ATT-PIC NOT = SPACES
             THEN 
               MOVE E-ATT-PIC TO ELEM-PICTURE 
               PERFORM ELEM-PIC-CLAUSE THRU ELEM-PIC-CLAUSE-XIT 
             END-IF 
           END-IF 
  
       600-END-ELEM-ATT.
  
  
      ******************************************************************
      * 
      * OCCURS CLAUSE.
  
           PERFORM SAVE-ELEM-INFO THRU SAVE-ELEM-INFO-XIT.
           PERFORM OCCURS-CLAUSE THRU OCCURS-CLAUSE-XIT.
           PERFORM RESTORE-ELEM-INFO THRU RESTORE-ELEM-INFO-XIT.
  
       610-END-ELEM-OCCURS. 
  
  
      ******************************************************************
      * 
      * DBPROC CLAUSES. 
  
      * MOVE THE ELEMENT'S FIRST PROCESS LINE INTO "CAT-WORK".
           MOVE CAT-NO-PRO TO DATA-ENTRY-CAT. 
           PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT.
           MOVE "Y" TO SKIP-COMMENTS. 
           PERFORM CHECK-COMMENTS THRU CHECK-COMMENTS-XIT.
  
      * CONSOLIDATE PROCESS LINE IF NECESSARY.
           PERFORM CON-ELEM-PRO THRU CON-ELEM-PRO-XIT.
  
      * LOOP THROUGH ELEMENT'S PROCESS LINES, CREATING THE PROPER CLAUSE
      * FOR EACH DBPROC GIVEN.
           PERFORM UNTIL E-PRO-DBP = SPACES 
             PERFORM SAVE-ELEM-INFO THRU SAVE-ELEM-INFO-XIT 
             MOVE E-PRO-DBP TO DBP-CATNAME
  
      * DETERMINE TYPE OF DBPROC AND PROCESS ACCORDINGLY. 
      * 
      * ACTUAL RESULT.
             IF E-PRO-PTYPE = "AR"
             THEN 
               MOVE KW-ACTUAL TO OUT-FIELD
               MOVE KW-ACTUAL-LEN TO OUT-LEN
               PERFORM START-STMT THRU STMT-XIT 
               PERFORM RESULT-PHRASE THRU RESULT-PHRASE-XIT 
             END-IF 
  
      * VIRTUAL RESULT. 
             IF E-PRO-PTYPE = "VR"
             THEN 
               MOVE KW-VIRTUAL TO OUT-FIELD 
               MOVE KW-VIRTUAL-LEN TO OUT-LEN 
               PERFORM START-STMT THRU STMT-XIT 
               PERFORM RESULT-PHRASE THRU RESULT-PHRASE-XIT 
             END-IF 
  
      * ENCODE/DECODE.
             IF E-PRO-PTYPE = "EC" OR "DC" OR "EA" OR "DA"
             THEN 
               PERFORM EN-DECODE-CLAUSE THRU EN-DECODE-CLAUSE-XIT 
             END-IF 
  
      * CHECK.
             IF E-PRO-PTYPE = "CH"
             THEN 
               MOVE E-PRO-DBP TO CHECK-DBP
             END-IF 
  
      * CALL. 
             IF E-PRO-PTYPE = "CA"
             THEN 
               MOVE KW-CALL TO OUT-FIELD
               MOVE KW-CALL-LEN TO OUT-LEN
               PERFORM START-STMT THRU STMT-XIT 
  
               PERFORM ADD-DBP-NAME THRU ADD-DBP-NAME-XIT 
  
               MOVE E-PRO-TIME TO CALL-TIME 
               PERFORM ADD-CALL-TIME THRU ADD-CALL-TIME-XIT 
  
               MOVE E-PRO-OPT TO CALL-OPTION
               PERFORM ADD-CALL-OPTION THRU ADD-CALL-OPTION-XIT 
             END-IF 
  
             PERFORM CON-ELEM-PRO THRU CON-ELEM-PRO-XIT 
           END-PERFORM
  
       620-END-ELEM-PRO.
  
  
      ******************************************************************
      * 
      * CHECK CLAUSE. 
  
      * MOVE ELEMENT'S FIRST LINETYPE "C" VALUE LINE INTO "CAT-WORK". 
           MOVE CAT-NO-VAL TO DATA-ENTRY-CAT. 
           MOVE "C" TO DATA-ENTRY-LINETYPE. 
           PERFORM MOVE-CAT-LINE THRU MOVE-CAT-LINE-XIT.
  
      * IF NO CHECK CLAUSE GIVEN, DONE WITH ELEMENT DATA DESCRIPTION. 
           IF DATA-RETURN-CODE NOT = ZERO 
           THEN 
             GO TO 640-END-ELEM-VAL 
           END-IF 
  
      * ERROR IF CHECKBY FIELD MISSING. 
           IF VAL-CHECKBY = SPACES
           THEN 
             MOVE IDX-710 TO MSG-IDX
             MOVE "ELEMENT-VALUES-CHECKBY" TO MSG-NAME
             PERFORM ERROR-TYPE2 THRU ERROR-TYPE2-XIT 
             GO TO 640-END-ELEM-VAL 
           END-IF 
  
      * START CHECK CLAUSE ON NEW LINE. 
           MOVE KW-CHECK TO OUT-FIELD.
           MOVE KW-CHECK-LEN TO OUT-LEN.
           PERFORM START-STMT THRU STMT-XIT.
  
      * DETERMINE TYPE OF PROCESSING TO BE DONE AND ADD IT TO CLAUSE. 
           MOVE 1 TO PICK-IDX.
  
       630-CHECKBY-LOOP.
           IF PICK-IDX > 13 
             OR VAL-CHECKBY (PICK-IDX : 4) = SPACES 
           THEN 
             MOVE SAVE-COL-OUT TO COLUMN-OUT
             GO TO 640-END-ELEM-VAL 
           END-IF 
  
      * CHECK IS PICTURE. 
      * 
           IF VAL-CHECKBY (PICK-IDX : 3) = "PIC"
           THEN 
             MOVE KW-PICTURE TO OUT-FIELD 
             MOVE KW-PICTURE-LEN TO OUT-LEN 
             PERFORM ADD-TO-STMT THRU STMT-XIT
             ADD 4 TO PICK-IDX
             MOVE COLUMN-OUT TO SAVE-COL-OUT
             MOVE 72 TO COLUMN-OUT
             GO TO 630-CHECKBY-LOOP 
           END-IF 
  
      * CHECK IS PROCEDURE. 
      * 
           IF VAL-CHECKBY (PICK-IDX : 4) = "PROC" 
           THEN 
             IF CHECK-DBP NOT = SPACES
             THEN 
               PERFORM ADD-DBP-NAME THRU ADD-DBP-NAME-XIT 
               ADD 5 TO PICK-IDX
               MOVE COLUMN-OUT TO SAVE-COL-OUT
               MOVE 72 TO COLUMN-OUT
               GO TO 630-CHECKBY-LOOP 
  
             ELSE 
               MOVE IDX-710 TO MSG-IDX
               MOVE "ELEMENT-PROCESS-TYPEPROC=CH" TO MSG-NAME 
               PERFORM ERROR-TYPE2 THRU ERROR-TYPE2-XIT 
               ADD 5 TO PICK-IDX
               MOVE COLUMN-OUT TO SAVE-COL-OUT
               MOVE 72 TO COLUMN-OUT
               GO TO 630-CHECKBY-LOOP 
             END-IF 
           END-IF 
  
      * CHECK IS VALUE NOT. 
      * 
           IF VAL-CHECKBY (PICK-IDX : 4) = "VALN" 
           THEN 
             MOVE KW-VALNOT TO OUT-FIELD
             MOVE KW-VALNOT-LEN TO OUT-LEN
             PERFORM ADD-TO-STMT THRU STMT-XIT
  
             PERFORM ADD-CHK-VAL THRU ADD-CHK-VAL-XIT 
             ADD 5 TO PICK-IDX
             MOVE COLUMN-OUT TO SAVE-COL-OUT
             MOVE 72 TO COLUMN-OUT
             GO TO 630-CHECKBY-LOOP 
           END-IF 
  
      * CHECK IS VALUE. 
      * 
           IF VAL-CHECKBY (PICK-IDX : 3) = "VAL"
           THEN 
             MOVE KW-VALUE TO OUT-FIELD 
             MOVE KW-VALUE-LEN TO OUT-LEN 
             PERFORM ADD-TO-STMT THRU STMT-XIT
  
             PERFORM ADD-CHK-VAL THRU ADD-CHK-VAL-XIT 
             ADD 4 TO PICK-IDX
             MOVE COLUMN-OUT TO SAVE-COL-OUT
             MOVE 72 TO COLUMN-OUT
             GO TO 630-CHECKBY-LOOP 
           END-IF 
  
       640-END-ELEM-VAL.
           MOVE SPACES TO DATA-ENTRY-LINETYPE.
           MOVE "N" TO OUT-CLAUSE.
           MOVE "." TO DMS-LINE (COLUMN-OUT - 1 : 1). 
  
      ******************************************************************
      * 
       ELEM-DATA-DESCR-XIT. 
           EXIT.
      /*****************************************************************
      ******************************************************************
      * 
      * SUBROUTINES TO ELEM-DATA-DESCR. 
  
  
      ******************************************************************
      * 
      * ELEM-TYPE-CLAUSE. 
      * 
      * INPUT:   ELEM-FORMAT      - FORMAT FROM ELEMENT'S ATTRIBUTE/
      *                             ALIAS CATEGORY
      *          ELEM-LENGTH      - LENGTH FROM ELEMENT'S ATTRIBUTE/
      *                             ALIAS CATEGORY
  
  
       ELEM-TYPE-CLAUSE.
  
      * START THE TYPE CLAUSE.
           MOVE KW-TYPE TO OUT-FIELD. 
           MOVE KW-TYPE-LEN TO OUT-LEN. 
           PERFORM START-STMT THRU STMT-XIT.
  
      * IDENTIFY TYPE AND ADD IT TO LINE. 
      * 
      * CHARACTER.
           IF ELEM-FORMAT = "C" 
           THEN 
             MOVE KW-CHAR TO OUT-FIELD
             MOVE KW-CHAR-LEN TO OUT-LEN
             PERFORM ADD-TO-STMT THRU STMT-XIT
             PERFORM ADD-ELEM-LEN THRU ADD-ELEM-LEN-XIT 
             GO TO ELEM-TYPE-CLAUSE-XIT 
           END-IF 
  
      * COMPLEX.
           IF ELEM-FORMAT = "CO"
           THEN 
             MOVE KW-COMPLEX TO OUT-FIELD 
             MOVE KW-COMPLEX-LEN TO OUT-LEN 
             PERFORM ADD-TO-STMT THRU STMT-XIT
             PERFORM ADD-ELEM-LEN THRU ADD-ELEM-LEN-XIT 
             GO TO ELEM-TYPE-CLAUSE-XIT 
           END-IF 
  
      * COMPLEX DECIMAL.
           IF ELEM-FORMAT = "COD" 
           THEN 
             MOVE KW-COMPLEX TO OUT-FIELD 
             MOVE KW-DECIMAL
               TO OUT-FIELD (KW-COMPLEX-LEN + 2 : KW-DECIMAL-LEN) 
             ADD KW-COMPLEX-LEN, 1, KW-DECIMAL-LEN GIVING OUT-LEN 
             PERFORM ADD-TO-STMT THRU STMT-XIT
             PERFORM ADD-ELEM-LEN THRU ADD-ELEM-LEN-XIT 
             GO TO ELEM-TYPE-CLAUSE-XIT 
           END-IF 
  
      * DECIMAL.
           IF ELEM-FORMAT = "D" 
           THEN 
             MOVE KW-DECIMAL TO OUT-FIELD 
             MOVE KW-DECIMAL-LEN TO OUT-LEN 
             PERFORM ADD-TO-STMT THRU STMT-XIT
             PERFORM ADD-ELEM-LEN THRU ADD-ELEM-LEN-XIT 
             GO TO ELEM-TYPE-CLAUSE-XIT 
           END-IF 
  
      * FIXED DECIMAL.
           IF ELEM-FORMAT = "FID" 
           THEN 
             MOVE KW-FIXED TO OUT-FIELD 
             MOVE KW-DECIMAL
               TO OUT-FIELD (KW-FIXED-LEN + 2 : KW-DECIMAL-LEN) 
             ADD KW-FIXED-LEN, 1, KW-DECIMAL-LEN GIVING OUT-LEN 
             PERFORM ADD-TO-STMT THRU STMT-XIT
             PERFORM ADD-ELEM-LEN THRU ADD-ELEM-LEN-XIT 
             GO TO ELEM-TYPE-CLAUSE-XIT 
           END-IF 
  
      * FLOAT DECIMAL.
           IF ELEM-FORMAT = "FD"
           THEN 
             MOVE KW-FLOAT TO OUT-FIELD 
             MOVE KW-DECIMAL
               TO OUT-FIELD (KW-FLOAT-LEN + 2 : KW-DECIMAL-LEN) 
             ADD KW-FLOAT-LEN, 1, KW-DECIMAL-LEN GIVING OUT-LEN 
             PERFORM ADD-TO-STMT THRU STMT-XIT
             PERFORM ADD-ELEM-LEN THRU ADD-ELEM-LEN-XIT 
             GO TO ELEM-TYPE-CLAUSE-XIT 
           END-IF 
  
      * REAL DECIMAL. 
           IF ELEM-FORMAT = "DR"
           THEN 
             MOVE KW-REAL TO OUT-FIELD
             MOVE KW-DECIMAL
               TO OUT-FIELD (KW-REAL-LEN + 2 : KW-DECIMAL-LEN)
             ADD KW-REAL-LEN, 1, KW-DECIMAL-LEN GIVING OUT-LEN
             PERFORM ADD-TO-STMT THRU STMT-XIT
             PERFORM ADD-ELEM-LEN THRU ADD-ELEM-LEN-XIT 
             GO TO ELEM-TYPE-CLAUSE-XIT 
           END-IF 
  
      * FIXED REAL DECIMAL. 
           IF ELEM-FORMAT = "DFR" 
           THEN 
             MOVE KW-FX-R-DEC TO OUT-FIELD
             MOVE KW-FX-R-DEC-LEN TO OUT-LEN
             PERFORM ADD-TO-STMT THRU STMT-XIT
             PERFORM ADD-ELEM-LEN THRU ADD-ELEM-LEN-XIT 
             GO TO ELEM-TYPE-CLAUSE-XIT 
           END-IF 
  
      * FLOAT REAL DECIMAL. 
           IF ELEM-FORMAT = "DRF" 
           THEN 
             MOVE KW-FL-R-DEC TO OUT-FIELD
             MOVE KW-FL-R-DEC-LEN TO OUT-LEN
             PERFORM ADD-TO-STMT THRU STMT-XIT
             PERFORM ADD-ELEM-LEN THRU ADD-ELEM-LEN-XIT 
             GO TO ELEM-TYPE-CLAUSE-XIT 
           END-IF 
  
      * FIXED.
           IF ELEM-FORMAT = "FI"
           THEN 
             MOVE KW-FIXED TO OUT-FIELD 
             MOVE KW-FIXED-LEN TO OUT-LEN 
             PERFORM ADD-TO-STMT THRU STMT-XIT
             PERFORM ADD-ELEM-LEN THRU ADD-ELEM-LEN-XIT 
             GO TO ELEM-TYPE-CLAUSE-XIT 
           END-IF 
  
      * FIXED REAL. 
           IF ELEM-FORMAT = "FIR" 
           THEN 
             MOVE KW-FIXED TO OUT-FIELD 
             MOVE KW-REAL TO OUT-FIELD (KW-FIXED-LEN + 2 : KW-REAL-LEN) 
             ADD KW-FIXED-LEN, 1, KW-REAL-LEN GIVING OUT-LEN
             PERFORM ADD-TO-STMT THRU STMT-XIT
             PERFORM ADD-ELEM-LEN THRU ADD-ELEM-LEN-XIT 
             GO TO ELEM-TYPE-CLAUSE-XIT 
           END-IF 
  
      * FLOAT.
           IF ELEM-FORMAT = "F" 
           THEN 
             MOVE KW-FLOAT TO OUT-FIELD 
             MOVE KW-FLOAT-LEN TO OUT-LEN 
             PERFORM ADD-TO-STMT THRU STMT-XIT
             PERFORM ADD-ELEM-LEN THRU ADD-ELEM-LEN-XIT 
             GO TO ELEM-TYPE-CLAUSE-XIT 
           END-IF 
  
      * FLOAT REAL. 
           IF ELEM-FORMAT = "FR"
           THEN 
             MOVE KW-FLOAT TO OUT-FIELD 
             MOVE KW-REAL TO OUT-FIELD (KW-FLOAT-LEN + 2 : KW-REAL-LEN) 
             ADD KW-FLOAT-LEN, 1, KW-REAL-LEN GIVING OUT-LEN
             PERFORM ADD-TO-STMT THRU STMT-XIT
             PERFORM ADD-ELEM-LEN THRU ADD-ELEM-LEN-XIT 
             GO TO ELEM-TYPE-CLAUSE-XIT 
           END-IF 
  
      * REAL. 
           IF ELEM-FORMAT = "R" 
           THEN 
             MOVE KW-REAL TO OUT-FIELD
             MOVE KW-REAL-LEN TO OUT-LEN
             PERFORM ADD-TO-STMT THRU STMT-XIT
             PERFORM ADD-ELEM-LEN THRU ADD-ELEM-LEN-XIT 
           END-IF 
  
       ELEM-TYPE-CLAUSE-XIT.
           EXIT.
  
  
      ******************************************************************
      * 
      * ADD-ELEM-LEN. 
      * 
      * ADD THE GIVEN LENGTH FIELD TO THE ELEMENT TYPE CLAUSE.
      * 
      * INPUT:   ELEM-LENGTH      - LENGTH FIELD FOR ELEMENT
  
       ADD-ELEM-LEN.
           IF ELEM-LENGTH = SPACES OR ZERO
           THEN 
             GO TO ADD-ELEM-LEN-XIT 
           END-IF 
  
           MOVE ELEM-LENGTH TO OUT-FIELD. 
  
      * IF LENGTH CONTAINS A PERIOD, REPLACE IT WITH A COMMA.  FIND 
      * LENGTH OF LENGTH FIELD. 
           PERFORM VARYING PICK-IDX FROM 1 BY 1 
             UNTIL PICK-IDX > 10
  
             IF OUT-FIELD (PICK-IDX : 1) = "."
             THEN 
               MOVE "," TO OUT-FIELD (PICK-IDX : 1) 
             END-IF 
  
             IF OUT-FIELD (PICK-IDX : 1) = SPACE
             THEN 
               SUBTRACT 1 FROM PICK-IDX GIVING OUT-LEN
               GO TO 650-ADD-LENGTH 
             END-IF 
           END-PERFORM
           MOVE 10 TO OUT-LEN.
  
       650-ADD-LENGTH.
           PERFORM ADD-TO-STMT THRU STMT-XIT. 
  
       ADD-ELEM-LEN-XIT.
           EXIT.
  
  
      ******************************************************************
      * 
      * ELEM-PIC-CLAUSE.
      * 
      * INPUT:   ELEM-PICTURE     - PICTURE FROM ELEMENT'S ATTRIBUTE/ 
      *                             ALIAS CATEGORY
  
       ELEM-PIC-CLAUSE. 
  
      * START PICTURE CLAUSE. 
           MOVE KW-PICTURE TO OUT-FIELD.
           MOVE KW-PICTURE-LEN TO OUT-LEN.
           PERFORM START-STMT THRU STMT-XIT.
  
      * MOVE PICTURE TO LINE SURROUNDED BY QUOTES.
           MOVE "Y" TO OUT-QUOTE. 
           MOVE ELEM-PICTURE TO OUT-FIELD.
           PERFORM FIND-LENGTH THRU FIND-LENGTH-XIT.
           PERFORM ADD-TO-STMT THRU STMT-XIT. 
  
       ELEM-PIC-CLAUSE-XIT. 
           EXIT.
  
  
      ******************************************************************
      * 
      * OCCURS-CLAUSE.
      * 
      * GENERATE THE OCCURS CLAUSE FOR AN ELEMENT'S DATA-DESCRIPTION. 
      * MAY ADVANCE TO NEXT STRUCTURE LINE OF GROUP/RECORD AND RE-SAVE. 
  
       OCCURS-CLAUSE. 
  
      * LOOK AT PARENT RECORD/GROUP'S NEXT STRUCTURE LINE IN "CAT-WORK" 
      * FOR OCCURS CLAUSE.
           IF LEVEL-IDX = 1 
           THEN 
             PERFORM RESTORE-REC-INFO THRU RESTORE-REC-INFO-XIT 
           ELSE 
             SUBTRACT GTBL-OPT-INCLEV FROM LEVEL-NO 
             SUBTRACT 1 FROM LEVEL-IDX
             PERFORM RESTORE-GRP-INFO THRU RESTORE-GRP-INFO-XIT 
             ADD GTBL-OPT-INCLEV TO LEVEL-NO
             ADD 1 TO LEVEL-IDX 
           END-IF 
  
      * IF OCCURS CLAUSE GIVEN, ADD IT ON A NEW LINE. 
           IF CAT-LINE-TYPE = "O" 
           THEN 
  
      * CONSOLIDATE STRUCTURE LINE IF NEEDED. 
             IF LEVEL-IDX = 1 
             THEN 
               PERFORM CON-RG-OSTC THRU CON-RG-OSTC-XIT 
               PERFORM SAVE-REC-INFO THRU SAVE-REC-INFO-XIT 
             ELSE 
               SUBTRACT GTBL-OPT-INCLEV FROM LEVEL-NO 
               SUBTRACT 1 FROM LEVEL-IDX
               PERFORM CON-RG-OSTC THRU CON-RG-OSTC-XIT 
               PERFORM SAVE-GRP-INFO THRU SAVE-GRP-INFO-XIT 
               ADD GTBL-OPT-INCLEV TO LEVEL-NO
               ADD 1 TO LEVEL-IDX 
             END-IF 
  
      * START CLAUSE WITH KEYWORD.
             IF RG-STC-TO NOT = SPACES
             THEN 
               MOVE KW-OCCURS TO OUT-FIELD
               MOVE KW-OCCURS-LEN TO OUT-LEN
               PERFORM START-STMT THRU STMT-XIT 
  
      * IF THE OCCURS-TO FIELD IS AN INTEGER, JUST COPY IT TO OUTPUT. 
               MOVE RG-STC-TO TO OUT-FIELD
               PERFORM FIND-LENGTH THRU FIND-LENGTH-XIT 
               IF OUT-FIELD (1 : OUT-LEN) IS NUMERIC
               THEN 
                 PERFORM ADD-TO-STMT THRU STMT-XIT
  
      * OTHERWISE, IT'S AN ELEMENT'S CATNAME.  ADD ITS DMSNAME TO THE 
      * OUTPUT LINE.
               ELSE 
                 MOVE RG-STC-TO TO ELEM-CATNAME 
                 MOVE RG-STC-TALIAS TO ELEM-ALIAS 
                 PERFORM ADD-ELEM-NAME THRU ADD-ELEM-NAME-XIT 
               END-IF 
  
      * PUT FINISHING TOUCH ON OCCURS CLAUSE. 
               MOVE KW-TIMES TO OUT-FIELD 
               MOVE KW-TIMES-LEN TO OUT-LEN 
               PERFORM ADD-TO-STMT THRU STMT-XIT
             END-IF 
           END-IF 
  
       OCCURS-CLAUSE-XIT. 
           EXIT.
  
  
      ******************************************************************
      * 
      * RESULT-PHRASE.
      * 
      * COMPLETE THE "RESULT OF" PHRASE OF THE ELEMENT'S DATA 
      * DESCRIPTION.
  
       RESULT-PHRASE. 
  
      * FIRST THE KEYWORDS. 
           MOVE KW-RES-OF TO OUT-FIELD. 
           MOVE KW-RES-OF-LEN TO OUT-LEN. 
           PERFORM ADD-TO-STMT THRU STMT-XIT. 
  
      * THEN THE DBPROC NAME. 
           PERFORM ADD-DBP-NAME THRU ADD-DBP-NAME-XIT.
  
       RESULT-PHRASE-XIT. 
           EXIT.
  
      ******************************************************************
      * 
      * EN-DECODE-CLAUSE. 
      * 
  
       EN-DECODE-CLAUSE.
           MOVE KW-FOR TO OUT-FIELD.
           MOVE KW-FOR-LEN TO OUT-LEN.
           PERFORM START-STMT THRU STMT-XIT.
  
           IF E-PRO-PTYPE = "EC" OR "EA"
           THEN 
             MOVE KW-ENCOD TO OUT-FIELD 
             MOVE KW-ENCOD-LEN TO OUT-LEN 
  
           ELSE 
             MOVE KW-DECOD TO OUT-FIELD 
             MOVE KW-DECOD-LEN TO OUT-LEN 
           END-IF 
  
           PERFORM ADD-TO-STMT THRU STMT-XIT. 
  
           IF E-PRO-PTYPE = "EA" OR "DA"
           THEN 
             MOVE KW-ALWAYS TO OUT-FIELD
             MOVE KW-ALWAYS-LEN TO OUT-LEN
             PERFORM ADD-TO-STMT THRU STMT-XIT
           END-IF 
  
           MOVE KW-CALL TO OUT-FIELD. 
           MOVE KW-CALL-LEN TO OUT-LEN. 
           PERFORM ADD-TO-STMT THRU STMT-XIT. 
  
           PERFORM ADD-DBP-NAME THRU ADD-DBP-NAME-XIT.
  
       EN-DECODE-CLAUSE-XIT.
           EXIT.
  
  
      ******************************************************************
      * 
      * ADD-CHK-VAL.
      * 
      * ADD THE "LIT-1 (THRU LIT-2)" PHRASES TO THE "CHECK IS VALUE 
      * (NOT)" CLAUSE.
  
       ADD-CHK-VAL. 
           PERFORM SAVE-ELEM-INFO THRU SAVE-ELEM-INFO-XIT.
           MOVE "N" TO FOUND-VALUE. 
           MOVE "N" TO THRU-FLAG. 
  
      * ADD EACH LITERAL FOUND IN VALUES CATEGORY TO CLAUSE.
           PERFORM UNTIL DATA-RETURN-CODE NOT = ZERO
             IF VAL-CKVAL NOT = SPACES
             THEN 
               MOVE VAL-CKVAL TO OUT-FIELD
               PERFORM FIND-LENGTH THRU FIND-LENGTH-XIT 
               IF VAL-TYPE = "L"
               THEN 
                 MOVE "Y" TO OUT-QUOTE
               END-IF 
               PERFORM ADD-TO-STMT THRU STMT-XIT
  
               MOVE "Y" TO FOUND-VALUE
               MOVE "Y" TO THRU-FLAG
             END-IF 
  
      * THRUVAL MAY NOT PRECEDE ITS PARTNER CKVAL.
             IF VAL-THRU NOT = SPACES 
             THEN 
               IF THRU-FLAG = "Y" 
               THEN 
                 MOVE KW-THRU TO OUT-FIELD
                 MOVE KW-THRU-LEN TO OUT-LEN
                 PERFORM ADD-TO-STMT THRU STMT-XIT
  
                 MOVE VAL-THRU TO OUT-FIELD 
                 PERFORM FIND-LENGTH THRU FIND-LENGTH-XIT 
                 IF THRU-TYPE = "L" 
                 THEN 
                   MOVE "Y" TO OUT-QUOTE
                 END-IF 
                 PERFORM ADD-TO-STMT THRU STMT-XIT
                 MOVE "N" TO THRU-FLAG
  
      * FORCE NEXT CKVAL TO START NEW LINE. 
                 MOVE COLUMN-OUT TO SAVE-COL-OUT
                 MOVE 72 TO COLUMN-OUT
  
      * ERROR IF CKVAL/THRUVAL FIELDS OUT OF ORDER. 
               ELSE 
                 MOVE IDX-705 TO MSG-IDX
                 MOVE "ELEMENT-VALUES" TO MSG-NAME
                 PERFORM ERROR-TYPE2 THRU ERROR-TYPE2-XIT 
               END-IF 
             END-IF 
  
      * MOVE ELEMENT'S NEXT TYPE "C" VALUE LINE INTO "CAT-WORK".
             PERFORM MOVE-NEXT-LINE THRU MOVE-NEXT-LINE-XIT 
           END-PERFORM
  
      * ERROR IF NO VALUE GIVEN FOR CHECK VALUE CLAUSE. 
           IF FOUND-VALUE = "N" 
           THEN 
             MOVE IDX-710 TO MSG-IDX
             MOVE "ELEMENT-VALUES-CKVAL" TO MSG-NAME
             PERFORM ERROR-TYPE2 THRU ERROR-TYPE2-XIT 
  
      * RESTORE "COLUMN-OUT" IF RESET EARLIER.
           ELSE 
             IF THRU-FLAG = "N" 
             THEN 
               MOVE SAVE-COL-OUT TO COLUMN-OUT
             END-IF 
           END-IF 
  
           PERFORM RESTORE-ELEM-INFO THRU RESTORE-ELEM-INFO-XIT.
  
       ADD-CHK-VAL-XIT. 
           EXIT.
      /*****************************************************************
      * UTILITIES SPECIFIC TO DMS SCHEMA GENERATION.
      ******************************************************************
  
      ******************************************************************
      * 
      * OUTPUT-DMS. 
      * 
      * OUTPUT-DMS ADDS THE SEQUENCE NUMBER TO "DMS-LINE" AND MOVES IT
      * TO THE OUTPUT BUFFER "GTBL-OUTPUT-TABLE", WHICH WILL BE PRINTED 
      * WHEN IT BECOMES 40 LINES LONG.
  
       OUTPUT-DMS.
  
      * INCREMENT INDEX INTO THE OUTPUT BUFFER. 
           ADD 1 TO GTBL-COUNT. 
  
      * INSERT SEQUENCE NUMBER INTO LINE. 
           MOVE SEQ-NO TO DMS-SEQNO.
           ADD GTBL-OPT-INCSEQNO TO SEQ-NO. 
  
      * MOVE LINE IMAGE INTO OUTPUT BUFFER AND CHECK IF IT'S FULL.
           MOVE DMS-LINE TO GTBL-CARD-IMAGE (GTBL-COUNT). 
           PERFORM OUTPUT-CHECK THRU OUTPUT-CHECK-XIT.
  
           MOVE SPACES TO DMS-LINE. 
  
       OUTPUT-DMS-XIT.
           EXIT.
  
  
      ******************************************************************
      * 
      * OUTPUT-COMMENT. 
      * 
      * MOVE THE CONTENTS OF "CAT-DETAIL", SURROUNDED BY DMS SCHEMA 
      * COMMENT DELIMITERS, TO THE OUTPUT BUFFER "GTBL-OUTPUT-TABLE", 
      * WHICH WILL BE PRINTED WHEN IT BECOMES 40 LINES LONG.
  
       OUTPUT-COMMENT.
  
      * INCREMENT INDEX INTO OUTPUT BUFFER AND INITIALIZE COMMENT-LINE
      * POINTERS. 
           ADD 1 TO GTBL-COUNT. 
           MOVE 2 TO COMMENT-COL. 
  
      * FIND LENGTH OF COMMENT WITHOUT TRAILING BLANKS. 
           SUBTRACT 2 FROM DETAIL-LEN.
           PERFORM VARYING COMMENT-LEN FROM DETAIL-LEN  BY -1 
             UNTIL CAT-DETAIL (COMMENT-COL + COMMENT-LEN : 1) 
               NOT = SPACE
               OR COMMENT-LEN = ZERO
             CONTINUE 
           END-PERFORM
           ADD 2 TO DETAIL-LEN. 
           ADD 1 TO COMMENT-LEN.
  
       700-COMMENT-LOOP.
  
      * IF COMMENT IS TOO LONG FOR ONE LINE, SPLIT IT ON A WORD BOUNDARY
      * AND MOVE THE FIRST PART TO THE COMMENT-LINE.
           IF COMMENT-LEN > 66
           THEN 
             PERFORM VARYING PICK-IDX FROM 65 BY -1 
               UNTIL CAT-DETAIL (COMMENT-COL + PICK-IDX : 1) = SPACE
                 OR PICK-IDX < ZERO 
               CONTINUE 
             END-PERFORM
  
             IF PICK-IDX < ZERO 
             THEN 
               MOVE 66 TO PICK-IDX
             ELSE 
               ADD 1 TO PICK-IDX
             END-IF 
             MOVE CAT-DETAIL (COMMENT-COL : PICK-IDX) TO SCHEMA-CMNT
             ADD PICK-IDX TO COMMENT-COL
             SUBTRACT PICK-IDX FROM COMMENT-LEN 
  
      * IF COMMENT FITS ON LINE, JUST MOVE IT.
           ELSE 
             MOVE CAT-DETAIL (COMMENT-COL : COMMENT-LEN) TO SCHEMA-CMNT 
             MOVE ZERO TO COMMENT-LEN 
           END-IF 
  
      * INSERT SEQUENCE NUMBER INTO LINE. 
           MOVE SEQ-NO TO SCH-CMNT-SEQNO. 
           ADD GTBL-OPT-INCSEQNO TO SEQ-NO. 
  
      * MOVE LINE IMAGE INTO OUTPUT BUFFER AND CHECK IF IT'S FULL.
           MOVE SCHEMA-COMMENT TO GTBL-CARD-IMAGE (GTBL-COUNT). 
           PERFORM OUTPUT-CHECK THRU OUTPUT-CHECK-XIT.
  
      * IF NOT FINISHED WITH COMMENT, GO BACK AND OUTPUT THE REST OF IT.
           IF COMMENT-LEN > ZERO
           THEN 
             ADD 1 TO GTBL-COUNT
             GO TO 700-COMMENT-LOOP 
           END-IF 
  
       OUTPUT-COMMENT-XIT.
           EXIT.
  
  
      ******************************************************************
      * 
      * ADD-CALL-TIME.
      * 
      * ADD THE TIME OF PROCESSING TO A "CALL DBP" CLAUSE OUTPUT LINE.
      * 
      * INPUT:   CALL-TIME        - TIME FIELD FROM THE PROCESS CATEGORY
  
  
       ADD-CALL-TIME. 
           PERFORM VARYING PICK-IDX FROM 1 BY 2 
             UNTIL PICK-IDX > 5 
  
             IF CALL-TIME (PICK-IDX : 1) = "B"
             THEN 
               MOVE KW-BEFORE TO OUT-FIELD
               MOVE KW-BEFORE-LEN TO OUT-LEN
               PERFORM ADD-TO-STMT THRU STMT-XIT
             END-IF 
  
             IF CALL-TIME (PICK-IDX : 1) = "E"
             THEN 
               MOVE KW-ONERR TO OUT-FIELD 
               MOVE KW-ONERR-LEN TO OUT-LEN 
               PERFORM ADD-TO-STMT THRU STMT-XIT
             END-IF 
  
             IF CALL-TIME (PICK-IDX : 1) = "A"
               MOVE KW-AFTER TO OUT-FIELD 
               MOVE KW-AFTER-LEN TO OUT-LEN 
               PERFORM ADD-TO-STMT THRU STMT-XIT
             END-IF 
           END-PERFORM
  
       ADD-CALL-TIME-XIT. 
           EXIT.
  
  
      ******************************************************************
      * 
      * ADD-CALL-OPTION.
      * 
      * ADD THE PROCESSING OPTIONS TO THE "CALL DBP" OUTPUT LINE. 
      * 
      * INPUT:   CALL-OPTION      - OPTION FIELD OF PROCESS CATEGORY
  
  
       ADD-CALL-OPTION. 
           IF CALL-OPTION = SPACES
           THEN 
             GO TO ADD-CALL-OPTION-XIT
           END-IF 
  
           PERFORM VARYING PICK-IDX FROM 1 BY 2 
             UNTIL PICK-IDX > 9 
  
             IF CALL-OPTION (PICK-IDX : 1) = "S"
             THEN 
               MOVE KW-STORE TO OUT-FIELD 
               MOVE KW-STORE-LEN TO OUT-LEN 
               PERFORM ADD-TO-STMT THRU STMT-XIT
             END-IF 
  
             IF CALL-OPTION (PICK-IDX : 1) = "D"
             THEN 
               MOVE KW-DELETE TO OUT-FIELD
               MOVE KW-DELETE-LEN TO OUT-LEN
               PERFORM ADD-TO-STMT THRU STMT-XIT
             END-IF 
  
             IF CALL-OPTION (PICK-IDX : 1) = "M"
             THEN 
               MOVE KW-MODIFY TO OUT-FIELD
               MOVE KW-MODIFY-LEN TO OUT-LEN
               PERFORM ADD-TO-STMT THRU STMT-XIT
             END-IF 
  
             IF CALL-OPTION (PICK-IDX : 1) = "F"
             THEN 
               MOVE KW-FIND TO OUT-FIELD
               MOVE KW-FIND-LEN TO OUT-LEN
               PERFORM ADD-TO-STMT THRU STMT-XIT
             END-IF 
  
             IF CALL-OPTION (PICK-IDX : 1) = "G"
             THEN 
               MOVE KW-GET TO OUT-FIELD 
               MOVE KW-GET-LEN TO OUT-LEN 
               PERFORM ADD-TO-STMT THRU STMT-XIT
             END-IF 
           END-PERFORM
  
       ADD-CALL-OPTION-XIT. 
           EXIT.
*CALL DMSIO 
*CALL DMSADD0 
*CALL DMSADD1 
*CALL DMSADD2 
*CALL DMSADDSCH 
*CALL DMSSAV1 
*CALL DMSSAV2 
*CALL DMSSAV3 
*CALL DMSSAV5 
*CALL DMSCON1 
*CALL DMSCON2 
*CALL DMSCONSCH 
