*DECK DATAMAP 
USETEXT CCTTEXT 
USETEXT DNTEXT
          PRGM DATAMAP; 
# 
**        DATAMAP - CREATE MEMORY MAPS OF THE DATA DIVISION AND 
*                   PROCEDURE DIVISION, AND OUTPUT THEM TO THE LIST FILE
* 
*                                                                      #
      BEGIN                  #DATAMAP#
# COMMON DECKS #
# CCT#
# AUXT #
*CALL AUXT1 
# AUXTVALS #
*CALL,AUXTVALS
# DNAT #
# DNATVALS #
*CALL,DNATVALS
# DNT # 
*CALL,DNT 
                    #FNATVALS#
*CALL FNATVALS
                     #PLT1# 
*CALL PLT1
# TABLETYP #
*CALL,TABLETYP
# USETAB #
*CALL,USETAB
# FNAT #
*CALL FNAT1 
# PNT # 
*CALL,PNT 
# PNAT #
*CALL PNAT1 
# LISTCTL # 
*CALL,LISTCTL 
*CALL,ASSEMOP 
*CALL TABLEDF 
*CALL NAMET 
        CONTROL EJECT;
# EXTERNAL ROUTINES REQUIRED #
          XREF PROC CMM$FGR;  #CMM FREE GROUP ROUTINE#
          XREF ITEM USEID I;  #GROUP NUMBER OF USE BLOCKS#
        XREF FUNC DEC C(10);  #CONVERT DATA TO DECIMAL DISPLAY# 
        XREF FUNC OCT C(40);  #CONVERT DATA TO OCTAL DISPLAY# 
        XREF FUNC VIRTUAL;  #ENSURE TABLE ENTRY IN CORE#
        XREF ITEM LISTHED C(90);  #TITLE ON EACH PAGE OF LISTING# 
        XREF ITEM LISTTYP C(20);  #TYPE FIELD OF (LISTING) TITLE# 
        XREF PROC CBLIST;    #WRITE ONTO LIST FILE# 
        XREF PROC OVERRTN;   #RETURN FROM OVERLAY#
        XREF PROC TMRECL;    #-CLOSE- TABLE WHICH HAS BEEN -REOPEN-ED#
        XREF PROC TMREOP;    #ENSURE TABLE IS -OPEN-# 
  
  
# ITEMS # 
        ITEM TABORD   U;     #ENTRY ORDINAL IN DNT AND DNAT#
        ITEM LEVEL    U;     #ENTRY LEVEL NUMBER# 
        ITEM IX       U;     #AN INDEX INTO A TABLE#
        ITEM IXAUXT   U;     #INDEX IN CORE OF AUXTABLE ENTRY#
        ITEM IXDNT    U;     #INDEX IN CORE OF DNT ENTRY# 
         DEF IXPNT  #IXDNT#;  #INDEX IN CORE OF PNT ENTRY#
        ITEM IXDNAT   U;     #INDEX IN CORE OF DNAT ENTRY#
         DEF IXPNAT  #IXDNAT#;  #INDEX IN CORE OF PNAT ENTRY# 
        ITEM IXFNAT   U;     #INDEX IN CORE OF FNAT ENTRY#
            ITEM RECEIVE C(10); 
        ITEM FTFLAG   U;     #FLAG - 0 IF 1ST TIME THRU SECTION HEADER
                               CODE, 1 IF 1ST TIME THRU OTHER ENTRY(S)
                                     2, IF COLUMN HDRS (NOT -SZ=-) DONE 
                                     3, IF "SZ=- COLUMN HEADER DONE#
        CONTROL IFNQ CB5$CDCS,"NO"; 
        ITEM SSFLAG   U=0;   #FLAG - 0 IF NO SUB-SCHEMA DATA
                                     1 IF PROCESSING SS DATA
                                     2 IF DONE PROCESSING SS DATA 
                                     3 IF -LNR- ON MAP (1ST ITEM AFTER
                                       SS DATA)#
        CONTROL FI; 
        ITEM BLKNAMSV C(7) = "       ";  #NAME OF LAST BLOCK PRINTED# 
        ITEM ADDR     U;     #ADDRESS, WITHIN BLOCK, OF ITEM# 
        ITEM BCP      U;     #BCP (WITHIN WORD) OF ITEM#
         DEF CODEBLKADDR  #BCP#;  #ADDRESS OF -CODE- BLOCK# 
        ITEM FNSAVE   C(8);  #FILE NAME#
        ITEM OCCLENS  U;     #SUM OF 1 OCCURRENCE PER S BSCRIPT DEPTH#
  
  
# ARRAYS #
        ARRAY [0:0] S (13);  #PRINT LINE# 
        BEGIN 
          ITEM DMLINE   C ( 0, 0,130);
          ITEM DMHEADR  C ( 4,12, 51);
          ITEM DMTRAILR C ( 5,54, 20);
          ITEM DMSECNM  C ( 3, 0, 30);
          ITEM DMLP     C ( 1, 6,  1);
          ITEM DMITMFN  C ( 1,12,  8);
          ITEM DMASTK   C ( 0,18,  1);
          ITEM DMFD     C ( 0,24,  2);
          ITEM DMITMLVL C ( 0,36,  2);
          ITEM DMITMLVL1 C ( 0,42,  1); 
          ITEM DMREDREN C ( 0,48,  1);
          ITEM DMIDXITM C ( 0,36,  3);
          ITEM DMITMNAM1 C ( 1, 0, 10); 
          ITEM DMITMNAM2 C ( 2, 0, 10); 
          ITEM DMITMNAM3 C ( 3, 0, 10); 
          ITEM PMSEC    C ( 1,12,  8);
          ITEM PMNAM1   C ( 2, 0, 10);
          ITEM PMNAM2   C ( 3, 0, 10);
          ITEM PMNAM3   C ( 4, 0, 10);
          ITEM DMBLOCKNTRY C (4,12,22); 
          ITEM DMBLOCK  C ( 4,12,  6);
          ITEM DMBLKNM  C ( 4,48,  7);
          ITEM DMBLKSL1 C ( 4,48,  1);
          ITEM DMBLKNMC C ( 4,54,  8);
          ITEM DMADDBCP C ( 5,48,  9);
         CONTROL IFNQ CB5$CDCS,"NO";
          ITEM DMREL    C (6,42,  9); 
         CONTROL FI;
          ITEM DMITMADD C ( 6,42,  6);
          ITEM PMADD    C ( 6,42,  6);
          ITEM DMSLASH  C ( 7,18,  1);
          ITEM DMITMBCP C ( 7,24,  2);
          ITEM DMSZ     C ( 7,42,  3);
          ITEM DMITMSZ  C ( 8, 0,  6);
          ITEM DMITMTYP C ( 8,54, 10);
          ITEM DMITMSYN C (10, 0,  7);
          ITEM DMLNR    C (11, 0,  4);
          CONTROL IFNQ CB5$CDCS,"NO"; 
          ITEM DMITMLNRX C (11, 0,  9); 
          CONTROL FI; 
          ITEM DMITMLNR C (11,24,  5);
          ITEM PMLNR    C (11,24,  5);
        END 
        ARRAY [0:6] S (3);  #SECTION HEADERS# 
        ITEM SECTHDR C (0,0,30) = 
          [ "FILE SECTION", 
            "WORKING-STORAGE SECTION",
            "LINKAGE SECTION",
            "COMMUNICATION SECTION",
            "REPORT SECTION", 
            "COMMON-STORAGE SECTION", 
            "SECONDARY-STORAGE SECTION" ];
        ARRAY [0:3] S (1);  #RECORD DESCRIPTION HEADERS#
        ITEM DESCHDR C (0,0,10) = 
          [ "FD", "SD", "CD", "RD" ]; 
        ARRAY [1:17] S(1);  #DNAT -TYPE- FIELD VALUES#
        ITEM DNTYPE C (0,0,10) =
          [ "ALPHA",
            "ALPHA-EDIT", 
            "AN", 
            "AN-EDIT",
            "ERROR",
            "NUM-EDIT", 
            "NUMERIC",
            "EXT FLT PT", 
            "INT DEC",
            "COMP-2", 
            "DP COMP-2",
            "COMP-1", 
            "LINE CNTR",
            "INDEX ITEM", 
            "INDEX-NAME", 
            "GROUP",
              "VAR LG GRP", 
              "          ", 
              "BOOLBIT   ", 
              "BOOLEAN   " ]; 
 # ITEMS USED BY GETNAME #
          ITEM W1  C(10); 
          ITEM W2  C(10); 
          ITEM W3  C(10); 
          ITEM NAMETPTR I;
          ITEM NBRWORDS I;
          CONTROL EJECT;
          PROC GETNAME; 
 # * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 *
 *        GETNAME - GETS NAME FROM NAME TABLE 
 *
 *        INPUTS ARE NAMETPTR WITH POINTER TO NAME TABLE AND NBRWORDS 
 *               WITH NUMBER OF WORDS IN ENTRY
 *        OUTPUT IS IN W1 TO W3 
 *
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * #
  
          BEGIN 
          IF NAMETPTR EQ 0
          THEN
            BEGIN    # NO POINTER - NO NAME # 
            W1 = "          ";
            W2 = "          ";
            W3 = "          ";
            RETURN; 
            END 
          W1 = NAMET$CHARS[VIRTUAL(TABLETYPE"NAMET$", NAMETPTR)]; 
          IF NBRWORDS GR 1
          THEN
            BEGIN 
            W2 = NAMET$CHARS[VIRTUAL(TABLETYPE"NAMET$", NAMETPTR + 1)]; 
            IF NBRWORDS GR 2
            THEN
              W3 = NAMET$CHARS[VIRTUAL(TABLETYPE"NAMET$", NAMETPTR+2)]; 
            ELSE
              W3 = "          ";
            END 
          ELSE
            BEGIN 
            W2 = "          ";
            W3 = "          ";
            END 
          RETURN; 
          END 
          CONTROL EJECT;
          PROC GETTYPE(RET);
 #     THIS PROCEDURE DETERMINES THE DATA TYPE FOR THE   #
 #     DNAT IN IXDNAT, AND RETURNS IS TYPE NAME IN RET   #
          ITEM RET C(10); 
          BEGIN 
          IF DN$TYPE[IXDNAT] EQ ALPHABET THEN 
            RET = "ALPHABET"; 
          IF DN$TYPE[IXDNAT] EQ ALPHEDIT THEN 
            RET = "ALPHAEDIT";
          IF DN$TYPE[IXDNAT] EQ ALPHNUM THEN
            RET = "ALPHNUM";
          IF DN$TYPE[IXDNAT] EQ ALPNUMED THEN 
            RET = "ALPHNUMED";
          IF DN$TYPE[IXDNAT] EQ ERRTYPE THEN
            RET = "ERRTYPE";
          IF DN$TYPE[IXDNAT] EQ NUMEDIT THEN
            RET = "NUMEDIT";
          IF DN$TYPE[IXDNAT] EQ COMP THEN 
            RET = "COMP"; 
          IF DN$TYPE[IXDNAT] EQ EXTFLOAT THEN 
            RET = "EXTFLOAT"; 
          IF DN$TYPE[IXDNAT] EQ COMP4 THEN
            RET = "COMP4";
          IF DN$TYPE[IXDNAT] EQ COMP2 THEN
            RET = "COMP2";
          IF DN$TYPE[IXDNAT] EQ DPCOMP2 THEN
            RET = "DPCOMP2";
          IF DN$TYPE[IXDNAT] EQ COMP1 THEN
            RET = "COMP1";
          IF DN$TYPE[IXDNAT] EQ GROUP THEN
            RET = "GROUP";
          IF DN$TYPE[IXDNAT] EQ VARGROUP THEN 
            RET = "VARGROUP"; 
          RETURN; 
          END 
          CONTROL EJECT;
           PROC PUTRCVE(LOCN);
 # THIS PROCEDURE DETERMINES THE SIZE OF THE NUMBER IN RECEIVE #
          ITEM LOCN I;
          BEGIN 
          FOR LOCN = 0  WHILE 
            C<LOCN,1>RECEIVE NQ " " DO
           LOCN = LOCN + 1; 
          RETURN; 
          END;
# AND RETURNS ITS SIZE #
          CONTROL EJECT;
          PROC FMADUMP; 
  
#     DUMPS FILE FMAFILE FOR USE BY FMA     # 
  
          XREF ITEM FMAFET; 
  
          XREF PROC PUTSQ;
               ITEM CHARPTR I;
               ITEM ITEMBCP I;
               ITEM SUBTRAKR I; 
               ITEM FMAWS C(140); 
               ITEM OCCNT I;
               ITEM IXPLT;
               ITEM IXPLTSTR; 
               ITEM LASTWD C(10); 
               BEGIN
               TMREOP(TABLETYPE"PLT$"); 
               TMREOP(TABLETYPE"PLTSTR$");
#     FIRST STEP THRU DNAT UNTIL FIRST FD IS FOUND     #
               TABORD = 15; 
 FNDFD: 
               IXDNAT = VIRTUAL(TABLETYPE"DNAT$", TABORD);
               IF (DN$LEVEL[IXDNAT] NQ FDDESCR) AND 
                 (DN$LEVEL[IXDNAT] NQ SDDESCR) THEN 
                 BEGIN
                 TABORD = TABORD + 1; 
                 IF TABORD GR CCTDNATLEN THEN 
                   GOTO ENDIT;
                 ELSE 
                   BEGIN
                   IXDNAT = VIRTUAL(TABLETYPE"DNAT$", TABORD);
                   GOTO FNDFD;
                   END
                 END
                 GOTO DODUMP; 
 UPTAB: 
                 TABORD = TABORD + 1; 
                 IF TABORD GR CCTDNTLEN THEN
                   GOTO ENDIT;
                 ELSE 
                   IXDNAT = VIRTUAL(TABLETYPE"DNAT$", TABORD);
 DODUMP:  
                   FMAWS = " "; 
                   IF DN$LEVEL[IXDNAT] EQ WSSECTN THEN
                     BEGIN
                     C<0, 3>FMAWS = "WSS";
                     PUTSQ(FMAFET, LOC(FMAWS), 140);
                     GOTO UPTAB;
                     END
                   IF DN$LEVEL[IXDNAT] EQ LKSECTN THEN
                     BEGIN
                     C<0, 3>FMAWS = "LKS";
                     PUTSQ(FMAFET, LOC(FMAWS), 140);
                     GOTO UPTAB;
                     END
                   IF DN$LEVEL[IXDNAT] EQ CDSECTN THEN
                     BEGIN
                     C<0, 3> FMAWS = "CDS"; 
                     PUTSQ(FMAFET, LOC(FMAWS), 140);
                     GOTO UPTAB;
                     END
                   IF DN$LEVEL[IXDNAT] EQ RDSECTN THEN
                     BEGIN
                     C<0, 3>FMAWS = "RDS";
                     PUTSQ(FMAFET, LOC(FMAWS), 140);
                     GOTO UPTAB;
                     END
                   IF DN$LEVEL[IXDNAT] EQ CSSECTN THEN
                     BEGIN
                     C<0, 3>FMAWS = "CSS";
                     PUTSQ(FMAFET, LOC(FMAWS), 140);
                     GOTO UPTAB;
                     END
                   IF DN$TYPE[IXDNAT] EQ ERRTYPE THEN 
                      GOTO UPTAB; 
                   RECEIVE = DEC(TABORD); 
                   PUTRCVE(CHARPTR);
                   C<3,5>FMAWS = "00000"; 
                   C<8-CHARPTR,CHARPTR>FMAWS =
                      C<0,CHARPTR>RECEIVE; #INDEX#
                   IXDNT = VIRTUAL(TABLETYPE"DNT$", TABORD);
                   NAMETPTR = DNTNAMETPTR[IXDNT]; 
                   NBRWORDS = DNTNBRWORDS[IXDNT]; 
                   GETNAME;   #PICK UP NAME FROM NAMET# 
                   NBRWORDS = NBRWORDS * 10;
                   C<15,10>FMAWS = W1;   #MOVE NAME TO FMAFILE# 
                   C<25,10>FMAWS = W2;
                   C<35,10>FMAWS = W3;
                   LASTWD = W1;   #DETERMINE NO. OF CHARACTERS IN NAME# 
                   IF NBRWORDS GR 10 THEN 
                     LASTWD = W2; 
                   IF NBRWORDS GR 20 THEN 
                     LASTWD = W3; 
                   FOR CHARPTR = 9 STEP -1 WHILE
                     C<CHARPTR,1>LASTWD EQ " " DO 
                     NBRWORDS = NBRWORDS - 1; 
                   RECEIVE = DEC(NBRWORDS); 
                   PUTRCVE(CHARPTR);
                   C<46,2>FMAWS = "00"; 
                   C<48-CHARPTR,CHARPTR>FMAWS = 
                     C<0,CHARPTR>RECEIVE;   #MOVE NAME LENGTH#
                   IF DNTNOTUNIQUE[IXDNT] EQ 1 THEN 
                     C<45,1>FMAWS = "T";
                     ELSE C<45,1>FMAWS = "F"; 
                   RECEIVE = DEC(DN$LINE[IXDNAT]);
                   PUTRCVE(CHARPTR);
                   C<10,5>FMAWS = "00000";
                   C<15-CHARPTR,CHARPTR>FMAWS = 
                     C<0,CHARPTR>RECEIVE; 
                   C<0,3>FMAWS = "LEV"; 
                   IF DN$LEVEL[IXDNAT] NQ 88 THEN 
                     GOTO DO66; 
                   C<8,2>FMAWS = "88"; #PROCESS 88'S# 
                   GOTO WRITEIT;
 DO66:     #IF LEVEL IS 66, PROCESS IT# 
                   IF DN$LEVEL[IXDNAT] NQ 66 THEN 
                     GOTO DOFD; 
                   C<8,2>FMAWS = "66";
                   RECEIVE = DEC(DN$STRENAM[IXDNAT]); 
                   PUTRCVE(CHARPTR);
                   C<133,5>FMAWS = "00000"; 
                   C<138-CHARPTR,CHARPTR>FMAWS =
                     C<0,CHARPTR>RECEIVE; 
                   RECEIVE = DEC(DN$ENRENAM[IXDNAT]); 
                   PUTRCVE(CHARPTR);
                   C<67,5>FMAWS = "00000";
                   C<72-CHARPTR,CHARPTR>FMAWS = 
                    C<0,CHARPTR>RECEIVE;
                   GETTYPE(RECEIVE);  #GET DATA TYPE# 
                   C<56,10>FMAWS = RECEIVE; 
                   GOTO WRITEIT;
 DOFD:  
                   IF (DN$LEVEL[IXDNAT] NQ FDDESCR) AND 
                     (DN$LEVEL[IXDNAT] NQ SDDESCR) THEN 
                     GOTO DO149;
                   C<0,3>FMAWS = "FIL"; 
                   IF DN$LEVEL[IXDNAT] EQ SDDESCR THEN
                     C<8,2>FMAWS = "SD";
                     ELSE C<8,2>FMAWS = "FD"; 
                   IXFNAT = VIRTUAL(TABLETYPE"FNAT$", 
                     DN$FNATPTR[IXDNAT]); 
                   IXPLT = VIRTUAL(TABLETYPE"PLT$", 
                     FN$DVCEPTR[IXFNAT]); 
                   IXPLTSTR = VIRTUAL(TABLETYPE"PLTSTR$", 
                     PL$STRINGPTR[IXPLT]);
                   C<48,7>FMAWS = C<0,7>PLT$CHAR[IXPLTSTR]; 
                   C<79, 2>FMAWS = "00";
                   RECEIVE  = DEC(DN$FNATPTR[IXDNAT]);
                   PUTRCVE(CHARPTR);
                   C<81-CHARPTR, CHARPTR>FMAWS = C<0, CHARPTR>RECEIVE;
                   GOTO WRITEIT;
 DO149:          #PROCESS ITEMS WITH LEVELS 01 TO 49 #
                 IF (DN$LEVEL[IXDNAT] LS 1) OR
                   (DN$LEVEL[IXDNAT] GR 49) THEN
                   IF DN$LEVEL[IXDNAT] NQ 77 THEN 
                     GOTO UPTAB;
                 #MUST SAVE BEGINNING POSITION OF RECORD IN SUBTRAKR# 
                 IF DN$LEVEL[IXDNAT] EQ 1 THEN
                   SUBTRAKR = DN$BYTEOFFS[IXDNAT];
                 RECEIVE = DEC(DN$LEVEL[IXDNAT]); 
                 PUTRCVE(CHARPTR);
                 C<8,2>FMAWS = "00";
                 C<10-CHARPTR,CHARPTR>FMAWS = 
                     C<0,CHARPTR>RECEIVE; 
                 #SUBTRACT BEGINNING WORD POS OF RECORD FROM BYTEOFFSET#
                 ITEMBCP = DN$BYTEOFFS[IXDNAT] - SUBTRAKR;
                 ITEMBCP = ITEMBCP * 10; #WORD OFFSET * 10# 
                 ITEMBCP = ITEMBCP + DN$CHARPOS[IXDNAT];
                 RECEIVE = DEC(ITEMBCP);
                 PUTRCVE(CHARPTR);
                 C<48,7>FMAWS = "0000000";
                 C<55-CHARPTR,CHARPTR>FMAWS = 
                    C<0,CHARPTR>RECEIVE;
                 IF DN$FILLREF[IXDNAT] EQ 1 THEN
                   C<72,1>FMAWS = "T";
                   ELSE C<72,1>FMAWS = "F"; 
                 RECEIVE = DEC(DN$ITMLEN[IXDNAT]);
                 PUTRCVE(CHARPTR);
                 C<73,7>FMAWS = "0000000";
                 C<80-CHARPTR,CHARPTR>FMAWS = 
                    C<0,CHARPTR>RECEIVE;
                 IF DN$RDEF[IXDNAT] EQ 1 THEN 
                   C<123,1>FMAWS = "T"; 
                   ELSE C<123,1>FMAWS = "F";
                 RECEIVE = DEC(DN$SDEPTH[IXDNAT]);
                 PUTRCVE(CHARPTR);
                 C<129,2>FMAWS = "00";
                 C<131-CHARPTR,CHARPTR>FMAWS =
                     C<0,CHARPTR>RECEIVE; 
                 IF DN$SDEPTH[IXDNAT] NQ 0 THEN 
                   BEGIN
                   IF DN$DEP[IXDNAT] EQ 1 THEN
                     C<66,1>FMAWS = "T";
                     ELSE C<66,1>FMAWS = "F"; 
                   IF DN$DEP[IXDNAT] EQ 1 THEN
                     BEGIN
                     IXAUXT = VIRTUAL(TABLETYPE"AUX$",
                       DN$AUXREF[IXDNAT]);
                     FOR IXAUXT = IXAUXT WHILE AX$TTYPE[IXAUXT] NQ
                       VAROCCUR DO
                       IXAUXT = VIRTUAL(TABLETYPE"AUX$",
                         AX$TNEXTPTR[IXAUXT]);
                     RECEIVE = DEC(AX$DEPNAM[IXAUXT]);
                     PUTRCVE(CHARPTR);
                     C<124,5>FMAWS = "00000"; 
                     C<129-CHARPTR,CHARPTR>FMAWS =
                       C<0,CHARPTR>RECEIVE; 
                     END
                   END
                  GETTYPE(RECEIVE); 
                  C<56,10>FMAWS = RECEIVE;
                  IF RECEIVE EQ "VARGROUP" THEN 
                    BEGIN 
                    IXAUXT = VIRTUAL(TABLETYPE"AUX$", 
                      DN$AUXREF[IXDNAT]); 
                    FOR IXAUXT = IXAUXT WHILE AX$TTYPE[IXAUXT]
                      NQ SUBOCCDEP DO 
                      IXAUXT = VIRTUAL(TABLETYPE"AUX$", 
                        AX$TNEXTPTR[IXAUXT]); 
                    RECEIVE = DEC(AX$OCCNAM[IXAUXT]); 
                    PUTRCVE(CHARPTR); 
                    C<85,5>FMAWS = "00000"; 
                    C<90-CHARPTR,CHARPTR>FMAWS =
                    C<0,CHARPTR>RECEIVE;
                    RECEIVE = DEC(AX$DEPNAM[IXAUXT]); 
                    PUTRCVE(CHARPTR); 
                    C<124,5>FMAWS = "00000";
                    C<129-CHARPTR,CHARPTR>FMAWS = 
                    C<0,CHARPTR>RECEIVE;
                    END 
                  IF RECEIVE EQ "COMP" THEN 
                    BEGIN 
                    IF DN$POINT[IXDNAT] LS 0 THEN 
                      C<82,1>FMAWS = "T"; 
                      ELSE C<82,1>FMAWS = "F";
                    RECEIVE = DEC(DN$POINT[IXDNAT]);
                    PUTRCVE(CHARPTR); 
                    C<120,3>FMAWS = "000";
                    C<123-CHARPTR,CHARPTR>FMAWS = 
                      C<0,CHARPTR>RECEIVE;
                    RECEIVE = DEC(DN$NUMLEN[IXDNAT]); 
                    PUTRCVE(CHARPTR); 
                    C<83,2>FMAWS = "00";
                    C<85-CHARPTR,CHARPTR>FMAWS =
                     C<0,CHARPTR>RECEIVE; 
                    # PASS INFO RELATING TO SIGN #
                    IF DN$LSIGN[IXDNAT] EQ 1 THEN 
                      C<81,1>FMAWS = "T"; 
                      ELSE C<81,1>FMAWS = "F";
                    IF DN$SIGNBIT[IXDNAT] EQ 1 THEN 
                      C<131,1>FMAWS = "T";
                      ELSE C<131,1>FMAWS = "F"; 
                    IF DN$SCHAR[IXDNAT] EQ 1 THEN 
                      C<132,1>FMAWS = "T";
                        ELSE C<132,1>FMAWS = "F"; 
                    END 
                  IF RECEIVE EQ "NUMEDIT" THEN
                     BEGIN
                     IF DN$BZERO[IXDNAT] EQ 1 THEN
                       C<55,1>FMAWS = "T";
                       ELSE C<55,1>FMAWS = "F"; 
                      #STORE PICTURE STRING#
                     IXAUXT = VIRTUAL(TABLETYPE"AUX$",
                       DN$AUXREF[IXDNAT]);
                     FOR IXAUXT = IXAUXT WHILE AX$TTYPE[IXAUXT] NQ
                       EDITINFO DO
                       IXAUXT = VIRTUAL(TABLETYPE"AUX$",
                         AX$TNEXTPTR[IXAUXT]);
                     IXPLT = VIRTUAL(TABLETYPE"PLT$", 
                      AX$PATTOFFS[IXAUXT]); 
                     IXPLT = VIRTUAL(TABLETYPE"PLT$", 
                       PL$LINE[IXPLT]); 
                     IXPLTSTR = VIRTUAL(TABLETYPE"PLTSTR$", 
                       PL$STRINGPTR[IXPLT]);
                     C<90,PL$LENGTH[IXPLT]>FMAWS =
                          C<0,PL$LENGTH[IXPLT]>PLT$CHAR[IXPLTSTR];
                     END
                   IF RECEIVE EQ "ALPHNUMED" THEN 
                     BEGIN
                      #STORE PICTURE STRING#
                      IXAUXT = VIRTUAL(TABLETYPE"AUX$", 
                       DN$AUXREF[IXDNAT]);
                     FOR IXAUXT = IXAUXT WHILE AX$TTYPE[IXAUXT] NQ
                       EDITINFO DO
                       IXAUXT = VIRTUAL(TABLETYPE"AUX$",
                        AX$TNEXTPTR[IXAUXT]); 
                     IXPLT = VIRTUAL(TABLETYPE"PLT$", 
                       AX$PATTOFFS[IXAUXT]);
                     IXPLT = VIRTUAL(TABLETYPE"PLT$", 
                        PL$LINE[IXPLT]);
                     IXPLTSTR = VIRTUAL(TABLETYPE"PLTSTR$", 
                       PL$STRINGPTR[IXPLT]);
                     C<90,PL$LENGTH[IXPLT]>FMAWS =
                        C<0,PL$LENGTH[IXPLT]>PLT$CHAR[IXPLTSTR];
                     END
                   IF (RECEIVE EQ "ALPHABET") OR
                     (RECEIVE EQ "ALPHNUM") THEN
                     BEGIN
                     IF DN$JUST[IXDNAT] EQ 1 THEN 
                       C<80,1>FMAWS = "T";
                       ELSE C<80,1>FMAWS = "F"; 
                     END
                   IF DN$SDEPTH[IXDNAT] NQ 0 THEN 
                     BEGIN    #IF DNAT HAS OCCURS CLAUSE #
                     IXAUXT = VIRTUAL(TABLETYPE"AUX$",
                       DN$AUXREF[IXDNAT]);
                     FOR IXAUXT = IXAUXT WHILE AX$TTYPE[IXAUXT] 
                       NQ MAXOCCUR DO 
                       IXAUXT = VIRTUAL(TABLETYPE"AUX$",
                         AX$TNEXTPTR[IXAUXT]);
                     FOR OCCNT = 1 STEP 1 WHILE OCCNT LQ
                       DN$SDEPTH[IXDNAT] DO 
                       BEGIN
                       #WRITE PREVIOUS RECORD#
                       PUTSQ(FMAFET, LOC(FMAWS), 140);
                       C<8,131>FMAWS = "  ";
                       C<0,3>FMAWS = "OCC"; 
                       RECEIVE = DEC(AX$MAXOCCNO[IXAUXT]);
                       PUTRCVE(CHARPTR);
                       C<10,7>FMAWS = "0000000";
                       C<17-CHARPTR,CHARPTR>FMAWS = 
                         C<0,7>RECEIVE; 
                       RECEIVE = DEC(AX$OCCLEN[IXAUXT]);
                       PUTRCVE(CHARPTR);
                       C<17,7>FMAWS = "0000000";
                       C<24-CHARPTR,CHARPTR>FMAWS = 
                         C<0,7>RECEIVE; 
                       RECEIVE = DEC(AX$SUBSLVL[IXAUXT]); 
                       PUTRCVE(CHARPTR);
                       C<8,2>FMAWS = "00";
                       C<10-CHARPTR,CHARPTR>FMAWS = 
                         C<0,2>RECEIVE; 
                       IXAUXT = VIRTUAL(TABLETYPE"AUX$",
                         AX$TNEXTPTR[IXAUXT]);
                       END
                     END
 WRITEIT: 
                   PUTSQ(FMAFET, LOC(FMAWS), 140);
                   GOTO UPTAB;
 ENDIT: 
                 PUTSQ(FMAFET, 0, 0); 
                 TMRECL(TABLETYPE"PLT$"); 
                 TMRECL(TABLETYPE"PLTSTR$");
                 RETURN;
                 END; 
          CONTROL  EJECT; 
          PROC   WRITETDFILE; 
 #
       WRITE COMPILER TABLES ON TDFILE FOR USE BY TERMINAL DUMP 
 #
          XREF  ITEM  TDFET;
          XREF  PROC  PUTSQ;
          ITEM  I;
          ITEM  INDEX;
          ITEM  J;
          DEF  WSLENGTH #100#;
          ARRAY WS [1:WSLENGTH];
              ITEM  WSA;
          ITEM  NWDS; 
          DEF   NCHARS #10*NWDS#; 
          BEGIN 
 #     WRITE  CCT                                                      #
          NWDS = LOC(CCTLASTITEM) - LOC(CCTENTRIES) + 1;
          PUTSQ(TDFET, LOC(CCTENTRIES), NCHARS);
          PUTSQ(TDFET, 0, 0); 
 #     WRITE USETAB                                                    #
          NWDS = BLOCKCNT * USEENTSIZE; 
          PUTSQ(TDFET, LOC(USETAB), NCHARS);
          PUTSQ(TDFET, 0 ,0); 
 #     WRITE DNT                                                       #
          NWDS = 0; 
        IF CCTLSTWSDNAT GR 0 THEN 
          FOR I = 0 STEP 1 UNTIL CCTLSTWSDNAT  # SHOULD BE LESS # 
          DO                                   # THAN CCTDNTLEN # 
              BEGIN 
              INDEX = VIRTUAL(TABLETYPE"DNT$", I);
              WSA[NWDS+1] = DNTNAMEINFO[INDEX]; 
              WSA[NWDS+2] = DNTINFO[INDEX]; 
              NWDS = NWDS + DNT$ENTSZ;
              IF NWDS + DNT$ENTSZ GR WSLENGTH 
              THEN
                  BEGIN 
                  PUTSQ(TDFET, LOC(WS), NCHARS);
                  NWDS = 0; 
                  END 
              END 
          IF  NWDS NQ 0 
          THEN
              BEGIN 
              PUTSQ(TDFET, LOC(WS), NCHARS);
              END 
          PUTSQ(TDFET, 0, 0); 
 #     WRITE DNAT                                                      #
          NWDS =0;
        IF CCTLSTWSDNAT GR 0 THEN 
          FOR I = 0 STEP 1 UNTIL CCTLSTWSDNAT 
          DO
              BEGIN 
              INDEX = VIRTUAL(TABLETYPE"DNAT$", I); 
              WSA[NWDS+1] = DN$WORD0[INDEX];
              WSA[NWDS+2] = DN$WORD1[INDEX];
              WSA[NWDS+3] = DN$WORD2[INDEX];
              WSA[NWDS+4] = DN$WORD3[INDEX];
              NWDS = NWDS + DNAT$ENTSZ; 
              IF NWDS + DNAT$ENTSZ GR WSLENGTH
              THEN
                  BEGIN 
                  PUTSQ(TDFET, LOC(WS), NCHARS);
                  NWDS =0;
                  END 
              END 
          IF NWDS NQ 0
          THEN
              BEGIN 
              PUTSQ(TDFET, LOC(WS),NCHARS); 
              END 
          PUTSQ(TDFET, 0, 0); 
 #     WRITE  AUXT                                                     #
          NWDS = 0; 
        IF CCTAUXTLEN GR 0 THEN 
          FOR  I = 0 STEP 1 UNTIL CCTAUXTLEN
          DO
              BEGIN 
              INDEX = VIRTUAL(TABLETYPE"AUX$",I); 
              WSA[NWDS+1] = AX$TGROUP[INDEX]; 
              NWDS = NWDS + AUXT$ENTSZ; 
              IF NWDS + AUXT$ENTSZ GR WSLENGTH
              THEN
                  BEGIN 
                  PUTSQ(TDFET, LOC(WS), NCHARS);
                  NWDS =0;
                  END 
              END 
          IF  NWDS NQ 0 
          THEN
              BEGIN 
              PUTSQ(TDFET, LOC(WS), NCHARS);
              END 
          PUTSQ (TDFET,0, 0); 
#     WRITE NAMET                                                      #
          NWDS = 0; 
        IF CCTNAMETLEN GR 0 THEN
          FOR I = 0 STEP 1 UNTIL CCTNAMETLEN
          DO
              BEGIN 
              INDEX = VIRTUAL(TABLETYPE"NAMET$",I); 
              WSA[NWDS+1] = NAMET$CHARS[INDEX]; 
              NWDS = NWDS + NAMET$ENTSZ;
              IF NWDS+NAMET$ENTSZ GR WSLENGTH 
              THEN
                  BEGIN 
                  PUTSQ(TDFET, LOC(WS), NCHARS);
                  NWDS = 0; 
                  END 
              END 
          IF NWDS NQ 0
          THEN
              BEGIN 
              PUTSQ(TDFET, LOC(WS), NCHARS);
              END 
          PUTSQ(TDFET, 0, 0); 
  
          RETURN; 
          END 
        CONTROL EJECT;
# EXECUTABLE CODE # 
        TMREOP(TABLETYPE"NAMET$"); # REOPEN NAMET # 
          TMREOP(TABLETYPE"DNAT$");  #REOPEN DNAT#
          TMREOP(TABLETYPE"DNT$");  #REOPEN DNT#
          TMREOP(TABLETYPE"FNAT$");  #REOPEN FNAT#
          TMREOP(TABLETYPE"AUX$");  #REOPEN AUX TABLE#
          IF  CCTTDF  THEN  WRITETDFILE;
          IF CCTDUMPDATA THEN FMADUMP;
          IF CCTMEMORYMAP THEN
          BEGIN 
        CBLIST (LISTCTL"OPEN");  #INITIALIZE DATA MAP LISTING#
        LISTTYP = "             MAP OF ";  #TO LISTING TITLE# 
        CBLIST(LISTCTL"TITLE", LISTHED, 110);    #DEFINE NEW TITLE# 
        CBLIST (LISTCTL"SUBTITLE", " ", 1);  #DEFINE A BLANK SUBTITLE#
        CBLIST (LISTCTL"EJECT");  #CAUSE A PAGE EJECT#
        DMLINE [0] = " ";    #BLANK PRINT LINE# 
        DMHEADR [0] = 
         "*** DATA MAP (ADDR/BCP IN OCTAL, SZ IN DECIMAL) ***"; 
        CBLIST (LISTCTL"LINE", DMLINE [0], 130);  #PRINT HEADER LINE# 
        CBLIST (LISTCTL"SKIPPRINT", " ", 1);  #DOUBLE SPACE#
        FTFLAG = 0; 
          FOR TABORD = 15 STEP 1 UNTIL CCTDNTLEN DO 
  
        #STEP THRU DNT TABLE, USING THE DNAT TABLE AND THE FNAT TABLE 
         WHERE NECESSARY, TO GET DESIRED INFORMATION FOR THE DATA MAP.
         THE DNAT TABLE PARALLELS THE DNT, AND THE PERTINENT FNAT EN- 
         TRIES ARE POINTED TO BY THE DNAT (AUX) ENTRIES.  THE LEADING 
         ENTRIES OF THE DNT (AND DNAT) ARE BYPASSED UNTIL THE ENTRY 
         CORRESPONDING TO THE FIRST DATA DIVISION SECTION HEADER IS 
         ENCOUNTERED.#
  
        BEGIN 
          DMLINE [0] = " ";  #BLANK PRINT LINE# 
          IXDNT = VIRTUAL (TABLETYPE"DNT$", TABORD);  #DNT ENTRY INDEX
                                                        IN CORE#
          IXDNAT = VIRTUAL (TABLETYPE"DNAT$", TABORD);  #DNAT ENTRY 
                                                          INDEX IN CORE#
          LEVEL = DN$LEVEL [IXDNAT];
          IF LEVEL EQ 0 THEN TEST TABORD; 
          IF FTFLAG NQ 0 THEN 
          BEGIN 
            IF LEVEL LS FDSECTN OR LEVEL EQ 66 OR LEVEL EQ 77 OR
               LEVEL EQ 88 THEN GOTO DMAP2;  #JUMP IF NOT A SECTION HDR#
          END 
          IX = 7; 
          IF LEVEL LQ CDSECTN AND LEVEL GQ FDSECTN THEN 
           IX = LEVEL - FDSECTN;
          IF LEVEL EQ RDSECTN      #REPORT SECTION HEADER # 
          THEN GOTO DMAP4;
          IF LEVEL EQ CSSECTN THEN IX = 5;
          IF LEVEL EQ SSSECTN THEN IX = 6;
          CONTROL IFNQ CB5$CDCS,"NO"; 
          IF LEVEL EQ DBFSSECTN THEN
          BEGIN 
            IX = 0;          #SS DATA HEADER TREATED AS FD SECTION HDR# 
            SSFLAG = 1;      #INDICATE SS DATA ENCOUNTERED# 
          END 
          CONTROL FI; 
          IF IX LS 7 THEN 
          BEGIN              #VIABLE SECTION HEADER#
            CONTROL IFNQ CB5$CDCS,"NO"; 
            IF SSFLAG NQ 0 AND LEVEL NQ DBFSSECTN 
             THEN SSFLAG = 2;  #SET FLAG FOR PROPER LINE NUMBER FIELD - 
                                NOTE -DMAP3-# 
            IF LEVEL EQ FDSECTN AND SSFLAG NQ 0 
             THEN TEST TABORD;  #FD SEC HDR OUTPUT WITH SS DATA#
            CONTROL FI; 
            DMSECNM [0] = SECTHDR [IX];  #SECTION NAME TO PRINT LINE# 
            CBLIST (LISTCTL"LINE", DMLINE [0], 130);  #OUTPUT LINE# 
          END 
          IF FTFLAG NQ 0 THEN TEST TABORD;  #JUMP IF NOT 1ST TIME IN
                                              LOOP# 
          IF IX LS 7         #IF 1ST VIABLE SECTION HEADER# 
           THEN FTFLAG = 1;  #INDICATE NOT 1ST TIME IN LOOP#
          TEST TABORD;       #TO NEXT DNT ENTRY#
  
       DMAP2: 
  
          IF DNTINFO [IXDNT] EQ 0 THEN TEST TABORD;  #JUMP IF UNNEEDED
                              ENTRY, E.G. LINAGE-COUNTER# 
          IX = 4; 
          IF LEVEL GQ FDDESCR AND LEVEL LQ RDDESCR THEN 
          BEGIN              #RECORD DESCRIPTION HEADER#
            IX = LEVEL - FDDESCR; 
            DMFD [0] = DESCHDR [IX];  #FD, SD, CD, OR RD TO PRINT LINE# 
          END 
          ELSE
          BEGIN              #"NORMAL" ITEM#
            IF LEVEL LS 10 THEN 
            BEGIN            #IF LEVEL LS 10 ENSURE LEADING ZERO# 
              DMITMLVL [0] = "00";
              DMITMLVL1 [0] = DEC (LEVEL);  #LEVEL TO PRINT LINE# 
            END 
            ELSE
              DMITMLVL [0] = DEC (LEVEL);  #LEVEL TO PRINT LINE#
            IF LEVEL EQ 1 THEN DMASTK [0] = "*";  #* TO LINE IF 01 ITEM#
            IF DN$RDEF [IXDNAT] EQ 1 OR DN$LEVEL [IXDNAT] EQ 66 
             THEN DMREDREN [0] = "R";  #R TO LINE IF REDEFINES/RENAMES# 
            IF DN$LEVEL [IXDNAT] EQ INDXLEVL THEN DMIDXITM [0] = "IDX"; 
                             #IDX TO LINE IF INDEX ITEM#
          END 
          NAMETPTR = DNTNAMETPTR[IXDNT];
          NBRWORDS = DNTNBRWORDS[IXDNT];
          GETNAME;   # GET NAME FROM NAME TABLE # 
          DMITMNAM1 = W1;    # MOVE NAME TO PRINT # 
          DMITMNAM2 = W2; 
          DMITMNAM3 = W3; 
          IF DNTFILLER[IXDNT] 
          THEN
            DMITMNAM1 = "FILLER"; 
          IF FTFLAG EQ 1 THEN 
          BEGIN              #COLUMN HEADERS TO PRINT LINE# 
            DMBLOCK [0] = "BLOCK="; 
            DMADDBCP [0] = "ADDR/BCP="; 
            CONTROL IFNQ CB5$CDCS,"NO"; 
            IF SSFLAG EQ 0 THEN DMLNR [0] = "LNR="; 
            CONTROL FI; 
            CONTROL IFEQ CB5$CDCS,"NO"; 
            DMLNR [0] = "LNR="; 
            CONTROL FI; 
            FTFLAG = 2;      #ENSURE ONLY 1 SET OF COLUMN HEADERS#
          END 
          IF FTFLAG EQ 2 AND IX EQ 4 THEN  #IF NO -SZ=- YET, AND NOT
                                             FD, SD, CD OR RD#
          BEGIN 
            DMSZ [0] = "SZ="; 
            FTFLAG = 3;      #ENSURE ONLY 1 -SZ=-#
          END 
          CONTROL IFNQ CB5$CDCS,"NO"; 
          IF SSFLAG EQ 2 THEN 
          BEGIN 
            DMLNR [0] = "LNR="; 
            SSFLAG = 3; 
          END 
          CONTROL FI; 
          IF LEVEL EQ 88 THEN GOTO DMAP3;  #NO MORE INFO FOR 88 ITEM# 
          IX = DN$MAJMSEC [IXDNAT]; 
          IF IX EQ LINKMSEC THEN GOTO DMAP3;  #NO MORE INFO IF LINKAGE- 
                                                SECTION ITEM# 
          ADDR = DN$WORDOFF [IXDNAT];  #ADDRESS WITHIN USE BLOCK# 
          IX = DN$SUBMSEC [IXDNAT];  #INDEX INTO USETAB#
          IF NOT GLOBAL [IX] THEN 
          BEGIN              #ITEM IS WITHIN PROGRAM BLOCK# 
            ADDR = ADDR + USESTART [IX];  #ADDRESS WITHIN PROGRAM BLOCK#
            IF BLKNAMSV NQ "PROGRAM" THEN 
            BEGIN            #BLOCK NAME TO LINE IF NOT SAME AS LAST# 
              DMBLOCK [0] = "BLOCK="; 
              DMBLKNM [0] = "PROGRAM";
              BLKNAMSV = "PROGRAM";  #SAVE BLOCK NAME#
            END 
          END 
          ELSE               #COMMON BLOCK# 
            IF BLKNAMSV NQ USENAME [IX] THEN
            BEGIN            #BLOCK NAME TO LINE IF NOT SAME AS LAST# 
              DMBLOCK [0] = "BLOCK="; 
              DMBLKSL1 [0] = "/";  #SURROUND BLOCK NAME WITH SLASHES# 
              FNSAVE = USENAME [IX];
              ZSTRIP ("/");  #STRIP TRAILING ZEROS AND ADD SLASH# 
              DMBLKNMC [0] = FNSAVE;
              BLKNAMSV = USENAME [IX];  #SAVE BLOCK NAME# 
            END 
          DMITMADD [0] = OCT (ADDR,14,6);  #ADDRESS TO PRINT LINE#
          DMSLASH [0] = "/";  #SLASH TO PRINT LINE# 
          IF LEVEL NQ FDDESCR AND LEVEL NQ SDDESCR THEN 
          BEGIN              #BCP, ITEM SIZE, TYPE TO PRINT LINE# 
            BCP = DN$CHARPOS [IXDNAT];
            DMITMBCP [0] = OCT (BCP,18,2);
            DMITMSZ [0] = DEC (DN$ITMLEN [IXDNAT]); 
            IX = DN$TYPE [IXDNAT];
          DMITMTYP[0] = DNTYPE[IX] ;
            #SYNC RT/LEFT ARE NOT INCLUDED AS IN COBOL 4 SINCE THE
             PERTINENT DNAT BITS ARE NOT EXTANT AT DATA MAP TIME# 
          END 
  
       DMAP3: 
  
          CONTROL IFNQ CB5$CDCS,"NO"; 
          IF SSFLAG NQ 1 THEN 
          CONTROL FI; 
            DMITMLNR [0] = DEC (DNTLINE [IXDNT]);  #SOURCE LINE NUMBER# 
          CONTROL IFNQ CB5$CDCS,"NO"; 
          ELSE
            DMITMLNRX [0] = "SUBSCHEMA";  #INDICATES AN SS ITEM#
          CONTROL FI; 
          IF LEVEL EQ FDDESCR OR LEVEL EQ SDDESCR THEN
          BEGIN 
            IX = DN$AUXREF [IXDNAT];
           CONTROL IFNQ CB5$CDCS,"NO";
            IF IX EQ 0 THEN 
            BEGIN            #SS RELATION - NO IMPLEMENTOR-NAME#
              DMFD = " "; 
              DMREL = "RELATION"; 
              DMBLOCKNTRY = " ";
              BLKNAMSV = " "; 
              LEVEL = 1;     #SET TO INDICATE NOT FD# 
            END 
           CONTROL FI;
          END 
          CBLIST (LISTCTL"LINE", DMLINE [0], 130);  #OUTPUT LINE# 
          IF LEVEL EQ FDDESCR THEN
          BEGIN              #IF FD, IMPLEMENTOR-NAME TO PRINT LINE#
            DMLINE [0] = " ";  #BLANK PRINT LINE# 
            DMLP [0] = "(";  #LEFT PAREN TO LINE# 
            IXAUXT = VIRTUAL (TABLETYPE"AUX$", IX); 
            IX = AX$FNATPTR [IXAUXT]; 
            IXFNAT = VIRTUAL (TABLETYPE"FNAT$", IX);
            FNSAVE = FN$LFN [IXFNAT];  #IMPLEMENTOR-NAME# 
            ZSTRIP (")");    #STRIP TRAILING ZEROS AND ADD RIGHT PAREN# 
            DMITMFN [0] = FNSAVE;  #FILE NAME TO PRINT LINE#
            CBLIST (LISTCTL"LINE", DMLINE [0], 20);  #OUTPUT LINE#
          END 
        END 
 DMAP4: 
  
  
        #PROCEDURE DIVISION MAP#
  
        FOR TABORD = 1 STEP 1 UNTIL BLOCKCNT DO  #GET ADDRESS OF -CODE- 
                                                   BLOCK# 
        BEGIN 
          IF USENAME [TABORD] EQ "CODE   " THEN GOTO PMAP1; 
        END 
        GOTO PMAPX;          #SHOULD NOT HAPPEN#
  
       PMAP1: 
  
        CODEBLKADDR = USESTART [TABORD];  #ADDRESS OF CODE BLOCK# 
        CBLIST (LISTCTL"SKIPPRINT", " ", 1);  #DOUBLE SPACE#
        DMLINE [0] = " ";  #BLANK PRINT LINE# 
        DMHEADR [0] = "       *** PROCEDURE MAP (ADDR IN OCTAL) ***"; 
        CBLIST (LISTCTL"SKIPPRINT", DMLINE [0], 130);  #PRINT LINE# 
        TMREOP (TABLETYPE"PNT$");  #ENSURE PNT TABLE OPEN#
        TMREOP (TABLETYPE"PNAT$");  #ENSURE PNAT TABLE OPEN#
        DMLINE [0] = " "; 
        DMADDBCP [0] = "    ADDR=";  #COLUMN HEADERS INTO PRINT LINE# 
        DMLNR [0] = "LNR="; 
        FOR TABORD = 1 STEP 1 UNTIL CCTPNTLEN DO
  
         #STEP THRU PNT TABLE, AND USING THE PNAT TABLE, TO GET THE 
          DESIRED INFORMATION FOR THE PROCEDURE MAP.# 
  
        BEGIN 
          IXPNT = VIRTUAL (TABLETYPE"PNT$", TABORD);  #PNT ENTRY INDEX
                                                        IN CORE#
          IF PNTLINE [IXPNT] EQ 0 THEN TEST TABORD;  #PERHAPS SKIP NTRY#
          NAMETPTR = PNTNAMETPTR[IXPNT];
          NBRWORDS = PNTNBRWORDS[IXPNT];
          GETNAME;   # GET NAME FROM NAME TABLE # 
          PMNAM1 = W1;   # MOVE NAME TO PRINT # 
          PMNAM2 = W2;
          PMNAM3 = W3;
          IXPNAT = VIRTUAL (TABLETYPE"PNAT$", TABORD);  #PNAT ENTRY IN- 
                                                          DEX IN CORE#
           IF PN$PROCKIND [IXPNAT] EQ 1 THEN PMSEC [0] = "SECTION"; 
                             #PERHAPS ADD WORD -SECTION-# 
          ADDR = CODEBLKADDR + PN$FIRSTADDR [IXPNAT]; #ADDRESS OF PROC# 
          PMADD [0] = OCT (ADDR,14,6);  #ADDRESS TO PRINT LINE# 
          PMLNR [0] = DEC (PNTLINE [IXPNT]);  #SOURCE LINE NUMBER#
          CBLIST (LISTCTL"LINE", DMLINE [0], 130);  #OUTPUT LINE# 
          DMLINE [0] = " "; 
        END 
  
       PMAPX: 
  
        DMLINE [0] = " ";    #BLANK PRINT LINE# 
        CBLIST (LISTCTL"LINE", DMLINE [0], 130);
        DMTRAILR [0] = "*** END MAP ***"; 
        CBLIST (LISTCTL"SKIPPRINT", DMLINE [0], 130); 
                             #OUTPUT LAST LINE# 
        CBLIST (LISTCTL"CLOSE");  #FINISH OFF DATA MAP# 
        TMRECL (TABLETYPE"PNT$"); 
        TMRECL (TABLETYPE"PNAT$");
          END 
        TMRECL (TABLETYPE"DNAT$");  #RESTORE TABLES TO OPEN/CLOSE 
                              CONDITIONS EXISTING BEFORE THIS PROGRAM#
        TMRECL (TABLETYPE"DNT$"); 
        TMRECL (TABLETYPE"FNAT$");
        TMRECL (TABLETYPE"AUX$"); 
        TMRECL(TABLETYPE"NAMET$");  # RE-CLOSE NAME TABLE # 
          CMM$FGR(USEID);   #FREE USE BLOCKS# 
        OVERRTN;             #RETURN FROM OVERLAY#
        CONTROL EJECT;
          PROC ZSTRIP (TRAILCHAR);
# 
**        ZSTRIP - PROCEDURE TO STRIP TRAILING ZEROS FROM FILE OR BLOCK 
*                  NAME CONTAINED IN -FNSAVE-, INSERT TRAILING RIGHT
*                  PAREN (IF FILE) OR SLASH (IF BLOCK), AND FILL REST 
*                  OF FIELD WITH BLANKS.
* 
*                                                                      #
        ITEM TRAILCHAR C(1);  #RIGHT PAREN OR SLASH#
        ITEM TFLAG; 
        ITEM I; 
  
  
        BEGIN 
          B<42,6> FNSAVE = 0; 
          TFLAG = 0;
          FOR I = 1 STEP 1 UNTIL 7 DO 
          BEGIN 
            IF B<I*6,6> FNSAVE NQ 0 
              THEN TEST I;
            IF TFLAG NQ 0 
              THEN C<I,1> FNSAVE = " "; 
              ELSE C<I,1> FNSAVE = TRAILCHAR; 
            TFLAG = 1;       #ENSURE ONLY 1 TRAILING CHAR#
          END 
        END 
      END 
      TERM
