*COMDECK COMSSLIB 
      DEF BUFSIZ #4096#;
      DEF CTLWDLENG #15#; 
      DEF F4 #8#;        # DDLCOMP VALUE FOR PARAMETER F4 (FTN 4)      #
      DEF F5 #9#;        # DDLCOMP VALUE FOR PARAMETER F5 (FTN 5)      #
      DEF NAME #101#; 
      DEF FNAME #99#; 
      XREF
        BEGIN 
        PROC CBPINIT; 
        PROC CBEXT; 
        PROC DDLABT;
        PROC DDLPRNT;    # PRINTS WHATEVER IS IN THE WORKING ST. ARRAY #
        PROC DDLINIT;    # INITIAL ENTRY IN CTLSCAN                    #
        PROC LEXSCAN;    # ENTRY POINT IN CTLSCAN                      #
        PROC DDLCLNL;    # CLOSE NEW SUBSCH LIB FILE                   #
        PROC DDLOPNL;    # OPEN NEW SUBSCH LIB FILE                    #
        PROC DDLRTNL;    # WRITE NEW SUBSCH LIB FILE                   #
        PROC DDLOPSB;    # OPENS THE SUB-SCHEMA FILE                   #
        PROC DDLRTSB;    # WRITES CONTENTS OF WORK BUFFER INTO FILE    #
        PROC DDLRDSB;    # READS FROM FILE INTO WORK BUFFER            #
        PROC CLSESB;     # CLOSES THE SUB/SCHEMA FILE                  #
        PROC CLSEOUT; 
        PROC ABRT1; 
        PROC OCT20; 
        PROC OVLINIT;    # ENTRY POINT IN (0,0) OVERLAY                #
        PROC DE$CLSC; 
        PROC DE$NMSC; 
        PROC DE$GTSC; 
        PROC DE$OPSC; 
        ITEM SCLFN; 
        ITEM OLD65;                    #HIGH ADDR OF CURRENT OVERLAY   #
        PROC CLOSECS ;   # CLOSE/UNLOAD CAPSULE SCRATCH FILE           #
        PROC OPENCS ;    # OPEN/REWIND CAPSULE SCRATCH FILE            #
        PROC READCS ;    # READ CAPSULE SCRATCH FILE                   #
        ITEM ABORTFLAG;  # SET IF FATAL ERRORS ENCOUNTERED.            #
          ITEM DDLSU;      # CONTAINS THE STORAGE USED.                #
        ITEM DDLCOMP;    # CONTAINS CODE FOR PARAMETER F4, F5, ETC.    #
        PROC ADDFTN;     # ADDS FORTRAN SOURCE FILES TO END OF SUB-SCH.#
        PROC PRES1S2;    # PREPARES FORTRAN SOURCE FILES               #
        ITEM LENS1S2;    # LENGTH OF SSOUT1 + SSOUT2, FROM PRES1S2 CALL#
        ITEM LENS1;      # LENGTH OF SSOUT1 FROM PRES1S2 CALL          #
        ITEM LENS2;      # LENGTH OF SSOUT2 FROM PRES1S2 CALL          #
        PROC READS1;     # READ FORTRAN SOURCE FILE SSOUT1             #
        PROC READS2;     # READ FORTRAN SOURCE FILE SSOUT2             #
        PROC CLS1S2;     # CLOSE SSOUT1, SSOUT2                        #
        ITEM ERRCNTR;  # CONTAINS THE COUNT OF DIAGNOSTICS ISSUED.     #
        ITEM EXHSS;      # EXHIBIT ALL SS NAMES AND DATES---- FLAG     #
          ITEM FIRSTWORD;  # LWA+1 OF THE LARGEST OVERLAY              #
        ITEM NEWLIB U;   # FLAG/LFN FOR SUBSCHEMA LIB COPY             #
        ITEM NOADDSS;    # NO ADDITION TO SS FILE--- FLAG              #
        ITEM PURGESS;    # PURGE SUB-SCHEMA IN FILE---FLAG             #
        ITEM REPLACESS;  # REPLACE SUB-SCHEMA IN FILE--- FLAG          #
        ITEM MULTSS B;   # TRUE - MULTIPLE SUBSCHEMA COMPILATION.      #
        ITEM NEXLENG;    # LENGTH IN CHARS OF SYNTAX ELEMENT           #
        ITEM NEXLENW;    # LENGTH IN WORDS OF SYNTAX ELEMENT           #
        ITEM NEXTYPE;    # CONTAINS THE SYNTACTIC TYPE OF CURRENT      #
                         # SOURCE WORD.                                #
        ITEM SBLFN;      # CONTAINS THE SUBSCHEMA FILE NAME.           #
        ITEM SBSCHMA;    # CONTAINS THE FIRST WORD ADDRESS OF THE      #
                         # SUB-SCHEMA IN CORE.                         #
        ITEM SBSCHML ;   # CONTAINS LENGTH IN WORDS OF THE SUB-SCHEMA  #
                         # DIRECTORY IN CORE.                          #
        ITEM NEWFILE;    # CONTAINS THE STATUS OF THE SUB-SCHEMA FILE  #
                         # ---- WHETHER FILE TO BE CREATED OR NOT.     #
        ITEM SKIPMSG B;    # TRUE - SKIP REGULAR DAYFILE MESSAGES      #
        ITEM TRVERR;     # SET IF TRIVIAL ERRORS ENCOUNTERED.          #
  
        ARRAY DDLIWSA [10]; 
          ITEM IWSA C(0,0,10);
        ARRAY NEXWORD [25]; 
          ITEM NEXWRD U(0,0,60);
        END 
  
        ARRAY DITWK [24] S(1);
        BEGIN 
*CALL DITCOMSC
        END 
  
# DECLARATIONS WITHIN $BEGIN AND $END BLOCKS ARE SATISFIED BY SYMPL    #
# TEXTS AS INDICATED IN THE USETEXT DIRECTIVE.                         #
  
      $BEGIN     # SYMPL TEXT * TSBTBL * USED                          #
  
      BASED ARRAY CBWORKBUF [0] S(1);  # SUBSCHEMA TABLE               #
        BEGIN 
*CALL SBCWDECLS 
*CALL SUBDECLS
*CALL SBDCDECLS 
*CALL SBRLHDDCL 
*CALL SBRLDBDCL 
        END 
      BASED ARRAY REALMLIST[0] S; 
        BEGIN 
*CALL SBRLMLST
        END 
      BASED ARRAY RECORDLIST[0] S;
        BEGIN 
*CALL SBRECLST
        END 
  
      $END
  
      ARRAY ARNAME[2] S;
        BEGIN 
        ITEM AREAWD U(0,0,60);
        ITEM AREANM C(0,0,30);
        END 
      ARRAY CKSBUF [66];; 
      ARRAY ORDWK[4] S; 
        BEGIN 
*CALL SCAHDDCLS 
*CALL SCRLHDDCL 
        END 
*CALL CKSCOM
      ARRAY SSNAMARR [0:2] S(1);
        BEGIN 
        ITEM SSNAM C(0,0,10); 
        ITEM SSNAM30 C(0,0,30); 
        END 
      ARRAY COMMESG[12] S(1); 
        BEGIN 
        ITEM CMESG C(0,0,10); 
        ITEM CMESG30 C(0,0,30); 
        END 
      ARRAY OLDINDBUF [0] S(4);  # BUFFER FOR INDEX ENTRY-             #
        BEGIN                    # OLD SUBSCHEMA LIB                   #
        ITEM OLDSSNAM C(0,0,10); # SUBSCHEMA NAME                      #
        ITEM OLDSSNM30 C(0,0,30); 
        ITEM OLDSSWA U(3,0,30);  # SUBSCH WORD ADDR IN FILE            #
        ITEM OLDSSLEN U(3,30,30);# SUBSCH LENGTH IN WORDS              #
        END 
      ARRAY NEWINDBUF [0] S(4);  # BUFFER FOR INDEX ENTRY -            #
        BEGIN                    # NEW SUBSCHEMA LIB                   #
        ITEM NEWSSNAM C(0,0,10); # SUBSCHEMA NAME                      #
        ITEM NEWSSNM30 C(0,0,30); 
        ITEM NEWSSWA U(3,0,30);  # SUBSCH WORD ADDR IN FILE            #
        ITEM NEWSSLEN U(3,30,30);# SUBSCH LENGTH IN WORDS              #
        END 
      ARRAY SSWORKBUF [BUFSIZ] S(1);
        BEGIN 
        ITEM SSINDXNAME U(0,0,60);  # SS NAME IN INDEX TABLE ENTRY.    #
        ITEM INDTBLEND U(0,0,60);   # ACTUAL END OF SUBSCH FILE # 
        ITEM SSINDXNME30 C(0,0,30); 
         ITEM SSWRDADDR U(3,0,30);  # WORD ADDRESS WHERE SS RESIDES. #
                                     # IN FILE.                        #
        ITEM SSINDXLEN U(3,30,30);  # SUBSCHEMA LENGTH. # 
        END 
      ARRAY SSCNTRLWRD [0]; 
        BEGIN 
        ITEM SUBSCHCOUNT U(0,0,12);  # COUNT OF SUB-SCHEMAS IN FILE    #
        ITEM SSINDXSTRT U(0,12,48);  # ADDRESS WHERE INDEX TABLE STARTS#
        END 
  
      ITEM ABRTFLAG B;     # A FLAG IS SET IF DDLF IS TO BE ABORTED ON #
      ITEM EXTFLAG B;    # FLAG TO SAY EXTEND SHOULD BE DONE           #
      ITEM FLAG B;
      ITEM FRSTINDWD;  # CONTAINS THE FIRST WORD ADDRESS OF THE INDEX  #
                         # TABLE FOR THE OLD SS LIB FILE               #
      ITEM FWANEWIND;    # CONTAINS FWA OF THE INDEX TABLE             #
                         # ON THE NEW SUBSCH LIB FILE                  #
      ITEM FWANEWSS;     # CONTANS UPDATED FWA ON NEW SUBSC            #
                         # LIB FILE FOR SUBSCH WRITES                  #
      ITEM FWAOLDSS;     # CONTAINS UPDATE FWA ON OLD SUBSC            #
                         # LIB FILE FOR SUBSCH READS                   #
      ITEM I,J,K,L;    # SCRATCH VARIABLES #
      ITEM LASTINDWD;  # CONTAINS THE LAST WORD ADDRESS OF YHE INDEX   #
      ITEM LENGMVD; 
      ITEM LC;         # SCRATCH VARIABLE  #
      ITEM LNGSSMODBFS; # SUBSCH LENGTH MODULO BUFSIZ                  #
      ITEM LNGSSREAD;   # NBR OF WORDS TO READ FROM SUBSCH             #
      ITEM LWACKSBLK;    # LWA OF CHECKSUM BLOCK                       #
      ITEM M; 
      ITEM NBRBUFSS;    # NBR OF BUFFERS TO WRITE FOR SUBSCH           #
      ITEM NEWINDXWA U; # WA ON NEW LIB FILE OF NXT AVAIL INDX ENTRY   #
      ITEM SBADJLENG;  # CONTAINS THE LENGTH ADJUSTED TO PRU BOUNDARY. #
      ITEM SSCOUNT; 
      ITEM SSCTLWDADR; # CONTAINS THE ADDRESS OF THE CONTROL WORD IN   #
                       # THE SUBSCHEMA FILE.                           #
      ITEM WRDADRINDX; # CONTAINS THE WRD. ADDR.OF INDEX TABLE ENTRIES #
      ITEM RLMPTR;
      ITEM DCLPTR;
      ITEM ITMPTR;
      ITEM ITMST; 
      ITEM SSHDPR C(60) = "          SUBSCHEMA
     CHECKSUM  "; 
  
      ARRAY MESSAGE1 [0:7]; 
        ITEM MESG1 C(0,0,10) = ["*****DID N", "OT LOCATE ", "SUB-SCHEMA"
         ," TO BE REP","LACED --- ","NEW SUB-SC","HEMA HAS B",
          "EEN ADDED "];
      ARRAY MESSAGE2 [0:9]; 
        ITEM MESG2 C(0,0,10) = ["*****SUB-S","CHEMA WITH"," THE SAME ", 
          "NAME AS TH","E NEW SUB-","SCHEMA ALR","EADY EXIST",
          "S --- FILE"," NOT UPDAT","ED        "];
      ARRAY MESSAGE3 [0:7]; 
        ITEM MESG3 C(0,0,10) = ["*****DID N","OT LOCATE ","          ", 
          "          ","          ","--PURGE NO","T POSSIBLE"]; 
      ARRAY MESSAGE4[0:5];
        ITEM MESG4 C(0,0,10) = ["     SUB-S","CHEMA,    ","          ", 
          "          ","          ",",PURGED   "];
      ARRAY MESSAGE5 [0:3]; 
        ITEM MESG5 C(0,0,10) = ["          ","LIST OF SU",
          "B-SCHEMAS ","IN FILE   "]; 
      ARRAY MESSAGE6A [0:11]; 
        ITEM MESG6A C(0,0,10) = ["          ","SUB-SCHEMA", 
          "          ","          ","      CREA","TION      ",
          "  ?       ","SCHEMA    ","          ","          ",
          "      CREA","TION      "]; 
      ARRAY MESSAGE6B [0:11]; 
        ITEM MESG6B C(0,0,10) = ["         -","----------", 
          "          ","          ","  --------","--------  ",
          "  ?      -","-------   ","          ","          ",
          "  --------","--------  "]; 
      ARRAY MESSAGE7 [0:6]; 
        ITEM MESG7 C(0,0,10) = ["          ","     -----","       END", 
          " OF FILE M","AINTENANCE","          ","     -----"]; 
      ARRAY MESSAGE8 [0:3]; 
        ITEM MESG8 C(0,0,10) = ["***** WARN","ING-- EMPT","Y SUBSCHEM", 
          "A FILE    "];
      ARRAY MESSAGE9 [0:7]; 
        ITEM MESG9 C(0,0,10) = ["          ","     -----","       BEG", 
          "IN SUB-SCH","EMA FILE M","AINTENANCE","          ",
          "     -----"];
      ARRAY MESSAGE10 [0:5];
        ITEM MESG10 C(0,0,10) = ["*****ILL-F","ORMATTED L","IBRARY -- ",
          "NOT UPDATA","BLE, DDL A","BORTED    "];
  
      ARRAY MESSAGE11 [0:3];
        ITEM MESG11 C(0,0,10) = ["***** EMPT", "Y SUBSCHEM",
                    "A FILE, DD","L ABORTED "]; 
      ARRAY MESSAGE12 [0:5];
        ITEM MESG12 C(0,0,10) = ["          ", "     -----",
                    "       NEW", " SUBSCHEMA", " LIBRARY G", 
                    "ENERATED" ]; 
      ARRAY MESSAGE13 [0:6];
        ITEM MESG13 C(0,0,10) = ["***** OLD ","SUBSCHEMA ","FILE BAD, ",
                    "SUBSCHEMA ","LENGTH IS ","ZERO. DDL ","ABORTED   " 
                    ];
      ARRAY MESSAGE14 [0:4];
        ITEM MESG14 C(0,0,10) = ["***** EMPT","Y INPUT FI","LE---PURGE",
                    " NOT POSSI","BLE       " ];
  
  
      CMESG[0] = "          ";
      DDLPRNT( COMMESG,10 );
      DDLPRNT( MESSAGE9, 80 );
      DDLPRNT( COMMESG,10 );
      ABRTFLAG = FALSE; 
      EXTFLAG = FALSE;
      DDLOPSB;
      IF NEWFILE LQ 1 AND EXHSS NQ 1 AND PURGESS NQ 1 THEN
        IF NEWLIB EQ 0  THEN
          GOTO CREATESSFL;
        ELSE
          BEGIN 
          DDLPRNT (MESSAGE11, 40);
          ERRCNTR = ERRCNTR + 1;
          ABRTFLAG = TRUE;
          GOTO EXIT1; 
          END 
  LOOP:     #  #
      IF NEWFILE LQ 1 THEN
        BEGIN 
        DDLPRNT( MESSAGE10,60 );
        ERRCNTR = ERRCNTR + 1;
        ABRTFLAG = TRUE;
        GOTO EXIT1; 
        END 
      IF NEWFILE LQ BUFSIZ THEN 
        BEGIN 
        I = NEWFILE;
        END 
      ELSE
        BEGIN 
        I = BUFSIZ; 
        END 
      J = NEWFILE -I+1;  # START OF READ TO SEARCH FOR ACTUAL END OF SS#
      DDLRDSB( LOC(SSWORKBUF), I, J );  # READ IN ENTRIES IN  # 
      FOR J = I-1 STEP -1 UNTIL 0 DO  # THE SUBSCHEMA FILE STARTING AT #
        BEGIN                     # EOI, SO AS TO FIND THE ACTUAL END  #
        IF INDTBLEND[J] EQ O"05160417062323061114" THEN  #OF THE FILE. #
                           #  E N D O F S S F I L # 
          BEGIN 
          SSCTLWDADR = NEWFILE - I + J; 
          J = 0;
          END 
        END 
      IF SSCTLWDADR EQ 0 THEN 
        BEGIN 
        NEWFILE = NEWFILE - I;
        GOTO LOOP;
  
        END 
      DDLRDSB( LOC(SSCNTRLWRD), 1, SSCTLWDADR );
      FOR J = 0 STEP 1 UNTIL I-1 DO 
        SSINDXNAME[J] = 0;
      IF NEWLIB NQ 0  THEN
        GOTO COPYSSFL;
      IF PURGESS EQ 1 THEN
        GOTO PURSUBSCH; 
      IF REPLACESS EQ 1 THEN
        GOTO REPLSUBSCH;
      IF EXHSS EQ 1 THEN
        GOTO EXHSSNAMES;
  
  ADDTOSSFL:   # ADDS TO THE SUBSCHEMA FILE, THE SUBSCHEMA COMPILED.   #
      IF SUBSCHCOUNT[0] EQ 0 THEN # IF FILE EMPTY, THEN                #
        BEGIN 
        DDLPRNT( MESSAGE8, 40 );   # ISSUE WARNING MESSAGE.  #
        ERRCNTR = ERRCNTR + 1;
        TRVERR = 1;          # SET TRIVIAL ERROR FLAG                  #
        END 
      P<CBWORKBUF> = SBSCHMA;      # SET BASED ARRAY TO START OF SUBSCH#
      STORSSNAM(SBSCHMA+CTLWDLENG+1,SBSCNAMELENW[CTLWDLENG]);#EMA IN   #
                                                     # CORE. STORE NAME#
      SRCHSSNAME; 
      IF FLAG THEN                # THE SAME NAME AS THE ONE TO BE     #
        BEGIN                     # ADDED ALREADY EXISTS. IF SO,       #
        DDLPRNT( MESSAGE2, 96 );  # ISSUE DIAGNOSTIC AND ABORT.        #
        ERRCNTR = ERRCNTR + 1;
        ABORTFLAG = 1;
        GOTO EXIT1; 
        END 
      PUTSUBSCHEMA (SSCTLWDADR+2) ;     # WRITE NEW SUBSCHEMA TO FILE. #
      SBDIRCKS;              # CHECKSUM SUBSCHEMA JUST COMPILED        #
      INDXTBLNEW( SSCTLWDADR + 2 + SBCWSBLENG[0] ); 
      INDXTBLUPD (SSCTLWDADR + 2);
      SUBSCHCOUNT[0] = SUBSCHCOUNT[0] + 1; # INCREMENT SUBSCH COUNT.   #
      DDLRTSB(LOC(SSWORKBUF), 4, WRDADRINDX);  # WRITE INDEX TABLE #
      DDLRTSB( LOC(SSCNTRLWRD), 1, WRDADRINDX+4 ); # WRITE COMTROL WRD #
                                                  # IN FILE.           #
      WRDADRINDX = WRDADRINDX + 5;
      GOTO EXIT;                  # GO TO EXIT.                        #
  
  CREATESSFL:      # CREATE A NEW SUB-SCHEMA FILE.                     #
      IF REPLACESS EQ 1 THEN
       BEGIN                     # SUB-SCHEMA TO BE REPLACED - ERROR   #
       DDLPRNT( MESSAGE8, 40 );  # ISSUE WARNING                       #
       DDLPRNT( MESSAGE1, 80 );  # MESSAGES.                           #
       TRVERR = 1;               # SET TRIVIAL ERROR FLAG              #
       ERRCNTR = ERRCNTR + 1;   # UPDATE ERROR COUNTER                 #
       END
      P<CBWORKBUF> = SBSCHMA;      # SET BASED ARRAY TO START OF SUBSCH#
                                  # IN CORE.                           #
      STORSSNAM(SBSCHMA+CTLWDLENG+1,SBSCNAMELENW[CTLWDLENG]);#STORE NAM#
      SUBSCHCOUNT[0] = 1;         # STORE COUNT OF SUBSCHS AND         #
      SSCTLWDADR = -1;       # INITIALIZE FOR CHECKSUM WRITE #
      PUTSUBSCHEMA (1) ;                # WRITE NEW SUBSCHEMA TO FILE. #
      SBDIRCKS;              # CHECKSUM SUBSCHEMA JUST COMPILED        #
      SSINDXSTRT[0] = SBCWSBLENG[0] + 1;   # STARTING ADDRESS OF INDEX #
                                           # TABLE                     #
      INDXTBLUPD (1); 
      DDLRTSB(LOC(SSWORKBUF), 4, SSINDXSTRT[0]); # WRITE INDEX TABLE #
      WRDADRINDX = SSINDXSTRT[0] + 4; # IN FILE, AND STORE NEXT AVAIL. #
      DDLRTSB( LOC(SSCNTRLWRD), 1, WRDADRINDX ); # WORD. WRITE CONTROL #
      WRDADRINDX = WRDADRINDX + 1;     #WORD IN FILE.                  #
      GOTO EXIT;                  # EXIT.                              #
  
  PURSUBSCH:       # PURGE SUBSCHEMAS  SPECIFIED IN INPUT STREAM.      #
        DDLSU = FIRSTWORD; # STORAGE USED                              #
        SKIPMSG = TRUE;    # SET TO SKIP REGULAR DAYFILE MESSAGES      #
      CBPINIT;           # SCAN FIRST SOURCE RECORD FOR SYNTACTIC TYPE #
      SSCOUNT = 0;           # INITIALIZE COUNT OF SUBSCHEMAS BEING PUR#
      IF SUBSCHCOUNT[0] EQ 0 THEN 
        BEGIN 
        DDLPRNT (MESSAGE11, 40);
        ERRCNTR = ERRCNTR + 1;
        ABRTFLAG = TRUE;
        GOTO EXIT1; 
        END 
      FOR I=1 STEP 1 WHILE NEXTYPE EQ NAME OR NEXTYPE EQ FNAME DO 
                                 # LOOP THROUGH INPUT REC-             #
        BEGIN            # ORD FOR SYNTACTIC TYPE "NAMES".             #
        STORSSNAM( LOC(NEXWORD), NEXLENW ); 
        SRCHSSNAME;    # SEARCH INDEX TABLE FOR SS NAME.  # 
        IF NOT FLAG THEN # IF NAME NOT FOUND THEN ISSUE DIAGNOSTIC TO  #
          BEGIN          # TO THAT EFFECT.                             #
          SSMSG( LOC(MESSAGE3), LOC(NEXWORD), NEXLENG );
          DDLPRNT( MESSAGE3, 70 );
          ERRCNTR = ERRCNTR + 1;
          TRVERR = 1;      # SET TRIVIAL ERROR FLAG                    #
          LEXSCAN;
                                 # IF , OR $ (EOS) FOUND, SKIP PAST IT #
          IF C<0,1>NEXWRD[0] EQ "," 
            OR C<0,1>NEXWRD[0] EQ "$" 
          THEN
            LEXSCAN;
          TEST; 
          END 
        INDXTBLNEW( SSCTLWDADR + 2 ); # WRITE NEW INDEX TABLE.  # 
        SUBSCHCOUNT[0] = SUBSCHCOUNT[0] - 1;     # DECREMENT COUNT OF  #
                         # SUBSCHEMAS IN FILE TO REFLECT THE PURGE.    #
        SSCOUNT = SSCOUNT + 1;
        SSMSG( LOC(MESSAGE4), LOC(NEXWORD), NEXLENG );
        DDLPRNT( MESSAGE4, 57 );
        LEXSCAN;
                                 # IF , OR $ (EOS) FOUND, SKIP PAST IT #
        IF C<0,1>NEXWRD[0] EQ "," 
          OR C<0,1>NEXWRD[0] EQ "$" 
        THEN
          LEXSCAN;
        END 
      IF I EQ 1 THEN     # IF NO NAMES SPECIFIED IN INPUT RECORD,      #
        BEGIN            # THEN ISSUE DIAGNOSTIC TO THAT EFFECT.       #
        DDLPRNT (MESSAGE14, 50);
        ERRCNTR = ERRCNTR + 1;
        ABRTFLAG = TRUE;
        GOTO EXIT1; 
        END 
      IF SSCOUNT GR 0 THEN
        BEGIN 
        DDLRTSB( LOC(SSCNTRLWRD), 1, WRDADRINDX );
        WRDADRINDX = WRDADRINDX + 1;
        INDTBLEND[0] = O"05160417062323061114"; 
        DDLRTSB(LOC(SSWORKBUF), 1, WRDADRINDX); 
        EXTFLAG = TRUE; 
        END 
        GOTO EXIT1; 
  
  REPLSUBSCH:      # REPLACE SUB-SCHEMA IN FILE WITH THE NEW SUBSCHEMA #
                   # COMPILED. IF SUB-SCHEMA IS NOT FOUND IN FILE, AN  #
                   # INFORMATIVE DIAGNOSTIC IS ISSUED AND THE NEW SUB- #
                   # SCHEMA IS ADDED TO THE FILE.                      #
      SSCOUNT = 0;
      IF SUBSCHCOUNT[0] EQ 0 THEN # IF SUB-SCHEMA FILE IS EMPTY,THEN   #
        BEGIN                     # PRINT MESSAGE TO THAT EFFECT,      #
        DDLPRNT( MESSAGE8, 40 );
        ERRCNTR = ERRCNTR + 1;
        TRVERR = 1;          # SET TRIVIAL ERROR FLAG                  #
        END 
      P<CBWORKBUF> = SBSCHMA;      # SET BASED ARRAY TO START OF SUB-  #
                                  # SCHEMA IN CORE.                    #
      PUTSUBSCHEMA (SSCTLWDADR+2) ;     # WRITE NEW SUBSCHEMA TO FILE. #
      SBDIRCKS;              # CHECKSUM SUBSCHEMA JUST COMPILED        #
      STORSSNAM(SBSCHMA+CTLWDLENG+1,SBSCNAMELENW[CTLWDLENG]);#STORE NAM#
      SRCHSSNAME; 
      IF NOT FLAG THEN          # LE ENTRY IF FOUND, ELSE ADD SUBSCH   #
        BEGIN 
        DDLPRNT( MESSAGE1, 80 );  # IN FILE AND ISSUE INFORMATIVE DIAG-#
        SSCOUNT = SSCOUNT + 1;
        ERRCNTR =ERRCNTR + 1; 
        TRVERR = 1;          # SET TRIVIAL ERROR FLAG                  #
        END 
      INDXTBLNEW( SSCTLWDADR + 2 + SBCWSBLENG[0] ); 
      INDXTBLUPD (SSCTLWDADR + 2);
      SUBSCHCOUNT[0] = SUBSCHCOUNT[0] + SSCOUNT;
      DDLRTSB(LOC(SSWORKBUF), 4, WRDADRINDX);  # WRITE INDEX TABLE #
                                                 # IN FILE. # 
      DDLRTSB( LOC(SSCNTRLWRD), 1, WRDADRINDX+4 ); # AND WRITE COMTROL #
      WRDADRINDX = WRDADRINDX + 5; # WRD IN FILE.UPDATE ADDRESS TP PO- #
      GOTO EXIT;                  # INT TO NEXT AVAILABLE WRD AND EXIT #
  
  
  EXHSSNAMES:      # LIST ALL SUB-SCHEMA NAMES AND DATE CREATED FROM   #
                   # THE SUB-SCHEMA FILE.                              #
  
      DDLSU = FIRSTWORD;   # STORAGE USED                              #
      SKIPMSG = TRUE;      # SET TO SKIP REGULAR DAYFILE MESSAGES      #
# PRINT HEADER LINES, DIAGNOSE EMPTY LIBRARY                           #
      PRNTHEAD; 
      WRDADRINDX = SSINDXSTRT [0];
      P<CBWORKBUF> = LOC (SSWORKBUF); 
#  LOOP THROUGH ALL INDEX TABLE ENTRIES                                #
      FOR J = 1  STEP 1 UNTIL SUBSCHCOUNT [0]  DO 
        BEGIN 
#  READ INDEX ENTRY, READ SUBSCH CONTROL WORDS, PRINT LINE             #
        RDOLDIND; 
        DDLRDSB (LOC(SSWORKBUF), (CTLWDLENG + 1), OLDSSWA [0]); 
        WRTEXLIN; 
        END 
      GOTO EXIT1; 
  
  
 COPYSSFL:               # COPY ACTIVE OLD SUBSCHEMAS TO NEW LIB       #
# SCAN THROUGH INDEX OF OLD SUBSCH LIB, ADDING UP SUBSCH LENGTHS, TO   #
# CALCULATE FIRST WORD ADDRESS OF INDEX ON NEW SUBSCH LIB              #
# IF ANY SUBSCH LENGTH IS ZERO, SEND DIAGNOSTIC AND ABORT              #
      FWANEWIND = 1;
      DDLSU = FIRSTWORD;   # STORAGE USED                              #
      SKIPMSG = TRUE;      # SET TO SKIP REGULAR DAYFILE MESSAGES      #
      WRDADRINDX = SSINDXSTRT [0];
      FOR I = 1  STEP 1 UNTIL SUBSCHCOUNT [0]  DO 
        BEGIN 
        RDOLDIND; 
        IF OLDSSLEN [0] EQ 0  THEN
          BEGIN 
          DDLPRNT (MESSAGE13, 70);
          ERRCNTR = ERRCNTR + 1;
          ABRTFLAG = TRUE;
          GOTO EXIT1; 
  
          END 
        FWANEWIND = FWANEWIND + OLDSSLEN [0]; 
        END 
# OPEN NEW SUBSCH LIB FILE, INITIALIZE VARIABLES, PRINT HEADER LINE    #
      DDLOPNL;
      NEWINDXWA = FWANEWIND;
      WRDADRINDX = SSINDXSTRT [0];
      FWANEWSS = 1; 
      P<CBWORKBUF> = LOC (SSWORKBUF); 
      PRNTHEAD; 
# SCAN THROUGH OLD SUBSCH LIB INDEX AGAIN, WRITING SUBSCHEMAS WHICH    #
# ARE ACTIVE TO NEW SUBSCH LIBRARY                                     #
      FOR I = 1  STEP 1 UNTIL SUBSCHCOUNT [0]  DO 
        BEGIN 
        RDOLDIND; 
#   GENERATE NEW INDEX ENTRY, WRITE TO NEW SUBSCH LIB AT NEWINDXWA     #
        NEWSSNM30 [0] = OLDSSNM30 [0];
        NEWSSWA [0] = FWANEWSS; 
        NEWSSLEN [0] = OLDSSLEN [0];
        DDLRTNL (LOC(NEWINDBUF), 4, NEWINDXWA); 
        NEWINDXWA = NEWINDXWA + 4;
# READ SUBSCH FROM OLD LIB AT FWAOLDSS, WRITE TO NEW LIB AT FWANEWSS   #
        FLAG = TRUE;      # FLAG TO INDICATE FIRST READ ON SS LIB      #
        FWAOLDSS = OLDSSWA [0]; 
        NBRBUFSS = NEWSSLEN [0] / BUFSIZ; 
        LNGSSMODBFS = NEWSSLEN [0] - (BUFSIZ * NBRBUFSS); 
        IF LNGSSMODBFS EQ 0  THEN 
          NBRBUFSS = NBRBUFSS - 1;
# LOOP THRU READS AND WRITES, A BUFSIZ AT A TIME, UNTIL THE ENTIRE     #
# SUBSCHEMA IS COPIED                                                  #
        FOR J = J WHILE NBRBUFSS GQ 0  DO 
          BEGIN 
          IF NBRBUFSS EQ 0  THEN
            LNGSSREAD = LNGSSMODBFS;
          ELSE LNGSSREAD = BUFSIZ;
          DDLRDSB (LOC(SSWORKBUF), LNGSSREAD, FWAOLDSS);
#  ON READ OF FIRST BUFFER, PRINT LINES WITH SUBSCH INFORMATION        #
          IF FLAG   THEN
            BEGIN 
            FLAG = FALSE; 
            WRTEXLIN; 
            END 
# WRITE BUFFER TO NEW SUBSCH LIB FILE, INCREMENT ADDRESSES             #
          DDLRTNL (LOC(SSWORKBUF), LNGSSREAD, FWANEWSS);
          FWAOLDSS = FWAOLDSS + LNGSSREAD;
          FWANEWSS = FWANEWSS + LNGSSREAD;
          NBRBUFSS = NBRBUFSS - 1;
          END 
        END 
# WRITE CONTROL WORD AND END-OF-SUBSCH MARKER TO NEW LIB FILE          #
      SSINDXSTRT [0] = FWANEWIND; 
      DDLRTNL (LOC(SSCNTRLWRD), 1, NEWINDXWA);
      NEWINDXWA = NEWINDXWA + 1;
      INDTBLEND[0] = O"05160417062323061114"; 
      DDLRTNL (LOC(SSWORKBUF), 1, NEWINDXWA); 
# PRINT MESSAGE FOR NEW LIBRARY GENERATED, CLOSE NEW LIB FILE          #
      DDLPRNT (MESSAGE12, 60);
      DDLCLNL;
      GOTO EXIT1; 
  
  
  EXIT:            # CLOSE FILES AND END FILE UPDATE.                  #
      INDTBLEND[0] = O"05160417062323061114"; # STORE ACTUAL END OF    #
      DDLRTSB( LOC(SSWORKBUF), 1, WRDADRINDX ); # SUBSCHEMA FILE AND   #
                                  # WRITE IT TO THE SUBSCHEMA FILE.    #
      IF NEWFILE GR 1 AND EXHSS NQ 1 THEN 
        EXTFLAG = TRUE; 
      DE$CLSC;     # CLOSE SCHEMA DIRECTORY FILE #
  EXIT1:    #   # 
      CMESG[0] = "          ";
      DDLPRNT( COMMESG,10 );
      DDLPRNT( MESSAGE7, 70 );
      CLSESB; 
      IF EXTFLAG  THEN
        CBEXT( SBLFN ); 
      IF ABRTFLAG THEN
        DDLABT( 5 );
      CLSEOUT;
      IF MULTSS THEN         # IF MULTIPLE SUBSCHEMAS TO BE COMPILED   #
        OVLINIT;             # RE-ENTER (0,0) OVERLAY                  #
      STOP; 
  
  PROC ADJTOPRUBND( NOWORDS );
#**********************************************************************#
#                  A D J T O P R U B N D                               #
#                                                                      #
#   ADJUSTS THE LENGTH PASSED TO IT , TO A PRU BOUNDARY.               #
#**********************************************************************#
  
    BEGIN 
      ITEM NOWORDS;      # LENGTH TO BE ADJUSTED.  #
      ITEM I1;           # SCRATCH VARIABLE.  # 
      IF NOWORDS EQ 0 THEN
        BEGIN 
        SBADJLENG = 0;
        RETURN; 
        END 
      I1 = NOWORDS - ((( NOWORDS - 1 )/64 ) * 64 ); 
      SBADJLENG = NOWORDS + 64 - I1;
      RETURN; 
    END 
  
  PROC INDXTBLNEW( WRITEADR );
#**********************************************************************#
#                  I N D X T B L N E W                                 #
#                                                                      #
#   WRITES THE NEW INDEX TABLE INTO THE SUB- SCHEMA FILE MINUS THE     #
#   ENTRY OF THE PURGED SUB-SCHEMA, IF PURGE IS TO TAKE PLACE. ELSE    #
# WRITES THE OLD INDEX TABLE AS IS.                                    #
#**********************************************************************#
  
    BEGIN 
      ITEM I3,J3,K3;     # SCRATCH VARIABLES  # 
      ITEM WRITEADR;
      J3 = SUBSCHCOUNT[0] * 4;
      WRDADRINDX = SSINDXSTRT[0]; # INITIALIZE TO START OF INDEX TABLE #
      SSINDXSTRT[0] = WRITEADR;   # STORE ADDRESS OF START OF INDEX TBL#
      FOR I3 = I3 WHILE J3 GR 0 DO # LOOP TO READ IN INDEX TABLE ENT.  #
        BEGIN 
        IF J3 GR BUFSIZ THEN      # IF INDEX TABLE LENBTH EXCEEDS WORK #
          I3 = BUFSIZ;            # BUFFER SIZE, THEN SET VARIABLE TO  #
        ELSE                      # MAXIMUM SIZE, ELSE                 #
          I3 = J3;                # SET SIZE TO INDEX TABLE LENGTH.    #
        J3 = J3 - I3;             # DECREMENT LENGTH OF INDEX TABLE.   #
        DDLRDSB( LOC(SSWORKBUF), I3, WRDADRINDX ); # READ IN INDX TBL  #
        K3 = I3;
      IF FLAG AND LENGMVD LS I3  THEN 
        BEGIN 
        IF LENGMVD NQ 0  THEN 
          BEGIN 
          ADJTOPRUBND (LENGMVD);
          DDLRTSB (LOC(SSWORKBUF), SBADJLENG, WRITEADR);
          WRITEADR = WRITEADR + LENGMVD;
          END 
        LENGMVD = LENGMVD + 4;
        I3 = I3 - LENGMVD;
        IF I3 NQ 0  THEN
          BEGIN 
          ADJTOPRUBND (I3); 
          DDLRTSB (LOC(SSWORKBUF) + LENGMVD, SBADJLENG, WRITEADR);
          END 
        FLAG = FALSE; 
        END 
        ELSE
          BEGIN 
          ADJTOPRUBND(I3);
          DDLRTSB( LOC(SSWORKBUF), SBADJLENG, WRITEADR);
          LENGMVD = LENGMVD - I3; 
          END 
        WRITEADR = WRITEADR + I3; 
        WRDADRINDX = WRDADRINDX + K3; 
        END 
      WRDADRINDX = WRITEADR;  # STORE ADDRESS OF NEXT AVAILABLE WORD   #
                             # FOR A WRITE IN THE SUBSCH FILE.         #
      RETURN; 
    END 
  
 PROC INDXTBLUPD (WRDADDR); 
#**********************************************************************#
#                  I N D X T B L U P D                                 #
#                                                                      #
#   BUILDS AN ENTRY IN THE INDEX TABLE FOR A NEW SUB-SCHEMA.           #
#**********************************************************************#
  
    BEGIN 
      ITEM WRDADDR;  # WORD ADDRESS OF SUBSCHEMA AS IT RESIDES IN FILE #
  
      SSINDXNME30 [0] = SSNAM30 [0];
      SSWRDADDR [0] = WRDADDR;
      SSINDXLEN [0] = SBCWSBLENG [0]; 
      RETURN; 
    END 
  
        PROC PRNTHEAD;
#********************************************************************* #
#                   P R N T H E A D                                    #
#                                                                      #
#   PRINT HEADER LINES FOR SUBSCHEMA FILE LIST                         #
#   ENTER WITH CONTROL WORD IN THE ARRAY SSCNTRLWRD                    #
#   EXITS WITH FRSTINDWD = WORD ADDRESS OF START OF INDEX ON LIBRARY   #
#   EXIT TO ABORT PROCESSING IF SUBSCH COUNT IN LIB CONTROL WD IS ZERO #
#********************************************************************* #
  
      BEGIN 
  
      ITEM IPRNT; 
  
      IF SUBSCHCOUNT[0] EQ 0 THEN 
        BEGIN 
        DDLPRNT (MESSAGE11, 40);
        ERRCNTR = ERRCNTR + 1;
        ABRTFLAG = TRUE;
        GOTO EXIT1; 
        END 
      DDLPRNT( MESSAGE5, 40 );
      FOR IPRNT = 0  STEP 1 UNTIL 12  DO
        CMESG [IPRNT] = "          "; 
      DDLPRNT (COMMESG, 10);
      DDLPRNT( MESSAGE6A, 120 );
      CMESG[4] = "    DATE  ";
      CMESG[5] = "  TIME    ";
      CMESG[10] = "    DATE  "; 
      CMESG[11] = "  TIME    "; 
      DDLPRNT( COMMESG, 120 );
      DDLPRNT( MESSAGE6B, 120); 
      RETURN; 
      END 
  
  PROC PUTSUBSCHEMA ((WA)) ;
#**********************************************************************#
#                       P U T S U B S C H E M A                        #
#                                                                      #
#   COPIES THE SUBSCHEMA DIRECTORY FROM CORE ((SBSCHML) WORDS STARTING #
#   AT (SBSCHMA)) AND THEN, IF THIS DOES NOT INCLUDE THE MAPPING CODE  #
#   CAPSULES, COPIES THEM FROM CODE GENERATOR SCRATCH FILE.  WRITES    #
#   ON THE SUBSCHEMA LIBRARY FILE STARTING AT WORD ADDRESS (WA).       #
#   IF IT IS A FORTRAN SUB-SCHEMA, THEN ADDFTN IS CALLED TO ADD        #
#   FORTRAN SOURCE STATEMENTS TO THE END OF THE SUB-SCHEMA.            #
#**********************************************************************#
    ITEM WA ; 
    ITEM TEMP;                         # HOLDS SBCWSBLENG              #
    ITEM MAX;                          # MAX WORDS TO READ             #
    BEGIN 
      TEMP = SBCWSBLENG;     # SAVE SS LENGTH IN CONTROL WDS           #
                                       # IF FORTRAN SUBSCHEMA,         #
      IF DDLCOMP EQ F4 OR DDLCOMP EQ F5 THEN
      BEGIN                            # ADD TO CONTROL WORDS          #
        PRES1S2;                       # PREPARE SSOUT1, SSOUT2        #
        SBCWFTNSSFWA = SBCWSBLENG + 1; # STORE FWA SSOUT               #
        SBCWFTNSSLEN = LENS1S2;        # STORE LENGTH SSOUT (S1+S2)    #
        SBCWSBLENG = SBCWSBLENG + LENS1S2; # ADD TO LENGTH OF SUBSCHEMA#
      END 
      ITEM N ;
      DDLRTSB (SBSCHMA, SBSCHML, WA) ;  # WRITE DIRECTORY # 
      WA = WA + SBSCHML;
      IF SBSCHML NQ TEMP THEN 
        BEGIN                           # IF CAPSULES NOT INCLUDED #
          OPENCS ;                           # OPEN SCRATCH FILE #
          N = BUFSIZ ;
          FOR WA = WA STEP N
                   WHILE  N EQ BUFSIZ  DO    # FOR EACH BUFSIZ WORDS #
            BEGIN 
              READCS (SSWORKBUF, BUFSIZ, N) ;     # READ A BUFFERFUL #
              IF  N NQ 0  THEN                     # AND COPY IT OUT #
                DDLRTSB (LOC (SSWORKBUF), N, WA) ;
            END 
          CLOSECS ;                          # CLOSE SCRATCH FILE # 
        END 
      IF DDLCOMP EQ F4 OR DDLCOMP EQ F5 THEN  # IF FORTRAN SUB-SCHEMA, #
        BEGIN                                 # ADD SOURCE LINES AT END#
          MAX = BUFSIZ;                   # COPY SSOUT1 TO LIB         #
          N   = BUFSIZ; 
          IF LENS1 LS BUFSIZ
          THEN
            BEGIN 
              MAX = LENS1;
              N = LENS1;
            END 
          FOR WA = WA WHILE LENS1 GR 0 DO 
            BEGIN 
              READS1(SSWORKBUF,MAX,N);
              DDLRTSB (LOC(SSWORKBUF),N,WA);
              WA = WA + N;
              LENS1 = LENS1 - N;
              IF MAX GR LENS1 
              THEN
                BEGIN 
                  MAX = LENS1;
                  N   = LENS1;
                END 
            END 
          MAX = BUFSIZ;                   # COPY SSOUT2 TO LIB         #
          N   = BUFSIZ; 
          IF LENS2 LS BUFSIZ
          THEN
            BEGIN 
              MAX = LENS2;
              N = LENS2;
            END 
          FOR WA = WA WHILE LENS2 GR 0 DO 
            BEGIN 
              READS2(SSWORKBUF,MAX,N);
              DDLRTSB (LOC(SSWORKBUF),N,WA);
              WA = WA + N;
              LENS2 = LENS2 - N;
              IF MAX GR LENS2 
              THEN
                BEGIN 
                  MAX = LENS2;
                  N   = LENS2;
                END 
            END 
          CLS1S2;                             # CLOSE SSOUT1, SSOUT2   #
        END 
      RETURN ;
    END 
  
      PROC RDOLDIND;
#********************************************************************* #
#                   R D O L D I N D                                    #
#   READ INDEX FILE ENTRY FROM OLD SUBSCHEMA FILE AT WORD ADDRESS      #
#   WRDADRINDX  INTO BUFFER OLDINDBUF.  INCREMENT WRDADRINDX BY 4.     #
#      CALLED BY EXHSSNAMES, COPYSSFL                                  #
#********************************************************************* #
  
      BEGIN 
      DDLRDSB (LOC(OLDINDBUF), 4, WRDADRINDX);
      WRDADRINDX = WRDADRINDX + 4;
      RETURN; 
      END 
  
      CONTROL EJECT;
  PROC SBDIRCKS;
#**********************************************************************#
#                  S B D I R C K S                                     #
#                                                                      #
#   FUNCTION -                                                         #
#     CHECKSUM SUBSCHEMA DIRECTORY, INCLUDING AREA, RECORD, ITEM,      #
#     DATA CONTROL AND RELATION ENTRIES.                               #
#                                                                      #
#   METHOD -                                                           #
#     THE CHECKSUM PROCESS IS CONTROLLED BY THE SUBSCHEMA REALM/       #
#     RELATION AND RECORD LISTS.                                       #
#                                                                      #
#     WORD ADDRESS FIELDS ARE ERASED FOR ALL SUBSCHEMA ENTRIES UNDER   #
#     CONTROL OF -FOR- LOOPS. THE ORDER OF PROCESSING IS AS FOLLOWS-   #
#                                                                      #
#     FOR EACH REALM UNTIL REALM LIST IS EXHAUSTED                     #
#       RETRIEVE REALM(AREA) CHECKSUM FROM SCHEMA AND ADD TO SUBSCHEMA #
#       BLOCK OF SCHEMA CHECKSUMS.                                     #
#       PROCESS DATA CONTROL ENTRY.                                    #
#                                                                      #
#         THEN FOR EACH RECORD OF THIS REALM UNTIL RECORD LIST IS      #
#         EXHAUSTED                                                    #
#           PROCESS RECORD ENTRY.                                      #
#           PROCESS ITEM ENTRIES.                                      #
#                                                                      #
#     FOR EACH RELATION UNTIL RELATION LIST IS EXHAUSTED               #
#       RETRIEVE RELATION CHECKSUM FROM SCHEMA AND ADD TO SUBSCHEMA    #
#       BLOCK OF SCHEMA CHECKSUMS.                                     #
#       PROCESS RELATION ENTRY.                                        #
#     WHEN ALL WORD ADDRESSES HAVE BEEN ERASED, SUBROUTINE CKSUM IS    #
#     CALLED TO CHECKSUM THE ENTIRE SUBSCHEMA.                         #
#                                                                      #
#     THE SCHEMA CHECKSUM BLOCK IS WRITTEN TO THE SUBSCHEMA DIRECTORY. #
#     SUBSCHEMA INDEX TABLE AND CONTROL WORDS ARE UPDATED TO REFLECT   #
#     THE ADDITION OF THE CHECKSUM BLOCK.                              #
#                                                                      #
#   ENTRY CONDITIONS -                                                 #
#     SUBSCHEMA HAS BEEN WRITTEN TO DISK. A COPY IS INTACT IN CM.      #
#     BASED ARRAY LIBWORKBUF POINTS TO SUBSCHEMA.                      #
#                                                                      #
#   EXIT CONDITIONS  -                                                 #
#     SUBSCHEMA CHECKSUMMING IS COMPLETE. SCHEMA CHECKSUM BLOCK HAS    #
#     BEEN WRITTEN TO DISK. INDEX TABLE AND CONTROL WORDS NOT YET      #
#     WRITTEN TO DISK.                                                 #
#                                                                      #
#   EXTERNAL CALLS -                                                   #
#     CKSUM,DDLPRNT,DDLRTSB,DE$NMSC,DE$GTSC                            #
#                                                                      #
#**********************************************************************#
      CONTROL EJECT;
      BEGIN 
      IF SCLFN EQ 0 THEN
        SCLFN = SBCWSCHEMANM[0];                 #USE DEFINED SCH NAME #
      DE$OPSC(SCLFN,DITWK,CKSBUF,66);            #OPEN SCHEMA FILE     #
      P<CKSBLK> = LOC(SSWORKBUF);  # FWA OF CHECKSUM BLOCK #
      LWACKSBLK = LOC(SSWORKBUF) + BUFSIZ - 3; # LWA OF CHECKSUM BLOCK #
      CKSWRD[0] = 0;               #CLEAR HEADER WORD#
      CKSRLS[0] = SBCWNUMRELS[0];  #BUILD SCHEMA CHECKSUM#
      CKSARS[0] = SBCWNUMAREAS[0]; #BLOCK HEADER         #
      P<CKSBLK> = LOC(SSWORKBUF) + 1;  # POSITION FOR CHECKSUMS # 
      SBCWCHECKSUM[0] = 0;   #INITIALIZE SUBSCHEMA CHECKSUM CONTROL WD #
      SBCWCKSUMWA[0] = SBCWSBLENG[0];  #SET CHECKSUM WORD ADDRESS#
      RLMPTR = 0; 
      LENGMVD = 0;
      P<REALMLIST> = LOC(CBWORKBUF) + SBCWRLMLSTAD[0]; #REALM LIST ADR #
      FOR I = 0 STEP 1 UNTIL SBCWNUMAREAS[0] - 1 DO   # REALM LOOP     #
      BEGIN 
      FOR J = 0 STEP 1 UNTIL 2 DO 
        AREAWD[J] = 0;                           #CLEAR AREA NAME      #
      CKSPTR = REALMADR[RLMPTR];                 #POINT TO REALM ENTRY #
        IF SBARALIASPTR[CKSPTR] NQ 0 THEN        #MUST GET ALIAS NAME  #
          BEGIN 
          J = CKSPTR + SBARALIASPTR[CKSPTR];
          K = SBARALIASLW[CKSPTR];
          C<0,SBARALIASLC[CKSPTR]>  AREANM[0] =  #GET AREA ALIAS NAME  #
          C<0,SBARALIASLC[CKSPTR]>  SBARALIAS30[J]; 
          END 
        ELSE                                     #NO ALIAS REALM NAME  #
          BEGIN 
          J = CKSPTR + SBARNAMEPTR[CKSPTR]; 
          K = SBARLENGWRDS[CKSPTR]; 
          C<0,SBARLENGCHAR[CKSPTR]>  AREANM[0] = #GET AREA NAME        #
          C<0,SBARLENGCHAR[CKSPTR]>  SBARNAME30[J]; 
          END 
        DE$NMSC(DITWK,3,ARNAME,K,5,ORDWK);       #GET REALM/AREA ORD   #
        IF LOC(CKSBLK) GQ LWACKSBLK THEN
          WRITECKSUM;        #NOT ENOUGH WSA,WRITE CURRENT BLOCK# 
        J = SCCWCKSUMWA[0] + (SCAREAORD[0]-1)*4 + 1; #SCHEMA CHECKSUM#
        DE$GTSC(CKSBLK,40,J);      #GET CORRESPONDING SCHEMA CHECKSUM#
        P<CKSBLK> = LOC(CKSBLK) + 4;  #POSTION FOR NEXT CHECKSUM# 
        J = SBARDCONTRLA[CKSPTR];                #FIND DC ENTRY        #
        DCLPTR = J + SBDCALTRKYPT[J];            #AND POINT TO 1ST KEY #
        J = DCLPTR;                              #SET J NONZERO        #
        FOR J = J WHILE J NQ 0 DO                #KEY LOOP             #
          BEGIN 
          SBDCRCENTRYA[DCLPTR] = 0;              #ERASE REC ENTRY WA   #
          J = SBDCKEYNITM[DCLPTR+1];             #SET J FOR NEXT PASS  #
          IF SBDCKEYIMBED[DCLPTR+1] THEN
            BEGIN 
            SBDCKEYDNADR[DCLPTR+2] = 0;          #ERASE DATANAME WA    #
            IF SBDCCONCTFG[DCLPTR+1] THEN        #CONCATENATED KEY     #
              BEGIN 
                K = DCLPTR + SBDCCNNMELW[DCLPTR+2]+2; #ADDR OF DN LIST# 
                FOR L = 0 STEP 1 UNTIL           #CONCAT KEY LOOP      #
                  SBDCCNNBRITM[DCLPTR+2] - 1 DO  #DBI LOOP             #
                SBDCCNDBIS[K+L] = 0;             #ERASE DBI WA         #
              END 
            END 
          DCLPTR = DCLPTR + J;     #INDEX TO NEXT KEY#
          END 
        SBARSYNADDR[CKSPTR] = 0;                 #ERASE SYNONYM WA     #
        SBARNEXT[CKSPTR] = 0;                    #ERASE NEXT AREA WA   #
        SBARDCONTRLA[CKSPTR] = 0;                #ERASE DC ENTRY WA    #
        SBARSAMENAME[CKSPTR] = 0;                #ERASE SAMENAME WA    #
      SBARSRCLNEN[CKSPTR] = 0;                   #ERASE SOURCE LINE NO #
        SBARKEYCAPA[CKSPTR] = 0;                 #ERASE KEY CAPSULE WA #
        SBARHASHWA[CKSPTR] = 0;                  # ERASE HASHTABLE WA  #
                                                 #POINT TO RECORD LIST #
        P<RECORDLIST> = LOC(REALMLIST) + REALMRECLIST[RLMPTR];
        FOR J = 0 STEP 1 UNTIL REALMRECLEN[RLMPTR]-1 DO    #RECORD LOOP#
          BEGIN 
            CKSPTR = RECLISTLADR[J];             #POINT TO RECORD ENTRY#
            SBRECSYNADR[CKSPTR] = 0;             #ERASE SYNONYM WA     #
            SBRECSMENMEA[CKSPTR] = 0;            #ERASE SAMENAME WA    #
            SBRECRLMADR[CKSPTR] = 0;             #ERASE OWNER AREA WA  #
            SBRECSRCLNEN[CKSPTR] = 0;            #ERASE SOURCE LINE NO #
            SBRECRDCAPA[CKSPTR] = 0;             #ERASE READ MAP WA    #
            SBRECWRCAPA[CKSPTR] = 0;             #ERASE WRITE MAP WA   #
            ITMPTR = CKSPTR + SBRECNXITEMP[CKSPTR];  #PT TO FIRST ITEM #
            FOR K = 0 STEP 1 UNTIL SBRECNBRITMS[CKSPTR]-1 DO #ITEM LOOP#
              BEGIN 
                ITMST = ITMPTR; 
                SBITMDOMADR[ITMPTR] = 0;         #ERASE DOM ITEM WA    #
            SBITMSCPTR[ITMPTR] = 0;              # ERASE SCHEMA PTR    #
            SBITMSAMEPTR[ITMPTR] = 0;            # ERASE SAMENAME PTR  #
                SBITMSYNADDR[ITMPTR] = 0;        #ERASE SYNONYM WA     #
                SBITMSRCLNEN[ITMPTR] = 0;        #ERASE SOURCE LINE NO #
                SBITMNXSSWA[ITMPTR] = 0;         #ERASE NEXT SS ITEM WA#
                SBITMNXSCPTR[ITMPTR] = 0;        #ERASE NEXT SC ITEM WA#
                IF SBITMRNRDPTR[ITMPTR] NQ 0 THEN     #IF RENAME-REDEF #
                BEGIN 
                  ITMPTR = ITMPTR + SBITMRNRDPTR[ITMPTR];  #PT TO RN-RD#
                    FOR L = ITMPTR WHILE L NQ 0 DO #RN-RD LOOP# 
                    BEGIN 
                    IF SBITMRRNNXT[ITMPTR] THEN  #NEXT FLAG - LOOP CTL #
                      L = 1;
                    ELSE
                      L = 0;
                  SBITMLRNDNAD[ITMPTR] = 0;      #ERASE LEFT RN-RD WA  #
                  SBITMRRNDNAD[ITMPTR] = 0;      #ERASE RIGHT RN-RD WA #
                      ITMPTR = ITMPTR + 1;
                    END 
                END 
                ELSE
                IF SBITMOCCURP[ITMPTR] NQ 0 THEN #OCCURS ITEM          #
                BEGIN 
                  ITMPTR = ITMPTR + SBITMOCCURP[ITMPTR];  #PT TO OCCURS#
                  IF SBITMDEPNDON[ITMPTR] OR     #DEP ON ITEM          #
                     SBITMOCCKNXT[ITMPTR] THEN   #KEY/INDEX            #
                    BEGIN 
                    ITMPTR = ITMPTR + 1;
                    FOR L = ITMPTR WHILE L NQ 0 DO  #OCCURS LOOP       #
                    BEGIN 
                      IF SBITMOCCLNXT[ITMPTR] THEN  #NEXT FLAG-LOOP CTL#
                        L = 1;
                      ELSE
                        L = 0;
                      IF SBITMOCCLTYP[ITMPTR] NQ 1 THEN  #IF NOT INDEX #
                        SBITMOCCLDNA[ITMPTR] = 0; #ERASE DN/KN WA      #
                      ITMPTR = ITMPTR + 1;
                    END 
                    END 
                END 
              ITMPTR = ITMST + SBITMNEXTP[ITMST];  #PT TO NEXT ITEM    #
              END 
          END 
        RLMPTR = RLMPTR + 4;                     #PT TO NXT RLMLIST ENT#
      END 
      IF SBCWNUMRELS[0] NQ 0 THEN 
        BEGIN 
      FOR I = 0 STEP 1 UNTIL SBCWNUMRELS[0] - 1 DO    #RELATION LOOP   #
      BEGIN 
        FOR J = 0 STEP 1 UNTIL 2 DO 
          AREAWD[J] = 0;                         #CLEAR RELATION NAME  #
        CKSPTR = RELATIONADR[RLMPTR];            #PT TO RELATION ENTRY #
        C<0,RSTRELNMELC[CKSPTR]> AREANM[0] =     #GET RELATION NAME    #
        C<0,RSTRELNMELC[CKSPTR]> RSTRELNAME30[CKSPTR];
        J = RSTRELNMELW[CKSPTR];
        DE$NMSC(DITWK,3,ARNAME,J,5,ORDWK);       #GET RELATION ORDINAL# 
        IF LOC(CKSBLK) GQ LWACKSBLK THEN
          WRITECKSUM;        #NOT ENOUGH WSA,WRITE PARTIAL BLOCK# 
        L = SCCWCKSUMWA[0] + SCCWNUMAREAS[0]*4 + (SCRELORD[0]-1)*4 + 1; 
        DE$GTSC(CKSBLK,40,L);      #GET CORRESPONDING RELATION CKSUM# 
        P<CKSBLK> = LOC(CKSBLK) + 4;   #POSITION FOR NEXT CHECKSUM# 
        J = ((RSTHIGHRANK[CKSPTR]-2)*2)+1;       #NUMBER OF DBI-S      #
        CKSPTR = CKSPTR + RSTRELNMELW[CKSPTR] + 2;    #PT TO DBI-S     #
        FOR K = 0 STEP 1 UNTIL J-1 DO            #DBI LOOP             #
        BEGIN 
          RSTAREAADR[CKSPTR+1] = 0;              #ERASE AREA WA        #
          CKSPTR = CKSPTR + 2;                   #INDEX TO NEXT DBI    #
        END 
      RLMPTR = RLMPTR + 4;                       #INDEX TO NEXT RELN   #
      END 
      END 
      K = SBCWRLMLSTAD[0] - SBCWFRSTAREA[0];  #NO OF WORDS TO CHECKSUM# 
                   #***************************************************#
                   #                                                   #
                   #         CHECKSUM THE SUBSCHEMA                    #
                   #                                                   #
                   #***************************************************#
      I = SBSCHMA + SBCWFRSTAREA[0];  #FIRST WORD ADDR FOR CHECKSUM#
                                            #COMPUTE SUBSCHEMA CHECKSUM#
      SBCWCHECKSUM[0] = CKSUM(SBCWCHECKSUM[0], I, K); 
      CKSPRNM[0] = " ";                          #BLANK FILL FOR NAME  #
                                                 #SS NAME TO MESSAGE   #
      CKSPRNM[0] = C<0,SBSCNAMELENC[CTLWDLENG]> SBSCHNAM30[CTLWDLENG];
      DDLPRNT(SSHDPR,60);                        #PRINT SS HEADER LINE #
      OCT20(SBCWCHECKSUM[0],CKSPRNT,5);     #CHECKSUM VAL-20OCTAL DIGS #
      DDLPRNT(CKSPRNT,70);                       #PRINT CHECKSUM       #
      WRITECKSUM;            #WRITE SCHEMA CHECKSUMS TO SS FILE#
      SBCWSBLENG = SBCWSBLENG + LENGMVD;
      LENGMVD = 0;
      DDLRTSB(SBSCHMA,CTLWDLENG,SSCTLWDADR+2); # UPDATE CONTROL WORDS # 
      RETURN; 
      END 
  PROC SRCHSSNAME;
#**********************************************************************#
#                  S R C H S S N A M E                                 #
#                                                                      #
#   SEARCHES THE INDEX TABLE FOR A MATCHING SUB- SCHEMA NAME. IF,      #
#   FOUND A FLAG IS SET TO INDICATE SO AND THE LOCATION OF THAT NAME   #
#   IN THE WORKING STORAGE AREA IS STORED IN LENGMVD.                  #
#**********************************************************************#
  
    BEGIN 
      ITEM I4,J4,K4;
      WRDADRINDX = SSINDXSTRT[0]; # INITIALIZE TO START OF INDEX TABLE #
      LENGMVD = 0;
      FLAG = FALSE; 
      J4 = SUBSCHCOUNT[0] * 4;
      FOR I4 = I4 WHILE J4 GR 0 DO # LOOP TO READ IN INDEX TABLE.  #
        BEGIN 
        IF J4 GR BUFSIZ THEN
          I4 = BUFSIZ;
        ELSE
          I4 = J4;
        J4 = J4 - I4; 
        DDLRDSB( LOC(SSWORKBUF), I4, WRDADRINDX ); # READ IN INDEX TBL #
                                                   # ENTRIES.          #
        FOR K4 = 0 STEP 4 UNTIL I4 - 1 DO # LOOP TO SEARCH FOR SS NAME #
          BEGIN 
          IF SSNAM30[0] EQ SSINDXNME30[K4] THEN 
            BEGIN 
            FLAG = TRUE;
            LENGMVD = LENGMVD + K4; 
            RETURN; 
            END 
          END 
        WRDADRINDX = WRDADRINDX + I4; 
        LENGMVD = LENGMVD + I4; 
        END 
      IF NOT FLAG THEN
        LENGMVD = 0;
      RETURN; 
    END 
  
  PROC SSMSG( MSGLOC, NAMLOC, NAMLENC );
#**********************************************************************#
#                  S S M S G                                           #
#                                                                      #
#   FILLS IN THE SUB-SCHEMA NAME PASSED TO IT, IN THE MESSAGE ARRAY.   #
#**********************************************************************#
  
    BEGIN 
      BASED ARRAY MSGARR [0:7]; 
        ITEM MSGN C(0,0,10);
      ITEM MSGLOC;     # LOCATION OF  MESSAGE ARRAY FOR BNAME STORE.   #
      ITEM I2,J2,K2;   # SCRATCH VARIABLES.  #
      BASED ARRAY NAMARR [0:2]; 
        ITEM NAM C(0,0,10); 
      ITEM NAMLOC;     # LOCATION WHERE SUBSCH NAME IS STORED.         #
      ITEM NAMLENC;    # LENGTH OF NAME IN CHARACTERS.                 #
      P<MSGARR> = MSGLOC; 
      P<NAMARR> = NAMLOC; 
      J2 = 0; 
      K2 = (NAMLENC - 1)/10 + 1;
      MSGN[2] = "          "; 
      MSGN[3] = "          "; 
      MSGN[4] = "          "; 
      FOR I2 = 2 STEP 1 WHILE K2 NQ 0 DO
        BEGIN 
        IF NAMLENC GR 10 THEN 
          BEGIN 
          MSGN[I2] = NAM[J2]; 
          NAMLENC = NAMLENC - 10; 
          J2 = J2 + 1;
          END 
        ELSE
          C<0,NAMLENC>MSGN[I2] = C<0,NAMLENC>NAM[J2]; 
        K2 = K2 - 1;
        END 
      RETURN; 
    END 
  
  PROC STORSSNAM( ASSNAMLOC, SSNAMLENG ); 
#**********************************************************************#
#                  S T O R S S N A M                                   #
#                                                                      #
#   STORES THE SUB-SCHEMA NAME PASSED TO IT AS A 30 CHARACTER ENTITY.  #
#**********************************************************************#
  
    BEGIN 
      ITEM ASSNAMLOC;    # LOCATION OF  SUBSCHEMA NAME  # 
      ITEM SSNAMLENG;     # LENGTH OF SUBSCHEMA NAME.  #
      BASED ARRAY SSNAMBAS [0:2]; 
        ITEM SSNAMPT C(0,0,10); 
      P<SSNAMBAS> = ASSNAMLOC;
      FOR J = 0  STEP 1 UNTIL 2  DO 
        B<0,60>SSNAM [J] = 0; 
      FOR J = 0 STEP 1 UNTIL SSNAMLENG - 1 DO 
        SSNAM[J] = SSNAMPT[J];
    END 
  
  
      PROC WRTEXLIN;
#********************************************************************* #
#                   W R T E X L I N                                    #
#   WRITES A LINE TO THE OUTPUT FILE USING DDLPRNT PROC.  THE LINE     #
#   IS STORED IN ARRAY COMMESG.  IT CONTAINS -                         #
#     WORDS 1, 2, 3 - A SUBSCHEMA NAME, OBTAINED FROM OLDINDBUF.       #
#     WORDS 4, 5    - DATE AND TIME OF SUBSCHEMA CREATION, OBTAINED    #
#                     FROM THE SSWORKBUF, WHICH CONTAINS THE SUBSCHEMA #
#                     CONTROL WORDS.                                   #
#     WORDS 7, 8, 9 - SCHEMA NAME, OBTAINEDD FROM THE SUBSCHEMA        #
#                     CONTROL WORDS IN SSWORKBUF.                      #
#     WORDS 10, 11  - DATE AND TIME OF SUBSCHEMA CREATION, OBTAINED    #
#                     FROM THE SUBSCHEMA CONTROL WORDS IN SSWORKBUF.   #
#   ON ENTRY, BASED ARRAY LIBWORKBUF MUST POINT TO A BUFFER WHICH      #
#   CONTAINS THE FIRST 12 WORDS (CONTROL WORDS) OF THE SUBSCHEMA.      #
#   USUALLY SSWORKBUF IS THIS BUFFER.   ALSO ARRAY OLDINDBUF MUST      #
#   CONTAIN AN INDEX TABLE ENTRY FOR THE CURRENT SUBSCHEMA.            #
#      CALLED BY EXHSSNAMES, COPYSSFL                                  #
#********************************************************************* #
  
      BEGIN 
  
      ITEM IWRT U;
      ITEM TEMP U;
  
      FOR IWRT = 0 STEP 1 UNTIL 12  DO       # BLANK FILL LINE         #
        CMESG [IWRT] = "          ";
      C<0,SBSCNAMELENC [CTLWDLENG]> CMESG30 [1]    # STORE SUBSCH NAME #
          = C<0,SBSCNAMELENC [CTLWDLENG]> OLDSSNM30 [0];
      FOR IWRT = 0  STEP 1 UNTIL 29  DO      # STORE SCHEMA NAME       #
        BEGIN 
        C<0> TEMP = C<IWRT> SBCWSCHNAM30 [0]; 
        IF TEMP NQ 0  THEN
          C<IWRT> CMESG30 [7] = C<0> TEMP;
        ELSE IWRT = 30;            # STOP AT FIRST ZERO-FILL CHARACTER #
        END 
      B<24,30> CMESG [4] = SBCWSBSCHDTE [0];
      B<12,30> CMESG [5] = SBCWSBSCHTME [0];
      B<24,30> CMESG [10] = SBCWSCHDATE [0];
      B<12,30> CMESG [11] = SBCWSCHTIME [0];
      DDLPRNT (COMMESG, 130);                # PRINT LINE              #
      RETURN; 
      END 
  
  
  PROC WRITECKSUM;
#**********************************************************************#
#                   W R I T E C K S U M                                #
#                                                                      #
#   WRITES SCHEMA CHECKSUM BLOCK TO SUBSCHEMA FILE--PARTIAL OR FULL.   #
#**********************************************************************#
    BEGIN 
      ITEM I,J;              #SCRATCH VARIABLES#
      I = SBCWSBLENG[0] + SSCTLWDADR+2 + LENGMVD;#ADR AT WHICH TO WRITE#
      J = LOC(CKSBLK) - LOC(SSWORKBUF); # NUMBER OF WORDS TO WRITE #
      DDLRTSB(LOC(SSWORKBUF), J, I);    # WRITE CHECKSUM BLOCK #
      LENGMVD = LENGMVD + J;           #NUMBER OF BLOCK WORDS WRITTEN#
      P<CKSBLK> = LOC(SSWORKBUF);       # RESET BLOCK POSITION #
      RETURN; 
    END          #END OF PROC#
