*DECK     DCCONCBL
00001  IDENTIFICATION DIVISION.                                         09/21/78
       PROGRAM-ID. CONCBL.
*CALL COPYRIGHT 
      *    THIS PROGRAM EXPLODES COBOL PROGRAM ENTRIES AS PART OF 
      *    THE DATA CATALOGUE CONVERSION. 
00009  ENVIRONMENT DIVISION.                                            DCCONCBL
00010  CONFIGURATION SECTION.                                           DCCONCBL
       SOURCE-COMPUTER. CYBER.
       OBJECT-COMPUTER. CYBER.
00013  INPUT-OUTPUT SECTION.                                            DCCONCBL
00014  FILE-CONTROL.                                                    DCCONCBL
           SELECT WORK-FILE ASSIGN TO WRKFILE 
               USE "RT=Z".
           SELECT SYSPRINT ASSIGN TO "OUTPUT".
           SELECT COBOL-FILE ASSIGN TO CONVFIL
               USE "RT=Z".
00018  DATA DIVISION.                                                   DCCONCBL
00019  FILE SECTION.                                                    DCCONCBL
00020  FD  COBOL-FILE                                                   DCCONCBL
00022      LABEL RECORDS ARE OMITTED                                    DCCONCBL
00024      RECORD CONTAINS 80 CHARACTERS                                DCCONCBL
00025      DATA RECORDS ARE UNLABEL-COB.                                DCCONCBL
00026  01  UNLABEL-COB                 PICTURE X(80).                   DCCONCBL
*CALL     CVTWKFD                                                          CL**2
*CALL     SYSPRTFD                                                         CL**2
       COMMON-STORAGE SECTION.
       77  RETURN-CODE                 PICTURE XX.
*CALL     CVTBL                                                            CL**2
00213  01  PRINT-CTL-TBL.                                                  CL**2
*CALL     WKPRINT                                                          CL**2
00029  WORKING-STORAGE SECTION.                                            CL**2
00030  01  LINE1.                                                          CL**2
00031      03  FILLER                  PICTURE X.                          CL**2
00032      03  LINE1A                  PICTURE X(10).                      CL**2
00033      03  FILLER                  PICTURE X(9).                       CL**2
00034      03  LINE1B                  PICTURE X(32).                      CL**2
00035      03  FILLER                  PICTURE X(2).                       CL**2
00036      03  LINE1C                  PICTURE X(78).                      CL**2
00037                                                                    DCCONCB
00038  01  LEVEL-TABLE.                                                 DCCONCBL
00039      02  LEV-TAB     OCCURS 10 TIMES.                             DCCONCBL
00040          03  LEVT-LINE       PICTURE XX.                          DCCONCBL
00041          03  LEVT-NAME           PICTURE X(32).                      CL**2
00042          03  LEVT-GNAM           PICTURE X(32).                      CL**2
00043          03 LEVT-HOLD.                                            DCCONCBL
00044              04  LEVT-LGHT   PIC 9(4).                            DCCONCBL
00045              04  LEVT-USE    PIC X.                               DCCONCBL
00046              04  LEVT-PIC        PICTURE X(25).                      CL**2
00047              04  LEVT-VALUE      PICTURE X(25).                      CL**2
00048              04  LEVT-JUST       PICTURE X.                          CL**2
00049              04  LEVT-SYNC       PICTURE X.                          CL**2
00050  01  HOLD-RENAME-TABLE.                                              CL**2
00051      03  FILLER                  PICTURE XXX.                        CL**2
00052      03  CVT-RENAME-HOLD         PICTURE X(32).                      CL**2
00053      03  CVT-CATNAME-HOLD        PICTURE X(32).                      CL**2
00054      03  CVT-ALIAS-HOLD          PICTURE X.                          CL**2
00055      03  CVT-BEGIN-HOLD          PICTURE X(4).                       CL**2
00056  01  COMMENT-TABLE.                                                  CL**2
00057      03  COM-LINE                PICTURE X(80) OCCURS 50 TIMES.      CL**2
00058                                                                    DCCONCB
00059 *                                                                 DCCONCBL
00060 *           W O R K   A R E A S                                   DCCONCBL
00061 *                                                                 DCCONCBL
00062  01  COBOL-IN.                                                    DCCONCBL
00063      02  FILLER                  PICTURE X(6).                    DCCONCBL
00064      02  COB-CONT                PICTURE X.                       DCCONCBL
00065      02  COB-SECTIONS.                                            DCCONCBL
00066          03 COB-PROGID           PICTURE X(11).                   DCCONCBL
00067          03  FILLER          PICTURE X(62).                       DCCONCBL
00068      02 COB-SECTIONS2 REDEFINES COB-SECTIONS.                     DCCONCBL
00069          03 COB-DATADIV          PICTURE X(13).                   DCCONCBL
00070          03  FILLRE          PICTURE X(60).                       DCCONCBL
00071      02 COB-SECTIONS3 REDEFINES COB-SECTIONS2.                    DCCONCBL
00072          03 COB-PROC             PICTURE X(18).                   DCCONCBL
00073          03  FILLER          PICTURE X(55).                       DCCONCBL
00074      02 COB-SECTIONS4 REDEFINES COB-SECTIONS3.                    DCCONCBL
00075          03 COB-ID-DIV           PICTURE X(23).                   DCCONCBL
00076          03  FILLER          PICTURE X(50).                       DCCONCBL
00077      02  COB-SECTIONS5 REDEFINES COB-SECTIONS4.                   DCCONCBL
00078          03 COB-LINE             PICTURE X OCCURS 65 TIMES.       DCCONCBL
00079          03 COB-ID               PICTURE X(8).                    DCCONCBL
00080  01  WORK-AREA.                                                   DCCONCBL
00081      02  WORKA   OCCURS 40   PICTURE X.                           DCCONCBL
00082  01  NUM-WORK.                                                    DCCONCBL
00083      02  NUM-1ST             PICTURE 9.                           DCCONCBL
00084      02  NUM-2ND             PICTURE 9.                           DCCONCBL
00085      02  NUM-3RD             PICTURE 9.                           DCCONCBL
00086      02  NUM-4TH             PICTURE 9.                           DCCONCBL
00087  01  NUM-WORK4 REDEFINES NUM-WORK PICTURE 9(4).                   DCCONCBL
00088  01  NUM-WORK3 REDEFINES NUM-WORK4.                               DCCONCBL
00089      02  NUM3                PICTURE 999.                         DCCONCBL
00090      02  FILLER              PICTURE X.                           DCCONCBL
00091  01  NUM-WORK2 REDEFINES NUM-WORK3.                               DCCONCBL
00092      02  NUM2                PICTURE 99.                          DCCONCBL
00093      02  FILLER              PICTURE XX.                          DCCONCBL
00094  01  NUM-WORK1 REDEFINES NUM-WORK2.                               DCCONCBL
00095      02  NUM1                PICTURE 9.                           DCCONCBL
00096      02  FILLER              PICTURE XXX.                         DCCONCBL
00097  01  NEXT-LINE.                                                   DCCONCBL
00098      02  FLD1                PICTURE X.                           DCCONCBL
00099      02  FLD2                PICTURE X.                           DCCONCBL
00100  01  HOLD-AREA.                                                   DCCONCBL
00101      02  HOLD-ELM.                                                DCCONCBL
00102          03  HOLD-LGHT       PICTURE 9(4).                        DCCONCBL
00103          03  HOLD-USE        PICTURE X.                           DCCONCBL
00104          03  HOLD-PIC            PICTURE X(25).                      CL**2
00105          03  HOLD-VALUE          PICTURE X(25).                      CL**2
00106          03  HOLD-JUST           PICTURE X.                          CL**2
00107          03  HOLD-SYNC           PICTURE X.                          CL**2
00108      02  HOLD-GRP.                                                DCCONCBL
               03  HOLD-GRP1. 
                   05  HOLD-REDEF          PICTURE X(32). 
                   05  HOLD-RDALIAS        PICTURE X(4).
               03  HOLD-GRP2. 
                   05  HOLD-OFROM          PICTURE X(4).
                   05  HOLD-OTO            PICTURE X(4).
                   05  HOLD-DEPEND         PICTURE X(32). 
               03  HOLD-GRP3. 
                   05  HOLD-INDEX          PIC X(32) OCCURS 10 TIMES. 
               03  HOLD-GRP4 OCCURS 10 TIMES. 
                   05  HOLD-KORDER         PICTURE X. 
                   05  HOLD-KNAME          PICTURE X(32). 
                   05  HOLD-KALIAS         PICTURE X(4).
               03  HOLD-GRP5. 
                   05  HOLD-RENAMES        PICTURE X(32). 
                   05  HOLD-RNALIAS        PICTURE X(4).
               03 HOLD-GRP6.
                   05  HOLD-THRU           PICTURE X(32). 
                   05  HOLD-THALIAS        PICTURE X(4).
00114  01  88-VAL-AREA.                                                 DCCONCBL
00115      03  88-AREA OCCURS 65 TIMES PICTURE X.                       DCCONCBL
00116  01  RECORD-COUNT                PICTURE 9(5).                       CL**2
00117  01  REC-CNT REDEFINES RECORD-COUNT.                                 CL**2
00118      03  REC-COUNT               PICTURE X OCCURS 5 TIMES.           CL**2
00119  01  BLOCK-COUNT                 PICTURE 9(5).                       CL**2
00120  01  BLK-CNT REDEFINES  BLOCK-COUNT.                                 CL**2
00121      03  BLK-COUNT               PICTURE X OCCURS 5 TIMES.           CL**2
00122  01  LABELS-HOLD                  PICTURE XXX.                       CL**2
00123  01  MODE-HOLD                    PICTURE X(6).                      CL**2
00124  01  FIL-NAME                    PICTURE X(32).                      CL**2
00125  01  FD-SW                       PICTURE X.                          CL**2
00126  01  CALC-BLK-SW                 PICTURE X.                          CL**2
00127  01  SUBX                        PICTURE S9 COMP.                    CL**2
00128  01  CATAL-NAME                  PICTURE X(32).                      CL**2
00129  01  DATA-NAME                   PICTURE X(32).                      CL**2
00130  01  CUR-LINE                PICTURE XX VALUE SPACE.              DCCONCBL
00131  01  LEVEL-NO                    PICTURE XX.                         CL**2
00132  01  END-SW                  PICTURE X VALUE "N".                 DCCONCBL
00133  01  CUR-NAME                    PICTURE X(32).                      CL**2
00134  01  SEG-NAME                    PICTURE X(32).                      CL**2
00135  01  GRP-DNAME                   PICTURE X(32).                      CL**2
00136  01  SEG-DNAME                   PICTURE X(32).                      CL**2
00137  01  RESET-SW                    PICTURE X.                          CL**2
00138  01  PROG-ID                 PICTURE X(10) VALUE SPACE.           DCCONCBL
00139  01  HIGH-LINE               PICTURE XX VALUE SPACE.              DCCONCBL
00140  01  READ-SW                     PICTURE X VALUE "R".             DCCONCBL
00141  01  SEG-FOUND               PICTURE X.                           DCCONCBL
00142  01  FIRST-LEVEL             PICTURE X.                           DCCONCBL
00143  01  END-SELECT-SW               PICTURE X.                          CL**2
00144  01  PREFIX-OUT                  PICTURE X(9).                       CL**2
00145  01  SAVE-USE                       PICTURE X.                       CL**2
00146  01  LINE-NO                 PICTURE XX.                          DCCONCBL
00147  01  COM-SW                      PICTURE X.                          CL**2
00148  01  COM-SUB                     PICTURE S9999 COMP.                 CL**2
00149  01  WK-SUB                  PICTURE S9999 COMP.                  DCCONCBL
00150  01  PX-SUB                      PICTURE S9999 COMP.                 CL**2
00151  01  LV-SUB                  PICTURE S9999 COMP.                  DCCONCBL
       01  INDEX-SUB                       PICTURE 99 VALUE 0.
       01  KEY-SUB                         PICTURE 99 VALUE 0.
       01  TEMP-SUB                        PICTURE 99.
00152  01  IN-SUB                  PICTURE S9999 COMP.                  DCCONCBL
00153  01  HOLD-IN-SUB                 PICTURE S9999 COMP.              DCCONCBL
00154  01  HOLD-IN-SUB2                 PICTURE S9999 COMP.                CL**2
00155  01  IN-SUB-HI               PICTURE S9999 COMP.                  DCCONCBL
00156  01  LV-SUB-HI               PICTURE S9999 COMP.                  DCCONCBL
00157  01  CTL-SW                  PIC X VALUE SPACE.                   DCCONCBL
00158  01  PIC-COUNT               PICTURE S9(5) .                       DCCONCB
00159  01  PIC-COUNTA              PICTURE S9(6) VALUE ZERO .            DCCONCB
00160  01  WORK-USE                PICTURE XXXX.                        DCCONCBL
00161  01  OCC-WORK                PIC 999.                             DCCONCBL
00162  01  LEN-S                   PICTURE XX VALUE HIGH-VALUE.         DCCONCBL
00164  01  ELMGRP-SW               PICTURE X VALUE SPACE.               DCCONCBL
00165  01  PER-FOUND               PICTURE X VALUE SPACE.               DCCONCBL
00166  01  HOLD-88-CATAL-NAME          PICTURE X(32).                      CL**2
       01 88-COUNT         PICTURE 9(5)   VALUE ZEROS.
00169 ***************************************************************      CL**2
00170 *                                                                    CL**2
00171 *     HEADING LITERALS                                               CL**2
00172 *                                                                    CL**2
00173 *****************************************************************    CL**2
00174  01  HEADING-LITS.                                                   CL**2
00175      03  LITERAL-1               PICTURE X(24) VALUE                 CL**2
00176         "REPORT DATE-".                                              CL**2
00177      03  LITERAL-2               PICTURE X(24) VALUE                 CL**2
00178         "DATE OF LAST REVISION-".                                    CL**2
00179      03  LITERAL-3               PICTURE X(5) VALUE                  CL**2
00180         "PAGE".                                                      CL**2
00181      03  LITERAL-4               PICTURE X(31) VALUE                 CL**2
00182         "D A T A   C A T A L O G U E   2".                           CL**2
00183      03  LITERAL-5               PICTURE X(25) VALUE                 CL**2
00184         "REVISION NUMBER-".                                          CL**2
00185      03  LITERAL-6               PICTURE X(10) VALUE                 CL**2
00186     "PROGRAM ID".                                                    CL**2
00187      03  LITERAL-7               PICTURE X(24) VALUE                 CL**2
00188     "COBOL DATANAME SELECTED".                                       CL**2
00189      03  LITERAL-8               PICTURE X(23) VALUE                 CL**2
00190     "IMAGE OF ITEM PROCESSED".                                       CL**2
00191      03  CONV-CBL-TITLE          PICTURE X(50) VALUE                 CL**2
00192     "  C O B O L   C O N V E R S I O N   R E P O R T  ".             CL**2
00193      03  TRUNCATION-MSG.                                             CL**2
00194          05  FILLER              PICTURE X(25) VALUE                 CL**2
00195          "     DCCVT-490-W ERROR * ".                                CL**2
00196          05  FILLER             PICTURE X(43) VALUE                  CL**2
00197     "TRUNCATION OCCURRED IN PICTURE/VALUE ABOVE".                    CL**2
00198      03  PROP-MSG.                                                   CL**2
00199          05  FILLER              PICTURE X(44) VALUE                 CL**2
               "DATA CATALOGUE 2                        V2.0".
00201          05  FILLER              PICTURE X(30) VALUE                 CL**2
*CALL LEVEL 
00203      03  NOT-FOUND-MSG.                                              CL**2
00204          05  FILLER              PICTURE X(25)                       CL**2
00205      VALUE "     DCCVT-495-S ERROR * ".                              CL**2
00206          05  PROG-NOT-FOUND         PICTURE X(8).                    CL**2
00207          05  FILLER                 PICTURE X(13)                    CL**2
00208          VALUE "  NOT ON FILE".                                      CL**2
00209      03  END-REPORT-MSG             PICTURE X(33)                    CL**2
00210          VALUE "***END COBOL CONVERSION REPORT***".                  CL**2
           02  MSG-270                     PICTURE X(50) VALUE
           "     DCCVT-270-S ERROR * KEYWORD *RENAMES* MISSING".
           02  MSG-275                     PICTURE X(64) VALUE
           "     DCCVT-275-S ERROR * RENAMES CLAUSE IS ONLY PERMITTED CL
      -    "AUSE".
           02  MSG-510                     PICTURE X(45) VALUE
           "     DCCVT-510-S ERROR * INDEX TABLE EXCEEDED". 
           02  MSG-515                     PICTURE X(43) VALUE
           "     DCCVT-515-S ERROR * KEY TABLE EXCEEDED". 
00215                                                                    DCCONCB
00216  PROCEDURE DIVISION.                                              DCCONCBL
       BEGIN-PARA.
00220      OPEN INPUT COBOL-FILE.                                          CL**2
00221      OPEN OUTPUT SYSPRINT.                                           CL**2
00222      OPEN OUTPUT WORK-FILE.                                          CL**2
00223      MOVE CONV-CBL-TITLE TO REPORT-TITLE-LONG.                       CL**2
00224      MOVE STRUCT-COUNT TO OUT-STCR.                               DCCONCBL
00225 ******************************************************************DCCONCBL
00226 *                                                                *DCCONCBL
00227 *                R E S E T S  - NEW PROGRAM                      *DCCONCBL
00228 *                                                                *DCCONCBL
00229 ******************************************************************DCCONCBL
00230  RESET-NEW-PROG.                                                  DCCONCBL
00231      MOVE SPACES TO PROG-ID.                                      DCCONCBL
00232      MOVE "N" TO FIRST-LEVEL, READ-SW, RESET-SW, SEG-FOUND.          CL**2
00233      MOVE "N" TO FD-SW.                                              CL**2
00234      MOVE SPACES TO COMMENT-TABLE.                                   CL**2
00235 ******************************************************************DCCONCBL
00236 *                                                                *DCCONCBL
00237 *            P R O G R A M   S E A R C H - FIND PROG-ID          *DCCONCBL
00238 *                                                                *DCCONCBL
00239 ******************************************************************DCCONCBL
00240  PROGRAM-READ.                                                    DCCONCBL
00241      PERFORM READ-COBOL THRU READ-COBOL-XIT.                      DCCONCBL
00242      IF END-SW EQUAL TO "E" GO TO COBOL-END.                      DCCONCBL
00243      IF COB-PROGID NOT EQUAL TO "PROGRAM-ID."                     DCCONCBL
00244          GO TO PROGRAM-READ.                                         CL**2
00245      MOVE 12 TO IN-SUB.                                           DCCONCBL
00246      PERFORM SPACER THRU SPACER-EXIT.                             DCCONCBL
00247      PERFORM SCAN THRU SCAN-EXIT.                                 DCCONCBL
00248      MOVE WORK-AREA TO PROG-ID.                                   DCCONCBL
00249  PROGRAM-SEARCH.                                                     CL**2
00250      MOVE 1 TO PROG-SUB.                                             CL**2
00251  PROG-LOOP.                                                          CL**2
00252      IF PROG-ID EQUAL TO CVT-PROG-NAME (PROG-SUB)                    CL**2
00253          GO TO TEST-PROG-CVT.                                        CL**2
00254      ADD 1 TO PROG-SUB.                                              CL**2
00255      IF PROG-SUB GREATER PROG-SUB-HI                                 CL**2
00256          GO TO RESET-NEW-PROG.                                       CL**2
00257      GO TO PROG-LOOP.                                                CL**2
00258  TEST-PROG-CVT.                                                      CL**2
00259      MOVE "N" TO RESET-SW.                                           CL**2
00260      MOVE "X" TO CVT-MOD-FND (PROG-SUB).                             CL**2
00261      IF CVT-PROGRAM (PROG-SUB) NOT EQUAL "Y"                         CL**2
00262          GO TO READ-FIRST.                                           CL**2
00263 ***************************************************************      CL**2
00264 *                                                                    CL**2
00265 *     WRITE MODULE RECORD                                            CL**2
00266 *                                                                    CL**2
00267 ***************************************************************      CL**2
00268      MOVE SPACES TO OUT-MOD-REC.                                     CL**2
00269      MOVE "50" TO OUT-ENTRY-TYPE.                                    CL**2
00270      MOVE "0" TO OUT-REC-TYPE.                                       CL**2
00271      MOVE "C" TO OUT-LANG-CODE.                                      CL**2
00272      IF CVT-NEWNAME (PROG-SUB) NOT EQUAL SPACES                      CL**2
00273          MOVE CVT-NEWNAME (PROG-SUB) TO OUT-CATNAME OUT-RENAME       CL**2
00274      ELSE                                                            CL**2
00275          MOVE PROG-ID TO OUT-CATNAME.                                CL**2
00276      MOVE SPACES TO OUT-SEGNAME.                                     CL**2
00277      MOVE PROG-ID TO OUT-MODULE-ID.                                  CL**2
00278      MOVE STRUCT-COUNT TO OUT-STCR.                                  CL**2
00279      WRITE OUT-MOD-REC.                                              CL**2
00280      ADD 1 TO STRUCT-COUNT.                                          CL**2
00281                                                                    DCCONCB
00282 *****************************************************************    CL**2
00283 *                                                                    CL**2
00284 *     READ THRU PROGRAM LOOKING FOR FIRST DATA DIVISION ENTRY        CL**2
00285 *                                                                    CL**2
00286 ****************************************************************     CL**2
00287  READ-FIRST.                                                         CL**2
00288      PERFORM READ-COBOL THRU READ-COBOL-XIT.                         CL**2
00289      IF END-SW EQUAL "E"                                             CL**2
00290          GO TO COBOL-END.                                            CL**2
00291      IF COB-CONT EQUAL TO "*"                                        CL**2
00292          GO TO READ-FIRST.                                           CL**2
00293      IF RESET-SW EQUAL "R"                                           CL**2
00294          GO TO RESET-NEW-PROG.                                       CL**2
00295      MOVE SPACE TO PER-FOUND.                                        CL**2
00296 ****************************************************************     CL**2
00297 *                                                                    CL**2
00298 *     EXTRACT LINE NUMBER AND DATANAME                               CL**2
00299 *     LOOKING FOR FIRST MATCH                                        CL**2
00300 *                                                                    CL**2
00301 ****************************************************************     CL**2
00302  LOCATE-LEVEL-NO.                                                    CL**2
00303      MOVE 1 TO IN-SUB.                                               CL**2
00304      PERFORM SPACER THRU SPACER-EXIT.                                CL**2
00305      ADD 2 TO IN-SUB.                                                CL**2
00306      IF COB-LINE (IN-SUB) NOT EQUAL TO SPACE                         CL**2
00307          GO TO READ-FIRST.                                           CL**2
00308      SUBTRACT 2 FROM IN-SUB.                                         CL**2
00309      PERFORM SCAN THRU SCAN-EXIT.                                    CL**2
00310      MOVE WORK-AREA TO LINE-NO.                                      CL**2
00311      PERFORM SPACER THRU SCAN-EXIT.                                  CL**2
00312      MOVE WORK-AREA TO DATA-NAME.                                    CL**2
00313 ****************************************************************     CL**2
00314 *                                                                    CL**2
00315 *     TEST FOR HIT AGAINST SELECT TABLE                              CL**2
00316 *                                                                    CL**2
00317 *     PROCESSING ALWAYS RETURNS HERE ON A LEVEL CHANGE               CL**2
00318 *                                                                    CL**2
00319 ****************************************************************     CL**2
00320  READ-TEST.                                                          CL**2
00321      MOVE 1 TO SEL-SUB.                                              CL**2
00322      MOVE "N" TO END-SELECT-SW.                                      CL**2
00323  SEL-LOOP.                                                           CL**2
00324      IF PROG-SUB EQUAL SELECT-ID (SEL-SUB) AND                       CL**2
00325          LINE-NO EQUAL CVT-LEVEL (SEL-SUB)                           CL**2
00326              GO TO TEST-DATANAME.                                    CL**2
00327  NEXT-SELECT.                                                        CL**2
00328      ADD 1 TO SEL-SUB.                                               CL**2
00329      IF SEL-SUB GREATER SEL-SUB-HI                                   CL**2
00330          GO TO READ-FIRST.                                           CL**2
00331      GO TO SEL-LOOP.                                                 CL**2
00332  TEST-DATANAME.                                                      CL**2
00333      IF DATA-NAME NOT EQUAL CVT-DATANAME (SEL-SUB)                   CL**2
00334          GO TO NEXT-SELECT.                                          CL**2
00335      MOVE LINE-NO TO LEVEL-NO.                                       CL**2
00336      MOVE "Y" TO SEG-FOUND.                                          CL**2
00337                                                                    DCCONCB
00338 ****************************************************************     CL**2
00339 *                                                                    CL**2
00340 *     HAVE A MATCH  - PROCESS RENAMES - PREFIX                       CL**2
00341 *     AND COBOL CLAUSES.                                             CL**2
00342 *                                                                    CL**2
00343 ****************************************************************     CL**2
00344  RENAME-PREFIX-PROC.                                                 CL**2
00345      PERFORM RENAME THRU RENAME-XIT.                                 CL**2
00346      PERFORM PREFIX THRU PREFIX-XIT.                                 CL**2
00347      IF LEVEL-NO EQUAL "FD"                                          CL**2
00348          GO TO PRINT-HDG.                                            CL**2
00349  SEARCH-01-FOUND.                                                    CL**2
00350      MOVE SPACES TO HOLD-AREA.                                       CL**2
00351      MOVE SPACES TO LEVEL-TABLE.                                     CL**2
           PERFORM KEY-CTL-INIT THRU KEY-CTL-XIT. 
00353      IF FD-SW EQUAL "Y"                                              CL**2
00354          GO TO WRITE-SEG.                                            CL**2
00355 *****************************************************************    CL**2
00356 *                                                                    CL**2
00357 *     INITIALIZE SUB-HEADINGS AND FORCE HEAD OF FORM                 CL**2
00358 *     PRINT PROGRAM ID AND SELECT DATANAME                           CL**2
00359 *                                                                    CL**2
00360 *****************************************************************    CL**2
00361  PRINT-HDG.                                                          CL**2
00362      MOVE SPACES TO LINE1.                                           CL**2
00363      MOVE LITERAL-6 TO LINE1A.                                       CL**2
00364      MOVE LITERAL-7 TO LINE1B.                                       CL**2
00365      MOVE LITERAL-8 TO LINE1C.                                       CL**2
00366 ******************************************************************   CL**2
00367 *     PRINT ENTRY                                                    CL**2
00368 ******************************************************************   CL**2
00369      MOVE 99 TO LINE-CT.                                             CL**2
00370      MOVE 1 TO PRT-CTL.                                              CL**2
00371      MOVE SPACES TO STD-REPORT-REC.                                  CL**2
00372      PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                     CL**2
00373      MOVE LINE1 TO STD-REPORT-REC.                                   CL**2
00374      PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                     CL**2
00375      PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                     CL**2
00376      MOVE SPACES TO LINE1.                                           CL**2
00377      MOVE CVT-PROG-NAME (PROG-SUB) TO LINE1A.                        CL**2
00378      MOVE CVT-DATANAME (SEL-SUB) TO LINE1B.                          CL**2
00379      MOVE COBOL-IN TO LINE1C.                                        CL**2
00380      MOVE LINE1 TO STD-REPORT-REC.                                   CL**2
00381      PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                     CL**2
00382      MOVE "N" TO FIRST-LEVEL.                                        CL**2
00383 ******************************************************************   CL**2
00384 *                                                                    CL**2
00385 *     IF SELECT IS AN FD                                             CL**2
00386 *          SCAN FD CLAUSES                                           CL**2
00387 *          WRITE FD HEADER RECORD AND MODULE STRUCTURE RECORD        CL**2
00388 *          LOCATE FIRST RECORD IN FILE                               CL**2
00389 *          WRITE FD STRUCTURE RECORD                                 CL**2
00390 *                                                                    CL**2
00391 ******************************************************************   CL**2
00392      IF LEVEL-NO EQUAL "FD"                                          CL**2
00393          PERFORM FD-SCAN THRU FD-SCAN-XIT                            CL**2
00394          PERFORM WRITE-MODS THRU WRITE-MODSX                         CL**2
00395          GO TO SEARCH-01-FOUND.                                      CL**2
00396      IF LEVEL-NO EQUAL "01"                                          CL**2
00397          GO TO WRITE-SEG.                                            CL**2
00398 **************************************************************       CL**2
00399 *                                                                    CL**2
00400 *     READ AHEAD TO DETERMINE IF ENTRY IS AN ELEMENT OR A GROUP      CL**2
00401 *                                                                    CL**2
00402 ***************************************************************      CL**2
00403      MOVE "O" TO READ-SW.                                            CL**2
00404      MOVE "N" TO CVT-RECORD (SEL-SUB).                               CL**2
00405  READ-AHEAD.                                                         CL**2
00406      PERFORM READ-COBOL THRU READ-COBOL-XIT.                         CL**2
00407      IF END-SW EQUAL "E"                                             CL**2
00408          PERFORM WRITE-ELM THRU WRITE-ELMX                           CL**2
00409          GO TO COBOL-END.                                            CL**2
00410      IF RESET-SW EQUAL "R"                                           CL**2
00411          PERFORM WRITE-ELM THRU WRITE-ELMX                           CL**2
00412          GO TO RESET-NEW-PROG.                                       CL**2
00413      IF COB-CONT EQUAL TO "*"                                        CL**2
00414          GO TO READ-AHEAD.                                           CL**2
00415 *                                                                    CL**2
00416 *     EXTRACT LINE NUMBER TO A WORK AREA                             CL**2
00417 *                                                                    CL**2
00418      MOVE 1 TO IN-SUB.                                               CL**2
00419      PERFORM SPACER THRU SPACER-EXIT.                                CL**2
00420      MOVE COB-LINE (IN-SUB) TO FLD1.                                 CL**2
00421      ADD 1 TO IN-SUB.                                                CL**2
00422      MOVE COB-LINE (IN-SUB) TO FLD2.                                 CL**2
           IF NEXT-LINE IS EQUAL TO "66"
             OR NEXT-LINE IS EQUAL TO "88"
               PERFORM WRITE-ELM THRU WRITE-ELMX
               GO TO READ-ROUTINE 
           END-IF.
00423      IF NEXT-LINE GREATER THAN LEVEL-NO                              CL**2
00424          MOVE NEXT-LINE TO HIGH-LINE                                 CL**2
00425          MOVE "G" TO ELMGRP-SW                                       CL**2
00426          GO TO FIRST-LEV20.                                          CL**2
00427      PERFORM WRITE-ELM THRU WRITE-ELMX.                              CL**2
00428      MOVE "N" TO SEG-FOUND, READ-SW.                                 CL**2
00429      MOVE SPACE TO PER-FOUND.                                        CL**2
00430      GO TO LOCATE-LEVEL-NO.                                          CL**2
00431 ******************************************************************   CL**2
00432 *                                                                    CL**2
00433 *          WRITE SEGMENT RECORD                                      CL**2
00434 *                                                                    CL**2
00435 ******************************************************************   CL**2
00436  WRITE-SEG.                                                          CL**2
00437      IF CVT-RECORD (SEL-SUB) NOT EQUAL "Y"                           CL**2
00438          GO TO READ-ROUTINE.                                         CL**2
00439      MOVE SPACES TO OUT-BASIC-REC.                                   CL**2
00440      MOVE "15" TO OUT-ENTRY-TYPE.                                    CL**2
00441      MOVE "0" TO OUT-REC-TYPE.                                       CL**2
00442      MOVE "C" TO OUT-LANG-CODE.                                      CL**2
00443      MOVE CATAL-NAME TO OUT-CATNAME.                                 CL**2
00444      MOVE CATAL-NAME TO SEG-NAME.                                    CL**2
00445      IF CVT-ALIAS-HOLD EQUAL "A"                                     CL**2
00446          MOVE CVT-CATNAME-HOLD TO OUT-RENAME                         CL**2
00447      ELSE                                                            CL**2
00448          MOVE CVT-RENAME-HOLD TO OUT-RENAME.                         CL**2
00449      MOVE CVT-BEGIN-HOLD TO OUT-RENAME-LINE.                         CL**2
00450      MOVE CVT-ALIAS-HOLD TO OUT-ALIAS.                               CL**2
00451      MOVE PREFIX-OUT TO OUT-PREFIX.                                  CL**2
00452      MOVE DATA-NAME TO OUT-SEGNAME SEG-DNAME.                        CL**2
00453      MOVE STRUCT-COUNT TO OUT-STCR.                                  CL**2
00454      IF HOLD-ELM NOT EQUAL SPACES                                    CL**2
00455          PERFORM LENGTH-CALC THRU LEN-XIT                            CL**2
00456          MOVE HOLD-ELM TO OUT-BASIC                                  CL**2
00457          MOVE SPACES TO HOLD-ELM.                                    CL**2
00458      WRITE OUT-BASIC-REC.                                            CL**2
00459      ADD 1 TO STRUCT-COUNT.                                          CL**2
00460                                                                    DCCONCB
00461 ************************************************************         CL**2
00462 *     EXTRACT NEXT LINE NO AND DATANAME                              CL**2
00463 *****************************************************************    CL**2
00464  READ-ROUTINE.                                                       CL**2
00465      IF END-SW EQUAL "E"                                             CL**2
00466          GO TO COBOL-END.                                            CL**2
00467      IF RESET-SW EQUAL "R"                                           CL**2
00468          GO TO RESET-NEW-PROG.                                       CL**2
00469      IF READ-SW EQUAL TO "O"                                         CL**2
00470          GO TO READ-SKIP.                                            CL**2
00471  READ-ROUTINE10.                                                     CL**2
00472      PERFORM READ-COBOL THRU READ-COBOL-XIT.                         CL**2
00473      IF END-SW EQUAL TO "E"                                          CL**2
00474          GO TO COBOL-END.                                            CL**2
00475      IF COB-CONT EQUAL TO "*"                                        CL**2
00476          PERFORM TABLE-NOTES THRU TABLE-NOTES-XIT                    CL**2
00477          MOVE "R" TO COM-SW                                          CL**2
00478          PERFORM WRITE-COMMENTS THRU WRITE-COMMENTS-XIT              CL**2
00479          MOVE SPACE TO COM-SW                                        CL**2
00480          GO TO READ-ROUTINE10.                                       CL**2
00481      IF RESET-SW EQUAL "R"                                           CL**2
00482          GO TO RESET-NEW-PROG.                                       CL**2
00483  READ-SKIP.                                                          CL**2
00484      MOVE SPACE TO PER-FOUND.                                        CL**2
00485 *                                                                    CL**2
00486 *     LOCATE LEVEL NUMBER                                            CL**2
00487 *                                                                    CL**2
00488      MOVE 1 TO IN-SUB.                                               CL**2
00489      PERFORM SPACER THRU SPACER-EXIT.                                CL**2
00490      ADD 2 TO IN-SUB.                                                CL**2
00491      IF COB-LINE (IN-SUB) NOT EQUAL TO SPACES                        CL**2
00492          GO TO READ-ROUTINE10.                                       CL**2
00493      SUBTRACT 2 FROM IN-SUB.                                         CL**2
00494      PERFORM SCAN THRU SCAN-EXIT.                                    CL**2
00495      MOVE WORK-AREA TO LINE-NO.                                      CL**2
00496      IF LINE-NO EQUAL TO 77                                          CL**2
00497          GO TO READ-ROUTINE10.                                       CL**2
00498 *                                                                    CL**2
00499 *     LOCATE DATA NAME                                               CL**2
00500 *                                                                    CL**2
00501      PERFORM SPACER THRU SCAN-EXIT.                                  CL**2
00502      MOVE WORK-AREA TO DATA-NAME.                                    CL**2
00503                                                                      CL**2
00504 ****************************************************************     CL**2
00505 *     NEW FD                                                         CL**2
00506 ****************************************************************     CL**2
00507      IF LINE-NO EQUAL "FD"                                           CL**2
00508          MOVE "N" TO FD-SW, SEG-FOUND, READ-SW                       CL**2
00509          MOVE "Y" TO END-SELECT-SW                                   CL**2
00510          GO TO READ-ROUTINE-XIT.                                     CL**2
00511      IF LINE-NO LESS THAN LEVEL-NO OR EQUAL TO LEVEL-NO              CL**2
00512          MOVE "N" TO SEG-FOUND, READ-SW                              CL**2
00513          MOVE "Y" TO END-SELECT-SW                                   CL**2
00514          GO TO READ-ROUTINE-XIT.                                     CL**2
00515 *                                                                    CL**2
00516 *     RENAME AND PREFIX PROCESSING                                   CL**2
00517 *                                                                    CL**2
00518  FIND-CN.                                                            CL**2
00519      PERFORM RENAME THRU RENAME-XIT.                                 CL**2
00520      PERFORM PREFIX THRU PREFIX-XIT.                                 CL**2
00521  PRINT-ENTRY.                                                        CL**2
00522      MOVE COBOL-IN TO LINE1C.                                        CL**2
00523      MOVE SPACES TO LINE1.                                           CL**2
00524      MOVE COBOL-IN TO LINE1C.                                        CL**2
00525      MOVE LINE1 TO STD-REPORT-REC.                                   CL**2
00526      PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                     CL**2
           PERFORM KEY-CTL-INIT THRU KEY-CTL-XIT. 
00530 ***************************************************************      CL**2
00531 *     READ AHEAD TO DETERMINE IF ENTRY IS A GROUP OR ELEMENT         CL**2
00532 *****************************************************************    CL**2
00533  LOOK-AHEAD.                                                         CL**2
00534      MOVE "O" TO READ-SW.                                            CL**2
00535      PERFORM READ-COBOL THRU READ-COBOL-XIT.                         CL**2
00536      IF END-SW EQUAL "E"                                             CL**2
00537          MOVE "E" TO ELMGRP-SW                                       CL**2
00538          GO TO READ-ROUTINE-XIT.                                     CL**2
00539      IF RESET-SW EQUAL "R"                                           CL**2
00540          MOVE "E" TO ELMGRP-SW                                       CL**2
00541          GO TO READ-ROUTINE-XIT.                                     CL**2
00542      IF COB-CONT EQUAL TO "*"                                        CL**2
00543          PERFORM TABLE-NOTES THRU TABLE-NOTES-XIT                    CL**2
00544          GO TO LOOK-AHEAD.                                           CL**2
00545      MOVE 1 TO IN-SUB.                                               CL**2
00546      PERFORM SPACER THRU SPACER-EXIT.                                CL**2
00547      MOVE COB-LINE (IN-SUB) TO FLD1.                                 CL**2
00548      ADD 1 TO IN-SUB.                                                CL**2
00549      MOVE COB-LINE (IN-SUB) TO FLD2.                                 CL**2
00550      MOVE "E" TO ELMGRP-SW.                                          CL**2
00551      IF NEXT-LINE EQUAL TO "88"                                      CL**2
             OR NEXT-LINE IS EQUAL TO "66"
00552          GO TO READ-ROUTINE-XIT.                                     CL**2
00553      IF NEXT-LINE GREATER LINE-NO                                    CL**2
00554          MOVE "G" TO ELMGRP-SW.                                      CL**2
00555  READ-ROUTINE-XIT.                                                   CL**2
00556                                                                    DCCONCB
00557 *                                                                    CL**2
00558 *     FIRST LEVEL PROCESSING                                         CL**2
00559 *                                                                    CL**2
00560  FIRST-LEV.                                                          CL**2
00561      IF LINE-NO EQUAL "01" AND FD-SW EQUAL "Y"                       CL**2
00562          GO TO NEW-01.                                               CL**2
00563      IF END-SELECT-SW EQUAL "Y"                                      CL**2
00564          GO TO READ-TEST.                                            CL**2
00565      IF FIRST-LEVEL EQUAL TO "Y"                                     CL**2
00566          GO TO FIRST-LEV10.                                          CL**2
00567      IF LINE-NO NOT EQUAL "88"                                       CL**2
             AND LINE-NO IS NOT EQUAL TO "66" 
00568          MOVE LINE-NO TO HIGH-LINE.                                  CL**2
00569      MOVE "Y" TO FIRST-LEVEL.                                        CL**2
00570  FIRST-LEV10.                                                     DCCONCBL
00571      IF ELMGRP-SW EQUAL TO "E"                                    DCCONCBL
             OR LINE-NO IS EQUAL TO "66"
             OR LINE-NO IS EQUAL TO "88"
00573          PERFORM WRITE-ELM THRU WRITE-ELMX                        DCCONCBL
00574          MOVE "R" TO COM-SW                                          CL**2
00575          PERFORM WRITE-COMMENTS THRU WRITE-COMMENTS-XIT              CL**2
00576          MOVE SPACE TO COM-SW                                        CL**2
00577          GO TO READ-ROUTINE.                                         CL**2
00578  FIRST-LEV20.                                                        CL**2
00579      MOVE 1 TO LV-SUB LV-SUB-HI.                                  DCCONCBL
00580      MOVE LINE-NO TO CUR-LINE LEVT-LINE (LV-SUB).                 DCCONCBL
00581      MOVE CATAL-NAME TO CUR-NAME LEVT-NAME (LV-SUB).              DCCONCBL
00582 *    MOVE GROUP DETAILS TO TABLE                                     CL**2
00583      MOVE HOLD-ELM TO LEVT-HOLD (LV-SUB).                            CL**2
00584      PERFORM WRITE-GRP THRU WRITE-GRPX.                           DCCONCBL
00585      MOVE "G" TO COM-SW.                                             CL**2
00586      PERFORM WRITE-COMMENTS THRU WRITE-COMMENTS-XIT.                 CL**2
00587      MOVE SPACE TO COM-SW.                                           CL**2
00588      MOVE GRP-DNAME TO LEVT-GNAM (LV-SUB).                        DCCONCBL
00589                                                                    DCCONCB
00590 ******************************************************************DCCONCBL
00591 *                                                                *DCCONCBL
00592 *        S E C O N D   L E V E L   P R O C E S S I N G           *DCCONCBL
00593 *                                                                *DCCONCBL
00594 ******************************************************************DCCONCBL
00595  SEC-LEV.                                                         DCCONCBL
00596      PERFORM READ-ROUTINE THRU READ-ROUTINE-XIT.                     CL**2
00597      IF LINE-NO EQUAL "01" AND FD-SW EQUAL "Y"                       CL**2
00598          GO TO NEW-01.                                               CL**2
00599      IF END-SELECT-SW EQUAL "Y"                                      CL**2
00600          GO TO READ-TEST.                                            CL**2
           IF LINE-NO IS EQUAL TO "66"
             OR LINE-NO IS EQUAL TO "88"
00602          PERFORM WRITE-ELM THRU WRITE-ELMX                           CL**2
00603          MOVE SPACES TO COMMENT-TABLE                                CL**2
00604          GO TO SEC-LEV.                                              CL**2
00605      IF ELMGRP-SW EQUAL TO "G" GO TO SEC-LEV-GRP.                 DCCONCBL
00606      IF LINE-NO LESS THAN CUR-LINE                                DCCONCBL
00607          GO TO SEC-LEV-ELMHI.                                     DCCONCBL
00608  SEC-LEV-ELM10.                                                   DCCONCBL
00609      MOVE LINE-NO TO CUR-LINE.                                    DCCONCBL
00610 *    MOVE ANY GROUP DETAILS TO HOLD-AREA.                         DCCONCBL
00611      PERFORM GROUP-CASCADE THRU GROUP-CASCADE-XIT.                   CL**2
00612      PERFORM WRITE-ELM THRU WRITE-ELMX.                           DCCONCBL
00613      PERFORM WRITE-GRPS THRU WRITE-GRPSX.                         DCCONCBL
00614      GO TO SEC-LEV.                                               DCCONCBL
00615  SEC-LEV-ELMHI.                                                   DCCONCBL
00616      IF LINE-NO EQUAL TO HIGH-LINE                                DCCONCBL
00617          GO TO FIRST-LEV10.                                       DCCONCBL
00618      MOVE 1 TO LV-SUB.                                            DCCONCBL
00619  SEC-LEV-ELM15.                                                   DCCONCBL
00620      IF LEVT-LINE (LV-SUB) EQUAL TO LINE-NO                       DCCONCBL
00621          GO TO SEC-LEV-ELM30.                                     DCCONCBL
00622      ADD 1 TO LV-SUB.                                             DCCONCBL
00623      IF LV-SUB NOT GREATER THAN LV-SUB-HI                         DCCONCBL
00624          GO TO SEC-LEV-ELM15.                                     DCCONCBL
00625  SEC-LEV-ELM30.                                                   DCCONCBL
00626      SUBTRACT 1 FROM LV-SUB.                                      DCCONCBL
00627      MOVE LEVT-NAME (LV-SUB) TO CUR-NAME.                         DCCONCBL
00628      MOVE LEVT-GNAM (LV-SUB) TO GRP-DNAME.                        DCCONCBL
00629 *    MOVE ANY GROUP DETAILS TO THE HOLD-AREA.                     DCCONCBL
00630      PERFORM GROUP-CASCADE THRU GROUP-CASCADE-XIT.                   CL**2
00631      GO TO SEC-LEV-ELM10.                                         DCCONCBL
00632  SEC-LEV-GRP.                                                     DCCONCBL
00633      IF LINE-NO LESS THAN CUR-LINE                                DCCONCBL
00634          GO TO SEC-LEV-GRPHI.                                     DCCONCBL
00635  SEC-LEV-GRPLO.                                                   DCCONCBL
00636      PERFORM WRITE-GRPS THRU WRITE-GRPSX.                         DCCONCBL
00637      MOVE LINE-NO TO CUR-LINE.                                    DCCONCBL
00638      MOVE CATAL-NAME TO CUR-NAME.                                 DCCONCBL
00639      MOVE 1 TO LV-SUB.                                            DCCONCBL
00640  SEC-LEV-GRP10.                                                   DCCONCBL
00641      IF LEVT-LINE (LV-SUB) NOT LESS THAN CUR-LINE                 DCCONCBL
00642          GO TO SEC-LEV-GRP20.                                     DCCONCBL
00643      ADD 1 TO LV-SUB.                                             DCCONCBL
00644      IF LV-SUB NOT GREATER THAN LV-SUB-HI                         DCCONCBL
00645          GO TO SEC-LEV-GRP10.                                     DCCONCBL
00646  SEC-LEV-GRP20.                                                   DCCONCBL
00647      MOVE CUR-LINE TO LEVT-LINE (LV-SUB).                         DCCONCBL
00648      MOVE CUR-NAME TO LEVT-NAME (LV-SUB).                         DCCONCBL
00649 *    MOVE THE GROUP DETAILS TO THE TABLE.                         DCCONCBL
00650      MOVE HOLD-ELM TO LEVT-HOLD (LV-SUB).                         DCCONCBL
00651      PERFORM WRITE-GRP THRU WRITE-GRPX.                           DCCONCBL
00652      MOVE "G" TO COM-SW.                                             CL**2
00653      PERFORM WRITE-COMMENTS THRU WRITE-COMMENTS-XIT.                 CL**2
00654      MOVE SPACE TO COM-SW.                                           CL**2
00655      MOVE GRP-DNAME TO LEVT-GNAM (LV-SUB).                        DCCONCBL
00656      ADD 1 TO LV-SUB-HI.                                          DCCONCBL
00657      MOVE LV-SUB TO LV-SUB-HI.                                    DCCONCBL
00658      GO TO SEC-LEV.                                               DCCONCBL
00659  SEC-LEV-GRPHI.                                                   DCCONCBL
00660      IF LINE-NO EQUAL TO HIGH-LINE                                DCCONCBL
00661          GO TO FIRST-LEV10.                                       DCCONCBL
00662      MOVE 1 TO LV-SUB.                                            DCCONCBL
00663  SEC-LEV-GRP40.                                                   DCCONCBL
00664      IF LEVT-LINE (LV-SUB) EQUAL TO LINE-NO                       DCCONCBL
00665          GO TO SEC-LEV-GRP45.                                     DCCONCBL
00666      ADD 1 TO LV-SUB.                                             DCCONCBL
00667      IF LV-SUB NOT GREATER THAN LV-SUB-HI                         DCCONCBL
00668          GO TO SEC-LEV-GRP40.                                     DCCONCBL
00669  SEC-LEV-GRP45.                                                   DCCONCBL
00670      SUBTRACT 1 FROM LV-SUB.                                      DCCONCBL
00671      MOVE LEVT-LINE (LV-SUB) TO CUR-LINE.                         DCCONCBL
00672      MOVE LEVT-NAME (LV-SUB) TO CUR-NAME.                         DCCONCBL
00673      MOVE LEVT-GNAM (LV-SUB) TO GRP-DNAME.                        DCCONCBL
00674 *    MOVE ANY GROUP DETAILS TO THE HOLD-AREA.                     DCCONCBL
00675      PERFORM GROUP-CASCADE THRU GROUP-CASCADE-XIT.                   CL**2
00676      GO TO SEC-LEV-GRPLO.                                         DCCONCBL
00677  NEW-01.                                                             CL**2
00678      MOVE "N" TO END-SELECT-SW FIRST-LEVEL.                          CL**2
00679      MOVE "Y" TO SEG-FOUND.                                          CL**2
00680      PERFORM RENAME THRU RENAME-XIT.                                 CL**2
00681      PERFORM PREFIX THRU PREFIX-XIT.                                 CL**2
00682      PERFORM WRITE-FDS THRU WRITE-FDSX.                              CL**2
00683      MOVE SPACES TO LINE1.                                           CL**2
00684      MOVE COBOL-IN TO LINE1C.                                        CL**2
00685      MOVE LINE1 TO STD-REPORT-REC.                                   CL**2
00686      PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                     CL**2
00687      GO TO SEARCH-01-FOUND.                                          CL**2
00688                                                                    DCCONCB
00689 ******************************************************************   CL**2
00690 *                                                                    CL**2
00691 *     RENAME  -  FIND CATALOGUE NAME                                 CL**2
00692 *                                                                    CL**2
00693 ******************************************************************   CL**2
00694  RENAME.                                                             CL**2
00695      MOVE SPACES TO HOLD-RENAME-TABLE.                               CL**2
00696      IF RN-SUB-HI EQUAL 0                                            CL**2
00697          GO TO RN-NOT-FOUND.                                         CL**2
00698      MOVE 1 TO RN-SUB.                                               CL**2
00699  FIND-RN.                                                            CL**2
00700      IF RN-SUB GREATER THAN RN-SUB-HI                                CL**2
00701          GO TO RN-NOT-FOUND.                                         CL**2
00702      IF LINE-NO EQUAL "88"                                           CL**2
00703          GO TO RENAME-XIT.                                           CL**2
00704      IF RENAME-ID (RN-SUB) EQUAL TO SEL-SUB                          CL**2
00705          AND CVT-RENAME (RN-SUB) EQUAL TO DATA-NAME                  CL**2
00706              GO TO RN-FOUND.                                         CL**2
00707      ADD 1 TO RN-SUB.                                                CL**2
00708      GO TO FIND-RN.                                                  CL**2
00709  RN-FOUND.                                                           CL**2
00710      MOVE CVT-RENAME-TABLE (RN-SUB) TO HOLD-RENAME-TABLE.            CL**2
00711      IF CVT-ALIAS-HOLD EQUAL "A"                                     CL**2
00712          GO TO RN-NOT-FOUND.                                         CL**2
00713      MOVE SPACES TO CATAL-NAME.                                      CL**2
00714      MOVE CVT-CATNAME-HOLD TO CATAL-NAME.                            CL**2
00715      GO TO RENAME-XIT.                                               CL**2
00716  RN-NOT-FOUND.                                                       CL**2
00717      MOVE DATA-NAME TO CATAL-NAME.                                   CL**2
00718  RENAME-XIT.                                                         CL**2
00719      EXIT.                                                           CL**2
00720 ******************************************************************   CL**2
00721 *                                                                    CL**2
00722 *         PREFIX TEST  - DROP IF REQUESTED                           CL**2
00723 *                                                                    CL**2
00724 ******************************************************************   CL**2
00725  PREFIX.                                                             CL**2
00726      MOVE SPACES TO PREFIX-OUT.                                      CL**2
00727      IF LINE-NO EQUAL "88"                                           CL**2
00728          GO TO PREFIX-XIT.                                           CL**2
00729      IF CVT-PREFIX (SEL-SUB) EQUAL SPACES                            CL**2
00730          GO TO PREFIX-XIT.                                           CL**2
00731      MOVE SPACES TO WORK-AREA.                                       CL**2
00732      MOVE CVT-PREFIX (SEL-SUB) TO WORK-AREA.                         CL**2
00733      MOVE SPACES TO 88-VAL-AREA.                                     CL**2
00734      MOVE CATAL-NAME TO 88-VAL-AREA.                                 CL**2
00735      MOVE 1 TO PX-SUB.                                               CL**2
00736  PRFX-10.                                                            CL**2
00737      IF WORKA (PX-SUB) EQUAL TO SPACE                                CL**2
00738          GO TO PRFX-FND.                                             CL**2
00739      IF 88-AREA (PX-SUB) NOT EQUAL TO WORKA (PX-SUB)                 CL**2
00740          GO TO PREFIX-XIT.                                           CL**2
00741      ADD 1 TO PX-SUB.                                                CL**2
00742      IF PX-SUB NOT EQUAL TO 10                                       CL**2
00743          GO TO PRFX-10.                                              CL**2
00744      IF 88-AREA (PX-SUB) EQUAL TO "-"                                CL**2
00745          ADD 1 TO PX-SUB.                                            CL**2
00746  PRFX-FND.                                                           CL**2
00747      MOVE SPACES TO WORK-AREA.                                       CL**2
00748      MOVE 1 TO WK-SUB.                                               CL**2
00749  PRFX-20.                                                            CL**2
00750      IF 88-AREA (PX-SUB) EQUAL TO SPACE                              CL**2
00751          GO TO PRFX-30.                                              CL**2
00752      MOVE 88-AREA (PX-SUB) TO WORKA (WK-SUB).                        CL**2
00753      ADD 1 TO PX-SUB WK-SUB.                                         CL**2
00754      IF WK-SUB NOT GREATER THAN 32                                   CL**2
00755          GO TO PRFX-20.                                              CL**2
00756  PRFX-30.                                                            CL**2
00757      MOVE WORK-AREA TO CATAL-NAME.                                   CL**2
00758      MOVE CVT-PREFIX (SEL-SUB) TO PREFIX-OUT.                        CL**2
00759  PREFIX-XIT.                                                         CL**2
00760      EXIT.                                                           CL**2
00761 ******************************************************************DCCONCBL
00762 *                                                                *DCCONCBL
00763 *        K E Y W O R D   I D E N   R O U T I N E                 *DCCONCBL
00764 *                                                                *DCCONCBL
00765 ******************************************************************DCCONCBL
       KEY-CTL-INIT.
           MOVE SPACES TO HOLD-GRP. 
           MOVE ZERO TO INDEX-SUB, KEY-SUB. 
           IF LINE-NO IS EQUAL TO "66"
               PERFORM RENAMES-SUB THRU RENAMES-EXIT
               GO TO KEY-CTL-XIT
           END-IF.
00766  KEY-CTL.                                                         DCCONCBL
00767      IF PER-FOUND EQUAL TO "."                                    DCCONCBL
00768          GO TO KEY-CTL-XIT.                                          CL**2
00769      PERFORM SPACER THRU SCAN-EXIT.                               DCCONCBL
00770  KEY-CTL10.                                                       DCCONCBL
00771      IF WORK-AREA EQUAL TO "PIC " OR "PICTURE "                   DCCONCBL
00772          GO TO PIC-SUB.                                           DCCONCBL
00773      IF WORK-AREA EQUAL TO "USE " OR "USAGE "                     DCCONCBL
00774          GO TO USE-SUB.                                           DCCONCBL
00775      MOVE WORK-AREA TO WORK-USE.                                  DCCONCBL
00776      IF WORK-USE EQUAL TO "COMP"                                  DCCONCBL
00777          GO TO USE-SUB20.                                         DCCONCBL
00778      IF WORK-AREA EQUAL TO "VALUE" OR "VALUES"                    DCCONCBL
00779          GO TO VAL-SUB.                                           DCCONCBL
00780      IF WORK-AREA EQUAL TO "OCCURS"                               DCCONCBL
00781          GO TO OCC-SUB.                                           DCCONCBL
00782      IF WORK-AREA EQUAL TO "REDEFINES"                            DCCONCBL
00783          GO TO RED-SUB.                                           DCCONCBL
00784      IF WORK-AREA EQUAL TO "JUST" OR "JUSTIFIED"                     CL**2
00785          GO TO JUST-SUB.                                          DCCONCBL
00786      IF WORK-AREA EQUAL TO "DISP"                                 DCCONCBL
00787          GO TO USE-SUB20.                                         DCCONCBL
00788      IF WORK-AREA EQUAL TO "SYNC" OR "SYNCHRONIZED"                  CL**2
00789          GO TO SYNC-SUB.                                          DCCONCBL
00790      IF WORK-AREA EQUAL TO "BLANK"                                DCCONCBL
00791          GO TO BLK-SUB.                                           DCCONCBL
00792      IF WORK-AREA EQUAL TO "SIGN"                                 DCCONCBL
00793          GO TO SIGN-SUB.                                          DCCONCBL
00794      GO TO KEY-CTL.                                               DCCONCBL
00795  KEY-CTL-XIT.                                                        CL**2
00796      EXIT.                                                           CL**2
00797 ******************************************************************DCCONCBL
00798 *                                                                *DCCONCBL
00799 *            P I C T U R E   C L A U S E   P R O C E S S         *DCCONCBL
00800 *                                                                *DCCONCBL
00801 ******************************************************************DCCONCBL
00802  PIC-SUB.                                                         DCCONCBL
00803 *    SKIP SPACES FIND THE PICTURE OR IS                           DCCONCBL
00804      PERFORM SPACER THRU SPACER-EXIT.                                CL**2
00805      MOVE IN-SUB TO HOLD-IN-SUB.                                     CL**2
00806      PERFORM SCAN THRU SCAN-EXIT.                                    CL**2
00807      IF WORK-AREA EQUAL TO "IS"                                   DCCONCBL
00808          PERFORM SPACER THRU SPACER-EXIT                             CL**2
00809          MOVE IN-SUB TO HOLD-IN-SUB                                  CL**2
00810          PERFORM SCAN THRU SCAN-EXIT.                                CL**2
00811      MOVE IN-SUB TO HOLD-IN-SUB2.                                    CL**2
00812      SUBTRACT HOLD-IN-SUB FROM HOLD-IN-SUB2.                         CL**2
00813      IF HOLD-IN-SUB2 GREATER THAN 25                                 CL**2
00814          MOVE SPACES TO LINE1                                        CL**2
00815          MOVE TRUNCATION-MSG TO LINE1C                               CL**2
00816          MOVE LINE1 TO STD-REPORT-REC                                CL**2
00817          PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                 CL**2
00818      MOVE WORK-AREA TO HOLD-PIC.                                  DCCONCBL
00819      GO TO KEY-CTL.                                               DCCONCBL
00820 ******************************************************************DCCONCBL
00821 *                                                                *DCCONCBL
00822 *            U S E A G E   C L A U S E   P R O C E S S           *DCCONCBL
00823 *                                                                *DCCONCBL
00824 ******************************************************************DCCONCBL
00825  USE-SUB.                                                         DCCONCBL
00826 *    SCAN PAST SPACES TO NEST WORD.                               DCCONCBL
00827      PERFORM SPACER THRU SCAN-EXIT.                               DCCONCBL
00828      IF WORK-AREA EQUAL TO "IS"                                   DCCONCBL
00829      PERFORM SPACER THRU SCAN-EXIT.                               DCCONCBL
00830  USE-SUB20.                                                       DCCONCBL
00831      IF WORK-AREA EQUAL TO "COMP " OR "COMPUTATIONAL "            DCCONCBL
00832          MOVE "C" TO HOLD-USE                                     DCCONCBL
00833          GO TO KEY-CTL.                                           DCCONCBL
00834      IF WORK-AREA EQUAL TO "COMP-1 " OR "COMPUTATIONAL-1 "        DCCONCBL
00835          MOVE "1" TO HOLD-USE                                     DCCONCBL
00836          GO TO KEY-CTL.                                           DCCONCBL
00837      IF WORK-AREA EQUAL TO "COMP-2 " OR "COMPUTATIONAL-2 "        DCCONCBL
00838          MOVE "2" TO HOLD-USE                                     DCCONCBL
00839          GO TO KEY-CTL.                                           DCCONCBL
00840      IF WORK-AREA EQUAL TO "COMP-3 " OR "COMPUTATIONAL-3 "        DCCONCBL
00841          MOVE "3" TO HOLD-USE                                     DCCONCBL
00842          GO TO KEY-CTL.                                           DCCONCBL
00843      IF WORK-AREA EQUAL TO "DISP " OR "DISPLAY "                  DCCONCBL
00844          MOVE "D" TO HOLD-USE                                     DCCONCBL
00845          GO TO KEY-CTL.                                           DCCONCBL
00846 ******************************************************************DCCONCBL
00847 *                                                                *DCCONCBL
00848 *            V A L U E   P R O C E S S I N G                     *DCCONCBL
00849 *                                                                *DCCONCBL
00850 ******************************************************************DCCONCBL
00851  VAL-SUB.                                                         DCCONCBL
00852 *    FIND THE VALUE OR IS/ARE                                     DCCONCBL
00853      IF LINE-NO EQUAL 88 GO TO 88-LEV-SCAN.                       DCCONCBL
00854      PERFORM SPACER THRU SPACER-EXIT.                                CL**2
00855      MOVE IN-SUB TO HOLD-IN-SUB.                                     CL**2
00856      PERFORM SCAN THRU SCAN-EXIT.                                    CL**2
00857      IF WORK-AREA EQUAL TO "IS" OR "ARE"                          DCCONCBL
00858          PERFORM SPACER THRU SPACER-EXIT                             CL**2
00859          MOVE IN-SUB TO HOLD-IN-SUB                                  CL**2
00860          PERFORM SCAN THRU SCAN-EXIT.                                CL**2
00861      MOVE IN-SUB TO HOLD-IN-SUB2.                                    CL**2
00862      SUBTRACT HOLD-IN-SUB FROM HOLD-IN-SUB2.                         CL**2
00863      IF HOLD-IN-SUB2 GREATER THAN 25                                 CL**2
00864          MOVE SPACES TO LINE1                                        CL**2
00865          MOVE TRUNCATION-MSG TO LINE1C                               CL**2
00866          MOVE 8 TO RETURN-CODE                                       CL**2
00867          MOVE LINE1 TO STD-REPORT-REC                                CL**2
00868          PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                 CL**2
00869      MOVE WORK-AREA TO HOLD-VALUE.                                DCCONCBL
00870      GO TO KEY-CTL.                                               DCCONCBL
00871  88-LEV-SCAN.                                                     DCCONCBL
00872      PERFORM SPACER THRU SPACER-EXIT.                             DCCONCBL
00873      MOVE IN-SUB TO HOLD-IN-SUB.                                  DCCONCBL
00874      PERFORM SCAN THRU SCAN-EXIT.                                 DCCONCBL
00875      IF WORK-AREA EQUAL TO "IS" OR "ARE"                          DCCONCBL
00876          PERFORM SPACER THRU SPACER-EXIT                          DCCONCBL
00877      ELSE    MOVE HOLD-IN-SUB TO IN-SUB.                          DCCONCBL
00878      MOVE 1 TO WK-SUB.                                            DCCONCBL
00879      MOVE SPACES TO 88-VAL-AREA.                                  DCCONCBL
00880  88-LEV-LOOP.                                                     DCCONCBL
00881      MOVE COB-LINE (IN-SUB) TO 88-AREA (WK-SUB).                  DCCONCBL
00882      ADD 1 TO IN-SUB.                                             DCCONCBL
00883      ADD 1 TO WK-SUB.                                             DCCONCBL
00884      IF COB-LINE (IN-SUB) NOT EQUAL "."                              CL**2
00885          GO TO 88-LEV-CHECK.                                         CL**2
00886      ADD 1 TO IN-SUB.                                                CL**2
00887      IF COB-LINE (IN-SUB) EQUAL SPACES                               CL**2
00888          GO TO KEY-CTL-XIT.                                          CL**2
00889      SUBTRACT 1 FROM IN-SUB.                                         CL**2
00890      GO TO 88-LEV-LOOP.                                              CL**2
00891  88-LEV-CHECK.                                                       CL**2
00892      IF IN-SUB GREATER THAN 65 GO TO KEY-CTL-XIT.                    CL**2
00893      GO TO 88-LEV-LOOP.                                           DCCONCBL
00894 ******************************************************************DCCONCBL
00895 *                                                                *DCCONCBL
00896 *            S I G N   P R O C E S S I N G                       *DCCONCBL
00897 *                                                                *DCCONCBL
00898 ******************************************************************DCCONCBL
00899  SIGN-SUB.                                                        DCCONCBL
00900 *    RID SPACES FIND IS,LEADING,TRAILING,SEPARATE OR CHAR         DCCONCBL
00901      PERFORM SPACER THRU SCAN-EXIT.                               DCCONCBL
00902      IF WORK-AREA EQUAL TO "IS"                                   DCCONCBL
00903          PERFORM SPACER THRU SCAN-EXIT.                           DCCONCBL
00904          IF WORK-AREA EQUAL TO "LEADING"                          DCCONCBL
00905              GO TO KEY-CTL.                                       DCCONCBL
00906          IF WORK-AREA EQUAL TO "TRAILING"                         DCCONCBL
00907              GO TO KEY-CTL.                                       DCCONCBL
00908          IF WORK-AREA EQUAL TO "SEPARATE" OR "CHARACTER"          DCCONCBL
00909              GO TO KEY-CTL                                        DCCONCBL
00910              ELSE GO TO KEY-CTL10.                                DCCONCBL
00911 ******************************************************************DCCONCBL
00912 *                                                                *DCCONCBL
00913 *            B L A N K   W H E N   Z E R O   P R O C E S S       *DCCONCBL
00914 *                                                                *DCCONCBL
00915 ******************************************************************DCCONCBL
00916  BLK-SUB.                                                         DCCONCBL
00917 *    RID SPACES,FIND WHEN OR ZERO                                 DCCONCBL
00918      PERFORM SPACER THRU SCAN-EXIT.                               DCCONCBL
00919      IF WORK-AREA EQUAL TO "WHEN"                                 DCCONCBL
00920          PERFORM SPACER THRU SCAN-EXIT.                           DCCONCBL
00921      IF WORK-AREA EQUAL TO "ZERO"                                 DCCONCBL
00922          GO TO KEY-CTL.                                           DCCONCBL
00923      GO TO KEY-CTL10.                                             DCCONCBL
00924 ******************************************************************DCCONCBL
00925 *                                                                *DCCONCBL
00926 *         S Y N C H R O N I Z E D   P R O C E S S I N G          *DCCONCBL
00927 *                                                                *DCCONCBL
00928 ******************************************************************DCCONCBL
00929  SYNC-SUB.                                                        DCCONCBL
00930      MOVE "S" TO HOLD-SYNC.                                          CL**2
00931      IF PER-FOUND EQUAL "."                                          CL**2
00932          GO TO KEY-CTL.                                              CL**2
00933      PERFORM SPACER THRU SCAN-EXIT.                               DCCONCBL
           IF WORK-AREA IS EQUAL TO "RIGHT" 
               MOVE "R" TO HOLD-SYNC
               GO TO KEY-CTL
           END-IF.
           IF WORK-AREA IS EQUAL TO "LEFT"
               MOVE "L" TO HOLD-SYNC
               GO TO KEY-CTL
           END-IF.
00936      GO TO KEY-CTL10.                                             DCCONCBL
00937 ******************************************************************DCCONCBL
00938 *                                                                *DCCONCBL
00939 *            J U S T F I E D   P R O C E S S I N G               *DCCONCBL
00940 *                                                                *DCCONCBL
00941 ******************************************************************DCCONCBL
00942  JUST-SUB.                                                        DCCONCBL
00943      IF PER-FOUND EQUAL "."                                          CL**2
00944          MOVE "R" TO HOLD-JUST                                       CL**2
00945          GO TO KEY-CTL.                                              CL**2
00946      PERFORM SPACER THRU SCAN-EXIT.                               DCCONCBL
00947      IF WORK-AREA EQUAL TO "LEFT"                                    CL**2
00948          MOVE "L" TO HOLD-JUST                                       CL**2
00949          GO TO KEY-CTL.                                              CL**2
00950      IF WORK-AREA EQUAL TO "RIGHT"                                   CL**2
00951          MOVE "R" TO HOLD-JUST                                       CL**2
00952          GO TO KEY-CTL.                                              CL**2
00953      GO TO KEY-CTL10.                                             DCCONCBL
00954 ******************************************************************DCCONCBL
00955 *                                                                *DCCONCBL
00956 *            R E D E F I N E S   P R O C E S S I N G             *DCCONCBL
00957 *                                                                *DCCONCBL
00958 ******************************************************************DCCONCBL
00959  RED-SUB.                                                         DCCONCBL
00960      PERFORM SPACER THRU SCAN-EXIT.                                  CL**2
           PERFORM FIND-RENAME THRU FIND-RENAME-EXIT. 
           IF RN-SUB IS EQUAL TO ZERO 
             OR (CVT-ALIAS (RN-SUB) IS EQUAL TO "A" 
             AND CVT-BEGIN (RN-SUB) IS EQUAL TO SPACE)
               MOVE WORK-AREA TO HOLD-REDEF 
           ELSE 
               MOVE CVT-CATNAME (RN-SUB) TO HOLD-REDEF
               MOVE CVT-BEGIN (RN-SUB) TO HOLD-RDALIAS
           END-IF.
00962      GO TO KEY-CTL.                                               DCCONCBL
00963 ******************************************************************DCCONCBL
00964 *                                                                *DCCONCBL
00965 *            O C C U R S   P R O C E S S I N G                   *DCCONCBL
00966 *                                                                *DCCONCBL
00967 ******************************************************************DCCONCBL
00968  OCC-SUB.                                                         DCCONCBL
00969      PERFORM SPACER THRU SCAN-EXIT.                               DCCONCBL
00970      MOVE 1 TO WK-SUB.                                            DCCONCBL
00971  OCC-SUB10.                                                       DCCONCBL
00972      MOVE WORKA (WK-SUB) TO NUM-1ST.                              DCCONCBL
00973      ADD 1 TO WK-SUB.                                             DCCONCBL
00974      IF WORKA (WK-SUB) EQUAL TO SPACE                             DCCONCBL
00975          MOVE NUM1 TO OCC-WORK                                    DCCONCBL
00976          GO TO OCC-SUB20.                                         DCCONCBL
00977      MOVE WORKA (WK-SUB) TO NUM-2ND.                              DCCONCBL
00978      ADD 1 TO WK-SUB.                                             DCCONCBL
00979      IF WORKA (WK-SUB) EQUAL TO SPACE                             DCCONCBL
00980          MOVE NUM2 TO OCC-WORK                                    DCCONCBL
00981          GO TO OCC-SUB20.                                         DCCONCBL
00982      MOVE WORKA (WK-SUB) TO NUM-3RD.                              DCCONCBL
00983      MOVE NUM3 TO OCC-WORK.                                       DCCONCBL
00984  OCC-SUB20.                                                       DCCONCBL
00985      MOVE OCC-WORK TO HOLD-OFROM.                                 DCCONCBL
00986      IF PER-FOUND EQUAL TO "."                                    DCCONCBL
00987          GO TO OCC-SUB70.                                         DCCONCBL
00988      PERFORM SPACER THRU SCAN-EXIT.                               DCCONCBL
00989      IF PER-FOUND EQUAL TO "."                                    DCCONCBL
00990          GO TO OCC-SUB70.                                         DCCONCBL
00991      IF WORK-AREA NOT EQUAL TO "TO " GO TO OCC-SUB50.             DCCONCBL
00992      PERFORM SPACER THRU SCAN-EXIT.                               DCCONCBL
00993      MOVE 1 TO WK-SUB.                                            DCCONCBL
00994  OCC-SUB30.                                                       DCCONCBL
00995      MOVE WORKA (WK-SUB) TO NUM-1ST.                              DCCONCBL
00996      ADD 1 TO WK-SUB.                                             DCCONCBL
00997      IF WORKA (WK-SUB) EQUAL TO SPACE                             DCCONCBL
00998          MOVE NUM1 TO OCC-WORK                                    DCCONCBL
00999          GO TO OCC-SUB40.                                         DCCONCBL
01000      MOVE WORKA (WK-SUB) TO NUM-2ND.                              DCCONCBL
01001      ADD 1 TO WK-SUB.                                             DCCONCBL
01002      IF WORKA (WK-SUB) EQUAL TO SPACE                             DCCONCBL
01003          MOVE NUM2 TO OCC-WORK                                    DCCONCBL
01004          GO TO OCC-SUB40.                                         DCCONCBL
01005      MOVE WORKA (WK-SUB) TO NUM-3RD.                              DCCONCBL
01006      MOVE NUM3 TO OCC-WORK.                                       DCCONCBL
01007  OCC-SUB40.                                                       DCCONCBL
01008      MOVE OCC-WORK TO HOLD-OTO.                                   DCCONCBL
01009      PERFORM SPACER THRU SCAN-EXIT.                               DCCONCBL
01010  OCC-SUB50.                                                       DCCONCBL
01011      IF PER-FOUND EQUAL "."                                          CL**2
01012          GO TO OCC-SUB70.                                            CL**2
01013      IF WORK-AREA EQUAL TO "TIMES "                               DCCONCBL
01014          PERFORM SPACER THRU SCAN-EXIT.                           DCCONCBL
01015      IF PER-FOUND EQUAL TO "."                                    DCCONCBL
01016          GO TO OCC-SUB70.                                         DCCONCBL
01017      IF WORK-AREA NOT EQUAL TO "DEPENDING "                       DCCONCBL
01018          GO TO OCC-SUB60.                                         DCCONCBL
01019      PERFORM SPACER THRU SCAN-EXIT.                               DCCONCBL
01020      IF WORK-AREA EQUAL TO "ON"                                   DCCONCBL
01021          PERFORM SPACER THRU SCAN-EXIT.                           DCCONCBL
01022      MOVE WORK-AREA TO HOLD-DEPEND.                               DCCONCBL
01023      IF PER-FOUND EQUAL TO "." GO TO OCC-SUB70.                   DCCONCBL
01024      PERFORM SPACER THRU SCAN-EXIT.                               DCCONCBL
01025      IF PER-FOUND EQUAL TO "." GO TO OCC-SUB70.                   DCCONCBL
       OCC-SUB60. 
           IF WORK-AREA IS NOT EQUAL TO "INDEXED" 
               GO TO OCC-SUB65. 
           PERFORM SPACER THRU SCAN-EXIT. 
           IF WORK-AREA IS EQUAL TO "BY"
               PERFORM SPACER THRU SCAN-EXIT. 
       OCC-INDEX. 
           IF WORK-AREA IS EQUAL TO "ASCENDING" 
             OR WORK-AREA IS EQUAL TO "DESCENDING"
               GO TO OCC-SUB65. 
           IF WORK-AREA IS EQUAL TO "BLANK" 
             OR WORK-AREA IS EQUAL TO "COMP"
             OR WORK-AREA IS EQUAL TO "DISP"
             OR WORK-AREA IS EQUAL TO "JUSTIFIED" 
             OR WORK-AREA IS EQUAL TO "JUST"
             OR WORK-AREA IS EQUAL TO "OCCURS"
             OR WORK-AREA IS EQUAL TO "PICTURE" 
             OR WORK-AREA IS EQUAL TO "PIC" 
             OR WORK-AREA IS EQUAL TO "REDEFINES" 
             OR WORK-AREA IS EQUAL TO "SIGN"
             OR WORK-AREA IS EQUAL TO "SYNCHRONIZED"
             OR WORK-AREA IS EQUAL TO "SYNC"
             OR WORK-AREA IS EQUAL TO "USAGE" 
             OR WORK-AREA IS EQUAL TO "USE" 
             OR WORK-AREA IS EQUAL TO "VALUE" 
               GO TO OCC-SUB70. 
           ADD 1 TO INDEX-SUB.
           IF INDEX-SUB IS GREATER THAN 10
               SUBTRACT 1 FROM INDEX-SUB
               MOVE 8 TO RETURN-CODE
               MOVE MSG-510 TO STD-REPORT-REC 
               PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT 
           ELSE 
               MOVE WORK-AREA TO HOLD-INDEX (INDEX-SUB) 
           END-IF.
           IF PER-FOUND IS EQUAL TO "." 
               GO TO OCC-SUB70. 
           PERFORM SPACER THRU SCAN-EXIT. 
           GO TO OCC-INDEX. 
       OCC-SUB65. 
           IF WORK-AREA IS NOT EQUAL TO "ASCENDING" 
             AND WORK-AREA IS NOT EQUAL TO "DESCENDING" 
               GO TO OCC-SUB70. 
       OCC-KEY. 
           IF WORK-AREA IS EQUAL TO "INDEXED" 
               GO TO OCC-SUB60. 
           IF WORK-AREA IS EQUAL TO "BLANK" 
             OR WORK-AREA IS EQUAL TO "COMP"
             OR WORK-AREA IS EQUAL TO "DISP"
             OR WORK-AREA IS EQUAL TO "JUSTIFIED" 
             OR WORK-AREA IS EQUAL TO "JUST"
             OR WORK-AREA IS EQUAL TO "OCCURS"
             OR WORK-AREA IS EQUAL TO "PICTURE" 
             OR WORK-AREA IS EQUAL TO "PIC" 
             OR WORK-AREA IS EQUAL TO "REDEFINES" 
             OR WORK-AREA IS EQUAL TO "SIGN"
             OR WORK-AREA IS EQUAL TO "SYNCHRONIZED"
             OR WORK-AREA IS EQUAL TO "SYNC"
             OR WORK-AREA IS EQUAL TO "USAGE" 
             OR WORK-AREA IS EQUAL TO "USE" 
             OR WORK-AREA IS EQUAL TO "VALUE" 
               GO TO OCC-SUB70. 
           ADD 1 TO KEY-SUB.
           IF KEY-SUB IS GREATER THAN 10
               SUBTRACT 1 FROM KEY-SUB
               MOVE 8 TO RETURN-CODE
               MOVE MSG-515 TO STD-REPORT-REC 
               PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT 
               GO TO OCC-KEY-30 
           END-IF.
           IF WORK-AREA IS EQUAL TO "ASCENDING" 
               MOVE "A" TO HOLD-KORDER (KEY-SUB)
               GO TO OCC-KEY-10 
           END-IF.
           IF WORK-AREA IS NOT EQUAL TO "DESCENDING"
               GO TO OCC-KEY-20 
           END-IF.
           MOVE "D" TO HOLD-KORDER (KEY-SUB). 
       OCC-KEY-10.
           SUBTRACT 1 FROM KEY-SUB. 
           PERFORM SPACER THRU SCAN-EXIT. 
           IF WORK-AREA IS EQUAL TO "KEY" 
               PERFORM SPACER THRU SCAN-EXIT
           END-IF.
           IF WORK-AREA IS EQUAL TO "IS"
               PERFORM SPACER THRU SCAN-EXIT
           END-IF.
           GO TO OCC-KEY. 
       OCC-KEY-20.
           PERFORM FIND-RENAME THRU FIND-RENAME-EXIT. 
           IF RN-SUB IS EQUAL TO ZERO 
             OR (CVT-ALIAS (RN-SUB) IS EQUAL TO "A" 
             AND CVT-BEGIN (RN-SUB) IS EQUAL TO SPACE)
               MOVE WORK-AREA TO HOLD-KNAME (KEY-SUB) 
           ELSE 
               MOVE CVT-CATNAME (RN-SUB) TO HOLD-KNAME (KEY-SUB)
               MOVE CVT-BEGIN (RN-SUB) TO HOLD-KALIAS (KEY-SUB) 
           END-IF.
       OCC-KEY-30.
           IF PER-FOUND IS EQUAL TO "." 
               GO TO OCC-SUB70. 
           PERFORM SPACER THRU SCAN-EXIT. 
           GO TO OCC-KEY. 
01033  OCC-SUB70.                                                       DCCONCBL
01034      IF HOLD-OTO EQUAL TO SPACES                                  DCCONCBL
01035          MOVE HOLD-OFROM TO HOLD-OTO                              DCCONCBL
01036          MOVE SPACES TO HOLD-OFROM.                               DCCONCBL
01037      IF PER-FOUND EQUAL TO "."                                    DCCONCBL
01038          GO TO KEY-CTL.                                           DCCONCBL
01039      GO TO KEY-CTL10.                                             DCCONCBL
01040                                                                    DCCONCB
  
      ******************************************************************
      * 
      *    RENAMES-SUB THRU RENAMES-EXIT
      * 
      *    SCAN RENAMES CLAUSE OF DATA DESCRIPTION ENTRY AND PREPARE
      *    HOLD-GRP5 AND HOLD-GRP6
      * 
      *    ON INPUT 
      *    WORK-AREA = DATA NAME
      * 
      *    ON OUTPUT
      *    HOLD-GRP5 AND HOLD-GRP6 SET UP 
      * 
      ******************************************************************
  
       RENAMES-SUB. 
           IF PER-FOUND IS EQUAL TO "." 
               MOVE MSG-270 TO STD-REPORT-REC 
               GO TO RENAMES-ERROR-EXIT 
           END-IF.
           PERFORM SPACER THRU SCAN-EXIT. 
           IF WORK-AREA IS NOT EQUAL TO "RENAMES" 
               MOVE MSG-270 TO STD-REPORT-REC 
               GO TO RENAMES-ERROR-EXIT 
           END-IF.
           IF PER-FOUND IS EQUAL TO "." 
               GO TO RENAMES-EXIT.
           PERFORM SPACER THRU SCAN-EXIT. 
           PERFORM FIND-RENAME THRU FIND-RENAME-EXIT. 
           IF RN-SUB IS EQUAL TO ZERO 
             OR (CVT-ALIAS (RN-SUB) IS EQUAL TO "A" 
             AND CVT-BEGIN (RN-SUB) IS EQUAL TO SPACE)
               MOVE WORK-AREA TO HOLD-RENAMES 
           ELSE 
               MOVE CVT-CATNAME (RN-SUB) TO HOLD-RENAMES
               MOVE CVT-BEGIN (RN-SUB) TO HOLD-RNALIAS
           END-IF.
           IF PER-FOUND IS EQUAL TO "." 
               GO TO RENAMES-EXIT.
           PERFORM SPACER THRU SCAN-EXIT. 
           IF WORK-AREA IS NOT EQUAL TO "THRU"
             AND WORK-AREA IS NOT EQUAL TO "THROUGH"
               MOVE MSG-275 TO STD-REPORT-REC 
               GO TO RENAMES-ERROR-EXIT 
           END-IF.
           IF PER-FOUND IS EQUAL TO "." 
               GO TO RENAMES-EXIT.
           PERFORM SPACER THRU SCAN-EXIT. 
           PERFORM FIND-RENAME THRU FIND-RENAME-EXIT. 
           IF RN-SUB IS EQUAL TO ZERO 
             OR (CVT-ALIAS (RN-SUB) IS EQUAL TO "A" 
             AND CVT-BEGIN (RN-SUB) IS EQUAL TO SPACE)
               MOVE WORK-AREA TO HOLD-THRU
           ELSE 
               MOVE CVT-CATNAME (RN-SUB) TO HOLD-THRU 
               MOVE CVT-BEGIN (RN-SUB) TO HOLD-THALIAS
           END-IF.
           IF PER-FOUND IS EQUAL TO "." 
               GO TO RENAMES-EXIT.
           PERFORM SPACER THRU SCAN-EXIT. 
           MOVE MSG-275 TO STD-REPORT-REC.
       RENAMES-ERROR-EXIT.
           MOVE 8 TO RETURN-CODE. 
           PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.
       RENAMES-ERROR-EXIT-10. 
           IF PER-FOUND IS EQUAL TO "." 
               GO TO RENAMES-EXIT.
           PERFORM SPACER THRU SCAN-EXIT. 
           GO TO RENAMES-ERROR-EXIT-10. 
       RENAMES-EXIT.
           EXIT.
  
      ******************************************************************
      * 
      *    FIND-RENAME THRU FIND-RENAME-EXIT
      * 
      *    SCAN RENAME TABLE FOR MATCH ON WORK-AREA 
      * 
      *    ON INPUT 
      *    WORK-AREA = DATA NAME TO MATCH 
      * 
      *    ON OUTPUT
      *    IF NO MATCH FOUND OR MATCH FOUND BUT CVT-ALIAS = "V" 
      *        RN-SUB = 0 
      *    IF MATCH FOUND AND CVT-ALIAS IS NOT EQUAL TO "V" 
      *        RN-SUB = INDEX INTO RENAME TABLE 
      * 
      ******************************************************************
  
       FIND-RENAME. 
           MOVE 0 TO RN-SUB.
       FIND-RENAME-10.
           ADD 1 TO RN-SUB. 
           IF RN-SUB IS GREATER THAN RN-SUB-HI
               MOVE 0 TO RN-SUB 
               GO TO FIND-RENAME-EXIT 
           END-IF.
           IF RENAME-ID (RN-SUB) IS EQUAL TO SEL-SUB
             AND CVT-RENAME (RN-SUB) IS EQUAL TO WORK-AREA
               GO TO FIND-RENAME-20.
           GO TO FIND-RENAME-10.
       FIND-RENAME-20.
           IF CVT-ALIAS (RN-SUB) IS EQUAL TO "V"
               MOVE 0 TO RN-SUB 
           END-IF.
       FIND-RENAME-EXIT.
           EXIT.
  
01041 ******************************************************************DCCONCBL
01042 *                                                                *DCCONCBL
01043 *            L E N G T H   A N A L Y S I S                       *DCCONCBL
01044 *                                                                *DCCONCBL
01045 ******************************************************************DCCONCBL
01046  LENGTH-CALC.                                                     DCCONCBL
01047      MOVE SPACES TO SAVE-USE.                                        CL**2
01048      MOVE HOLD-PIC TO WORK-AREA.                                  DCCONCBL
01049      MOVE ZERO TO PIC-COUNT.                                      DCCONCBL
01050      MOVE ZERO TO WK-SUB.                                         DCCONCBL
01051  LEN-00.                                                          DCCONCBL
01052      ADD 2 TO WK-SUB.                                             DCCONCBL
01053      IF WORKA (WK-SUB) EQUAL TO "("                               DCCONCBL
01054          GO TO LEN-30.                                               CL**2
01055      SUBTRACT 1 FROM WK-SUB.                                      DCCONCBL
01056      IF WORKA (WK-SUB) EQUAL TO SPACE                             DCCONCBL
01057          GO TO LEN-70.                                            DCCONCBL
01058      IF WORKA (WK-SUB) NOT EQUAL TO "."                           DCCONCBL
01059          GO TO LEN-02.                                            DCCONCBL
01060      ADD 1 TO WK-SUB.                                             DCCONCBL
01061      IF WORKA (WK-SUB) EQUAL TO SPACE                             DCCONCBL
01062          GO TO LEN-70.                                            DCCONCBL
01063      SUBTRACT 1 FROM  WK-SUB.                                     DCCONCBL
01064  LEN-02.                                                          DCCONCBL
01065      IF WORKA (WK-SUB) EQUAL TO "9"                               DCCONCBL
01066          MOVE "N" TO SAVE-USE                                        CL**2
01067          GO TO LEN-10.                                            DCCONCBL
01068      IF WORKA (WK-SUB) EQUAL TO "X"                               DCCONCBL
01069          MOVE "X" TO SAVE-USE                                        CL**2
01070          GO TO LEN-10.                                            DCCONCBL
01071      IF WORKA (WK-SUB) EQUAL TO "Z"                               DCCONCBL
01072          GO TO LEN-10.                                            DCCONCBL
01073      IF WORKA (WK-SUB) EQUAL TO "$"                               DCCONCBL
01074          GO TO LEN-10.                                            DCCONCBL
01075      IF WORKA (WK-SUB) EQUAL TO "V"                               DCCONCBL
01076          GO TO LEN-20.                                            DCCONCBL
01077      IF WORKA (WK-SUB) EQUAL TO ","                               DCCONCBL
01078          GO TO LEN-20.                                            DCCONCBL
01079      IF WORKA (WK-SUB) EQUAL TO "S"                               DCCONCBL
01080          GO TO LEN-20.                                            DCCONCBL
01081      IF WORKA (WK-SUB) EQUAL TO "0"                               DCCONCBL
01082          GO TO LEN-10.                                            DCCONCBL
01083      IF WORKA (WK-SUB) EQUAL TO "P"                               DCCONCBL
01084          GO TO LEN-10.                                            DCCONCBL
01085      IF WORKA (WK-SUB) EQUAL TO "A"                               DCCONCBL
01086          GO TO LEN-10.                                            DCCONCBL
01087      IF WORKA (WK-SUB) EQUAL TO "+"                               DCCONCBL
01088          GO TO LEN-20.                                            DCCONCBL
01089      IF WORKA (WK-SUB) EQUAL TO "-"                               DCCONCBL
01090          GO TO LEN-20.                                            DCCONCBL
01091      IF WORKA (WK-SUB) EQUAL TO "C"                               DCCONCBL
01092          GO TO LEN-20.                                            DCCONCBL
01093      IF WORKA (WK-SUB) EQUAL TO "R"                               DCCONCBL
01094          GO TO LEN-20.                                            DCCONCBL
01095      IF WORKA (WK-SUB) EQUAL TO "*"                               DCCONCBL
01096          GO TO LEN-10.                                            DCCONCBL
01097      IF WORKA (WK-SUB) NOT EQUAL TO "D"                           DCCONCBL
01098          GO TO LEN-20.                                            DCCONCBL
01099      ADD 1 TO WK-SUB.                                             DCCONCBL
01100      GO TO LEN-20.                                                DCCONCBL
01101  LEN-10.                                                          DCCONCBL
01102      ADD 1 TO PIC-COUNT.                                          DCCONCBL
01103  LEN-20.                                                          DCCONCBL
01104      GO TO LEN-00.                                                DCCONCBL
01105  LEN-30.                                                             CL**2
01106      SUBTRACT 1 FROM WK-SUB.                                         CL**2
01107      IF WORKA (WK-SUB) EQUAL "9"                                     CL**2
01108          MOVE "N" TO SAVE-USE                                        CL**2
01109      ELSE                                                            CL**2
01110          MOVE "X" TO SAVE-USE.                                       CL**2
01111      ADD 2 TO WK-SUB.                                                CL**2
01112  LEN-50.                                                          DCCONCBL
01113 *    EXTRACT THE NUMERICS FROM A X(100) SITUATION                 DCCONCBL
01114 *    WORKA IS POINTING AFTER ( TO FIRST DIGIT                     DCCONCBL
01115      MOVE WORKA (WK-SUB) TO NUM-1ST.                              DCCONCBL
01116      ADD 1 TO WK-SUB.                                             DCCONCBL
01117      IF WORKA (WK-SUB) EQUAL TO ")"                               DCCONCBL
01118          ADD NUM1 TO PIC-COUNT                                    DCCONCBL
01119          GO TO LEN-55.                                            DCCONCBL
01120      MOVE WORKA (WK-SUB) TO NUM-2ND.                              DCCONCBL
01121      ADD 1 TO WK-SUB.                                             DCCONCBL
01122      IF WORKA (WK-SUB) EQUAL TO ")"                               DCCONCBL
01123          ADD NUM2 TO PIC-COUNT                                    DCCONCBL
01124          GO TO LEN-55.                                            DCCONCBL
01125      MOVE WORKA (WK-SUB) TO NUM-3RD.                              DCCONCBL
01126      ADD 1 TO WK-SUB.                                             DCCONCBL
01127      IF WORKA (WK-SUB) EQUAL TO ")"                               DCCONCBL
01128          ADD NUM3 TO PIC-COUNT                                    DCCONCBL
01129          GO TO LEN-55.                                            DCCONCBL
01130      MOVE WORKA (WK-SUB) TO NUM-4TH.                              DCCONCBL
01131      ADD 1 TO WK-SUB.                                             DCCONCBL
01132      IF WORKA (WK-SUB) EQUAL TO ")"                               DCCONCBL
01133          ADD NUM-WORK4 TO PIC-COUNT                               DCCONCBL
01134          GO TO LEN-55.                                            DCCONCBL
01135      MOVE 9999 TO PIC-COUNT.                                      DCCONCBL
01136      ADD 2 TO WK-SUB.                                             DCCONCBL
01137      GO TO LEN-00.                                                DCCONCBL
01138  LEN-55.                                                          DCCONCBL
01139      GO TO LEN-00.                                                DCCONCBL
01140  LEN-70.                                                          DCCONCBL
01141      IF HOLD-USE EQUAL TO SPACE                                   DCCONCBL
01142          MOVE SAVE-USE TO HOLD-USE                                   CL**2
01143          GO TO LEN-90.                                            DCCONCBL
01144      IF HOLD-USE EQUAL TO "D"                                     DCCONCBL
01145          GO TO LEN-90.                                            DCCONCBL
01146      IF HOLD-USE EQUAL TO "3"                                     DCCONCBL
01147          GO TO LEN-80.                                            DCCONCBL
01148      IF HOLD-USE EQUAL TO "1"                                     DCCONCBL
01149          MOVE 4 TO HOLD-LGHT                                      DCCONCBL
01150          GO TO LEN-XIT.                                           DCCONCBL
01151      IF HOLD-USE EQUAL TO "2"                                     DCCONCBL
01152          MOVE 8 TO HOLD-LGHT                                      DCCONCBL
01153          GO TO LEN-XIT.                                           DCCONCBL
01154 *    ASSUME BINARY                                                DCCONCBL
01155      IF PIC-COUNT GREATER THAN 12                                 DCCONCBL
01156           MOVE 8 TO HOLD-LGHT  GO TO LEN-XIT.                     DCCONCBL
01157      IF PIC-COUNT GREATER THAN 4                                  DCCONCBL
01158          MOVE 4 TO HOLD-LGHT ELSE                                 DCCONCBL
01159          MOVE 2 TO HOLD-LGHT.                                     DCCONCBL
01160          GO TO LEN-XIT.                                           DCCONCBL
01161  LEN-80.                                                          DCCONCBL
01162      ADD 2 TO PIC-COUNT.                                          DCCONCBL
01163      DIVIDE PIC-COUNT BY 2 GIVING PIC-COUNTA.                     DCCONCBL
01164      MOVE PIC-COUNTA TO PIC-COUNT.                                DCCONCBL
01165  LEN-90.                                                          DCCONCBL
01166      MOVE PIC-COUNT TO HOLD-LGHT.                                 DCCONCBL
01167  LEN-XIT. EXIT.                                                   DCCONCBL
01168                                                                    DCCONCB
01169 ******************************************************************DCCONCBL
01170 *                                                                *DCCONCBL
01171 *            W R I T E   E L E M E N T                           *DCCONCBL
01172 *                                                                *DCCONCBL
01173 ******************************************************************DCCONCBL
01174  WRITE-ELM.                                                       DCCONCBL
01175      IF CVT-ELEMENT (SEL-SUB) NOT EQUAL "Y"                          CL**2
01176          MOVE SPACES TO HOLD-ELM                                     CL**2
01177          GO TO WRITE-ELMX.                                           CL**2
01178      PERFORM LENGTH-CALC THRU LEN-XIT.                            DCCONCBL
01179      PERFORM WRITE-SEGS THRU WRITE-SEGSX.                         DCCONCBL
01180      MOVE SPACES TO OUT-BASIC-REC.                                   CL**2
01181      IF DATA-NAME EQUAL TO "FILLER " OR "FILL "                   DCCONCBL
01182      MOVE SPACES TO HOLD-USE                                      DCCONCBL
01183      MOVE SPACES TO HOLD-PIC                                      DCCONCBL
01184      MOVE SPACES TO HOLD-VALUE                                    DCCONCBL
01185      MOVE SPACES TO HOLD-JUST                                     DCCONCBL
01186      MOVE SPACES TO HOLD-SYNC                                        CL**2
01187          GO TO WRITE-ELMX.                                        DCCONCBL
01188  WRITE-ELM10.                                                     DCCONCBL
01189      MOVE "05" TO OUT-ENTRY-TYPE.                                    CL**2
01190      MOVE "0" TO OUT-REC-TYPE.                                       CL**2
01191      MOVE "C" TO OUT-LANG-CODE.                                      CL**2
01192      IF LINE-NO EQUAL 88                                          DCCONCBL
01193          MOVE "1" TO OUT-REC-TYPE                                    CL**2
01194          MOVE 88-VAL-AREA TO OUT-VAL-88                           DCCONCBL
01195          MOVE STRUCT-COUNT TO OUT-STCR                               CL**2
01196      ELSE MOVE CATAL-NAME TO HOLD-88-CATAL-NAME                   DCCONCBL
01197          MOVE CVT-ALIAS-HOLD TO OUT-ALIAS                            CL**2
01198          MOVE CVT-BEGIN-HOLD TO OUT-RENAME-LINE                      CL**2
01199          MOVE PREFIX-OUT TO OUT-PREFIX                               CL**2
01200          MOVE CVT-RENAME-HOLD TO OUT-RENAME                          CL**2
01201          MOVE 9000 TO OUT-STCR                                    DCCONCBL
01202          MOVE HOLD-ELM TO OUT-BASIC.                                 CL**2
01203      MOVE HOLD-88-CATAL-NAME TO OUT-CATNAME.                      DCCONCBL
01204      MOVE DATA-NAME TO OUT-SEGNAME.                               DCCONCBL
01205      IF CVT-ALIAS-HOLD EQUAL "A"                                     CL**2
01206          MOVE CVT-CATNAME-HOLD TO OUT-RENAME.                        CL**2
01207      IF LINE-NO EQUAL 88                                             CL**2
01208          WRITE OUT-88-REC                                            CL**2
01209      ELSE                                                            CL**2
               IF LINE-NO IS EQUAL TO "66"
                 AND HOLD-THRU IS NOT EQUAL TO SPACE
                   MOVE "10" TO OUT-ENTRY-TYPE
               END-IF 
               WRITE OUT-BASIC-REC
               END-IF.
01211      ADD 1 TO STRUCT-COUNT.                                          CL**2
01212      MOVE SPACES TO HOLD-ELM.                                     DCCONCBL
01213  WRITE-ELMX.                                                      DCCONCBL
01214      EXIT.                                                        DCCONCBL
01215                                                                    DCCONCB
01216 ******************************************************************DCCONCBL
01217 *                                                                *DCCONCBL
01218 *            W R I T E   G R O U P                               *DCCONCBL
01219 *                                                                *DCCONCBL
01220 ******************************************************************DCCONCBL
01221  WRITE-GRP.                                                       DCCONCBL
01222      IF CVT-GROUP (SEL-SUB) NOT EQUAL "Y"                            CL**2
01223          GO TO WRITE-GRPX.                                           CL**2
01224      PERFORM WRITE-SEGS THRU WRITE-SEGSX.                         DCCONCBL
01225      MOVE SPACES TO OUT-BASIC-REC.                                   CL**2
01226      MOVE "10" TO OUT-ENTRY-TYPE.                                    CL**2
01227      MOVE "0" TO OUT-REC-TYPE.                                       CL**2
01228      MOVE "C" TO OUT-LANG-CODE.                                      CL**2
01229      MOVE LEVT-NAME (LV-SUB) TO OUT-CATNAME.                      DCCONCBL
01230      MOVE DATA-NAME TO OUT-SEGNAME GRP-DNAME.                     DCCONCBL
01231      IF CVT-ALIAS-HOLD EQUAL "A"                                     CL**2
01232          MOVE CVT-CATNAME-HOLD TO OUT-RENAME                         CL**2
01233      ELSE                                                            CL**2
01234          MOVE CVT-RENAME-HOLD TO OUT-RENAME.                         CL**2
01235      MOVE CVT-ALIAS-HOLD TO OUT-ALIAS.                               CL**2
01236          MOVE CVT-BEGIN-HOLD TO OUT-RENAME-LINE.                     CL**2
01237      MOVE PREFIX-OUT TO OUT-PREFIX.                                  CL**2
01238      MOVE STRUCT-COUNT TO OUT-STCR.                               DCCONCBL
01239      IF HOLD-ELM NOT EQUAL SPACES                                    CL**2
01240          PERFORM LENGTH-CALC THRU LEN-XIT                            CL**2
01241          MOVE HOLD-ELM TO OUT-BASIC                                  CL**2
01242          MOVE SPACES TO HOLD-ELM.                                    CL**2
01243      WRITE OUT-BASIC-REC.                                            CL**2
01244      ADD 1 TO STRUCT-COUNT.                                          CL**2
01245  WRITE-GRPX.                                                      DCCONCBL
01246      EXIT.                                                        DCCONCBL
01247 ******************************************************************DCCONCBL
01248 *                                                                *DCCONCBL
01249 *            W R I T E   G R O U P   S T R U C T U R E           *DCCONCBL
01250 *                                                                *DCCONCBL
01251 ******************************************************************DCCONCBL
01252  WRITE-GRPS.                                                      DCCONCBL
01253      IF CVT-GROUP (SEL-SUB) NOT EQUAL "Y"                            CL**2
01254          GO TO WRITE-GRPSX.                                          CL**2
01255      IF CVT-ELEMENT (SEL-SUB) NOT EQUAL "Y"                          CL**2
01256          GO TO WRITE-GRPSX.                                          CL**2
01257      MOVE SPACES TO OUT-STC-REC.                                     CL**2
01258      MOVE "10" TO OUT-ENTRY-TYPE.                                    CL**2
01261      MOVE CUR-NAME TO OUT-CATNAME.                                DCCONCBL
01262      MOVE GRP-DNAME TO OUT-SEGNAME.                               DCCONCBL
           PERFORM WRITE-GRPS-SEGS THRU WRITE-GRPS-SEGS-EXIT. 
01271  WRITE-GRPSX.                                                     DCCONCBL
01272      EXIT.                                                        DCCONCBL
01273                                                                    DCCONCB
01274 ******************************************************************DCCONCBL
01275 *                                                                *DCCONCBL
01276 *        W R I T E   S E G M E N T   S T R U C T U R E           *DCCONCBL
01277 *                                                                *DCCONCBL
01278 ******************************************************************DCCONCBL
01279  WRITE-SEGS.                                                         CL**2
01280      IF CVT-RECORD (SEL-SUB) NOT EQUAL "Y"                           CL**2
01281          GO TO WRITE-SEGSX.                                          CL**2
01282      MOVE SPACES TO OUT-STC-REC.                                     CL**2
01283      IF LINE-NO EQUAL 88 GO TO WRITE-SEGSX.                       DCCONCBL
           IF LINE-NO IS NOT EQUAL TO HIGH-LINE 
             AND LINE-NO IS NOT EQUAL TO "66" 
               GO TO WRITE-SEGSX. 
01285      MOVE "15" TO OUT-ENTRY-TYPE.                                    CL**2
01288      MOVE SEG-NAME TO OUT-CATNAME.                                DCCONCBL
01289      MOVE SEG-DNAME TO OUT-SEGNAME.                               DCCONCBL
           PERFORM WRITE-GRPS-SEGS THRU WRITE-GRPS-SEGS-EXIT. 
01298  WRITE-SEGSX.                                                     DCCONCBL
01299      EXIT.                                                        DCCONCBL
01300                                                                    DCCONCB
      ******************************************************************
      * 
      *    WRITE-GRPS-SEGS THRU WRITE-GRPS-SEGS-EXIT
      * 
      *    WRITE OUT-STC-REC, OUT-STC-OCCUR-REC, OUT-STC-INDEX-REC, 
      *    AND OUT-STC-KEY-REC FOR GROUP OR RECORD
      * 
      *    ON INPUT 
      *    HOLD-GRP SET UP
      * 
      *    ON OUTPUT
      *    RECORDS WRITTEN TO WRK-FILE
      * 
      ******************************************************************
  
       WRITE-GRPS-SEGS. 
           MOVE "1" TO OUT-REC-TYPE.
           MOVE "C" TO OUT-LANG-CODE. 
           MOVE "1" TO OUT-REC-CODE.
           MOVE CATAL-NAME TO OUT-STCNAME.
           IF CVT-ALIAS-HOLD IS EQUAL TO "A"
             AND CVT-BEGIN-HOLD IS NOT EQUAL TO SPACE 
               MOVE CVT-BEGIN-HOLD TO OUT-STC-ALIAS-NO
               MOVE CVT-CATNAME-HOLD TO OUT-STCNAME 
           END-IF.
           IF CATAL-NAME IS EQUAL TO "FILLER " OR "FILL " 
               MOVE HOLD-LGHT TO FILLER-LENGTH. 
           MOVE HOLD-REDEF TO OUT-REDEF.
           MOVE HOLD-RDALIAS TO OUT-RDALIAS.
           MOVE STRUCT-COUNT TO OUT-STCR. 
           WRITE OUT-STC-REC. 
           ADD 1 TO STRUCT-COUNT. 
           IF HOLD-GRP2 IS NOT EQUAL TO SPACE 
               MOVE "2" TO OUT-REC-CODE 
               MOVE STRUCT-COUNT TO OUT-STCR
               MOVE HOLD-GRP2 TO OUT-STC-GRP2 
               WRITE OUT-STC-OCCUR-REC
               ADD 1 TO STRUCT-COUNT
           END-IF.
           IF INDEX-SUB IS NOT EQUAL TO ZERO
               MOVE "3" TO OUT-REC-CODE 
               PERFORM VARYING TEMP-SUB FROM 1 BY 1 
                 UNTIL TEMP-SUB IS GREATER THAN INDEX-SUB 
                   MOVE STRUCT-COUNT TO OUT-STCR
                   MOVE HOLD-INDEX (TEMP-SUB) TO OUT-INDEX
                   WRITE OUT-STC-INDEX-REC
                   ADD 1 TO STRUCT-COUNT
               END-PERFORM
           END-IF.
           IF KEY-SUB IS NOT EQUAL TO ZERO
               MOVE "4" TO OUT-REC-CODE 
               PERFORM VARYING TEMP-SUB FROM 1 BY 1 
                 UNTIL TEMP-SUB IS GREATER THAN KEY-SUB 
                   MOVE STRUCT-COUNT TO OUT-STCR
                   MOVE HOLD-GRP4 (TEMP-SUB) TO OUT-STC-GRP4
                   WRITE OUT-STC-KEY-REC
                   ADD 1 TO STRUCT-COUNT
               END-PERFORM
           END-IF.
           IF HOLD-GRP5 IS NOT EQUAL TO SPACE 
               MOVE STRUCT-COUNT TO OUT-STCR
               ADD 1 TO STRUCT-COUNT
               MOVE "5" TO OUT-REC-CODE 
               MOVE HOLD-GRP5 TO OUT-STC-GRP5 
               WRITE OUT-STC-RENAMES-REC
           END-IF.
           IF HOLD-GRP6 IS NOT EQUAL TO SPACE 
               MOVE STRUCT-COUNT TO OUT-STCR
               ADD 1 TO STRUCT-COUNT
               MOVE "6" TO OUT-REC-CODE 
               MOVE HOLD-GRP6 TO OUT-STC-GRP6 
               WRITE OUT-STC-THRU-REC 
           END-IF.
       WRITE-GRPS-SEGS-EXIT.
           EXIT.
  
  
  
01301 *****************************************************************    CL**2
01302 *                                                                    CL**2
01303 *     W R I T E   M O D U L E   S T R U C T U R E  R E C O R D       CL**2
01304 *                                                                    CL**2
01305 ******************************************************************   CL**2
01306  WRITE-MODS.                                                         CL**2
01307      IF CVT-PROGRAM (PROG-SUB) NOT EQUAL "Y"                         CL**2
01308          GO TO WRITE-MODSX.                                          CL**2
01309      MOVE SPACES TO OUT-MODSTC-REC.                                  CL**2
01310      MOVE "50" TO OUT-ENTRY-TYPE.                                    CL**2
01311      MOVE "1" TO OUT-REC-TYPE.                                       CL**2
01312      MOVE "C" TO OUT-LANG-CODE.                                      CL**2
01313      MOVE STRUCT-COUNT TO OUT-STCR.                                  CL**2
01314      IF CVT-NEWNAME (PROG-SUB) EQUAL SPACES                          CL**2
01315          MOVE PROG-ID TO OUT-CATNAME                                 CL**2
01316      ELSE                                                            CL**2
01317          MOVE CVT-NEWNAME (PROG-SUB) TO OUT-CATNAME.                 CL**2
01318      MOVE FIL-NAME TO OUT-MOD-STCNAME.                               CL**2
01319      WRITE OUT-MODSTC-REC.                                           CL**2
01320      ADD 1 TO STRUCT-COUNT.                                          CL**2
01321  WRITE-MODSX.                                                        CL**2
01322      EXIT.                                                           CL**2
01323 **************************************************************       CL**2
01324 *                                                                    CL**2
01325 *     W R I T E       F D                                            CL**2
01326 *                                                                    CL**2
01327 ****************************************************************     CL**2
01328  WRITE-FD.                                                           CL**2
01329      IF CVT-FILE (SEL-SUB) NOT EQUAL "Y"                             CL**2
01330          GO TO WRITE-FDX.                                            CL**2
01331      MOVE SPACES TO OUT-FIL-REC.                                     CL**2
01332      MOVE "20" TO OUT-ENTRY-TYPE.                                    CL**2
01333      MOVE "0" TO OUT-REC-TYPE.                                       CL**2
01334      MOVE "C" TO OUT-LANG-CODE.                                      CL**2
01335      MOVE CATAL-NAME TO OUT-CATNAME FIL-NAME.                        CL**2
01336      MOVE PREFIX-OUT TO OUT-PREFIX.                                  CL**2
01337      MOVE STRUCT-COUNT TO OUT-STCR.                                  CL**2
01338      IF CVT-ALIAS-HOLD EQUAL "A"                                     CL**2
01339          MOVE CVT-CATNAME-HOLD TO OUT-RENAME                         CL**2
01340      ELSE                                                            CL**2
01341          MOVE CVT-RENAME-HOLD TO OUT-RENAME.                         CL**2
01342      MOVE CVT-ALIAS-HOLD TO OUT-ALIAS.                               CL**2
01343      MOVE LABELS-HOLD TO OUT-LABELS.                                 CL**2
01344      MOVE MODE-HOLD TO OUT-FORMAT.                                   CL**2
01345      IF RECORD-COUNT NOT EQUAL 0                                     CL**2
01346          MOVE RECORD-COUNT TO OUT-RECSIZE.                           CL**2
01347      IF BLOCK-COUNT NOT EQUAL 0                                      CL**2
01348          MOVE BLOCK-COUNT TO OUT-BLKSIZE.                            CL**2
01349      WRITE OUT-FIL-REC.                                              CL**2
01350      ADD 1 TO STRUCT-COUNT.                                          CL**2
01351  WRITE-FDX.                                                          CL**2
01352      EXIT.                                                           CL**2
01353 *****************************************************************    CL**2
01354 *                                                                    CL**2
01355 *     W R I T E     F I L E     S T R U C T U R E                    CL**2
01356 *                                                                    CL**2
01357 ****************************************************************     CL**2
01358  WRITE-FDS.                                                          CL**2
01359      IF CVT-FILE (SEL-SUB) NOT EQUAL "Y"                             CL**2
01360          GO TO WRITE-FDSX.                                           CL**2
01361      MOVE SPACES TO OUT-FILSTC-REC.                                  CL**2
01362      MOVE "20" TO OUT-ENTRY-TYPE.                                    CL**2
01363      MOVE "1" TO OUT-REC-TYPE.                                       CL**2
01364      MOVE "C" TO OUT-LANG-CODE.                                      CL**2
01365      MOVE FIL-NAME TO OUT-CATNAME.                                   CL**2
01366      MOVE CATAL-NAME TO OUT-FIL-STCNAME.                             CL**2
01367      MOVE STRUCT-COUNT TO OUT-STCR.                                  CL**2
01368      WRITE OUT-FILSTC-REC.                                           CL**2
01369      ADD 1 TO STRUCT-COUNT.                                          CL**2
01370  WRITE-FDSX.                                                         CL**2
01371      EXIT.                                                           CL**2
01372 ****************************************************************     CL**2
01373 *                                                                    CL**2
01374 *     SCAN FD CLAUSE - WRITE FD HEADER AND MODULE STR RECORD         CL**2
01375 *           LOCATE FIRST 01 UNDER FD AND WRITE FD STR RECORD         CL**2
01376 *                                                                    CL**2
01377 ******************************************************************   CL**2
01378  FD-SCAN.                                                            CL**2
01379      MOVE "Y" TO FD-SW.                                              CL**2
01380      MOVE "N" TO CALC-BLK-SW.                                        CL**2
01381      MOVE SPACES TO LABELS-HOLD.                                     CL**2
01382      MOVE SPACES TO MODE-HOLD.                                       CL**2
01383      MOVE ZERO TO RECORD-COUNT BLOCK-COUNT.                          CL**2
01384      PERFORM SPACER THRU SCAN-EXIT.                                  CL**2
01385      GO TO LOCATE-CLAUSE.                                            CL**2
01386  PERIOD-CHECK.                                                       CL**2
01387      IF PER-FOUND EQUAL "."                                          CL**2
01388          MOVE SPACE TO PER-FOUND                                     CL**2
01389          GO TO SCAN-DONE.                                            CL**2
01390      PERFORM SPACER THRU SCAN-EXIT.                                  CL**2
01391  LOCATE-CLAUSE.                                                      CL**2
01392      IF WORK-AREA EQUAL "LABEL"                                      CL**2
01393          GO TO LABEL-PROC.                                           CL**2
01394      IF WORK-AREA EQUAL "BLOCK"                                      CL**2
01395          GO TO BLOCK-PROC.                                           CL**2
01396      IF WORK-AREA EQUAL "RECORD"                                     CL**2
01397          GO TO RECORD-PROC.                                          CL**2
01398      IF WORK-AREA EQUAL "RECORDING"                                  CL**2
01399          GO TO RECORDING-PROC.                                       CL**2
01400      GO TO PERIOD-CHECK.                                             CL**2
01401 ****************************************************************     CL**2
01402 *                                                                    CL**2
01403 *     L A B E L   CLA U S E   P R O C E S S I N G                    CL**2
01404 *                                                                    CL**2
01405 **************************************************************       CL**2
01406  LABEL-PROC.                                                         CL**2
01407      PERFORM SPACER THRU SCAN-EXIT.                                  CL**2
01408      IF WORK-AREA EQUAL "RECORD" OR "RECORDS"                        CL**2
01409          NEXT SENTENCE                                               CL**2
01410      ELSE                                                            CL**2
01411          GO TO LOCATE-CLAUSE.                                        CL**2
01412      PERFORM SPACER THRU SCAN-EXIT.                                  CL**2
01413      IF WORK-AREA EQUAL "IS" OR "ARE"                                CL**2
01414          PERFORM SPACER THRU SCAN-EXIT.                              CL**2
01415      IF WORK-AREA EQUAL "OMITTED"                                    CL**2
01416          MOVE "NL" TO LABELS-HOLD                                    CL**2
01417          GO TO PERIOD-CHECK.                                         CL**2
01418      IF WORK-AREA EQUAL "STANDARD"                                   CL**2
01419          MOVE "SL" TO LABELS-HOLD                                    CL**2
01420          GO TO PERIOD-CHECK.                                         CL**2
01421      MOVE "NSL" TO LABELS-HOLD.                                      CL**2
01422      GO TO PERIOD-CHECK.                                             CL**2
01423 ***************************************************************      CL**2
01424 *                                                                    CL**2
01425 *     R E C O R D   C O N T A I N S   C L A U S E                    CL**2
01426 *                                                                    CL**2
01427 ****************************************************************     CL**2
01428  RECORD-PROC.                                                        CL**2
01429      PERFORM SPACER THRU SCAN-EXIT.                                  CL**2
01430      IF WORK-AREA NOT EQUAL "CONTAINS"                               CL**2
01431          GO TO LOCATE-CLAUSE.                                        CL**2
01432      PERFORM SPACER THRU SCAN-EXIT.                                  CL**2
01433      PERFORM JUSTIFY-RECSIZE THRU JUSTIFY-RECSIZE-XIT.               CL**2
01434  RECORD-PROC10.                                                      CL**2
01435      IF PER-FOUND EQUAL "."                                          CL**2
01436          MOVE SPACE TO PER-FOUND                                     CL**2
01437          GO TO SCAN-DONE.                                            CL**2
01438      PERFORM SPACER THRU SCAN-EXIT.                                  CL**2
01439      IF WORK-AREA EQUAL "CHARACTERS"                                 CL**2
01440          GO TO PERIOD-CHECK.                                         CL**2
01441      IF WORK-AREA NOT EQUAL "TO"                                     CL**2
01442          GO TO LOCATE-CLAUSE.                                        CL**2
01443      PERFORM SPACER THRU SCAN-EXIT.                                  CL**2
01444      PERFORM JUSTIFY-RECSIZE THRU JUSTIFY-RECSIZE-XIT.               CL**2
01445      GO TO RECORD-PROC10.                                            CL**2
01446 ******************************************************************   CL**2
01447 *                                                                    CL**2
01448 *     R E C O R D I N G   M O D E   C L A U S E                      CL**2
01449 *                                                                    CL**2
01450 *****************************************************************    CL**2
01451  RECORDING-PROC.                                                     CL**2
01452      PERFORM SPACER THRU SCAN-EXIT.                                  CL**2
01453      IF WORK-AREA EQUAL "MODE"                                       CL**2
01454          PERFORM SPACER THRU SCAN-EXIT.                              CL**2
01455      IF WORK-AREA EQUAL "IS"                                         CL**2
01456          PERFORM SPACER THRU SCAN-EXIT.                              CL**2
01457      MOVE WORK-AREA TO MODE-HOLD.                                    CL**2
01458      GO TO PERIOD-CHECK.                                             CL**2
01459 *****************************************************************    CL**2
01460 *                                                                    CL**2
01461 *     B L O C K   C O N T A I N S   C L A U S E                      CL**2
01462 *                                                                    CL**2
01463 ****************************************************************     CL**2
01464  BLOCK-PROC.                                                         CL**2
01465      PERFORM SPACER THRU SCAN-EXIT.                                  CL**2
01466      IF WORK-AREA EQUAL "CONTAINS"                                   CL**2
01467          PERFORM SPACER THRU SCAN-EXIT.                              CL**2
01468      PERFORM JUSTIFY-BLKSIZE THRU JUSTIFY-BLKSIZE-XIT.               CL**2
01469  BLOCK-PROC10.                                                       CL**2
01470      IF PER-FOUND EQUAL "."                                          CL**2
01471          MOVE SPACE TO PER-FOUND                                     CL**2
01472          GO TO SCAN-DONE.                                            CL**2
01473      PERFORM SPACER THRU SCAN-EXIT.                                  CL**2
01474      IF WORK-AREA EQUAL "CHARACTERS"                                 CL**2
01475          GO TO PERIOD-CHECK.                                         CL**2
01476      IF WORK-AREA EQUAL "RECORDS"                                    CL**2
01477          MOVE "Y" TO CALC-BLK-SW                                     CL**2
01478          GO TO PERIOD-CHECK.                                         CL**2
01479      IF WORK-AREA NOT EQUAL "TO"                                     CL**2
01480          GO TO LOCATE-CLAUSE.                                        CL**2
01481      PERFORM SPACER THRU SCAN-EXIT.                                  CL**2
01482      PERFORM JUSTIFY-BLKSIZE THRU JUSTIFY-BLKSIZE-XIT.               CL**2
01483      GO TO BLOCK-PROC10.                                             CL**2
01484 ***********************************************************          CL**2
01485 *     SCANNING COMPLETED - COMPUTE BLOCKSIZE IF NECESSARY            CL**2
01486 ****************************************************************     CL**2
01487  SCAN-DONE.                                                          CL**2
01488      IF CALC-BLK-SW EQUAL "Y"                                        CL**2
01489          MOVE "N" TO CALC-BLK-SW                                     CL**2
01490          MULTIPLY RECORD-COUNT BY BLOCK-COUNT.                       CL**2
01491      PERFORM WRITE-FD THRU WRITE-FDX.                                CL**2
01492  LOCATE-01.                                                          CL**2
01493      PERFORM READ-COBOL THRU READ-COBOL-XIT.                         CL**2
01494      MOVE SPACES TO LINE1.                                           CL**2
01495      MOVE COBOL-IN TO LINE1C.                                        CL**2
01496      MOVE LINE1 TO STD-REPORT-REC.                                   CL**2
01497      PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                     CL**2
01498      MOVE 1 TO IN-SUB.                                               CL**2
01499      PERFORM SPACER THRU SCAN-EXIT.                                  CL**2
01500      IF WORK-AREA NOT EQUAL "01"                                     CL**2
01501          GO TO LOCATE-01.                                            CL**2
01502      PERFORM SPACER THRU SCAN-EXIT.                                  CL**2
01503      MOVE WORK-AREA TO DATA-NAME.                                    CL**2
01504      MOVE "01" TO LEVEL-NO.                                          CL**2
01505      PERFORM RENAME THRU RENAME-XIT.                                 CL**2
01506      PERFORM PREFIX THRU PREFIX-XIT.                                 CL**2
01507      PERFORM WRITE-FDS THRU WRITE-FDSX.                              CL**2
01508  FD-SCAN-XIT.                                                        CL**2
01509      EXIT.                                                           CL**2
01510  JUSTIFY-RECSIZE.                                                    CL**2
01511      IF WORKA (WK-SUB) EQUAL SPACES                                  CL**2
01512          SUBTRACT 1 FROM WK-SUB.                                     CL**2
01513      MOVE 5 TO SUBX.                                                 CL**2
01514      MOVE ZERO TO RECORD-COUNT.                                      CL**2
01515  MOVE-REC.                                                           CL**2
01516      IF SUBX EQUAL 0                                                 CL**2
01517          GO TO JUSTIFY-RECSIZE-XIT.                                  CL**2
01518      MOVE WORKA (WK-SUB) TO REC-COUNT (SUBX).                        CL**2
01519      SUBTRACT 1 FROM SUBX WK-SUB.                                    CL**2
01520      IF WK-SUB NOT EQUAL 0                                           CL**2
01521          GO TO MOVE-REC.                                             CL**2
01522  JUSTIFY-RECSIZE-XIT.                                                CL**2
01523      EXIT.                                                           CL**2
01524  JUSTIFY-BLKSIZE.                                                    CL**2
01525      IF WORKA (WK-SUB) EQUAL SPACES                                  CL**2
01526          SUBTRACT 1 FROM WK-SUB.                                     CL**2
01527      MOVE 5 TO SUBX.                                                 CL**2
01528      MOVE ZERO TO BLOCK-COUNT.                                       CL**2
01529  MOVE-BLK.                                                           CL**2
01530      IF SUBX EQUAL 0                                                 CL**2
01531          GO TO JUSTIFY-BLKSIZE-XIT.                                  CL**2
01532      MOVE WORKA (WK-SUB) TO BLK-COUNT (SUBX).                        CL**2
01533       SUBTRACT 1 FROM SUBX WK-SUB.                                   CL**2
01534       IF WK-SUB NOT EQUAL 0                                          CL**2
01535          GO TO MOVE-BLK.                                             CL**2
01536  JUSTIFY-BLKSIZE-XIT.                                                CL**2
01537      EXIT.                                                           CL**2
01538 ******************************************************************DCCONCBL
01539 *                                                                *DCCONCBL
01540 *            S P A C E R - P A S S   B L A N K S                 *DCCONCBL
01541 *                                                                *DCCONCBL
01542 ******************************************************************DCCONCBL
01543  SPACER.                                                          DCCONCBL
01544      IF COB-LINE (IN-SUB) IS NOT EQUAL TO SPACE                   DCCONCBL
01545          GO TO SPACER-EXIT.                                       DCCONCBL
01546      ADD 1 TO IN-SUB.                                             DCCONCBL
01547      IF IN-SUB LESS THAN 66 GO TO SPACER.                         DCCONCBL
01548      PERFORM READ-COBOL THRU READ-COBOL-XIT.                      DCCONCBL
01549      IF SEG-FOUND EQUAL TO "Y"                                    DCCONCBL
01550          MOVE SPACES TO LINE1                                        CL**2
01551          MOVE COBOL-IN TO LINE1C                                     CL**2
01552          MOVE LINE1 TO STD-REPORT-REC                                CL**2
01553          PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                 CL**2
01554      MOVE 1 TO IN-SUB.                                            DCCONCBL
01555      GO TO SPACER.                                                DCCONCBL
01556  SPACER-EXIT.                                                     DCCONCBL
01557      EXIT.                                                        DCCONCBL
01558 ******************************************************************DCCONCBL
01559 *                                                                *DCCONCBL
01560 *            S C A N  -  M O V E  N O N  B L A N K S             *DCCONCBL
01561 *                                                                *DCCONCBL
01562 ******************************************************************DCCONCBL
01563  SCAN.                                                            DCCONCBL
01564      MOVE 1 TO WK-SUB.                                            DCCONCBL
01565      MOVE SPACES TO WORK-AREA.                                    DCCONCBL
01566  SCAN-LOOP.                                                       DCCONCBL
01567      IF COB-LINE (IN-SUB) EQUAL TO SPACE GO TO SCAN-END.             CL**2
01568      IF COB-LINE (IN-SUB) NOT EQUAL "."                           DCCONCBL
01569          GO TO SCAN-10.                                           DCCONCBL
01570      IF IN-SUB EQUAL TO 65                                        DCCONCBL
01571          MOVE "." TO PER-FOUND                                    DCCONCBL
01572          GO TO SCAN-EXIT.                                         DCCONCBL
01573      ADD 1 TO IN-SUB.                                             DCCONCBL
01574      IF COB-LINE (IN-SUB) EQUAL TO SPACE                          DCCONCBL
01575          MOVE "." TO PER-FOUND                                    DCCONCBL
01576          GO TO SCAN-EXIT.                                         DCCONCBL
01577      SUBTRACT 1 FROM IN-SUB.                                      DCCONCBL
01578  SCAN-10.                                                         DCCONCBL
01579 *    THE FOLLOWING CODE IS USED ONLY FOR VALUE PROCESSING         DCCONCBL
01580 *    SCAN-30 IS THE END                                           DCCONCBL
01581      IF COB-LINE (IN-SUB) NOT EQUAL TO QUOTE                      DCCONCBL
01582          GO TO SCAN-30.                                           DCCONCBL
01583      ADD 1 TO IN-SUB.                                             DCCONCBL
01584  SCAN-20.                                                         DCCONCBL
01585      MOVE COB-LINE (IN-SUB) TO WORKA (WK-SUB).                    DCCONCBL
01586      ADD 1 TO IN-SUB WK-SUB.                                      DCCONCBL
01587      IF IN-SUB GREATER THAN 65 GO TO SCAN-EXIT.                   DCCONCBL
01588      IF WK-SUB GREATER THAN 40 GO TO SCAN-EXIT.                      CL**2
01589      IF COB-LINE (IN-SUB) EQUAL TO QUOTE                          DCCONCBL
01590          ADD 1 TO IN-SUB                                          DCCONCBL
01591          GO TO SCAN-END.                                             CL**2
01592      GO TO SCAN-20.                                               DCCONCBL
01593  SCAN-30.                                                         DCCONCBL
01594      MOVE COB-LINE (IN-SUB) TO WORKA (WK-SUB).                    DCCONCBL
01595      ADD 1 TO IN-SUB                                              DCCONCBL
01596      IF IN-SUB GREATER THAN 65 GO TO SCAN-END.                       CL**2
01597      ADD 1 TO WK-SUB.                                             DCCONCBL
01598      GO TO SCAN-LOOP.                                             DCCONCBL
01599  SCAN-END.                                                           CL**2
01600      IF COB-LINE (IN-SUB) EQUAL ","                                  CL**2
01601          ADD 1 TO IN-SUB                                             CL**2
01602          GO TO SCAN-EXIT.                                            CL**2
01603      SUBTRACT 1 FROM WK-SUB.                                         CL**2
01604      IF WORKA (WK-SUB) EQUAL ","                                     CL**2
01605          MOVE SPACE TO WORKA (WK-SUB)                                CL**2
01606          GO TO SCAN-EXIT.                                            CL**2
01607      ADD 1 TO WK-SUB.                                                CL**2
01608  SCAN-EXIT.                                                       DCCONCBL
01609      EXIT.                                                        DCCONCBL
01610                                                                    DCCONCB
01611 ******************************************************************DCCONCBL
01612 *                                                                 DCCONCBL
01613 *    GROUP CASCADE ROUTINE                                        DCCONCBL
01614 *                                                                 DCCONCBL
01615 ******************************************************************DCCONCBL
01616  GROUP-CASCADE.                                                   DCCONCBL
01617      IF HOLD-USE EQUAL SPACES                                     DCCONCBL
01618          MOVE LEVT-USE (LV-SUB) TO HOLD-USE.                      DCCONCBL
01619      IF HOLD-PIC EQUAL SPACES                                     DCCONCBL
01620          MOVE LEVT-PIC (LV-SUB) TO HOLD-PIC.                      DCCONCBL
01621      IF HOLD-VALUE EQUAL SPACES                                   DCCONCBL
01622          MOVE LEVT-VALUE (LV-SUB) TO HOLD-VALUE.                  DCCONCBL
01623      IF HOLD-JUST EQUAL SPACES                                    DCCONCBL
01624          MOVE LEVT-JUST (LV-SUB) TO HOLD-JUST.                    DCCONCBL
01625      IF HOLD-SYNC EQUAL SPACES                                       CL**2
01626          MOVE LEVT-SYNC (LV-SUB) TO HOLD-SYNC.                       CL**2
01627  GROUP-CASCADE-XIT.                                                  CL**2
01628      EXIT.                                                           CL**2
*CALL     DISPLAYLN                                                        CL**2
*CALL     WRITELN                                                          CL**2
01631  USER-ROUTINE.                                                       CL**2
01632       GO TO USER-ROUTINE-XIT.                                        CL**2
01633  USER-ROUTINE-XIT.                                                   CL**2
01634       EXIT.                                                          CL**2
01635                                                                    DCCONCB
01636  READ-COBOL.                                                      DCCONCBL
01637      READ COBOL-FILE AT END                                          CL**2
01638          MOVE "E" TO END-SW                                          CL**2
01639          GO TO READ-COBOL-XIT.                                       CL**2
01640      MOVE UNLABEL-COB TO COBOL-IN.                                   CL**2
01641      IF COB-PROC EQUAL "PROCEDURE DIVISION"                          CL**2
01642          MOVE "R" TO RESET-SW.                                       CL**2
01643      IF COB-ID-DIV EQUAL "IDENTIFICATION DIVISION"                   CL**2
01644          MOVE "R" TO RESET-SW.                                       CL**2
01645      IF COB-ID-DIV EQUAL "ID DIVISION."                              CL**2
01646          MOVE "R" TO RESET-SW.                                       CL**2
           IF COB-ID-DIV EQUAL "COMMON-STORAGE SECTION."
              AND FD-SW EQUAL "Y"  MOVE "R" TO RESET-SW.
           IF COB-ID-DIV EQUAL "WORKING-STORAGE SECTION"
              AND FD-SW EQUAL "Y"  MOVE "R" TO RESET-SW.
01647  READ-COBOL-XIT.                                                     CL**2
01648 *****************************************************************    CL**2
01649 *     TABLES A TOTAL OF 50 COMMENT LINES                             CL**2
01650 *****************************************************************    CL**2
01651  TABLE-NOTES.                                                        CL**2
01652      IF CVT-NOTES-OPT (PROG-SUB) NOT EQUAL "Y"                       CL**2
01653          GO TO TABLE-NOTES-XIT.                                      CL**2
01654      IF COMMENT-TABLE EQUAL SPACES                                   CL**2
01655          MOVE 1 TO COM-SUB.                                          CL**2
01656      IF COM-SUB GREATER 50                                           CL**2
01657          GO TO TABLE-NOTES-XIT.                                      CL**2
01658      MOVE COBOL-IN TO COM-LINE (COM-SUB).                            CL**2
01659      ADD 1 TO COM-SUB.                                               CL**2
01660  TABLE-NOTES-XIT.                                                    CL**2
01661      EXIT.                                                           CL**2
01662 *****************************************************************    CL**2
01663 *                                                                    CL**2
01664 *     COMMENT LINES ARE TAKEN FROM THE TABLE AND                     CL**2
01665 *          FORMATTED AS EITHER RECORD STRUCTURE RECORDS              CL**2
01666 *          OR GROUP STRUCTURE RECORDS                                CL**2
01667 *                                                                    CL**2
01668 *****************************************************************    CL**2
01669  WRITE-COMMENTS.                                                     CL**2
01670      IF CVT-NOTES-OPT (PROG-SUB) NOT EQUAL "Y"                       CL**2
01671          GO TO WRITE-COMMENTS-XIT.                                   CL**2
01672      IF COMMENT-TABLE EQUAL SPACES                                   CL**2
01673          GO TO WRITE-COMMENTS-XIT.                                   CL**2
01674      IF COM-SW EQUAL "G"                                             CL**2
01675          GO TO TEST-GROUPS.                                          CL**2
01676      IF CVT-RECORD (SEL-SUB) NOT EQUAL "Y"                           CL**2
01677          GO TO NO-COMMENTS.                                          CL**2
01678      MOVE 1 TO COM-SUB.                                              CL**2
01679      GO TO SET-UP-KEY.                                               CL**2
01680  TEST-GROUPS.                                                        CL**2
01681      IF CVT-GROUP (SEL-SUB) NOT EQUAL "Y"                            CL**2
01682          GO TO NO-COMMENTS.                                          CL**2
01683      MOVE 1 TO COM-SUB.                                              CL**2
01684  SET-UP-KEY.                                                         CL**2
01685      MOVE SPACES TO OUT-COMMENT-REC.                                 CL**2
01686      IF COM-SW EQUAL "R"                                             CL**2
01687          MOVE "15" TO OUT-ENTRY-TYPE                                 CL**2
01688          MOVE SEG-NAME TO OUT-CATNAME                                CL**2
01689          MOVE SEG-DNAME TO OUT-SEGNAME                               CL**2
01690      ELSE                                                            CL**2
01691          MOVE "10" TO OUT-ENTRY-TYPE                                 CL**2
01692          MOVE LEVT-NAME (LV-SUB) TO OUT-CATNAME                      CL**2
01693          MOVE GRP-DNAME TO OUT-SEGNAME.                              CL**2
01694      IF COM-SUB GREATER THAN 50                                      CL**2
01695          GO TO WRITE-COMMENTS-XIT.                                   CL**2
01696      IF COM-LINE (COM-SUB) EQUAL SPACES                              CL**2
01697          MOVE SPACES TO COMMENT-TABLE                                CL**2
01698          GO TO WRITE-COMMENTS-XIT.                                   CL**2
01699 *                                                                    CL**2
01700 *     PRINT COMMENT                                                  CL**2
01701 *                                                                    CL**2
01702      MOVE SPACES TO LINE1                                            CL**2
01703      MOVE COM-LINE (COM-SUB) TO LINE1C.                              CL**2
01704      MOVE LINE1 TO STD-REPORT-REC.                                   CL**2
01705      PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                     CL**2
01706 *                                                                    CL**2
01707 *     WRITE RECORD                                                   CL**2
01708 *                                                                    CL**2
01709      MOVE COM-LINE (COM-SUB) TO OUT-COMMENT.                         CL**2
01710      MOVE 1 TO OUT-REC-TYPE.                                         CL**2
01711      MOVE "C" TO OUT-LANG-CODE.                                      CL**2
01712      MOVE STRUCT-COUNT TO OUT-STCR.                                  CL**2
01713      WRITE OUT-COMMENT-REC.                                          CL**2
01714      ADD 1 TO STRUCT-COUNT.                                          CL**2
01715      ADD 1 TO COM-SUB.                                               CL**2
01716          GO TO SET-UP-KEY.                                           CL**2
01717  NO-COMMENTS.                                                        CL**2
01718      MOVE SPACES TO COMMENT-TABLE.                                   CL**2
01719  WRITE-COMMENTS-XIT.                                                 CL**2
01720      EXIT.                                                           CL**2
01721  COBOL-END.                                                       DCCONCBL
01722      PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                     CL**2
01723      PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                     CL**2
01724      MOVE 1 TO PROG-SUB.                                             CL**2
01725  COBOL-END10.                                                     DCCONCBL
01726      IF CVT-MOD-FND (PROG-SUB) EQUAL TO "X"                          CL**2
01727          GO TO COBOL-END20.                                       DCCONCBL
01728      MOVE CVT-PROG-NAME (PROG-SUB) TO PROG-NOT-FOUND.                CL**2
01729      MOVE NOT-FOUND-MSG TO STD-REPORT-REC.                           CL**2
01730      MOVE 8 TO RETURN-CODE.                                          CL**2
01731      PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                     CL**2
01732      PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                     CL**2
01733  COBOL-END20.                                                     DCCONCBL
01734      ADD 1 TO PROG-SUB.                                              CL**2
01735      IF PROG-SUB NOT GREATER THAN PROG-SUB-HI                        CL**2
01736          GO TO COBOL-END10.                                       DCCONCBL
01737      PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                     CL**2
01738      MOVE END-REPORT-MSG TO STD-REPORT-REC.                          CL**2
01739      PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                     CL**2
01740      CLOSE WORK-FILE.                                             DCCONCBL
01741      CLOSE COBOL-FILE.                                               CL**2
01742      CLOSE SYSPRINT.                                                 CL**2
           EXIT PROGRAM.
