*DECK CBINDEX 
USETEXT TSBTBL                                                          005210
  PRGM FTINDEX;                                                         008930
    BEGIN 
#**********************************************************************#
#                                                                      #
#                  C B I N D E X                                       #
#                                                                      #
#   BUILDS THE INDEX THAT IS REFERENCED BY THE DIRECTORY ACCESS ROUT-  #
#   INES.                                                              #
#   1. THE REALM LIST CREATED WHEN THE REALM ENTRIES WHERE BEING BUILT #
#      IS MOVED BEHINED THE DATA CONTROL ENTRIES.                      #
#   2. THEN A SCAN OF EACH RECORD ENTRY IS MADE CHECKING THE ORDINAL   #
#      NUMBER OF THE OWNER RECORD. THE FIRST SCAN CHECK FOR ORDINAL 1, #
#      THE SECOND SCAN CHECKS FOR ORDINAL 2 AND SO ON.                 #
#   3. WHEN A MATCH IS FOUND THE ADDRESS OF THE RECORD AND THE LENGTH  #
#      OF THE RECORD IS STORED IN THE RECORD LIST.                     #
#   4. WHEN ALL THE REALM ORDINAL NUMBERS HAVE BEEN EXAUSTED , CONTROL #
#      IS THEN RETURNED.                                               #
#                                                                      #
#   ENTRY CONDITIONS:                                                  #
#      NONE. THE BASED ARRAY CBWORDBUF POINTS TO THE SUB-SCHEMA IN CORE#
#      FIRSTWORD CONTAINS THE WORD ADDRESS OF THE FIRST WORD OF THE SUB#
#      SCHEMA. FIRSTWORD IS XDEF IN CNTRL. THE NUMBER OF PASSES        #
#      SCANNING THE RECORD ENTRIES IS DETERMINED BY HOW MANY REALMS    #
#      WHERE DEFINED IN THE SUB-SCHEMA. THE NUMBER OF REALMS ARE STORED#
#      IN THE CONTROL WORD ENTRY.                                      #
#                                                                      #
#**********************************************************************#
      DEF AK #6#;                # CODE IN FIT FOR AK FILE ORG         #
      DEF F4 #8#;                      # DDLCOMP VALUE FOR FTN4        #
      DEF F5 #9#;                      # DDLCOMP VALUE FOR FTN5        #
      XREF ITEM FIRSTWORD;             # CONTAINS THE FIRST WORD ADDRES#
      XREF ITEM SBSCHMA;               # CONTAINS THE FIRST WORD ADDR  #
                                       # OF THE WORKING STORAGE AREA.  #
                                       # THE FIRST 150 WORDS IS ALLOCAT#
                                       # ED TO THE REALM LIST. THE REST#
                                       # OF CORE IS ALLOCATED TO THE SB#
                                       #SCHEMA.                        #
      XREF ITEM SBSCHML;               # LENGTH OF CM RESIDENT SUBSCH  #
      XREF PROC SNATCHO;
      XREF ITEM ABORTFLAG;             # FLAG THAT INDICATES FATAL DIAG#
                                       # NOSTIC HAS BEEN ISSUED.       #
      XREF ITEM DDLCOMP;               # CONTAINS CODE FOR FTN4 OR FTN5#
      XREF ITEM DDLMEM;                # CONTAINS THE LAST WORD ADDRESS#
                                       # OF THE USERS FIELD LENGTH.    #
      XREF ITEM DDLSU ;                # CONTAINS MAX STORAGE USED     #
      XREF ITEM ERRCNTR;               # TALLIES THE NUMBER OF DIAGS  # 
                                       # ISSUED.                      # 
      XREF ITEM MAXFL ;            # CONTAINS MAX FIELD LENGTH ALLOWED #
      XREF ITEM MAXSELENG;             # CONTAINS THE MAXIMUM SUB-ENTRY#
                                       # LENGTH.                       #
      XREF ITEM RELFLAG B;             # TRUE - RELATION CLAUSE WAS    #
                                       #        SPECIFIED.             #
      XREF PROC DDLPRNT;               # PRINTS INFO TO OUTPUT.       # 
      XREF PROC ABRT1;                 # ISSUES DAY MESSAGE - INNSUF   #
                                       # FIELD LENGTH- AND ABORTS RUN. #
      XREF PROC MEMORY ;               # ISSUES FIELD LENGTH REQUEST   #
      XREF PROC SSCGLD;                # LOADS THE CODE GENERATION     #
                                       # OVERLAY.                      #
      XREF PROC DIAGDL;                # DIAGNOSTIC ROUTINE.           #
      XREF PROC RELSTAT;     # OUTPUTS RELATION STATISTICS.            #
      XREF PROC WSSOUT2;               # WRITES TO SSOUT (ZZZZZS2)     #000280
                                                                        000300
# DECLARATIONS BETWEEN $BEGIN AND $END BLOCKS ARE SATISFIED BY SYMPL   #005230
# TEXTS AS INDICATED IN THE USETEXT DIRECTIVE.                         #005240
                                                                        005250
      $BEGIN     # SYMPL TEXT * TSBTBL * USED                          #005260
                                                                        005270
      BASED ARRAY REALMLIST [0] S;        # CONTAINS THE REALM NAME    #
        BEGIN                             # AND POINTERS TO THE RECORD #
                                          # LIST AND REALM ENTRIES.    #
*CALL SBRLMLST
        END 
      BASED ARRAY RECORDLIST [0] S;       # CONTAINS THE WORD ADDRESS  #
        BEGIN                             # OF RECORDS THAT BELONG TO A#
                                          # SPECIFIC RECORD.           #
*CALL SBRECLST
        END 
      BASED ARRAY CBWORKBUF [0] S;
        BEGIN 
      CONTROL NOLIST; 
          ITEM BUFWORD U(0,0,60); 
*CALL SBCWDECLS 
*CALL SUBDECLS
*CALL SBDCHDDCL                                                         000280
*CALL SBDCKYDCL                                                         000290
                                                                        001880
          ITEM SBCWSBCKSUM1 U(7,00,30);   # SUB-SCHEMA CHECKSUM        # CHECKSU
          ITEM SBCWSBCKSUM2 U(7,30,30);   #                            # CHECKSU
                                                                        001910
      CONTROL LIST; 
        END 
                                                                        005290
      $END                                                              005300
      BASED ARRAY FIT;
*CALL FITDCLS 
      ARRAY DIAG300 [7];
        ITEM D300 C(0,0,10) = ["  ***313**",
                              "          ", 
                              "       NO ", 
                              "RECORD ENT", 
                              "RIES WHERE", 
                              " SPECIFIED", 
                              " FOR REALM", 
                              " -       -"];
      ITEM I;                          # SCRATCH ITEM.                 #
      ITEM J;                          # SCRATCH ITEM.                 #
      ITEM K;                          # SCRATCH ITEM.                 #
      ITEM L;                          # SCRATCH ITEM.                 #000310
      ITEM TEMP U;                                                      000620
                                                                        002110
      ITEM AREAORDD C(10);             # AREA ORDINAL IN DISPLAY CODE  #002120
      ITEM CWPTR;                      # POINTER USED WHEN REFERENCEING#
                                       # OR STORING FIELDS IN THE      #
      ITEM DCPTR;                      # POINTER USED WHEN REFERENCING #000350
                                       # THE AREA DATA CONTROL ENTRIES #000360
      ITEM DISPVAL C(10);              # DISPLAY CODE VALUE OF A NUMBER#000330
      ITEM CTEMP C(30);                # 30 CHAR TEMP FIELD            #000500
      ITEM FILLING B;                  # FLAG FOR SCHEMA NAME LOOP     #000510
                                                                        000340
                                       # SOURCE LINE TEMPLATES FOR USE #000350
                                       # IN GENERATING SSOUT FILE.     #000360
                                                                        000370
      ITEM F4ISTAT1 C(70) =                                            "000380
      INTEGER DBREALM(3),DBSTAT,DBSCNAM(3),DBRUID                     "; CHECKSU
                                                                        000400
                                                                        000430
      ITEM F4CSTAT1 C(70) =                                            "000440
      COMMON/DB0000/DBREALM,DBSTAT,DBSCNAM,DBRUID                     "; CHECKSU
                                                                        000460
      ITEM F4CSTAT2 C(70) =                                            "000470
     +,DBRELST";                                                        000250
                                                                        000490
      ITEM F4IFIT C(70) =                                              "000500
      INTEGER DBRXXXX(3),DBSXXXX,DBFXXXX(35),DBTXXXX(2)               ";000510
                                                                        000520
      ITEM F4CFIT C(70) =                                              "000530
      COMMON/DB0000/DBRXXXX,DBSXXXX,DBFXXXX,DBTXXXX                   ";000540
                                                                        000550
      ITEM F4IRELDFLT C(70) =                                          "000560
      INTEGER DBRELST(1)                                              ";000570
                                                                        000580
      ITEM F4DRELDFLT C(70) =                                          "000620
      DATA DBRELST/0/                                                 ";000630
                                                                        000640
      ITEM F4DSTAT0 C(70) =                                            "
      DATA DBT0001/10H          ,0/"; 
  
      ITEM F4DSTAT1 C(70) =                                            "000650
      DATA DBREALM/3*1H /,DBSTAT/0/                                   "; CHECKSU
      ITEM F4DSTAT2 C(70) =                                            "000140
     +,DBSCNAM/10H0000000000,10H0000000000,10H0000000000/";             000270
                                                                        000790
      ITEM F4DFIT1 C(70) =                                             "000800
      DATA DBRXXXX/10H          ,10H          ,10H          /,        ";000130
                                                                        000820
                                   # FORTRAN 4 FIT DATA STMT SKELETONS #
  
      ITEM F4DFIT2 C(70) =                                             "000830
     + DBSXXXX/0/,DBFXXXX/12*0,77777777000000000000B,11*0,            ";000150
                                                                        000140
      ITEM F4DFIT3 C(70) =                                             "000150
     +00000000000017777777B,6*0,77777777760000000000B,                ";000160
                                                                        000170
      ITEM F4DFIT4 C(70) =                                             "000180
     +00000000007000000000B,2*0/                                      ";000190
                                                                        000850
                                   # FORTRAN 5 FIT DATA STMT SKELETONS #
  
      ITEM F5DFIT2 C(70) =                                             "
     + DBSXXXX/0/,DBFXXXX/12*0,O""77777777000000000000"",11*0,        ";
  
      ITEM F5DFIT3 C(70) =                                             "
     +O""00000000000017777777"",6*0,O""77777777760000000000"",        ";
  
      ITEM F5DFIT4 C(70) =                                             "
     +O""00000000007000000000"",2*0/                                  ";
  
      ITEM KEYPTR;                     # POINTER USED WHEN REFERENCING #000380
                                       # THE AREA DATA CONTROL KEY ENTS#000390
      ITEM ITEMPTR U;                  # POINTS TO ITEM ENTRY          #000160
      ITEM ORDNUM;                     # CONTAINS THE ORDINAL NUMBER   #
                                       # OF THE CURRENT SCAN.          #
                                       # CONTROL WORD ENTRY.           #
      ITEM REALMLISTADR;               # CONTAINS THE WORD ADDRESS OF  #
                                       # REALM LIST ENTRY.             #
      ITEM REALMLISTPTR;               # POINTER USED WHEN REFERENCEING#
                                       # OR STORING VALUES IN THE      #
                                       # REALM LIST.                   #
      ITEM RECLSTADR;                  # CONTAINS THE WORD ADDRESS OF  #
                                       # FIRST RECORD LIST ENTRY.      #
      ITEM RECLSTPTR;                  # POINTER USED WHEN REFERENCEING#
                                       # OR STORING VALUES IN THE      #
                                       # RECORD LIST.                  #
      ITEM RECNBR;                     # CONTAINS THE NUMBER OF WORDS  #
                                       # OF A RECORD LIST FOR A        #
                                       # SPECIFIC REALM.               #
      ITEM RECPTR;                     # POINTER USED WHEN REFERENCEING#
                                       # THE RECORD ENTRIES.           #
      ITEM RTFLAG;                     # FLAG INDICATING WHICH PART OF #
                                       # THE WORD IS THE RECORD INFOR- #
                                       # MATION TO BE WRITTEN.         #
                                       #   0 = LEFT PART.              #
                                       #   1 = RIGHT PART.             #
      CONTROL EJECT;                                                    000130
FUNC XCDD (NUMBER) C(10);                                               000140
   BEGIN                                                                000150
#**********************************************************************#000160
#                                                                      #000170
#                         X C D D                                      #000180
#                                                                      #000190
#     THIS FUNCTION CONVERTS A BINARY INTEGER INTO DECIMAL DISPLAY     #000200
#     CODE                                                             #000210
#                                                                      #000220
#**********************************************************************#000230
      ITEM NUMBER;               # NUMBER TO BE CONVERTED              #000240
      ITEM WORK C(10);                                                  000250
      ITEM I,J,K;                                                       000260
      WORK = "0000000000";       # ZERO FILL                           #000270
      I = NUMBER;                                                       000280
      FOR K = 54 STEP -6 WHILE I GR 0 DO                                000290
        BEGIN                                                           000300
          J = I / 10;                                                   000310
          B<K,6>WORK = I - J*10 + O"33";                                000320
          I = J;                                                        000330
        END                                                             000340
      XCDD = WORK;                                                      000350
      RETURN;                                                           000360
   END                                                                  000370
      CONTROL EJECT;                                                    000380
FUNC XCOD(NUMBER) C(10);                                                000390
   BEGIN                                                                000400
#**********************************************************************#000410
#                                                                      #000420
#                         X C O D                                      #000430
#                                                                      #000440
#     THIS FUNCTION CONVERTS A BINARY INTEGER INTO OCTAL DISPLAY CODE  #000450
#                                                                      #000460
#**********************************************************************#000470
      ITEM NUMBER;               # NUMBER TO BE CONVERTED              #000480
      ITEM WORK C(10);                                                  000490
      ITEM I,J;                                                         000500
      WORK = "0000000000";       # ZERO FILL                           #000510
      I = NUMBER;                                                       000520
      FOR J = 3  STEP 3 UNTIL 30 DO                                     000530
        B<60-J*2,6>WORK = B<60-J,3>NUMBER + O"33";                      000700
      XCOD = WORK;                                                      000550
      RETURN;                                                           000560
   END                                                                  000570
      CONTROL EJECT;                                                    000575
                                                                        001220
#**********************************************************************#001230
#         START OF PROC                                                #001240
#**********************************************************************#001250
                                                                        001260
      P<CBWORKBUF> = SBSCHMA; # SET THE ADDRESS OF THE SUB-SCHEMA.     #
                                                                        000870
                                       # BUILD F4 STMTS FOR STATUS,ETC.#000880
                                                                        000890
      WSSOUT2(F4ISTAT1,70);            # WRITE STATUS DECL. TO SSOUT   #000950
                                                                        000970
      WSSOUT2(F4CSTAT1,70);            # WRITE STATUS COMMON TO SSOUT  #000980
      WSSOUT2(F4CSTAT2,70);                                             000990
                                                                        001000
                                       # FOR EACH AREA ORDINAL,        #001010
      FOR I=1 STEP 1 UNTIL SBCWNUMAREAS[CWPTR] DO                       001020
        BEGIN                                                           001030
          DISPVAL = XCDD(I);                                            001040
          DISPVAL = C<6,4>DISPVAL;                                      001050
          C<17,4>F4IFIT = DISPVAL;     # STORE ORDINAL INTO TEMPLATES  #001060
          C<28,4>F4IFIT = DISPVAL;                                      001070
          C<36,4>F4IFIT = DISPVAL;                                      001080
          C<48,4>F4IFIT = DISPVAL;                                      001090
          C<23,4>F4CFIT = DISPVAL;                                      001100
          C<31,4>F4CFIT = DISPVAL;                                      001110
          C<39,4>F4CFIT = DISPVAL;                                      001120
          C<47,4>F4CFIT = DISPVAL;                                      001130
                                                                        001140
          WSSOUT2(F4IFIT,70);          # WRITE FIT DECL. TO SSOUT      #001150
                                                                        001160
          WSSOUT2(F4CFIT,70);          # WRITE FIT COMMON TO SSOUT     #001170
                                                                        001180
        END                                                             001190
                                                                        001200
      IF RELFLAG THEN         # IF RELATION ENTRIES PRESENT, CALL ROUT-#
        RELSTAT;             # INE TO PRINT RELATION STATISTICS ON THE #
                                       # ROUTINE ALSO WRITES FORTRAN   #001280
                                       # SOURCE STATEMENTS TO SSOUT,   #001290
                                       # IF RELATION/RESTRICT          #001300
                                       # STATEMENTS WERE USED.         #001310
                                                                        001320
                                       # IF NO RELATION ENTRIES,       #001330
      IF NOT RELFLAG THEN                                               001340
        BEGIN                          # USE DEFAULT RELATION TEMPLATES#001350
                                                                        001360
          WSSOUT2(F4IRELDFLT,70);      # WRITE DEFAULT DECL. TO SSOUT  #001370
          WSSOUT2(F4DRELDFLT,70);      # WRITE DEFAULT DATA TO SSOUT   #001390
                                                                        001400
        END                                                             001410
  
                                       # WRITE FORTRAN VERSION STMT    #
                                       # TO FORTRAN/DML PGRM           #
  
      IF DDLCOMP EQ F4                 # IF FORTRAN 4                  #
      THEN
        C<22,3>F4DSTAT0 = "FT4";       # STORE FT4 INTO DATA STMT      #
  
      IF DDLCOMP EQ F5                 # IF FORTRAN 5                  #
      THEN
        C<22,3>F4DSTAT0 = "FT5";       # STORE FT5 INTO DATA STMT      #
  
      WSSOUT2(F4DSTAT0,70);            # WRITE FORTRAN VERSION STMT    #
  
                                                                        001420
                                       # BUILD F4 DATA STATEMENTS      #001430
                                                                        001440
                                       # SUBSCHEMA NAME                #001450
      TEMP = SBCWSBHDRPTR;             # GET SS ENTRY OFFSET           #000230
                                       # MOVE NAME INTO CHAR AREA TO   #000240
                                       # BLANK FILL ALL 30 CHARS       #000250
      CTEMP = C<0,SBSCNAMELENC[TEMP]>SBSCHNAM30[TEMP];                  000260
                                       # SCHEMA NAME                   #001490
                                       # CONVERT ZERO FILL TO BLANKS   #000310
      FILLING = TRUE;                                                   000320
      CTEMP = SBCWSCHNAM30;                                             000330
      FOR I = 29 STEP -1 WHILE I GQ 0 AND FILLING DO                    000340
        IF C<I>CTEMP EQ 0                                               000350
        THEN                                                            000360
          C<I>CTEMP = " ";                                              000370
        ELSE                                                            000380
        IF C<I>CTEMP NQ 0                                               000390
        THEN                                                            000400
          FILLING = FALSE;                                              000410
                                                                        000420
      C<18,10>F4DSTAT2 = C<0,10>CTEMP;                                   CHECKSU
      C<32,10>F4DSTAT2 = C<10,10>CTEMP;                                  CHECKSU
      C<46,10>F4DSTAT2 = C<20,10>CTEMP;                                 000310
                                                                        001560
      WSSOUT2(F4DSTAT1,70);            # WRITE DATA STMTS 1-3 TO SSOUT #001570
      WSSOUT2(F4DSTAT2,70);                                             001580
      P<REALMLIST> = FIRSTWORD;     # WORD ADDRESS WHERE THE REALM LIST#
                                   # IS TO BE BUILT.                   #
      J = SBCWSBLENG[CWPTR]; # USE THE SUB-SCHEMA LENGTH AS THE POINTER#
                             # TO THE NEXT AVAILABLE WORD.             #
      SBCWMAXSELEN[CWPTR] = MAXSELENG;  # STORE MAX. SUB-ENTRY LENGTH. #
      SBCWRLMLSTAD[CWPTR] = J;   # STORE THE FIRST WORD ADDRESS OF THE #
                                 # REALM LIST.                         #
      K = (SBCWNUMAREAS[CWPTR] + SBCWNUMRELS[CWPTR]) * 4 - 1; # CALCUL-#
                 # ATE THE LENGTH OF THE REALM LIST.                   #
      I = ((FIRSTWORD + 2 * (K+1) + J + SBCWNUMBERCS + 63) / 64) * 64 ; 
      IF  I GR DDLSU  THEN
        DDLSU = I ;                    # UPDATE STORAGE USED           #
      IF  I GR B<0,30> DDLMEM  THEN 
        BEGIN                          # IF MORE STORAGE NEEDED        #
          IF  I GR MAXFL  THEN
            ABRT1 ;                    # ABORT IF TOO MUCH, ELSE       #
          MEMORY (I) ;                 # REQUEST WHAT IS NEEDED        #
        END 
      IF  (SBSCHMA + J + K + 1 + SBCWNUMBERCS) GR B<0,30> DDLMEM  THEN
        BEGIN 
          P<CBWORKBUF> = FIRSTWORD + K + 1 ;
          SBSCHMA = SBSCHMA - P<CBWORKBUF> ;         # MOVE SUB-SCHEMA #
          FOR  I = 0 STEP 1 UNTIL J  DO              # DOWN TOWARD THE #
            BUFWORD [I] = BUFWORD [I+SBSCHMA] ;      # REALMLIST ARRAY #
          SBSCHMA = P<CBWORKBUF> ;
        END 
      FOR I=0 STEP 1 UNTIL K DO # MOVE THE REALM LIST FROM THE BEGINING#
                             # OF THE CBWORKBUF TO THE END.            #
        BUFWORD[J+I] = REALMLISTNME[I]; 
      RECLSTADR = J + K + 1; # CALCULATE THE ADDRESS OF THE RECORD LIST#
      P<RECORDLIST> = SBSCHMA + RECLSTADR; # WORD ADDRESS OF THE       #
                                             # RECORD LIST.            #
      P<REALMLIST> = SBSCHMA + J; # RE-ADJUST THE REALM LIST           #
                                          # TO ITS NEW LOCATION        #
      REALMLISTADR = J; # SAVE THE WORD ADDRESS OF THE REALM LIST.     #
    CONTSCAN:   #    #
      RECPTR = SBCWFRSTRECA[CWPTR]; # SET THE RECORD POINTER TO THE    #
                           # RECORD ENTRY IN THE SUB-SCHEMA.           #
      ORDNUM = ORDNUM + 1; # INCREMENT THE ORDINAL NUMBER FOR THE SCAN.#
      REALMRECLIST[REALMLISTPTR] = (RECLSTADR+RECLSTPTR) - REALMLISTADR;
           # STORE THE ADDRESS OF THE RECORD LIST INTO THE REALM LIST.# 
      RECLISTWRD[RECLSTPTR] = 0;
      FOR I=0 STEP 1 UNTIL SBCWNUMBERCS[CWPTR] - 1 DO # READ FROM      #
               # RECORD TO RECORD SEARCHING FOR A MATCH ON ORDINAL NUMB#
        BEGIN 
          J = SBRECNXRECP[RECPTR]; # GET THE NEXT RECORD POINTER.      #
          IF J EQ 0 THEN # CHECK IF THERE IS A NEXT RECORD.            #
            J = SBCWDCADDR[CWPTR] - RECPTR; # THERE IS NO NEXT RECORD  #
                # THEREFORE RECORD LENGTH HAS TO BE CALCULATED.        #
          K = SBRECWITHINO[RECPTR]; 
          IF K EQ ORDNUM THEN 
            BEGIN # COMPARE THE ORDINAL NUMBER IN THE RECORD ENTRY     #
                  # AGAINST THE CONTENTS OF ORDNUM.                    #
                                                                        001930
                                    #-------BUILD FIT DATA STMTS-------#
                                                                        001950
                                       # REALM ORDINAL                 #001960
              DISPVAL = XCDD(ORDNUM);                                   001970
              DISPVAL = C<6,4>DISPVAL;                                  001980
              C<14,4>F4DFIT1 = DISPVAL;                                 001990
  
              IF DDLCOMP EQ F4     # IF FORTRAN VERSION 4              #
              THEN
                BEGIN 
                C<10,4>F4DFIT2 = DISPVAL;  # PLACE REALM ORDINAL INTO  #
                C<21,4>F4DFIT2 = DISPVAL;  # FTN4 DATA STMT SKELETON   #
                END 
              ELSE                 # ELSE, ASSUME FORTRAN VERSION 5    #
                BEGIN 
                C<10,4>F5DFIT2 = DISPVAL;  # PLACE REALM ORDINAL INTO  #
                C<21,4>F5DFIT2 = DISPVAL;  # FTN5 DATA STMT SKELETON   #
                END 
  
                                       # REALM NAME                    #002020
                                       # MOVE NAME INTO CHAR AREA TO   #000620
                                       # BLANK FILL ALL 30 CHARS       #000630
                                       # GET LENGTH OF REALM NAME      #000633
             L = SBARLENGCHAR[REALMADR[REALMLISTPTR]];                  000635
                                                                        000637
             CTEMP = C<0,L>REALMLSTNM30[REALMLISTPTR];                  000640
                                                                        000650
      C<22,10>F4DFIT1 = C<0,10>CTEMP;                                   000660
      C<36,10>F4DFIT1 = C<10,10>CTEMP;                                  000670
      C<50,10>F4DFIT1 = C<20,10>CTEMP;                                  000680
                                                                        000410
                                       # MRL IS RECORD LENGTH          #000420
                                       # CONVERT TO OCTAL DISPLAY CODE #000430
              DISPVAL = XCOD(SBRECLENGTH [ RECPTR ]);                   000440
  
              IF DDLCOMP EQ F4     # IF FORTRAN VERSION 4              #
              THEN
                BEGIN              # STORE MRL INTO FTN4 STMT SKELETON #
                C<31,8>F4DFIT2 = C<2,8>DISPVAL; 
                END 
              ELSE                 #  ELSE, ASSUME FTN5                #
                BEGIN              #  STORE MRL INTO FTN5 STMT SKELETON#
                C<33,8>F5DFIT2 = C<2,8>DISPVAL; 
                END 
                                                                        000460
                                       # FIND DATA CONTROL ENTRY       #000470
              DCPTR = SBARDCONTRLA[REALMADR[REALMLISTPTR]];             000560
                                       # FIND FIRST KEY ENTRY          #000490
              KEYPTR = DCPTR + SBDCALTRKYPT [ DCPTR ];                  000500
                                       # FIND PRIMARY KEY ENTRY        #000510
              FOR L = 1 DO                                              000150
              BEGIN                                                     000530
              IF SBDCKEYPRI [ KEYPTR + 1 ] THEN                         000540
               BEGIN                                                    000550
                                       # PICK UP KEY ADDR              #000560
                                       # GET ADDR OF ITEM ENTRY        #000180
                ITEMPTR = SBDCKEYDNADR[KEYPTR+2];                       000190
                                       # GET BEGINNING WORD POSITION   #000200
                TEMP = SBITMBWP[ITEMPTR];                               000210
                DISPVAL = XCOD(TEMP); # CONVERT TO OCTAL DISPLAY       #000650
  
                IF DDLCOMP EQ F4   # IF FORTRAN VERSION 4 -- USE FTN4  #
                THEN               # DATA STMT SKELETON                #
                  BEGIN 
                                   # STORE FIT KA(PRE-PASS WILL MODIFY)#
                  C<18,8>F4DFIT3 = C<2,8>DISPVAL; 
                  C<32,4>F4DFIT3 = C<6,4>DISPVAL;  # STORE FIT RKW     #
                  END 
                ELSE               # ELSE, ASSUME FORTRAN VERSION 5    #
                                   # AND USE FTN5 DATA STMT SKELETON   #
                  BEGIN 
                                   # STORE FIT KA(PRE-PASS WILL MODIFY)#
                  C<20,8>F5DFIT3 = C<2,8>DISPVAL; 
                  C<36,4>F5DFIT3 = C<6,4>DISPVAL;  # STORE FIT RKW     #
                  END 
                                                                        000630
                                       # PICK UP RKW,KP,KL AND PACK    #000640
                                       # TOGETHER BEFORE CONVERSION    #000650
                                                                        000660
                                 # GET FIT ADDRESS AND SET BASED ARRAY #
                P<FIT> = DCPTR + SBDCFITPTR[DCPTR] + SBSCHMA; 
               IF FITFO EQ AK 
               THEN 
                 BEGIN
                                 # FOR AK FILES, ADJUST KEY INFO       #
                                 # PICK UP KEY POSITION                #
                                 # SHIFT LEFT 2                        #
                   TEMP = FITKP * 2;
                                 # SHIFT TO FORM RKP AND KP            #
                                 # SHIFT LEFT 4 BITS                   #
                   TEMP = TEMP * 16 + TEMP; 
                                 # SHIFT AND ADD KL                    #
                                 # SHIFT LEFT 8 BITS                   #
                   TEMP = TEMP * 256 + FITKL; 
                 END
               ELSE BEGIN 
                                       # PICK UP BEGINNING CHAR POS.   #000670
                                 # DIVIDE BY 6, MULTIPLY BY 2          #
                TEMP = SBITMBBP[ITEMPTR] / 3; 
                                       # SHIFT TO FORM RKP AND KP      #000690
                                 # SHIFT LEFT 4 BITS                   #
                TEMP = TEMP * 16 + TEMP;
                                       # SHIFT AND ADD KL              #000710
                                 # SHIFT LEFT 8 BITS                   #
  
                                 # IF CONCATENATED KEY FLAG SET, USE   #
                                 # THE CONCATENATED KEY SIZE FROM THE  #
                                 # KEY ENTRY OF THE SUBSCHEMA DC.      #
                                 # OTHERWISE, USE THE ITEM SIZE FROM   #
                                 # THE ITEM ENTRY                      #
                IF SBDCCONCTFG[KEYPTR+1]
                THEN
                  BEGIN 
                    TEMP = TEMP * 256 + SBDCKEYSIZ[KEYPTR+1]; 
                  END 
  
                ELSE
                  BEGIN 
                    TEMP = TEMP * 256 + SBITMUSESIZE[ITEMPTR];
                  END 
  
               END
                                       # SHIFT FOR ROUND OCTAL DIGIT ON#000730
                                       # STORE INTO TEMPLATE           #000740
                TEMP = TEMP * 2;                                        000730
                DISPVAL = XCOD(TEMP); # CONVERT TO OCTAL DISPLAY       #000740
  
                IF DDLCOMP EQ F4   # IF FTN4 USE FTN4 STMT SKELETON    #
                THEN
                  BEGIN 
                  C<36,6>F4DFIT3 = C<4,6>DISPVAL;  # STORE RKP, KP + KL#
                  END 
                ELSE               # ELSE ASSUME FTN5-USE FTN5 SKELETON#
                  BEGIN 
                  C<40,6>F5DFIT3 = C<4,6>DISPVAL;  # STORE RKP, KP + KL#
                  END 
                                                                        000780
                                       # PICK UP KEY TYPE              #000790
                TEMP = SBDCKEYTYPE [ KEYPTR ];                          000760
                DISPVAL = XCOD (TEMP);                                  000770
  
                IF DDLCOMP EQ F4   # IF FTN4 USE FTN4 STMT SKELETON    #
                THEN
                  BEGIN 
                  C<16,1>F4DFIT3 = C<9,1>DISPVAL;  # STORE FIT KT      #
                  END 
                ELSE               # ELSE ASSUME FTN5-USE FTN5 SKELETON#
                  BEGIN 
                  C<18,1>F5DFIT3 = C<9,1>DISPVAL;  # STORE FIT KT      #
                  END 
  
                                 #-------WRITE FIT DATA TO SSOUT-------#
  
                IF DDLCOMP EQ F4 #             IF FORTRAN 4            #
                THEN
                  BEGIN 
                  WSSOUT2(F4DFIT1,70);
                  WSSOUT2(F4DFIT2,70);  #   WRITE OUT FTN4 SKELETONS   #
                  WSSOUT2(F4DFIT3,70);
                  WSSOUT2(F4DFIT4,70);
                  END 
                ELSE               #     ELSE ASSUME FORTRAN 5         #
                  BEGIN 
                  WSSOUT2(F4DFIT1,70);
                  WSSOUT2(F5DFIT2,70);  # WRITE OUT FTN5 SKELETONS     #
                  WSSOUT2(F5DFIT3,70);
                  WSSOUT2(F5DFIT4,70);
                  END 
  
                GOTO LOOPEND;                                           000170
               END                                                      000880
                                                                        000890
                                       # GET NEXT KEY POINTER          #000900
              KEYPTR = SBDCKEYNITM[KEYPTR+1] + KEYPTR;                  000130
              END                                                       000920
                                                                        002090
LOOPEND:                                                                000190
              RECLISTLADR[RECLSTPTR] = RECPTR; # STORE THE REC ADDRESS.#
              RECLISTLLENG[RECLSTPTR] = J; # STORE THE RECORD LENGTH.  #
              RECNBR = RECNBR + 1;  # INCREMENT THE RECLIST LENGTH     #
                                    # COUNTER.                         #
              RECLSTPTR = RECLSTPTR + 1;  # INCREMENT COUNTER TO NEXT  #
              RECLISTWRD[RECLSTPTR] = 0; # WORD.                       #
            END 
          RECPTR = RECPTR + J; # INCREMENT POINTER TO THE NEXT RECORD  #
                               # ENTRY .                               #
        END 
      IF RECNBR EQ 0 AND REALMADR LS SBCWFRSTRECA[CWPTR] THEN 
                        # CHECK IF THERE WHERE ANY RECORD ENTRIES      #
        BEGIN # SPECIFIED FOR THE RELAM NAME NOW BEING PROCESSED.      #
          J = SBARLENGCHAR[REALMADR[REALMLISTPTR]]; # GET THE CHARACTER#
                  # LENGTH OF THE SUBJECT REALM NAME.                  #
          IF J GR 7 THEN
            J= 7; 
          C<2,7>D300[7] = O"55555555555555";
          C<2,J>D300[7] = C<0,J>REALMLISTNME[REALMLISTPTR]; 
          DDLPRNT(DIAG300,80);
          ERRCNTR = ERRCNTR + 1;
          ABORTFLAG = 1;
        END 
      REALMRECLEN[REALMLISTPTR] = RECNBR; # STORE THE LENGTH OF THE    #
                                          # RECORD LIST.               #
      RECNBR = 0;   # REINITIALIZE THE COUNTER.                        #
      IF ORDNUM EQ SBCWNUMAREAS[CWPTR] THEN # CHECK IF SCANNED FOR ALL #
                                            # REALMS.                  #
        BEGIN 
          SBCWSBLENG[CWPTR] = RECLSTADR + RECLSTPTR + 1;
          SBSCHML = SBCWSBLENG[CWPTR];
          SSCGLD;    # CALL ROUTINE TO LOAD CODE GENERATOR OVERLAY #
        END 
      REALMLISTPTR = REALMLISTPTR + 4; # INCREMENT POINTER TO THE NEXT #
                             # REALM LIST ENTRY                        #
      GOTO CONTSCAN;
    END 
  TERM; 
