*DECK C5TDMP
USETEXT CCTTEXT 
USETEXT DNTEXT
#* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * #
#                                                                      #
#                             C 5 T D M P                              #
#                                                                      #
#                                                                      #
#                       TERMINAL DUMP ANALYZER                         #
#                                                                      #
#     GIVEN -                                                          #
#                                                                      #
#         CALLING SEQUENCE:   C5TDMP,P1,P2,P3,P4.                      #
#                                                                      #
#                ALL PARAMETERS ARE OPTIONAL:                          #
#                                                                      #
#                T            COMPILER INFORMATION FILE NAME           #
#                OMITTED      INFORMATION IS OBTAINED FROM FILE TDFILE #
#                T=LFN        INFORMATION IS OBTAINED FROM FILE LFN    #
#                L            DUMP LISTING FILE NAME                   #
#                OMITTED      LISTING IS WRITTEN ON FILE OUTPUT        #
#                L=LFN        LISTING IS WRITTEN ON FILE LFN           #
#                I            DIRECTIVES FILE NAME                     #
#                OMITTED      THERE ARE NO DIRECTIVES                  #
#                I            DIRECTIVES ARE OBTAINED FROM FILE INPUT  #
#                I=LFN        DIRECTIVES ARE OBTAINED FROM FILE LFN    #
#                NA           NO ARRAYS DUMPED                         #
#                OMITTED      ALL ARRAY ARE TO BE DUMPED ON LISTNG FILE#
#                NA           NO ARRAYS ARE TO BE DUMPED ON LISTNG FILE#
#                                                                      #
#         FILES READ:                                                  #
#                                                                      #
#                INPUT    (FROM -I- OPTION ON CONTROL CARD)            #
#                TDFILE   (FROM -T- OPTION ON CONTROL CARD)            #
#                ZZZZZ4P                                               #
#                                                                      #
#* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * #
          PRGM C5TDMP;
  
          BEGIN 
  
#     GLOBAL DEFINITIONS.                                              #
  
          DEF    CARD$SIZE    #80#;    # INPUT DIRECTIVES RECORD SIZE  #
          DEF    COMBLKTYPE   #3#;     # COMMON BLOCK PGMTYPE          #
          DEF    DIRECTVFNAME #"INPUT     "#; 
          DEF    LISTFNAME    #"OUTPUT    "#; 
          DEF    LISTMSGLEN   #80#;    # MESSAGES TO LIST FILE LENGTH  #
          DEF    LIST$ENTSZ   #4#;
          DEF    NONPROGTYPE  #0#;     # NON PGM TYPE IN PGMTYPE       #
          DEF    PAGESIZE     #58#; 
          DEF    PGMBLKTYPE   #1#;     # MAIN PGM BLOCK PGMTYPE        #
          DEF    SUBPGMBLKTYP #2#;     # SUB-PGM BLOCK PGMTYE          #
          DEF    TDFNAME      #"TDFILE    "#; 
          DEF    ZZFNAME      #"ZZZZZ4P   "#; 
  
#     TOKEN$TYPE VALUES                                                #
  
          DEF    DATANAME$VAL #1#;
          DEF    NUMBER$VAL   #2#;
          DEF    SELECT$VAL   #3#;
          DEF    EXCEPT$VAL   #4#;
          DEF    OCCURS$VAL   #5#;
          DEF    TO$VAL       #6#;
          DEF    OF$VAL       #7#;
  
          DEF    ADJTHISSCRPT(PTR,OCC)
              #IF SCRPLVL GR 1 AND
                (OCC/SCRPKEYOCCNO[SCRPLVL])*SCRPKEYOCCNO[SCRPLVL] EQ OCC
               THEN 
                   PTR = PTR + SCRPEXLEN[SCRPLVL-1];
                   BEGIN
                   ADJSCRPPTS(PTR,OCC); 
                   END                                             I=I#;
  
          DEF    DNTNAME1    # NAMET$CHARS[DNTNAMETPTR[TABORD]] #;
          DEF    DNTNAME2    # NAMET$CHARS[DNTNAMETPTR[TABORD]+1] #;
          DEF    DNTNAME3    # NAMET$CHARS[DNTNAMETPTR[TABORD]+2] #;
  
  
          DEF   WRTANYDUPS(LST) 
             #IF LST GR 1 AND DUPLICATES
              THEN
                  BEGIN 
                  DUPLICATES = FALSE; 
                  CHKFORDUPS = FALSE; 
                  TENCHARS[0] = CDD(OCCURSLOW); 
                  OCCLOW[0] = C<4,6>TENCHARS[0];
                  TENCHARS[0] = CDD(OCCURSHIGH);
                  OCCHIGH[0] = C<4,6>TENCHARS[0]; 
                  WRITELINE(SAMELINE,7,0);
                  END#; 
  
  
#     GLOBAL ITEMS.                                                    #
  
          ITEM   BITLENGTH; 
          ITEM   BLANKS       C(10) = "          "; 
          ITEM   CARD         C(CARD$SIZE); 
          ITEM   CCTPTR       I;
          ITEM   CHARSCRITEM  C(40);
          ITEM   CHKFORDUPS   B = FALSE;
          ITEM   COMP1TMP     C(20);
          ITEM   DIRECTIVES   B = FALSE;
          ITEM   DIRFN        C(10) = DIRECTVFNAME; 
          ITEM   DUMPNAMES; 
          ITEM   DUPLICATES   B = FALSE;
          ITEM   EOINPUT      B = FALSE;
          ITEM   EXCEPTSEEN   B = FALSE;
          ITEM   FIRST        B;
          ITEM   FIRSTDIR     B = TRUE; 
          ITEM   I            I;
          ITEM   IOSTAT       I;
          ITEM   J            I;
          ITEM   LINECT       I;
          ITEM   LASTLINE$NO; 
          ITEM   LIMITEDARRAY B = FALSE;
          ITEM   LINKPTR      U;
          ITEM   LISTPOINTER  U;
          ITEM   LISTSIZE     U = 0;
          ITEM   LSTFN        C(10) = LISTFNAME;
          ITEM   NEWPAGE      I = 1;
          ITEM   NOIODONE     C(20) = " NO I/O DONE.       "; 
          ITEM   NWDS;
          ITEM   OCCURENCEFLG B = FALSE;
          ITEM   OCCURSHIGH   U;
          ITEM   OCCURSLOW    U;
          ITEM   OMITARRAYS   B = FALSE;
          ITEM   PARATRACE    C(40) = 
                             " --------- PARAGRAPH TRACE-BACK --------";
          ITEM   PASTLINE     C(100); 
          ITEM   PGMCOUNT     I = 0;
          ITEM   PGMPTR       I = 0;
          ITEM   PSAVE; 
          ITEM   RACOUNT      I;
          ITEM   SELECTSEEN   B = FALSE;
          ITEM   SCRPINIT     I;
          ITEM   SCRPLEN      I;
          ITEM   SCRPLVL      I;
          ITEM   SCRPMAX      I;
          ITEM   SEVENS         = O"77777777777777777777";
          ITEM   TABORD       I;
          ITEM   TDFN         C(10) = TDFNAME;
          ITEM   TKNSIZE      U;
          ITEM   TKNTYPE      U;
          ITEM   TOKEN        C(30);
          ITEM   TRAILER1     C(140) =
                     "                                    CHAR     1
     2         3         4         5         6         7         8
   9         0";
          ITEM   TRAILER2     C(140) =
                     "                                    12345678901234
567890123456789012345678901234567890123456789012345678901234567890123456
78901234567890";
          ITEM   TSTRING      C(200); 
          ITEM   T1 I, T2 I, T3 I, T4 I, T5 I;   # TEMP CELLS          #
          ITEM   T6 I, T7 I, T8 I, T9 I, T10 I;  # TEMP CELLS          #
          ITEM   ZEROS        U = 0;
          ITEM   ZZFN         C(10) = ZZFNAME;
  
#     ERROR MESSAGE ITEMS                                              #
  
          ITEM   ERRBADEXCEPT C(LISTMSGLEN) = " *** SELECT DIRECTIVE ALR
EADY SEEN, EXCEPT DIRECTIVES IGNORED.********          "; 
          ITEM   ERRBADNAME   C(LISTMSGLEN) = " *** DATA-NAME BEFORE ANY
 DIRECTIVES, IGNORED.****                              "; 
          ITEM   ERRBADSELECT C(LISTMSGLEN) = " *** EXCEPT DIRECTIVE ALR
EADY SEEN, SELECT DIRECTIVES IGNORED.********          "; 
          ITEM   ERRMISNAME   C(LISTMSGLEN) = " *** DATA-NAME MISSING FR
OM OCURRENCE DIRECTIVE.  DIRECTIVE IGNORED.**          "; 
          ITEM   ERRMISNGLIT  C(LISTMSGLEN) = " *** FIRST INTEGER IN OCC
URRENCES DIRECTIVE MISSING, DIRECTIVE IGNORED.*********"; 
          ITEM   ERRMIS2NDLIT C(LISTMSGLEN) = " *** AN INTEGER MUST FOLL
OW TO IN THE OCCURENCES DIRECTIVE, DIRECTIVE IGNORED.**"; 
          ITEM   ERRNUMGRTEN  C(LISTMSGLEN) = " *** OCCURRENCES DIRECTIV
E INTEGER TRUNCATED ON RIGHT AFTER 10TH DIGIT.*********"; 
          ITEM   ERROVER30DN  C(LISTMSGLEN) = " *** DATA-NAME MORE THAN 
30 CHARACTERS LONG, ONLY LEFT MOST 30 CHARACTERS USED.*"; 
          ITEM   ERRBADPARAM  C(40) = 
                             " UNRECOGNIZABLE PARAM ON C5TDMP CARD    ";
          ITEM   ERRFORMAT    C(40) = 
                             " FORMAT ERROR ON C5TDMP CARD            ";
          ITEM   ERRNODIRCTVS C(40) = 
                             " EMPTY DIRECTIVES FILE                  ";
          ITEM   ERRTDFN1     C(40) = 
                             " C5TDMP - PREMATURE EOR ON              ";
          ITEM   ERRZZFN1     C(40) = 
                             " C5TDMP - PREMATURE EOR ON ZZZZZ4P      ";
  
  
#     GLOBAL ARRAYS.                                                   #
  
          ARRAY CHARSCR;
              BEGIN 
              ITEM   TENCHARS     C(0,0,10);
              END 
  
          ARRAY  DATATYCODES[1:20]; 
              BEGIN 
              ITEM   DATATYC      C(0,0,3) =
                                 ["AL ","ALE","AN ","ANE","ERR","NE ",
                                  "CP ","EF ","CP4","CP2","DC2","CP1",
                                  "LC ","ID ","IN ",,,,"BIT","BL "];
              END 
  
          ARRAY DILINE S(14); 
              BEGIN 
              ITEM   DIFULL       C(0,0,140) = [" "]; 
              ITEM   DINAME       C(0,6,30);
              ITEM   DIOCCN       C(0,0,12);
              ITEM   DIDIRLINE    C(0,6,CARD$SIZE); 
              ITEM   DIOCCV       C(1,12,6);
              ITEM   DIPLUS       C(2,48,7);
              ITEM   DITYPE       C(3,12,3);
              ITEM   DIVALUE      C(3,36,100);
              END 
  
          ARRAY DUMPCTL;
              BEGIN 
              ITEM  PLENGTH       (0,24,18);
              ITEM  LASTIOLINE    (0,42,18);
              ITEM  PPTR          (0,42,18);
              ITEM  SNAPLENGTH    (0,42,18);
              ITEM  DUMPCTLWORD   (0,0,60); 
              END 
  
          ARRAY LASTI$OLINE S(3); 
              BEGIN 
              ITEM  LASTIOTEXT   C(0,0,20) = [" LAST I/O STATEMENT "];
              ITEM  LASTIONO     C(2,0,10) = [" "]; 
              END 
  
          ARRAY LAST$LINE S(3); 
              BEGIN 
              ITEM  LASTLNTEXT   C(0,0,20) = [" LAST LINE EXECUTED "];
              ITEM  LASTLNNO     C(2,0,10) = [" "]; 
              END 
  
          ARRAY PNAMES [1:10] S(3); 
              ITEM   PARAGRAPH    C(0,0,30);
  
          ARRAY PGMHDR1 S(8); 
              BEGIN 
              ITEM   PGMH1A       C(0,0,40) = 
                          [" --------- P R O G R A M - I D -------- "]; 
              ITEM   PGMH1B       C(4,0,40) =[" "]; 
              END 
  
          ARRAY PGMHDR2 S(5); 
              BEGIN 
              ITEM   PGMH2A       C(0,0,30) = 
                                 [" DATA NAME                    "];
              ITEM   PGMH2B       C(3,0,10) = [" TYPE     "]; 
              ITEM   PGMH2C       C(4,0,10) = ["CONTENTS  "]; 
              END 
  
          ARRAY SAMELINE S(7);
              BEGIN 
              ITEM  SAMEWORDS    C(0, 0,70);
              ITEM  OCCN         C(0, 0,14) = ["  OCCURRENCES "]; 
              ITEM  OCCLOW       C(1,24, 6) = [" "];
              ITEM  OCCTO        C(2, 0, 4) = [" TO "]; 
              ITEM  OCCHIGH      C(2,24, 6) = [" "];
              ITEM  OCCDUP       C(3, 0,40) = 
                          [" ARE DUPLICATES OF PREVIOUS OCCURRENCE. "]; 
              END 
  
          ARRAY SNAPLITLINE S(5); 
              BEGIN 
              ITEM  SNAPLINEHDR  C(0,0,20) = [" SNAP DUMP -        "];
              ITEM  SNAPLITERAL  C(2,0,30) = [" "]; 
              END 
  
          ARRAY SCRP [1:49] S(2); 
              BEGIN 
              ITEM  SCRPKEYOCCNO I(0,0,60); 
              ITEM  SCRPEXLEN     I(1,0,60);
              END 
  
  
          BASED ARRAY CHARS S(11);
              BEGIN 
              ITEM   PGMCHARS     C(0,0,110); 
              END 
  
          BASED ARRAY CSTRING S(11);
              ITEM   CONVCHARS    C(0,0,110); 
  
          BASED ARRAY LISTARRAY S(4); 
              BEGIN 
              ITEM  LSTNAME      C(0,0,30);      # NAME                #
              ITEM  LSTFSTLIT    U(3,42,18);     # LOW OCCURS RANGE    #
              ITEM  LSTSCNDLIT   U(3,24,18);     # HIGH OCCURS RANGE   #
              ITEM  LSTSIZE      U(3,19,5);      # NAME SIZE CHARS     #
              ITEM  LSTLINK      I(3,0,18);      # LINK TO SAME NAME   #
              END 
  
          BASED ARRAY PGMBLOCK; 
              BEGIN 
              ITEM   PGMTYPE      U(0,0,2); 
              ITEM   PGMLENGTH    U(0,6,18);
              ITEM   PGMFWA       U(0,24,18); 
              ITEM   PDMPFWA      U(0,42,18); 
              ITEM   PGMNAME      C(0,0,10);
              ITEM   CMNKT        U(0,6,18);
              ITEM   CMNLENGTH    U(0,24,18); 
              ITEM   CMNFWA       U(0,42,18); 
              ITEM   PGMWORD      U(0,0,60);
              END 
  
          BASED ARRAY RAAREA[0:64] S(1);
              BEGIN 
              ITEM   RACODE       U(0,54,6);
              ITEM   RANAME       C(0,0,7); 
              END 
  
          BASED ARRAY WORDS;
              BEGIN 
              ITEM   AWD          U(0,0,60);
              END 
  
          BASED ARRAY WORDS4CCT;
              BEGIN 
              ITEM   CCTWD        U(0,0,60);
              END 
  
  
#     STATUS DECLARATIONS.                                             #
  
          STATUS TKN$TYPE 
              ,  DN          # DATA NAME                               #
              ,  NUM         # A NUMBER - INTEGER                      #
              ,  RW 
              ; 
  
  
#     EXTERNAL REFERENCES.                                             #
  
          XREF
              BEGIN 
              PROC    BIT2DSP;
              FUNC    CDD C(6);         # DD=CDD(BIN)                  #
              FUNC    CMM$ALF;          #P<BLK>=CMM$ALF(SIZE,SC,GID)   #
              PROC    CMM$CSF;          #CMM$CSF(BLK,NSC)              #
              PROC    CMM$FRF;          #CMM$FRF(BLK)                  #
              PROC    CMM$GLF;          #CMM$GLF(BLK,INCR)             #
              PROC    CMM$SLF;          #CMM$SLF(BLK,DECR)             #
              PROC    CVCOMP1;          #CVCOMP1(VALUE,DEST)           #
              PROC    CVCOMP2;          #CVCOMP2(VALUE,BCP,DEST)       #
              FUNC    DSP2BIN      U;   #DSP2BIN(DC,SIZE)              #
              PROC    SETHDR;           #SETHDR                        #
              PROC    TDEMPTY;          #TDEMPTY                       #
              PROC    TDERROR;          #TDERROR(ERRMES)               #
              PROC    TDFET;            #TDFET(LFN1,LFN2,LFN3)         #
              PROC    TDREAD;           #TDREAD(LFN)                   #
              FUNC    TDREADH;          #RL = TDREADH(LFN,WSA,N)       #
              FUNC    TDREADW;          #STAT=TDREADW(LFN,WSA,N)       #
              PROC    TDRET;            #TDRET(LFN)                    #
              PROC    TDREW;            #TDREW(LFN)                    #
              PROC    TDSKIPF;          #TDSKIPF(LFN,N)                #
              PROC    TDWRITH;          #TDWRITH(LFN,WSA,N)            #
              PROC    TDWRITR;          #TDWRITR(LFN)                  #
              END 
  
#     EXTERNAL DATA REFERENCES.                                        #
  
          XREF ARRAY MAINHDR [0:12];
              ITEM   HDRWORD      C(0,0,10);
  
  
#     CALLS TO COMMON DECKS.                                           #
  
*CALL AUXT1 
*CALL AUXTVALS
*CALL DNATVALS
*CALL DNT 
*CALL NAMET 
*CALL USETAB
          CONTROL EJECT;
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
#                                                                      #
#     ADJSCRPPTS(CHARPTR,SCRPNO) - ADJUST SUBSCRIPT POINTERS           #
#                                                                      #
#     GIVEN - THE SUBSCRIPT NUMBER OF THE LAST ELEMENTARY ITEM PRINTED #
#             AND THE CHARACTER POINTER                                #
#                                                                      #
#     DOES - ADDS ON ANY EXTRA DIGITS BELONGING TO A LOWER SUBSCRIPT   #
#            LEVEL TO CHARPTR WHEN ONE OF THOSE SUBSCRIPT BOUNDARIES   #
#            HAVE BEEN REACHED                                         #
#                                                                      #
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
  
  
          PROC ADJSCRPPTS(CHARPTR,SCRPNO);
  
          BEGIN 
  
          ITEM   CHARPTR      I;
          ITEM   SCRPNO       I;
  
          FOR I = SCRPLVL - 1 STEP -1 WHILE I GR 1
          DO
              BEGIN 
              IF (SCRPNO/SCRPKEYOCCNO[I]) * SCRPKEYOCCNO[I] EQ SCRPNO 
              THEN   # ADD EXTRA DIGITS OF NEXT HIGHER SUBSCRIPT       #
                  BEGIN 
                  CHARPTR = CHARPTR + SCRPEXLEN[I-1]; 
                  END 
              ELSE   # NO MORE DIGITS TO SKIP                          #
                  BEGIN 
                  I = 0;
                  END 
              END 
  
          RETURN; 
  
          END 
CONTROL EJECT;
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
#                                                                      #
#     ANOTHERCCT - ANOTHER CCT OF TDF                                  #
#                                                                      #
#     DOES  - READS IN CCT FROM TDF IF ANOTHER ONE EXISTS              #
#             RETURN TRUE                                              #
#             IF EOF REACHED ON TDF RETURN FALSE                       #
#                                                                      #
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
  
          FUNC ANOTHERCCT B;
  
          BEGIN 
  
          P<WORDS4CCT> = LOC(CCTENTRIES[0]);
          CCTPTR = 0; 
          TDREAD(TDFN); 
  
          FOR I = I WHILE TDREADW(TDFN,WORDS4CCT[CCTPTR],1) EQ 0
          DO
              BEGIN 
              CCTPTR = CCTPTR + 1;
              END 
  
          IF CCTPTR EQ 0
          THEN
              BEGIN 
              ANOTHERCCT = FALSE; 
              END 
          ELSE
              BEGIN 
              ANOTHERCCT = TRUE;
              END 
  
          END   # ANOTHERCCT                                           #
          CONTROL EJECT;
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
#                                                                      #
#         CHECKEOR - CHECK END OF RECORD.                              #
#                                                                      #
#         GIVEN - FIRST PARAMETER IS NAME OF FILE.                     #
#                                                                      #
#         DOES - ISSUES A ONE-WORD -READW- ON THE FILE.  IT SHOULD     #
#                ALREADY BE AT EOR/EOF/EOI.  IF NOT, AN ERROR IS GIVEN.#
#                                                                      #
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
  
          PROC CHECKEOR(A); 
  
          BEGIN 
  
          ITEM   A            C(10);
          ITEM   ERRFLONG     C(40) = 
                             " RECORD TOO LONG ON FILE -              ";
  
          IF TDREADW(A,I,1) EQ 0
          THEN
              BEGIN 
              C<30,10>ERRFLONG = C<0,10>A;
              TDERROR(ERRFLONG);
              END 
  
          RETURN; 
  
          END       # CHECKEOR #
          CONTROL EJECT;
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
#                                                                      #
#         CONVCOMP1 - CONVERT COMP-1 ITEM.                             #
#                                                                      #
#         GIVEN - FIRST PARAM IS A COMP-1 VALUE OF ANY LEGAL SIZE.     #
#                 DISPLAY CODE VALUE IS TO GO INTO PRINT LINE IN THE   #
#                 START OF THE ITEM *DIVALUE*.                         #
#                                                                      #
#         DOES - CALLS *CVCOMP1* (A TERMINAL DUMP ROUTINE), WHICH,     #
#                IN TURN, CALLS *C.R1S14 (A COBOL OBJECT ROUTINE).     #
#                THE VALUE RETURNED IS IN NINES COMPLIMENT FORM IF THE #
#                ORIGINAL VALUE IS NEGATIVE, IN WHICH CASE, IT IS      #
#                CONVERTED TO POSITIVE, AND A MINUS SIGN INSERTED.     #
#                                                                      #
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
  
          PROC CONVCOMP1(A);
  
          BEGIN 
  
          ITEM   A            I;
          ITEM   AB           I;
          ITEM   AC           I;
          ITEM   C1HOLD       C(20);
  
          IF  A GR 2 ** 48 - 1 OR A LS -(2 ** 48 - 1) 
          THEN
              BEGIN 
              C<0,10>DIVALUE = "**********";
              C<10,10>DIVALUE = " ";
              RETURN; 
              END 
          CVCOMP1(A,C1HOLD);
          AC = 0; 
          IF C<0,1>C1HOLD EQ "0"
          THEN                          # POSITIVE VALUE               #
              BEGIN 
              FOR AB = 0 STEP 1 WHILE AC EQ 0 AND AB LQ 18
              DO
                  BEGIN 
                  IF C<AB,1>C1HOLD EQ "0" 
                  THEN
                      BEGIN 
                      TEST AB;
                      END 
                  ELSE
                      BEGIN 
                      AC = 1; 
                      AB = AB - 1;
                      END 
                  END 
              FOR AC = 0 STEP 1 WHILE AB LQ 19
              DO
                  BEGIN 
                  C<AC,1>DIVALUE = C<AB,1>C1HOLD; 
                  AB = AB + 1;
                  END 
              END 
          ELSE                          # NEGATIVE VALUE               #
              BEGIN 
              C<0,1>DIVALUE = "-";
              FOR AB = 6 STEP 1 WHILE AC EQ 0 AND AB LQ 18
              DO
                  BEGIN 
                  IF C<AB,1>C1HOLD EQ "9" 
                  THEN
                      BEGIN 
                      TEST AB;
                      END 
                  ELSE
                      BEGIN 
                      AC = 1; 
                      AB = AB - 1;
                      END 
                  END 
              FOR AC = 1 STEP 1 WHILE AB LQ 19
              DO
                  BEGIN 
                  C<AC,1>DIVALUE = O"77" - C<AB,1>C1HOLD; 
                  AB = AB + 1;
                  END 
              END 
          SIGNPOINT;                    # INSERT POINT IF NECESSARY    #
  
          END       # CONVCOMP1 # 
          CONTROL EJECT;
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
#                                                                      #
#         COREINDEX - GET ADDRESS OF DATA ITEM.                        #
#                                                                      #
#         GIVEN - *PGMPTR* CONTAINS FWA OF PROGRAM BLOCK RELATIVE TO   #
#                 START OF *PGMBLOCK*.  THE COMPILER TABLES FOR THIS   #
#                 SAME PROGRAM ARE IN THE VARIOUS BLOCKS FOR THEM.     #
#                 P<PGMBLOCK> IS STILL SET TO FWA OF *PGMBLOCK*.       #
#                                                                      #
#         DOES - COMPUTES AND RETURNS THE ADDRESS, RELATIVE TO THE     #
#                START OF *PGMBLOCK*, OF THE DATA ITEM CURRENTLY       #
#                BEING POINTED TO IN THE DNT/DNAT.  IF A ZERO VALUE IS #
#                RETURNED, THE ITEM IS NOT OF INTEREST AND IS NOT      #
#                PRINTED.                                              #
#                                                                      #
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
  
          FUNC COREINDEX I; 
  
          BEGIN 
  
          ITEM   CXTMP1       I;
          ITEM   CXTMP2       I;
          ITEM   CXTMP3       I;
  
          SWITCH MAJMTYPE 
                                        # 0 -  NEVER USED              #
              ,PROCDATA                 # 1 -  FILE DESCRIPTION        #
              ,NULLPROC                 # 2 -  SORT FILE DESCRIPTION   #
              ,NULLPROC                 # 3 -  SPECIAL REG MSEC        #
              ,PROCDATA                 # 4 -  WORKING-STORAGE         #
              ,NULLPROC                 # 5 -  LINKAGE SECTION         #
              ,NULLPROC                 # 6 -  COMMUNICATIONS DESC     #
              ,NULLPROC                 # 7 -  REPORT DESCRIPTION      #
              ,NULLPROC                 # 8 -  LITERAL                 #
              ,NULLPROC                 # 9 -  TEMPORARY ITEM          #
              ,PROCDATA                 # 10 - INDEX                   #
              ,PROCDATA                 # 11 - COMMON-STORAGE          #
              ,NULLPROC                 # 12 - SECONDARY-STORAGE       #
              ; 
  
          GOTO MAJMTYPE[DN$MAJMSEC[TABORD]];
  
NULLPROC: 
          COREINDEX = 0;
          RETURN; 
  
PROCDATA: 
          CXTMP3 = DN$SUBMSEC[TABORD];     # INDEX INTO USETAB         #
          IF NOT GLOBAL[CXTMP3] 
          THEN                          # PROGRAM BLOCK                #
              BEGIN 
              COREINDEX = DN$WORDOFF[TABORD]
                          + USESTART[CXTMP3] + PGMPTR + 4 
                          - (PDMPFWA[PGMPTR] - PGMFWA[PGMPTR]); 
              END 
          ELSE                          # COMMON BLOCK                 #
              BEGIN 
              FOR CXTMP1 = 0 STEP CXTMP2          # FIND THIS COMMON   #
              DO                        # BLOCK ENTRY IN PGMBLOCK      #
                  BEGIN 
                  IF PGMTYPE[CXTMP1] NQ COMBLKTYPE
                  THEN                  # ENTRY FOR PROGRAM BLOCK      #
                      BEGIN 
                      CXTMP2 = PGMLENGTH[CXTMP1] + 4; 
                      TEST CXTMP1;
                      END 
                  ELSE                  # ENTRY FOR COMMON BLOCK       #
                      BEGIN 
                      CXTMP2 = CMNLENGTH[CXTMP1] + 1; 
                      IF CMNKT[CXTMP1] EQ CXTMP3
                      THEN
                          BEGIN 
                          GOTO CORE1; 
                          END 
                      ELSE
                          BEGIN 
                          TEST CXTMP1;
                          END 
                      END 
                  END 
  
CORE1:  
              COREINDEX = DN$WORDOFF[TABORD] + CXTMP1 + 1;
              END 
  
          RETURN; 
  
          END       # COREINDEX # 
CONTROL EJECT;
#* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * #
#                                                                      #
#     CRACKCNTRLCD - CRACK CONTROL CARD                                #
#                                                                      #
#     DOES - SAVES THE CONTROL CARD PARAMETERS                         #
#                                                                      #
#* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * #
  
          PROC CRACKCNTRLCD;
  
          BEGIN 
  
          DEF TPARAM       #1#; 
          DEF LPARAM       #2#; 
          DEF IPARAM       #3#; 
          DEF NAPARAM      #4#; 
          DEF BADPARAM     #0#; 
  
          DEF PROPERPUNC   # RACODE[T1] EQ 0 OR RACODE[T1] EQ 1 OR
                             RACODE[T1] EQ O"17"#;
          DEF EQUALSIGN    # RACODE[T1] EQ 2 OR RACODE[T1] EQ "="     #;
  
          ITEM PARAMETER     U; 
  
          SWITCH PARAMSWITCH
               BAD$PARAM     # 0 - BAD PARAMETER                       #
              ,T$PARAM       # 1 - TDFILE                              #
              ,L$PARAM       # 2 - LIST FILE                           #
              ,I$PARAM       # 3 - DIRECTIVES FILE                     #
              ,NA$PARAM      # 4 - NO ARRAYS TO BE PRINTED             #
              ; 
  
          P<RAAREA> = 0;
          RACOUNT = RACODE[O"64"] + 1;   # ADR OF LAST PARAM           #
  
#     LOOP THRU PARAMETERS                                             #
  
          T1 = 2; 
          FOR I = I WHILE T1 LQ RACOUNT 
          DO
              BEGIN 
              PARAMETER = BADPARAM;    # ASSUME BAD PARAMETER          #
              IF C<0,1>RANAME[T1] EQ "T"
                 AND C<1,6>RANAME[T1] EQ C<1,6>ZEROS
              THEN
                  BEGIN 
                  PARAMETER = TPARAM; 
                  END 
              IF C<0,1>RANAME[T1] EQ "L"
                 AND C<1,6>RANAME[T1] EQ C<1,6>ZEROS
              THEN
                  BEGIN 
                  PARAMETER = LPARAM; 
                  END 
              IF C<0,1>RANAME[T1] EQ "I"
                 AND C<1,6>RANAME[T1] EQ C<1,6>ZEROS
              THEN
                  BEGIN 
                  PARAMETER = IPARAM; 
                  END 
              IF C<0,2>RANAME[T1] EQ "NA" 
                 AND C<2,5>RANAME[T1] EQ C<2,5>ZEROS
              THEN
                  BEGIN 
                  PARAMETER = NAPARAM;
                  END 
  
              GOTO PARAMSWITCH[PARAMETER];
  
BAD$PARAM:  
              TDERROR(ERRFORMAT); 
  
I$PARAM:  
              DIRECTIVES = TRUE;
              IF EQUALSIGN   # FOLLOWS I                               #
              THEN
                  BEGIN 
                  T1 = T1 + 1;
                  IF PROPERPUNC   # FOLLOWS FILE NAME                  #
                  THEN   # STORE FILE NAME                             #
                      BEGIN 
                      DIRFN = RANAME[T1]; 
                      END 
                  ELSE
                      BEGIN 
                      TDERROR(ERRFORMAT); 
                      END 
                  END 
              ELSE   # EQUAL SIGN DOES NOT FOLLOW I                    #
                  BEGIN 
                  IF NOT ( PROPERPUNC )  # FOLLOWING I                 #
                  THEN
                      BEGIN 
                      TDERROR(ERRFORMAT); 
                      END 
                  END 
              GOTO ENDPARAMCASE;
  
L$PARAM:  
              IF EQUALSIGN   # FOLLOWS L                               #
              THEN
                  BEGIN 
                  T1 = T1 + 1;
                  IF PROPERPUNC   # FOLLOWS FILE NAME                  #
                  THEN   #STORE FILE NAME                              #
                      BEGIN 
                      LSTFN = RANAME[T1]; 
                      END 
                  ELSE
                      BEGIN 
                      TDERROR(ERRFORMAT); 
                      END 
                  END 
              ELSE   # EQUAL SIGN DOES NOT FOLLOW L                    #
                  BEGIN 
                  IF NOT ( PROPERPUNC )  # FOLLOWING L                 #
                  THEN
                      BEGIN 
                      TDERROR(ERRFORMAT); 
                      END 
                  END 
              GOTO ENDPARAMCASE;
  
NA$PARAM: 
              IF PROPERPUNC   # FOLLOWS NA                             #
              THEN
                  BEGIN 
                  OMITARRAYS = TRUE;
                  END 
              ELSE
                  BEGIN 
                  TDERROR(ERRFORMAT); 
                  END 
              GOTO ENDPARAMCASE;
  
T$PARAM:  
              IF EQUALSIGN   # FOLLOWS T                               #
              THEN
                  BEGIN 
                  T1 = T1 + 1;
                  IF PROPERPUNC   # FOLLOWS FILE NAME                  #
                  THEN
                      BEGIN 
                      TDFN = RANAME[T1];
                      END 
                  ELSE
                      BEGIN 
                      TDERROR(ERRFORMAT); 
                      END 
                  END 
              ELSE   # EQUAL SIGN DOES NOT FOLLOW T                    #
                  BEGIN 
                  IF NOT ( PROPERPUNC )   # FOLLOWING T                #
                  THEN
                      BEGIN 
                      TDERROR(ERRFORMAT); 
                      END 
                  END 
              GOTO ENDPARAMCASE;
  
ENDPARAMCASE: 
              T1 = T1 + 1;
  
              END   # LOOP THRU PARAMS                                 #
  
          DELBLANKS(LSTFN); 
          C<30,10>ERRTDFN1 = TDFN;
          DELBLANKS(TDFN);
          DELBLANKS(DIRFN); 
          DELBLANKS(ZZFN);
  
          RETURN; 
  
          END   # CRACKCNTRLCD                                         #
          CONTROL EJECT;
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
#                                                                      #
#         DELBLANKS - DELETE BLANKS FROM NAME.                         #
#                                                                      #
#         GIVEN - FIRST PARAMETER IS NAME, LEFT JUSTIFIED WITH ANY     #
#                 COMBINATION OF BLANK OR ZERO FILL.                   #
#                                                                      #
#         DOES - SETS ZERO FILL IN ALL CHARS RIGHT OF THE RIGHT-MOST   #
#                NON-ZERO, NON-BLANK CHARACTER.                        #
#                                                                      #
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
  
          PROC DELBLANKS(A);
  
          BEGIN 
  
          ITEM   A            C(10);
  
          FOR T1 = 9 STEP -1 UNTIL 0
          DO
              BEGIN 
              IF B<T1*6,6>A NQ 0 AND C<T1,1>A NQ " "
              THEN
                  BEGIN 
                  RETURN; 
                  END 
              ELSE
                  BEGIN 
                  B<T1*6,6>A = 0; 
                  END 
              END 
          END       # DELBLANKS # 
CONTROL EJECT;
#* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * #
#                                                                      #
#     DUMP$HEADNGS - DUMP HEADINGS                                     #
#                                                                      #
#     DOES  - READS SNAP HEADINGS, PARAGRAPH TRACE, AND LAST LINE      #
#             EXECUTED INFO OFF OF DUMP FILE AND WRITE ON LISTING      #
#                                                                      #
#* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * #
  
          PROC DUMP$HEADNGS;
  
          BEGIN 
  
          NEWPAGE = 1;  #  FORCE PAGE EJECT                            #
  
#     CHECK FOR SNAP DUMP, IF THERE WRITE HEADER                       #
  
          IF DUMPCTLWORD[0] NQ 0
          THEN   # WRITE SNAP DUMP HEADER                              #
              BEGIN 
              P<CSTRING> = LOC(SNAPLITERAL[0]); 
              IF TDREADW(ZZFN,CSTRING,3) NQ 0 
              THEN   # PREMATURE EOR                                   #
                  BEGIN 
                  TDERROR(ERRZZFN1);
                  END 
              WRITELINE(SNAPLITLINE,5,0);   # WRITE SNAP HEADER     # 
              END 
  
#     PUT OUT PARAGRAPH TRACE AND LAST LINE EXECUTED, IF BOTH THERE    #
  
          IF  TDREADW(ZZFN,DUMPCTL,1)  NQ 0 
          THEN
              BEGIN 
              TDEMPTY;
              END 
          T1 = PLENGTH[0];
          IF  T1 NQ 0 
          THEN   # PARAGRAPH TRACE PRESENT                             #
              BEGIN 
              IF TDREADW(ZZFN,PNAMES,T1) NQ 0 
              THEN
                  BEGIN 
                  TDERROR(ERRZZFN1);
                  END 
              T2 = T1/3;     #NUMBER OF PARAGRAPH NAMES#
              T3 = PPTR[0];  #MOST RECENT              #
              WRITELINE(PARATRACE,4,1); 
              C<0,10>CHARSCRITEM = BLANKS;
              IF  T2 EQ 10 AND T3 NQ T2 
              THEN
                  BEGIN 
                  FOR  I = T3+1 STEP 1 UNTIL T2 
                  DO
                      BEGIN 
                      C<10,30>CHARSCRITEM = PARAGRAPH[I]; 
                      WRITELINE(CHARSCRITEM,4,0); 
                      END 
                  END 
              FOR  I = 1 STEP 1 UNTIL T3
              DO
                  BEGIN 
                  C<10,30>CHARSCRITEM = PARAGRAPH[I]; 
                  WRITELINE(CHARSCRITEM,4,0); 
                  END 
              IF TDREADW(ZZFN,LASTLINE$NO,1) NQ 0 
              THEN
                  BEGIN 
                  TDERROR(ERRZZFN1);
                  END 
              LASTLNNO[0] = CDD(LASTLINE$NO); 
              WRITELINE(LAST$LINE,3,1); 
              END 
          ELSE   # NO TRACE WRITE LAST I/O LINE NUMBER                 #
              BEGIN 
              IF LASTIOLINE[0] NQ 0 
              THEN   # WRITE LAST I/O LINE NUMBER                      #
                  BEGIN 
                  LASTIONO[0] = CDD(LASTIOLINE[0]); 
                  WRITELINE(LASTI$OLINE,3,1); 
                  END 
              ELSE   # NO I/O DONE                                     #
                  BEGIN 
                  WRITELINE(NOIODONE,2,1);
                  END 
              END 
  
          END   # DUMP$HEADNGS #
CONTROL EJECT;
#* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * #
#                                                                      #
#     GETCHARSTRNG - GET CHARACTER STRING                              #
#                                                                      #
#     GIVEN - DIRECTIVES FILE                                          #
#                                                                      #
#     DOES  - RETRIEVES CHAR STRING FROM DIRECTIVES FILE               #
#                                                                      #
#* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * #
  
          PROC GETCHARSTRNG;
  
          BEGIN 
          ITEM   CHARPTR      I = CARD$SIZE;
          ITEM   HAVECHARSTRG B;
          ITEM   OVER30DIAG   B;
          ITEM   RL           U = CARD$SIZE;
          ITEM   TALLY        U;
  
          IF EOINPUT
          THEN
              BEGIN 
              RETURN; 
              END 
  
          IF FIRSTDIR 
          THEN
              BEGIN 
              FIRSTDIR = FALSE; 
              TDREAD(DIRFN);
              END 
  
#     CLEAR TOKEN VALUES AND INITIALIZE                                #
  
          HAVECHARSTRG = FALSE; 
          OVER30DIAG = FALSE; 
          TALLY = 0;
          TOKEN   = " ";
          TKNSIZE = 0;
          TKNTYPE = 0;
  
#     LOOP THRU EACH CHAR POSITION ON CARD FROM DIRECTIVES FILE 
      SKIPPING LEADING BLANKS, GATHERING CHARS UNTIL FIRST BLANK
      FOLLOWING FIRST NON-BLANK, ONLY KEEP FIRST 30 CHARS. RETURN THIS
      STRING AS A NEW TOKEN TO CALLER                                  #
  
          FOR I = I WHILE NOT ( HAVECHARSTRG )
          DO
              BEGIN 
              CHARPTR = CHARPTR + 1;
              IF CHARPTR GQ RL
              THEN
                  BEGIN 
                  RL = TDREADH(DIRFN,CARD,CARD$SIZE/10);
                  IF RL NQ 0
                  THEN   # EOR OR EOF/EOI                              #
                      BEGIN 
                      IF RL GR 0
                      THEN   # EOR ENCOUNTERED                         #
                          BEGIN 
                          EOINPUT = TRUE; 
                          IF TALLY NQ 0 
                          THEN   # PROCESS LAST CHARACTER STRING       #
                              BEGIN 
                              HAVECHARSTRG = TRUE;
                              TKNSIZE = TALLY;
                              GOTO LOOP;
                              END 
                          TKNTYPE = 0;
                          RETURN; 
                          END 
                      ELSE    # EOF/EOI SEEN                           #
                          BEGIN 
                          TDERROR(ERRNODIRCTVS);
                          END 
                      END 
                  DIFULL = " "; 
                  DIDIRLINE = CARD; 
                  WRITELINE(DILINE,CARD$SIZE/10,0); 
                  CHARPTR = 0;
                  RL = 80;
                  END 
  
              IF C<CHARPTR,1>CARD EQ " "
              THEN   # HAVE SPACE                                      #
                  BEGIN 
                  IF TALLY NQ 0 
                  THEN   # WE HAVE A STRING MARK IT SO                 #
                      BEGIN 
                      TKNSIZE = TALLY;
                      HAVECHARSTRG = TRUE;
                      END 
                  END 
              ELSE   # HAVE A CHARACTER                                #
                  BEGIN 
                  IF TALLY GQ 30
                  THEN   # DIAGNOSE DATA-NAME GR 30 CHARS              #
                      BEGIN 
                      IF NOT OVER30DIAG 
                      THEN
                          BEGIN 
                          WRITELINE(ERROVER30DN,LISTMSGLEN/10,0); 
                          OVER30DIAG = TRUE;
                          END 
                      END 
                  ELSE   # ADD CHAR TO TOKEN                           #
                      BEGIN 
                      C<TALLY,1>TOKEN = C<CHARPTR,1>CARD; 
                      END 
                  TALLY = TALLY + 1;
                  END 
  
LOOP: 
              END   # OF CHAR GATHERING LOOP                           #
  
          IDENTIFY; 
  
          RETURN; 
  
          END  # OF GETCHARSTRG                                        #
  
CONTROL EJECT;
#* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * #
#                                                                      #
#     IDENTIFY - IDENTIFY CURRENT TOKEN                                #
#                                                                      #
#     GIVEN - TOKEN IN TOKEN                                           #
#             SIZE IN TKNSIZE                                          #
#                                                                      #
#     DOES  - TKNTYPE = NUMBER, DATANAME, OR RESERVED WORD VALUE       #
#                                                                      #
#* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * #
  
          PROC IDENTIFY;
  
          BEGIN 
  
          SWITCH IDSWITCH 
              ,ID             #  1 - CHARACTER                         #
              ,TWO            #  2 - CHARACTERS                        #
              ,ID             #  3 - CHARACTERS                        #
              ,ID             #  4 - CHARACTERS                        #
              ,ID             #  5 - CHARACTERS                        #
              ,SIX            #  6 - CHARACTERS                        #
              ,ID             #  7 - CHARACTERS                        #
              ,ID             #  8 - CHARACTERS                        #
              ,ID             #  9 - CHARACTERS                        #
              ,ID             # 10 - CHARACTERS                        #
              ,ELEVEN         # 11 - CHARACTERS                        #
              ; 
  
  
          IF TKNSIZE GR 11
          THEN
              BEGIN 
              GOTO ID;
              END 
          GOTO IDSWITCH[TKNSIZE];      # JUMP ACCORDING TO TOKEN SIZE  #
  
TWO:  
  
#     HERE IF TOKEN SIZE = 2                                           #
  
          IF C<0,2>TOKEN EQ "OF"
          THEN   # TOKEN IS RESERVED WORD OF                           #
              BEGIN 
              TKNTYPE = OF$VAL; 
              RETURN; 
              END 
          IF C<0,2>TOKEN EQ "TO"
          THEN   # TOKEN IS RESERVED WORD TO                           #
              BEGIN 
              TKNTYPE = TO$VAL; 
              RETURN; 
              END 
          GOTO ID;   # NOT A RESERVED WORD SEE IF NUM OR DATA NAME     #
  
  
SIX:  
  
#     HERE IF TOKEN SIZE = 6                                           #
          IF C<0,6>TOKEN EQ "EXCEPT"
          THEN
              BEGIN 
              TKNTYPE = EXCEPT$VAL; 
              RETURN; 
              END 
          IF C<0,6>TOKEN EQ "SELECT"
          THEN
              BEGIN 
              TKNTYPE = SELECT$VAL; 
              RETURN; 
              END 
          GOTO ID;   # NOT A RESERVED WORD SEE IF NUM OR DATA NAME     #
  
ELEVEN: 
  
#     HERE IF TOKEN SIZE = 11                                          #
  
          IF C<0,11>TOKEN EQ "OCCURRENCES"
          THEN
              BEGIN 
              TKNTYPE = OCCURS$VAL; 
              RETURN; 
              END 
          GOTO ID;   # NOT A RESERVED WORD SEE IF NUM OR DATA NAME     #
  
ID: 
  
#     HERE IF TOKEN YET TO BE IDENTIFIED                               #
  
          FOR T2 = 0 STEP 1 UNTIL TKNSIZE - 1 
          DO
              BEGIN 
              IF C<T2,1>TOKEN LS "0" OR C<T2,1>TOKEN GR "9" 
              THEN   # NOT NUMERIC MUST BE DATA NAME                   #
                  BEGIN 
                  TKNTYPE = DATANAME$VAL; 
                  RETURN; 
                  END 
              END 
  
#     WE HAVE AN INTEGER SEE IF < 11 DIGITS                            #
  
          IF TKNSIZE GR 11
          THEN
              BEGIN 
              WRITELINE(ERRNUMGRTEN,LISTMSGLEN/10,0); 
              TKNSIZE = 10; 
              END 
  
          TKNTYPE = NUMBER$VAL; 
  
          RETURN; 
  
          END   # IDENTIFY                                             #
CONTROL EJECT;
#* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * #
#                                                                      #
#     LINKDUPS - LINK DUPLICATES                                       #
#                                                                      #
#     GIVEN - T1 = LAST TOKEN IN LIST YOU WISH LINKED                  #
#                                                                      #
#     DOES  - LSTLINK[T1] = 0.                                         #
#             STARTING WITH T1 SEARCHES DOWN THE LIST UNTIL IF FINDS   #
#             A MATCHING DATA NAME. SET LSTLINK OF THIS DATA NAME ENTRY#
#             TO T1.  IF NO MATCHING DATA NAME IN SEARCH DO NOTHING.   #
#                                                                      #
#                                                                      #
#* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * #
  
          PROC LINKDUPS;
  
          BEGIN 
  
          LSTLINK[T1] = -1; 
          FOR T2 = T1 - 1 STEP -1 UNTIL 1 
          DO
              BEGIN 
              IF TKNSIZE EQ LSTSIZE[T2] AND LSTFSTLIT[T2] NQ 0
                 AND C<0,TKNSIZE>TOKEN EQ C<0,TKNSIZE>LSTNAME[T2] 
              THEN   # FOUND A MATCH LINK AND RETURN                   #
                  BEGIN 
                  LSTLINK[T2] = T1;  # LINK MATCH TO CURRENT ENTRY     #
                  RETURN; 
                  END 
              END 
          RETURN; 
  
          END   # LINKDUPS                                             #
CONTROL EJECT;
#* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * #
#                                                                      #
#      NAMESMATCH - NAMES MATCH                                        #
#                                                                      #
#      DOES  - RETURNS TRUE IF NAME ASSOCIATED WITH THE DNT[TABORD]    #
#              ENTRY IN NAMET MATCHES THE DIRECTIVES LIST NAME POINTED #
#              TO BY LISTPOINTER                                       #
#                                                                      #
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
  
          FUNC NAMESMATCH B;
  
          BEGIN 
  
          ITEM NAME         C(30);
  
          NAMESMATCH = FALSE; 
          NAME = " "; 
          T1 = (LSTSIZE[LISTPOINTER]+9)/10; 
  
          IF DNTNBRWORDS[TABORD] NQ T1
          THEN
              BEGIN 
              RETURN; 
              END 
  
          IF T1 GR 2
          THEN
              BEGIN 
              C<20,10>NAME = DNTNAME3;
              END 
          IF T1 GR 1
          THEN
              BEGIN 
              C<10,10>NAME = DNTNAME2;
              END 
          C<0,10>NAME = DNTNAME1; 
  
          IF NAME EQ LSTNAME[LISTPOINTER] 
          THEN
              BEGIN 
              NAMESMATCH = TRUE;
              END 
  
          RETURN; 
  
          END   # NAMESMATCH                                       #
CONTROL EJECT;
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
#                                                                      #
#     PGMINCORE - PROGRAM IN CORE                                      #
#                                                                      #
#     GIVEN - PGMCOUNT = NUMBER OF PROGRAMS IN CORE IMAGE              #
#                                                                      #
#     DOES  - RETURNS TRUE WITH PGMPTR = FWA OF PROGRAM RELATIVE TO    #
#                     START OF PGMBLOCK, IF PROGRAM IN CORE IMAGE.     #
#           - RETURNS FALSE IF PROGRAM NOT IN CORE IMAGE               #
#                                                                      #
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
  
          FUNC PGMINCORE B; 
  
          BEGIN 
  
#     INITIALIZE FOR SEARCH                                            #
  
          PGMPTR = 0; 
          T5 = PGMCOUNT;
          PGMINCORE = FALSE;
  
          FOR I = I WHILE T5 NQ 0 
          DO
              BEGIN 
              T5 = T5 - 1;
              IF PGMTYPE[PGMPTR] EQ COMBLKTYPE
              THEN   # COMMON BLOCK DONT CHECK                         #
                  BEGIN 
                  PGMPTR = PGMPTR + CMNLENGTH[PGMPTR] + 1;
                  END 
              ELSE   # A PROGRAM CHECK                                 #
                  BEGIN 
                  IF CCTPROGRI0 EQ PGMNAME[PGMPTR+1]
                     AND CCTPROGRI1 EQ PGMNAME[PGMPTR+2]
                     AND CCTPROGRI2 EQ PGMNAME[PGMPTR+3]
                  THEN   # FOUND - SET FLAGS TO TERMINATE SEARCH       #
                      BEGIN 
                      PGMINCORE = TRUE; 
                      T5 = 0; 
                      END 
                  ELSE   # TRY AGAIN                                   #
                      BEGIN 
                      PGMPTR = PGMPTR + PGMLENGTH[PGMPTR] + 4;
                      END 
                  END 
              END   # SEARCH LOOP                                      #
  
          RETURN; 
  
          END   # PGMINCORE                                            #
          CONTROL EJECT;
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
#                                                                      #
#         PLUGDATANAME - PLUG DATA NAME.                               #
#                                                                      #
#         GIVEN - *TABORD* POINTS TO CURRENT DNT/DNAT ENTRY.           #
#                                                                      #
#         DOES - PUTS NAME OF DATA ITEM IN PRINT LINE.                 #
#                                                                      #
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
  
          PROC PLUGDATANAME;
  
          BEGIN 
  
          IF DNTFILLER[TABORD]
          THEN
              BEGIN 
              DINAME[0] = "FILLER"; 
              END 
          ELSE
              BEGIN 
              DINAME[0] = " ";
              IF DNTNBRWORDS[TABORD] GR 2 
              THEN
                  BEGIN 
                  C<20,10>DINAME = DNTNAME3;
                  END 
              IF DNTNBRWORDS[TABORD] GR 1 
              THEN
                  BEGIN 
                  C<10,10>DINAME = DNTNAME2;
                  END 
              C<0,10>DINAME = DNTNAME1; 
              END 
  
          IF LIMITEDARRAY 
          THEN
              BEGIN 
              WRITELINE(DILINE,4,0);
              END 
  
          RETURN; 
  
          END       # PLUGDATANAME #
          CONTROL EJECT;
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
#         PLUGDATATYPE - PLUG DATA TYPE.                               #
#                                                                      #
#         GIVEN - *TABORD* POINTS TO CURRENT DNT/DNAT ENTRY.           #
#                                                                      #
#         DOES - PUTS A 3-CHAR (OR LESS) MNEMONIC IN THE PRINT LINE    #
#                WHICH INDICATES THE DATA TYPE.                        #
#                                                                      #
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
  
          PROC PLUGDATATYPE;
  
          BEGIN 
          DITYPE[0] = DATATYC[DN$TYPE[TABORD]]; 
          RETURN; 
          END       # PLUGDATATYPE #
CONTROL EJECT;
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
#                                                                      #
#     PRINT$ABLE - PRINTABLE DNT ENTRY                                 #
#                                                                      #
#     GIVEN - TABORD - ORDINAL OF CURRENT DNT ENTRY                    #
#                                                                      #
#     DOES  - RETURNS FALSE IF NON-VIABLE DNT ENTRY                    #
#                           OR ENTRY WAS IN DIRECTIVES NAME LIST FROM  #
#                              AN EXCEPT STATEMENT                     #
#                           OR SELECT DIRECTIVE ACTIVE AND ENTRY NOT IN#
#                              DIRECTIVES NAME LIST                    #
#                           OR OMITARRAYS TRUE AND ENTRY IS AN ARRAY   #
#                              NOT IN THE DIRECTIVES NAME LIST         #
#             RETURNS TRUE OTHERWISE                                   #
#                                                                      #
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
  
          FUNC PRINT$ABLE   B;
  
          BEGIN 
  
          ITEM  MATCHED      B = FALSE; 
  
          IF DNTINFO[TABORD] EQ 0 
          THEN   # NON-VIABLE ENTRY RETURN FALSE                       #
              BEGIN 
              PRINT$ABLE = FALSE; 
              RETURN; 
              END 
  
          LISTPOINTER = 0;
          PRINT$ABLE = TRUE;
          OCCURENCEFLG = FALSE; 
          LIMITEDARRAY = FALSE; 
          MATCHED = FALSE;
  
#     SEARCH DIRECTIVES NAME LIST FOR THIS DNT ENTRY                   #
  
          FOR I = I WHILE LISTPOINTER LS LISTSIZE 
          DO
              BEGIN 
              IF NAMESMATCH 
              THEN   # FOUND THIS DNT MATCHES NAME IN DIRECTIVES LIST  #
                  BEGIN 
                  IF LSTFSTLIT[LISTPOINTER] NQ 0
                  THEN   # IT IS IN AN OCCURRENCE DIRECTIVE            #
                      BEGIN 
                      OCCURENCEFLG = TRUE;
                      LIMITEDARRAY = TRUE;
                      PRINT$ABLE = TRUE;
                      RETURN; 
                      END 
                  ELSE   # IT IS IN A SELECT OR EXCEPT DIRECTIVE       #
                      BEGIN 
                      MATCHED = TRUE; 
                      END 
                  END 
              LISTPOINTER = LISTPOINTER + 1;
              END   # SEARCH FOR DNT IN DIRECTIVES NAME LIST           #
  
           IF EXCEPTSEEN AND MATCHED
           THEN   # THIS DNT IS NOT TO BE PRINTED                      #
               BEGIN
               PRINT$ABLE = FALSE;
               RETURN;
               END
  
          IF SELECTSEEN AND NOT MATCHED 
          THEN   # THIS DNT NOT TO BE PRINTED                          #
              BEGIN 
              PRINT$ABLE = FALSE; 
              RETURN; 
              END 
  
          IF OMITARRAYS AND DN$SDEPTH[TABORD] NQ 0 AND NOT MATCHED
          THEN
              BEGIN 
              PRINT$ABLE = FALSE; 
              END 
  
          RETURN; 
  
          END   # PRINT$ABLE                                           #
CONTROL EJECT;
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
#                                                                      #
#     RDRESTOFTBLS - READ REST IN THE REST OF THE COMPILER TABLES      #
#                                                                      #
#     DOES  - READS THE USETAB, DNAT, DNT, AUXT, NAMET FROM TDF        #
#                                                                      #
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
  
          PROC RDRESTOFTBLS;
  
          BEGIN 
  
#     1) *USETAB* IS FIRST. READ INTO CMM BLOCK                        #
  
          TDREAD(TDFN); 
          P<USETAB> = CMM$ALF(0,3,0); 
          P<WORDS> = P<USETAB>; 
          T5 = 0; 
          FOR T1 = 0 WHILE TDREADW(TDFN,T2,1) EQ 0
          DO
              BEGIN 
              CMM$GLF(USETAB,1);
              AWD[T5] = T2; 
              T5 = T5 + 1;
              END 
          CMM$CSF(USETAB,2);
  
#     2) READ THE *DNAT* IMMEDIATELY AFTER THE *DNT*, BOTH IN THE      #
#        SAME FIXED BLOCK.                                             #
  
          TDREAD(TDFN);                 # BEGIN *DNT* READ             #
          T4 = (CCTLSTWSDNAT+1) * DNT$ENTSZ;
          T5 = (CCTLSTWSDNAT+1) * DNAT$ENTSZ; 
          P<DNT> = CMM$ALF(T4+T5,2,0);
          IF TDREADW(TDFN,DNT,T4) NQ 0
          THEN
              BEGIN 
              TDERROR(ERRTDFN1);
              END 
          CHECKEOR(TDFN); 
          TDREAD(TDFN);                 # BEGIN *DNAT* READ            #
          P<DNAT> = P<DNT> + T4;
          IF TDREADW(TDFN,DNAT,T5) NQ 0 
          THEN
              BEGIN 
              TDERROR(ERRTDFN1);
              END 
          CHECKEOR(TDFN); 
  
#     3) READ THE *AUXT* INTO A FIXED BLOCK.                           #
  
          TDREAD(TDFN); 
          T4 = (CCTAUXTLEN+1) * AUXT$ENTSZ; 
          P<AUXT> = CMM$ALF(T4,2,0);
          IF CCTAUXTLEN NQ 0
          THEN
              BEGIN 
              IF TDREADW(TDFN,AUXT,T4) NQ 0 
              THEN
                  BEGIN 
                  TDERROR(ERRTDFN1);
                  END 
              END 
          CHECKEOR(TDFN); 
  
#     4) *NAMET* IS LAST. READ INTO CMM BLOCK                          #
  
          TDREAD(TDFN); 
          T5 = (CCTNAMETLEN+1) * NAMET$ENTSZ; 
          P<NAMET> = CMM$ALF(T5,2,0); 
          IF CCTNAMETLEN NQ 0 
          THEN
              BEGIN 
              IF TDREADW(TDFN,NAMET,T5) NQ 0
              THEN
                  BEGIN 
                  TDERROR(ERRTDFN1);
                  END 
              END 
          CHECKEOR(TDFN); 
  
          END   # RDRESTOFTBLS                                         #
CONTROL EJECT;
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
#                                                                      #
#     READPGMBLKS - READ PROGRAM BLOCKS                                #
#                                                                      #
#     DOES  - READS THE PROGRAM BLOCKS AND COMMON BLOCKS FOR THE       #
#             CURRENT DUMP FROM ZZZZZ4P                                #
#                                                                      #
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
  
          PROC READPGMBLKS; 
  
          BEGIN 
  
          P<PGMBLOCK> = CMM$ALF(1,3,0); 
          PGMPTR = 0; 
          PGMCOUNT = 0; 
          IF TDREADW(ZZFN,PGMBLOCK[PGMPTR],1) NQ 0
          THEN
              BEGIN 
              TDERROR(ERRZZFN1);
              END 
          FOR T1 = 1 WHILE PGMTYPE[PGMPTR] NQ NONPROGTYPE 
          DO
              BEGIN 
              IF PGMTYPE[PGMPTR] EQ COMBLKTYPE
              THEN
                  BEGIN 
                  T4 = CMNLENGTH[PGMPTR]; 
                  END 
              ELSE
                  BEGIN 
                  T4 = PGMLENGTH[PGMPTR] + 3; 
                  END 
              T5 = T4 + 1;
              CMM$GLF(PGMBLOCK,T5); 
              PGMPTR = PGMPTR + 1;
              IF T4 NQ 0
              THEN
                  BEGIN 
                  IF TDREADW(ZZFN,PGMBLOCK[PGMPTR],T4) NQ 0 
                  THEN
                      BEGIN 
                      TDERROR(ERRZZFN1);
                      END 
                  END 
              PGMPTR = PGMPTR + T4; 
              PGMCOUNT = PGMCOUNT + 1;
              IF TDREADW(ZZFN,PGMBLOCK[PGMPTR],T1) NQ 0 
              THEN
                  BEGIN 
                  TDERROR(ERRZZFN1);
                  END 
              END 
          CMM$SLF(PGMBLOCK,1);
          CMM$CSF(PGMBLOCK,2);
  
          END   # READPGMBLKS                                          #
CONTROL EJECT;
#* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * #
#                                                                      #
#     READ$DIRCTVS - READ DIRECTIVES                                   #
#                                                                      #
#     GIVEN - DIRECTIVES FLAG                                          #
#                                                                      #
#     DOES  - READS AND SAVES DIRECTIVES FROM DIRECTIVES FILE          #
#                                                                      #
#* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * #
  
          PROC READ$DIRCTVS;
  
          BEGIN 
  
          ITEM  IGNORE       B=FALSE; 
  
          SWITCH TOKENSWITCH
               ENDTKNCASE   # 0 - END OF INPUT                         #
              ,DATANAME     # 1 - DATA NAME                            #
              ,ENDTKNCASE   # 2 - NUMBER - INTEGER                     #
              ,SELECT       # 3 - SELECT DIRECTIVE                     #
              ,EXCEPT       # 4 - EXCEPT DIRECTIVE                     #
              ,OCCURRENCES  # 5 - OCCURRENCES DIRECTIVE                #
              ,ENDTKNCASE   # 6 - TO RESERVED WORD                     #
              ,ENDTKNCASE   # 7 - OF RESERVED WORD                     #
              ; 
  
          T1 = 0; 
          P<LISTARRAY> = CMM$ALF(LIST$ENTSZ,3,0); # ALLOCATE LIST BLK  #
  
          FOR I = I WHILE NOT EOINPUT 
          DO
              BEGIN 
  
              GETCHARSTRNG; 
              GOTO TOKENSWITCH[TKNTYPE];
  
DATANAME: 
              IF NOT IGNORE 
              THEN
                  BEGIN 
                  IF  (SELECTSEEN OR EXCEPTSEEN)
                  THEN
                      BEGIN   # SELECT/EXCEPT DATANAME STORE IT IN LIST#
                      LSTNAME[T1] = C<0,TKNSIZE>TOKEN;
                      LSTSIZE[T1] = TKNSIZE;
                      LSTFSTLIT[T1] = 0;
                      LSTSCNDLIT[T1] = 0; 
                      LSTLINK[T1] = -1; 
                      CMM$GLF(LISTARRAY,LIST$ENTSZ);
                      T1 = T1 + 1;
                      END 
                  ELSE   # SELECT OR EXCEPT NOT SEEN YET DIAGNOSE      #
                      BEGIN 
                      WRITELINE(ERRBADNAME,LISTMSGLEN/10,0);
                      END 
                   END
              GOTO ENDTKNCASE;
  
EXCEPT: 
              IF SELECTSEEN 
              THEN   # IGNORE DIRECTIVE AND DATA NAMES THAT FOLLOW     #
                  BEGIN 
                  WRITELINE(ERRBADEXCEPT,LISTMSGLEN/10,0);
                  IGNORE = TRUE;
                  END 
              ELSE   # FLAG EXCEPT SEEN                                #
                  BEGIN 
                  EXCEPTSEEN = TRUE;
                  IGNORE = FALSE; 
                  END 
              GOTO ENDTKNCASE;
  
OCCURRENCES:  
              GETCHARSTRNG; 
              IF TKNTYPE NQ TKN$TYPE"NUM" 
              THEN   # DIAGNOSE LITERAL MISSING FROM OCCURRENCES DIR.  #
                  BEGIN 
                  WRITELINE(ERRMISNGLIT,LISTMSGLEN/10,0); 
                  IGNORE = TRUE;
                  GOTO ENDTKNCASE;
                  END 
              LSTFSTLIT[T1] = DSP2BIN(TOKEN,TKNSIZE); 
  
              GETCHARSTRNG; 
              IF TKNTYPE LS TKN$TYPE"RW" OR C<0,2>TOKEN NQ "TO" 
              THEN   # ONLY ONE OCCURRENCE REQUESTED                   #
                  BEGIN 
                  LSTSCNDLIT[T1] = LSTFSTLIT[T1]; 
                  END 
              ELSE   # TO OPTION OF OCCURRENCES SAVE 2ND LITERAL       #
                  BEGIN 
                  GETCHARSTRNG; 
                  IF TKNTYPE NQ TKN$TYPE"NUM" 
                  THEN   # MISSING LITERAL FOLLOWING TO                #
                      BEGIN 
                      WRITELINE(ERRMIS2NDLIT,LISTMSGLEN/10,0);
                      IGNORE = TRUE;
                      GOTO ENDTKNCASE;
                      END 
                  LSTSCNDLIT[T1] = DSP2BIN(TOKEN,TKNSIZE);
                  GETCHARSTRNG; 
                  END 
  
              IF TKNTYPE GQ TKN$TYPE"RW" AND C<0,2>TOKEN EQ "OF"
              THEN   # SKIP OF IF PRESENT                              #
                  BEGIN 
                  GETCHARSTRNG; 
                  END 
  
              IF TKNTYPE NQ TKN$TYPE"DN"
              THEN   # DIAGNOSE MISSING DATANAME                       #
                  BEGIN 
                  WRITELINE(ERRMISNAME,LISTMSGLEN/10,0);
                  IGNORE = TRUE;
                  GOTO TOKENSWITCH[TKNTYPE];
                  END 
  
              LSTNAME[T1] = C<0,TKNSIZE>TOKEN;   # STORE DATA NAME     #
              LSTSIZE[T1] = TKNSIZE;
              LINKDUPS;   # LINK TO ANY OTHER OCCURRENCES OF THIS NAME #
              CMM$GLF(LISTARRAY,LIST$ENTSZ);
              T1 = T1 + 1;
              GOTO ENDTKNCASE;
  
SELECT: 
              IF EXCEPTSEEN 
              THEN   # IGNORE DIRECTIVE AND FOLLOWING DATA NAMES       #
                  BEGIN 
                  WRITELINE(ERRBADSELECT,LISTMSGLEN/10,0);
                  IGNORE = TRUE;
                  END 
              ELSE   # FLAG SELECT SEEN                                #
                  BEGIN 
                  SELECTSEEN = TRUE;
                  IGNORE = FALSE; 
                  END 
              GOTO ENDTKNCASE;
  
ENDTKNCASE: 
  
              END   # LOOP THRU DIRECTIVES                             #
  
          LISTSIZE = T1;
          IF LISTSIZE EQ 0
          THEN   # NO DIRECTIVES FREE CMM BLOCKS, INDICATE NO DIRECTVS #
              BEGIN 
              DIRECTIVES = FALSE; 
              CMM$FRF(LISTARRAY); 
              TDERROR(ERRNODIRCTVS);
              END 
          ELSE   # CLEAN-UP                                            #
              BEGIN 
              CMM$SLF(LISTARRAY,1); 
              CMM$CSF(LISTARRAY,2); 
              END 
          RETURN; 
  
          END   # READ$DIRECTVS                                        #
          CONTROL EJECT;
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
#                                                                      #
#         SETOCCURS - SET OCCURRENCE COUNT.                            #
#                                                                      #
#         GIVEN - 1ST PARAM IS (NEXT OCCURRENCE NUMBER) - 1.           #
#                 *TABORD* POINTS TO CURRENT DNT/DNAT ENTRY.           #
#                 *LINECT* = NUMBER OF LINES WRITTEN TO CURRENT PAGE.  #
#                                                                      #
#         DOES - PUTS OUT THE NEXT OCCURRENCE NUMBER IN ANY CASE.      #
#                SETS UP DUPLICATE LINES CHECKING IF:                  #
#                 1) FIRST TIME.                                       #
#                 2) DUPLICATES LINE JUST PRINTED.                     #
#                PUTS OUT THE WORD *OCCURRENCE* IF:                    #
#                 1) IT IS BEING CALLED FOR THE 1ST TIME FOR THIS ITEM.#
#                 2) BEGINNING A NEW PAGE.                             #
#                 3) EACH OCCURRENCE TAKES MORE THAN ONE LINE.         #
#                 4) DUPLICATES LINES JUST PRINTED.                    #
#                                                                      #
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
  
          PROC SETOCCURS(A);
  
          BEGIN 
  
          ITEM   A            I;
  
          IF NOT CHKFORDUPS 
          THEN
              BEGIN 
              PASTLINE = DIVALUE[0];
              OCCURSLOW = A + 1;
              OCCURSHIGH = A; 
              CHKFORDUPS = TRUE;
              END 
          DIFULL[0] = " ";              # BLANK OUT LINE               #
          IF A EQ 1 OR LINECT + 5 GR PAGESIZE OR DN$ITMLEN[TABORD]
              GR 100 OR LIMITEDARRAY
          THEN
              BEGIN 
              DIOCCN[0] = "  OCCURRENCE"; 
              END 
          TENCHARS[0] = CDD(A + 1);     # CONVERT OCCURRENCE NUMBER    #
          DIOCCV[0] = C<4,6>TENCHARS[0];
  
          RETURN; 
  
          END       # SETOCCURS # 
          CONTROL EJECT;
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
#                                                                      #
#         SETSDEPTH - SET SUBSCRIPT DEPTH.                             #
#                                                                      #
#         GIVEN - *TABORD* POINTS TO CURRENT DNT/DNAT ENTRY.           #
#                                                                      #
#         DOES - SETS *SCRPMAX* TO THE NUMBER OF OCCURRENCES OF THE    #
#                CURRENT DATA ITEM.  NOTE THAT SINCE ONLY ELEMENTARY   #
#                ITEMS ARE PRINTED IN THE DUMP, THIS IS USED           #
#                ONLY FOR ELEMENTARY ITEMS.                            #
#                SETS *SCRPINIT* TO THE OFFSET TO THE 1ST OCCURRENCE.  #
#                SETS *SCRPLEN* TO THE SPACING BETWEEN EACH OCCURRENCE.#
#                                                                      #
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
  
          PROC SETSDEPTH; 
  
          BEGIN 
  
          ITEM   SCRPSCR1     I;
          ITEM   SCRPSCR2     I;
          ITEM   SCRPSCR4     I;
  
          SCRPMAX = 1;                  # INITIALIZE OCCURRENCE COUNT  #
          SCRPINIT = 0; 
          SCRPLEN = 0;
          SCRPSCR1 = DN$SDEPTH[TABORD]; 
  
          IF SCRPSCR1 EQ 0
          THEN   #  NO SUBSCRIPTS                                      #
              BEGIN 
              RETURN; 
              END 
  
          SCRPSCR2 = DN$AUXREF[TABORD];           # 1ST AUXT POINTER   #
                 SCRPLVL = 0; 
          SCRPSCR4 = 0; 
  
          FOR T1 = T1 WHILE SCRPSCR4 EQ 0 
          DO
              BEGIN 
              IF AX$TTYPE[SCRPSCR2] EQ MAXOCCUR 
              THEN
                  BEGIN 
                  SCRPLVL = SCRPLVL + 1;
                  IF SCRPLVL EQ SCRPSCR1
                  THEN
                      BEGIN 
                      SCRPSCR4 = 1;               # FLAG LAST TIME THRU#
                      END 
                  SCRPMAX = SCRPMAX * AX$MAXOCCNO[SCRPSCR2];
                                        # ADVANCE OCCURRENCE COUNT     #
                  IF SCRPLVL NQ 1 
                  THEN
                      BEGIN 
                      SCRPEXLEN[SCRPLVL-1] =
                        SCRPEXLEN[SCRPLVL-1] -
                         (AX$MAXOCCNO[SCRPSCR2] * AX$OCCLEN[SCRPSCR2]); 
                      END 
                  SCRPKEYOCCNO[SCRPLVL] = AX$MAXOCCNO[SCRPSCR2];
                  SCRPEXLEN[SCRPLVL] = AX$OCCLEN[SCRPSCR2]; 
                  IF AX$SUBSLVL[SCRPSCR2] EQ SCRPSCR1 
                  THEN
                      BEGIN 
                      SCRPLEN = AX$OCCLEN[SCRPSCR2];
                      END 
                  END 
              SCRPSCR2 = AX$TNEXTPTR[SCRPSCR2]; 
              END 
  
          FOR I = SCRPLVL - 1 STEP -1 UNTIL 1 
          DO
              BEGIN 
              SCRPKEYOCCNO[I] = SCRPKEYOCCNO[I] * SCRPKEYOCCNO[I+1];
              END 
  
          RETURN; 
  
          END       # SETSDEPTH # 
          CONTROL EJECT;
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
#                                                                      #
#         SIGNPOINT - SET SIGN AND POINT.                              #
#                                                                      #
#         GIVEN - NUMERIC DISPLAY OR COMP-1 ITEM IS STORED AT THE      #
#                 BEGINNING OF *DIVALUE*, LEFT-JUSTIFIED.              #
#                 *TABORD* POINTS TO DNT/DNAT ENTRY FOR THAT ITEM.     #
#                                                                      #
#         DOES - REMOVES OVERPUNCHES AND INSERTS + OR - SIGN AT LEFT   #
#                OF ITEM OR MOVES A TRAILING SEPARATE SIGN TO THE      #
#                LEFT.  NOTE THAT THIS INTENTIONALLY LEAVES AN EXPLICIT#
#                + SIGN FOR THESE CASES.                               #
#                ADDS A DECIMAL POINT AND ANY NECESSARY LEADING OR     #
#                TRAILING ZEROS.  A LEADING POINT WILL BE PRECEDED     #
#                BY ONE ZERO.  A TRAILING POINT WILL NOT BE SHOWN.     #
#                                                                      #
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
  
          PROC SIGNPOINT; 
          BEGIN 
  
          ITEM   SP1          I;
          ITEM   SP2          I;
          ITEM   SPC1         C(1); 
          ITEM   SPFN         I;
          ITEM   SPOPVALS     C(40) 
                 = "+0+1+2+3+4+5+6+7+8+9-1-2-3-4-5-6-7-8-9-0";
          ITEM   SPPOINT      I;
          ITEM   SPSIZE       I;
          ITEM   SPST         I;
  
          SPC1 = C<0,1>DIVALUE; 
          IF SPC1 GQ "0" AND SPC1 LQ "9"
          THEN
              BEGIN 
              SPST = 0; 
              END 
          ELSE
              BEGIN 
              IF SPC1 EQ O"72"
              THEN
                  BEGIN 
                  SPC1 = O"00";   # FOR ZERO OV PUNCH                  #
                  END 
              IF SPC1 EQ O"66"
              THEN
                  BEGIN 
                  SPC1 = O"23";   # SET PROPER INDEX                   #
                  END 
              IF SPC1 GQ 0 AND SPC1 LQ O"23"
              THEN
                  BEGIN 
                  FOR SP1 = 18 STEP -1 UNTIL 1
                  DO
                      BEGIN 
                      C<SP1+1,1>DIVALUE = C<SP1,1>DIVALUE;
                      END 
                  C<0,2>DIVALUE = C<SPC1*2,2>SPOPVALS;
                  END 
              SPST = 1; 
              END 
  
          FOR SPFN = 0 STEP 1 WHILE C<SPFN,1>DIVALUE NQ " " 
          DO
              BEGIN 
              TEST SPFN;
              END 
  
          SPFN = SPFN - 1;
          SPC1 = C<SPFN,1>DIVALUE;
          IF SPC1 LS "0" OR SPC1 GR "9" 
          THEN
              BEGIN 
              SPST = 1; 
              FOR SP1 = SPFN-1 STEP -1 UNTIL 0
              DO
                  BEGIN 
                  C<SP1+1,1>DIVALUE = C<SP1,1>DIVALUE;
                  END 
              IF SPC1 EQ "+" OR SPC1 EQ "-" 
              THEN
                  BEGIN 
                  C<0,1>DIVALUE = SPC1; 
                  END 
              ELSE
                  BEGIN 
                  IF SPC1 EQ O"72"
                  THEN
                      BEGIN 
                      SPC1 = O"00"; 
                      END 
                  IF SPC1 EQ O"66"
                  THEN
                      BEGIN 
                      SPC1 = O"23"; 
                      END 
                  C<0,1>DIVALUE = C<SPC1*2,1>SPOPVALS;
                  C<SPFN+1,1>DIVALUE = C<SPC1*2+1,1>SPOPVALS; 
                  SPFN = SPFN + 1;
                  END 
              END 
  
          SPSIZE = SPFN - SPST + 1; 
          SPPOINT = DN$POINT[TABORD]; 
          IF SPPOINT EQ 0 
          THEN
              BEGIN 
              RETURN; 
              END 
  
          IF SPPOINT GQ SPSIZE
          THEN                          # ADD LEADING ZEROS AND POINT  #
              BEGIN 
              SP2 = SPPOINT - SPSIZE + 2; 
              FOR SP1 = SPFN STEP -1 UNTIL SPST 
              DO
                  BEGIN 
                  C<SP1+SP2,1>DIVALUE = C<SP1,1>DIVALUE;
                  END 
              FOR SP1 = SPST+SP2-1 STEP -1 UNTIL SPST+2 
              DO
                  BEGIN 
                  C<SP1,1>DIVALUE = "0";
                  END 
              C<SPST,2>DIVALUE = "0.";
              END 
          ELSE
              BEGIN 
              IF SPPOINT GR 0 
              THEN                      # INSERT POINT BETWEEN DIGITS  #
                  BEGIN 
                  SP2 = SPFN - SPPOINT + 1; 
                  FOR SP1 = SPFN STEP -1 UNTIL SP2
                  DO
                      BEGIN 
                      C<SP1+1,1>DIVALUE = C<SP1,1>DIVALUE;
                      END 
                  C<SP1+1,1>DIVALUE = ".";
                  END 
              ELSE                      # ADD TRAILING ZEROS           #
                  BEGIN 
                  SP2 = SPFN + 1; 
                  FOR SP1 = SPPOINT STEP 1 UNTIL -1 
                  DO
                      BEGIN 
                      C<SP2,1>DIVALUE = "0";
                      SP2 = SP2 + 1;
                      END 
                  END 
              END 
  
          END       # SIGNPOINT # 
CONTROL EJECT;
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
#                                                                      #
#     WRITEDUMP - WRITES THE DUMP OF COBOL DATA DIVISION.              #
#                                                                      #
#     DOES  - PUTS OUT HEADERS FOR CURRENT PROGRAM.                    #
#             LOOP THRU DNT DUMPING CONTENTS OF EACH USER DEFINED      #
#             ENTRY AS PER THE INPUT DIRECTIVES                        #
#                                                                      #
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
  
          PROC WRITEDUMP; 
  
          BEGIN 
  
          SWITCH GETTHEVALS 
                                        #  0 - NEVER USED              #
              ,DNLONG                   #  1 - ALPHABETIC              #
              ,DNLONG                   #  2 - ALPHABETIC EDITED       #
              ,DNLONG                   #  3 - ALPHANUMERIC            #
              ,DNLONG                   #  4 - ALPHANUMERIC EDITED     #
              ,DNTEST                   #  5 - ERROR                   #
              ,DNLONG                   #  6 - NUMERIC EDITED          #
              ,DNLONG                   #  7 - NUMERIC COMP (DISPLAY)  #
              ,DNTEST                   #  8 - EXTERNAL FLOATING POINT #
              ,DNCOMP4                  #  9 - COMP-4                  #
              ,DNCOMP2                  # 10 - COMP-2                  #
              ,DNTEST                   # 11 - DOUBLE PRECISION COMP-2 #
              ,DNCOMP1                  # 12 - COMP-1                  #
              ,DNCOMP1                  # 13 - LINE COUNTER - RPW      #
              ,DNCOMP1                  # 14 - INDEX DATA ITEM         #
              ,DNINDNAME                # 15 - INDEX NAME              #
              ,DNTEST                   # 16 - GROUP                   #
              ,DNTEST                   # 17 - VARIABLE LENGTH GROUP   #
              ,DNTEST                   # 18 - NON DATA TYPE           #
              ,DNBIT                    # 19 - BOOLEAN BIT             #
              ,DNLONG                   # 20 - BOOLEAN DISPLAY         #
              ; 
  
#      PUT OUT HEADERS FOR THIS PROGRAM.                               #
  
          C<0,10>PGMH1B = CCTPROGRI0;   # INSERT PROGRAM-ID IN 1ST HDR #
          C<10,10>PGMH1B = CCTPROGRI1;
          C<20,10>PGMH1B = CCTPROGRI2;
          C<7,2>HDRWORD[4] = "OF";
          HDRWORD[5] = CCTPROGRI0;      # INSERT PROGRAM-ID IN MAIN HDR#
          HDRWORD[6] = CCTPROGRI1;
          HDRWORD[7] = CCTPROGRI2;
          T1 = 8; 
          WRITELINE(PGMHDR1,T1,3);      # PUT OUT 1ST HEADER           #
          T1 = 5; 
          WRITELINE(PGMHDR2,T1,2);      # PUT OUT 2ND HEADER           #
          T1 = 1; 
          WRITELINE(BLANKS,T1,0); 
  
#      START OF DATA NAME PROCESSING.                                  #
  
          FOR TABORD = 1 STEP 1 UNTIL CCTLSTWSDNAT
          DO
              BEGIN 
              IF NOT PRINT$ABLE 
              THEN   # LOOP IF ITEM NOT TO BE PRINTED                  #
                  BEGIN 
                  TEST TABORD;
                  END 
              DIFULL[0] = " ";          # BLANK OUT LINE               #
              CHKFORDUPS = FALSE; 
              DUPLICATES = FALSE; 
              GOTO GETTHEVALS[DN$TYPE[TABORD]];  # GO TO CORRECT
                                                           PROCESSOR   #
  
 DNTEST:  
              TEST TABORD;
  
 DNBIT: 
          PLUGDATANAME; 
          PLUGDATATYPE; 
          SETSDEPTH;
          T1 = COREINDEX; 
          IF  T1 EQ 0 
          THEN
              BEGIN 
              TEST TABORD;
              END 
          P<CHARS> = P<PGMBLOCK> + T1;
          T3 = DN$CHARPOS[TABORD];
          T5 = DN$ITMLEN[TABORD]; 
          BITLENGTH = DN$BITLEN[TABORD];
          NWDS  = (BITLENGTH + 9)/10; 
          IF  NWDS LQ 20
          THEN
              BEGIN 
              P<CSTRING> = LOC(TSTRING);
              END 
          ELSE
              BEGIN 
              P<CSTRING> = CMM$ALF(NWDS,2,0); 
              END 
          PSAVE = P<CSTRING>; 
          T8 = (T3 + SCRPINIT) / 10;
          P<CHARS> = P<CHARS> + T8;    #INCREMENT ADDR FOR SUBSCRIPTS  #
          T3 = T3 + SCRPINIT - T8*10;  #ADJUSTED BCP                   #
          FOR T6 = 1 STEP 1 UNTIL SCRPMAX 
          DO
              BEGIN 
              T7 = 0; 
              T9 = BITLENGTH; 
              IF BITLENGTH GR 100 
              THEN   # DO NOT SUPRESS ITEMS > 100 CHARACTERS IN LENGTH #
                  BEGIN 
                  CHKFORDUPS = FALSE; 
                  END 
              P<CSTRING> = PSAVE; 
              BIT2DSP(CHARS,T3,BITLENGTH,CSTRING);
              FOR  T1 = 0 STEP 100 WHILE T9 NQ 0
              DO
                  BEGIN 
                  T9 = T9 - 100;
                  IF  T9 GQ 0 
                  THEN
                      BEGIN 
                      T8 = 100; 
                      END 
                  ELSE
                      BEGIN 
                      T8 = T9 + 100;
                      T9 = 0; 
                      END 
                  DIVALUE[0] = C<T7,T8>CONVCHARS; 
                  IF  T1 NQ 0 
                  THEN
                      BEGIN 
                      TENCHARS[0] = CDD(T1);
                      C<0,6>DIPLUS = C<4,6>TENCHARS[0]; 
                      C<6,1>DIPLUS = "+"; 
                      END 
                  WRTOCCURENCE(T6,14,0);
                  IF BITLENGTH GR 100 
                  THEN
                      BEGIN 
                      DIFULL[0] = " ";               #BLANK LINE       #
                      END 
                  T2 = (T7 + T8) / 10;
                  P<CSTRING> = P<CSTRING> + T2; 
                  T7 = T7 + T8 - T2*10; 
                  END 
              ADJTHISSCRPT(T3,T6);
              T2 = (T3 + SCRPLEN) / 10; 
              P<CHARS> = P<CHARS> + T2; 
              T3 = T3 + SCRPLEN - T2*10;
              SETOCCURS(T6);
              END 
          P<CSTRING> = PSAVE; 
          IF NWDS GR 20 
          THEN
              BEGIN 
              CMM$FRF(CSTRING); 
              END 
          WRTANYDUPS(T6)
          TEST  TABORD; 
  
 DNCOMP1: 
              IF DN$TYPE[TABORD] EQ LINECTR 
              THEN
                  BEGIN 
                  DINAME[0] = "+++ LINE COUNTER +++"; 
                  END 
              ELSE
                  BEGIN 
                  PLUGDATANAME; 
                  END 
              PLUGDATATYPE; 
              SETSDEPTH;
              T1 = COREINDEX; 
              IF T1 EQ 0
              THEN
                  BEGIN 
                  TEST TABORD;
                  END 
              P<WORDS> = P<PGMBLOCK> + T1 + SCRPINIT/10;
              FOR T6 = 1 STEP 1 UNTIL SCRPMAX 
              DO
                  BEGIN 
                  CONVCOMP1(WORDS); 
                  T2 = 6; 
                  WRTOCCURENCE(T6,T2,0);
                  T2 = 0; 
                  ADJTHISSCRPT(T2,T6);
                  P<WORDS> = P<WORDS> + (SCRPLEN+T2)/10;
                  SETOCCURS(T6);
                  END 
              WRTANYDUPS(SCRPMAX) 
              TEST TABORD;
  
 DNCOMP2: 
              PLUGDATANAME; 
              PLUGDATATYPE; 
              SETSDEPTH;
              T1 = COREINDEX; 
              IF T1 EQ 0
              THEN
                  BEGIN 
                  TEST TABORD;
                  END 
              P<WORDS> = P<PGMBLOCK> + T1 + SCRPINIT/10;
              FOR T6 = 1 STEP 1 UNTIL SCRPMAX 
              DO
                  BEGIN 
                  CVCOMP2(WORDS,0,CHARSCRITEM); 
                  DIVALUE[0] = C<0,23>CHARSCRITEM;
                  T2 = 6; 
                  WRTOCCURENCE(T6,T2,0);
                  T2 = 0; 
                  ADJTHISSCRPT(T2,T6);
                  P<WORDS> = P<WORDS> + (SCRPLEN+T2)/10;
                  SETOCCURS(T6);
                  END 
              WRTANYDUPS(SCRPMAX) 
              TEST TABORD;
  
 DNCOMP4: 
          PLUGDATANAME; 
          PLUGDATATYPE; 
          SETSDEPTH;
          T1 = COREINDEX; 
          IF  T1 EQ 0 
          THEN
              BEGIN 
              TEST TABORD;
              END 
          T8 = (DN$CHARPOS[TABORD] + SCRPINIT)/10;
          P<CHARS> = P<PGMBLOCK> + T1 + T8; 
          T3 = DN$CHARPOS[TABORD] + SCRPINIT - T8*10; 
          T5 = DN$ITMLEN[TABORD] * 6; 
          FOR T6 = 1 STEP 1 UNTIL SCRPMAX 
          DO
              BEGIN 
              I = B<6*T3,T5>PGMCHARS; 
              IF  B<6*T3,1 >PGMCHARS EQ 1 AND DN$SIGNBIT[TABORD] NQ 0 
              THEN
                  BEGIN 
                  B<0,60-T5>I = B<0,60-T5>SEVENS; 
                  END 
              CONVCOMP1(I); 
              T2 = 6; 
              WRTOCCURENCE(T6,T2,0);
              ADJTHISSCRPT(T3,T6);
              T2 = (T3 + SCRPLEN) / 10; 
              P<CHARS> = P<CHARS> + T2; 
              T3 = T3 + SCRPLEN - T2*10;
              SETOCCURS(T6);
              END 
          WRTANYDUPS(SCRPMAX) 
          TEST TABORD;
  
 DNINDNAME: 
              PLUGDATANAME; 
              PLUGDATATYPE; 
              T1 = COREINDEX; 
              IF T1 EQ 0
              THEN
                  BEGIN 
                  TEST TABORD;
                  END 
              P<WORDS> = P<PGMBLOCK> + T1;
              CONVCOMP1(AWD[0] LAN O"7777777777");
              T1 = 6; 
              WRITELINE(DILINE,T1,0); 
              TEST TABORD;
  
 DNLONG:  
              PLUGDATANAME; 
              PLUGDATATYPE; 
              SETSDEPTH;
              T1 = COREINDEX; 
              IF T1 EQ 0
              THEN
                  BEGIN 
                  TEST TABORD;
                  END 
              P<CHARS> = P<PGMBLOCK> + T1;
              T3 = DN$CHARPOS[TABORD];
              T5 = DN$ITMLEN[TABORD]; 
              IF T3 + T5 LQ 10 AND SCRPMAX EQ 1 
              THEN            # IF ENTIRE ITEM FITS IN 1ST 10 CHARS    #
                              # AND IF UN-SUBSCRIPTED                  #
                  BEGIN 
                  DIVALUE[0] = C<T3,T5>PGMCHARS;
                  IF DN$TYPE[TABORD] EQ COMP
                  THEN
                      BEGIN 
                      SIGNPOINT;
                      END 
                  T1 = 5; 
                  WRITELINE(DILINE,T1,0); 
                  END 
              ELSE            # IF BIGGER THAN 10 CHARS OR SUBSCRIPTED #
                  BEGIN 
                  T8 = (T3 + SCRPINIT) / 10;      # SET LOCATION OF    #
                  P<CHARS> = P<CHARS> + T8;       # 1ST OCCURRENCE     #
                  T3 = T3 + SCRPINIT - T8*10; 
                  FOR T6 = 1 STEP 1 UNTIL SCRPMAX 
                  DO
                      BEGIN 
                      T7 = T3;
                      T9 = T5;
                      IF T5 GR 100
                      THEN   # DONT SUPRESS ITEMS > 100 CHARS IN LENGTH#
                          BEGIN 
                          CHKFORDUPS = FALSE; 
                          END 
                      T10 = P<CHARS>; 
                      FOR T1 = 0 STEP 100 WHILE T9 NQ 0 
                      DO
                          BEGIN 
                          T9 = T9 - 100;# T9 = CHARS LEFT IN ITEM      #
                          IF T9 GQ 0    # T8 = NO. OF CHARS TO PRINT
                                               THIS LINE               #
                          THEN
                              BEGIN 
                              T8 = 100; 
                              END 
                          ELSE
                              BEGIN 
                              T8 = T9 + 100;
                              T9 = 0; 
                              END 
                          DIVALUE[0] = C<T7,T8>PGMCHARS;
                                        # INSERT DISPLAY CHARS IN LINE #
                          IF T1 NQ 0
                          THEN
                              BEGIN 
                              TENCHARS[0] = CDD(T1);
                              C<0,6>DIPLUS = C<4,6>TENCHARS[0]; 
                              C<6,1>DIPLUS = "+"; 
                              END 
                          IF DN$TYPE[TABORD] EQ COMP
                          THEN
                              BEGIN 
                              SIGNPOINT;
                              END 
                          T2 = 14;
                          WRTOCCURENCE(T6,T2,0);
                          IF T5 GR 100
                          THEN
                              BEGIN 
                              DIFULL[0] = " ";        # BLANK OUT LINE #
                              END 
                          T2 = (T7 + T8) / 10;
                          P<CHARS> = P<CHARS> + T2; 
                          T7 = T7 + T8 - T2*10; 
                          END 
                      ADJTHISSCRPT(T3,T6);
                      T2 = (T3 + SCRPLEN) / 10; 
                      P<CHARS> = T10 + T2;
                      T3 = T3 + SCRPLEN - T2*10;
                      SETOCCURS(T6);
                      END 
                  WRTANYDUPS(SCRPMAX) 
                 CHKFORDUPS = FALSE;
                  END 
              END 
  
#      ALL FINISHED PROCESSING CURRENT PROGRAM.  FREE THOSE BLOCKS     #
#      CONTAINING COMPILER TABLES FOR IT AND DO NEXT PROGRAM, IF ONE.  #
  
          CMM$FRF(USETAB);
          CMM$FRF(DNT); 
          CMM$FRF(AUXT);
          CMM$FRF(NAMET); 
  
          END   # OF WRITEDUMP# 
          CONTROL EJECT;
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
#                                                                      #
#      WRITELINE - SEND A LINE TO THE OUTPUT FILE.                     #
#                                                                      #
#      GIVEN - PARAM 1:  FWA OF LINE.                                  #
#              PARAM 2:  NUMBER OF WORDS IN LINE.                      #
#              PARAM 3:  NUMBER OF LINES TO SKIP BEFORE SENDING LINE.  #
#              T6:       OCCURENCE NUMBER.                             #
#                                                                      #
#      DOES - PUTS OUT PAGE HEADER WHEN NECESSARY.  PUTS OUT LINE.     #
#             PUTS OUT TRAILER AT BOTTOM OF PAGE WHEN NECESSARY.       #
#                                                                      #
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
  
          PROC WRITELINE(A,B,(C));
  
          BEGIN 
  
          ITEM   A            I;
          ITEM   B            I;
          ITEM   C            I;
          ITEM   WLTMP        I;
          ITEM   WRITEDUPS    B = FALSE;
  
#     CHECK FOR DUPLICATE LINES                                        #
  
          IF CHKFORDUPS 
          THEN
              BEGIN 
              IF PASTLINE EQ DIVALUE[0] 
              THEN   # CURRENT LINE = PAST LINE                        #
                  BEGIN 
                  IF OCCURSHIGH + 1 EQ T6 
                  THEN   #  CURRENT LINE IS NEXT OCCURENCE HENCE WE    #
                      BEGIN  # HAVE A MATCH SO DONT PRINT              #
                      OCCURSHIGH = T6;
                      DUPLICATES = TRUE;
                      RETURN; 
                      END 
                  END 
  
#     PRINT RANGE OF DUPLICATE LINES                                   #
  
              IF DUPLICATES 
              THEN
                  BEGIN 
                  TENCHARS[0] = CDD(OCCURSLOW); 
                  OCCLOW[0] = C<4,6>TENCHARS[0];
                  TENCHARS[0] = CDD(OCCURSHIGH);
                  OCCHIGH[0] = C<4,6>TENCHARS[0]; 
                  WRITEDUPS = TRUE; 
                  END 
              DUPLICATES = FALSE; 
              CHKFORDUPS = FALSE; 
              END 
  
#     PRINT CURRENT LINE                                               #
  
WLINE1: 
          IF NEWPAGE NQ 0 
          THEN
              BEGIN 
              SETHDR;                             # SET UP MAIN HEADER #
              TDWRITH(LSTFN,MAINHDR,13);
              C = 3;
              LINECT = 1; 
              NEWPAGE = 0;
              END 
  
          IF LINECT + C + 5 GR PAGESIZE 
          THEN
              BEGIN 
              WRTRAILER;
              GOTO WLINE1;
              END 
  
          IF WRITEDUPS
          THEN
              BEGIN 
              LINECT = LINECT + 1;
              TDWRITH(LSTFN,SAMELINE,7);
              WRITEDUPS = FALSE;
              END 
  
          FOR WLTMP = C-1 STEP -1 UNTIL 0 
          DO    # PUT OUT BLANK LINES                                  #
              BEGIN 
              TDWRITH(LSTFN,BLANKS,1);
              END 
  
          LINECT = LINECT + C + 1;
          TDWRITH(LSTFN,A,B);                     # PUT OUT LINE       #
          IF LINECT EQ PAGESIZE 
          THEN
              BEGIN 
              WRTRAILER;
              END 
  
          RETURN; 
  
          END       # WRITELINE # 
CONTROL EJECT;
#* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * #
#                                                                      #
#     WRTOCCURENCE(NTH, SIZE, BLANKLINES)                              #
#                                                                      #
#     GIVEN - NTH = OCCURRENCE NUMBER.                                 #
#             SIZE = NUMBER OF WORDS IN LINE.                          #
#             BLANKLINES = NUMBER OF BLANK LINES TO PRINT BEFORE.      #
#                                                                      #
#     DOES  - IF OCCURENCEFLG THEN ITEM MUST BE IN DIRECTIVES LIST FROM#
#             AN OCCURRENCE DIRECTIVE SEE IF IT IS WITHIN THE          #
#             OCCURRENCE BOUNDARIES, IF SO PRINT IT, IF NOT RETURN.    #
#             IF NOT OCCURENCEFLG THEN PRINT IT.                       #
#                                                                      #
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
  
          PROC WRTOCCURENCE(NTH, SIZE, BLANKLINES); 
  
          BEGIN 
  
          ITEM   BLANKLINES    U; 
          ITEM   NTH           U; 
          ITEM   SIZE          U; 
  
          IF NOT OCCURENCEFLG 
          THEN   # PRINT ITEM                                          #
              BEGIN 
              WRITELINE(DILINE,SIZE,BLANKLINES);
              END 
          ELSE   # SEE IF ITEM WITHIN OCCURENCE RANGE                  #
              BEGIN 
              LINKPTR = LISTPOINTER;
              FOR I = I WHILE LINKPTR GQ 0
              DO
                  BEGIN 
                  IF LSTFSTLIT[LINKPTR] LQ NTH
                     AND LSTSCNDLIT[LINKPTR] GQ NTH 
                  THEN
                      BEGIN 
                      IF LIMITEDARRAY 
                      THEN
                          BEGIN 
                          PLUGDATATYPE; 
                          LIMITEDARRAY = FALSE; 
                          CHKFORDUPS = FALSE; 
                          END 
                      WRITELINE(DILINE,SIZE,BLANKLINES);
                      LINKPTR = -1; 
                      END 
                  ELSE
                      BEGIN 
                      LINKPTR = LSTLINK[LINKPTR]; 
                      END 
                  END 
              END 
  
          RETURN; 
  
          END   # OF WRTOCCURENCE                                      #
CONTROL EJECT;
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
#                                                                      #
#      WRTRAILER - WRITE TRAILER.                                      #
#                                                                      #
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *#
  
          PROC WRTRAILER; 
  
          BEGIN 
  
          IF NEWPAGE EQ 0 
          THEN
              BEGIN 
              TDWRITH(LSTFN,BLANKS,1);      # 2 BLANK LINES            #
              TDWRITH(LSTFN,BLANKS,1);
              TDWRITH(LSTFN,TRAILER1,14);   # 1ST LINE OF TRAILER      #
              TDWRITH(LSTFN,TRAILER2,14);   # 2ND LINE OF TRAILER      #
              NEWPAGE = 1;
              END 
  
          RETURN; 
  
          END       # WRTRAILER # 
CONTROL EJECT;
  
#     GLOBAL CODE.                                                     #
  
          CRACKCNTRLCD;      # CRACK THE CONTROL CARD PARAMETERS       #
  
          TDFET(TDFN,ZZFN,LSTFN,DIRFN);  # CREATE FETS AND BUFFERS     #
          TDREW(ZZFN);                   # REWIND DUMP FILE            #
  
          IF DIRECTIVES 
          THEN
              BEGIN   # READ INPUT DIRECTIVES                          #
              READ$DIRCTVS; 
              END 
  
          TDREAD(ZZFN); 
          FIRST = TRUE; 
  
          FOR I=I WHILE TDREADW(ZZFN,DUMPCTL,1) EQ 0
          DO   # LOOP THRU EACH DUMP ON THE DUMP FILE                  #
              BEGIN 
              DUMP$HEADNGS;  # WRITE SNAP HEADNGS,PARA TRACE, LAST LINE#
              TDREW(TDFN);   # REWIND TDF                              #
              READPGMBLKS;   # READ PRGMS AND COMMON BLKS FOR THIS DUMP#
  
#     READ IN EACH CCT FROM TDFILE, IF THIS PROGRAM NOT IN CORE IMAGE 
      READ FROM ZZFN THEN SKIP TO NEXT CCT AND TRY AGAIN, IF PROGRAM IS 
      IN CORE IMAGE DO THE DUMP.  EXIT LOOP WHEN EOF ON TDFILE         #
  
              FIRST = TRUE; 
              FOR I=I WHILE ANOTHERCCT
              DO
                  BEGIN 
                  FIRST = FALSE;
                  IF PGMINCORE
                  THEN
                      BEGIN            # PROGRAM IN CORE IMAGE         #
                      RDRESTOFTBLS;    # READ REMAINDER OF TABLES      #
                      WRITEDUMP;       # DO THE DUMP                   #
                      WRTRAILER;
                      END 
                  ELSE
                      BEGIN            # PROGRAM NOT IN CORE IMAGE     #
                      TDSKIPF(TDFN,5); # SKIP REMAINING TABLES ON TDF  #
                      END 
                  END  # OF THIS DUMP                                  #
              CMM$FRF(PGMBLOCK);
  
              IF FIRST
              THEN
                  BEGIN 
                  TDEMPTY;
                  END 
  
              END 
  
#     ALL FINISHED CLEAN-UP AND STOP                                   #
  
          TDRET(ZZFN);
          TDWRITR(LSTFN); 
          IF DIRECTIVES 
          THEN
              BEGIN 
              CMM$FRF(LISTARRAY); 
              END 
  
          STOP; 
  
          END    # C5TDUMP                                             #
  
          TERM
