*DECK     PH1CTL
          IDENT  PH1CTL 
 PH1CTL   TITLE  PH1CTL -    PHASE 1 CONTROLLER (DECLARATIVE PROCESSING)
*CALL     SSTCALL 
          LIST   F,X
          SPACE  4
 B=PH1CT  RPVDEF             DEFINE ROUTINE FWA FOR REPRIEVE UTILITY
          USE    CODE              FORCE LITERALS TO COME FIRST 
  
          ENTRY  PH1CTL,PH1SCAN 
          ENTRY  PROGC
  
          EXT    START.,CODE.,VALUE.,ST.,FP.,ENTRY.D
          EXT    MACFLAG,UFLAG,DFLAG,COMPMSG,RSELECT
          EXT    N.FILES,WB.LFN,WB.ESS
          EXT    N.FP 
          EXT    XFRNAME
          EXT    FWAWORK,FTNEND 
          EXT    CAFLAG,OLIST 
          EXT    CONVERT
          EXT    ECGS 
          EXT    F.CMPS 
          EXT    INFORM 
          EXT    INITBL 
          EXT    N.EQUF 
  
 SYM1     EQU    12B
 SYMEND   EQU    13B
 TYPE     EQU    24B               STMT TYPE CODE 
 SELIST   EQU    32B
 ATYPE    EQU    51B
  
 PROGRAM  EQU    RA.SSW+56B        PROG    12/2000B,48/0
*                                  BLKDTA  60/0 
*                                  SUBR    12/2001B,48/0
*                                  FUNC    12/2002B,48/0
  
 L.SVCD   EQU    2                 LENGTH OF CODE IN *START.* TO SAVE 
*                                    AND RESTORE *TEMPA0.*
  
  
 E.HCNF   EQU    55                HEADER CARD APPEARS AFTER FIRST CARD 
 E217     =      217         ERR MSG NR - *PROG START.* GENERATED 
 E224     =      224         ERR MSG NR - *LDR DIRECTIVE SYNTAX ERR*
 E225     =      225         ERR MSG NR - *NOT ENOUGH MEM FOR LDR DIR*
 E299     =      299         ERR MSG NR - *NON-ANSI STATEMENT*
 E315     =      315         ERR MSG NR - *LDR DIRECTIVE NOT 1ST LINE*
 E323     =      323
  
  
**        STATEMENT TYPE CODES. 
  
 ST.FMT   =      9           FORMAT 
 ST.END   =      13          END (NORMAL) 
 ST.ASG   =      14          ASSIGN 
 ST.BAD   =      18          BAD STATEMENT
 ST.INV   =      37          END (INVENTED) 
 EQX      SPACE  4,3
 EQX      MACRO  LOC
          EQ     =X_LOC 
          ENDM
*CALL     DBGCOM
  
 ESS      MACRO  NAME              ENTER NAME IN SYMTAB AND SAVE ORDINAL
          SA1    =8R_NAME 
          RJ     ESS
          SX7    B1 
          SA7    =X_NAME
          ENDM
*CALL     PARSEM
*CALL     FMACDEF 
          TITLE              DPEXT - PROCESS EXTERNAL STATEMENT 
*** 
*         DPEXT - PROCESS "EXTERNAL" STMT 
* 
 E.EXTE   EQU    59                SYNTAX ERROR 
 E.CUN    EQU    99                CONFLICTING USE OF NAME
  
 DPEXT    GETE
  
 DPEXT.L  IF.NE  NAME,DPEXTE1      IF NOT A NAME
          UPDATE
          SYMBOL
          IX2    X6+X2             FIRST OCCURANCE, ADD TYPE TO NAME
          NZ     X7,DPEXT.D        IF PREVIOUS REFS IN A DEBUG STMT 
  
*         SYMBOL PREVIOUSLY REFERENCED
  
          EQ     B1,B5,DPEXTE2     ERROR IF ORDINAL 1 
          MX0    L.TYP
          BX3    X0*X2
          LX3    L.TYP
          SX4    X3-T.LAB 
          PL     X4,DPEXTE2        ERROR IF RETURNS, ETC
          BX3    X2 
          LX3    59-P.VAR 
          NG     X3,DPEXTE2        IF PREVIOUS REFS AS A LOCAL VAR
  
 DPEXT3   SX0    B5 
          LX0    P.EXT
          BX6    X0+X2
          LX0    P.EST-P.EXT
          SA5    RSELECT
          BX6    X0+X6
          SA6    A2                SET EXT BIT IN WORD B
  
          ZR     X5,DPEXT4         IF R = 0 
          ADDREF B1,REF            ADD A REFERENCE FOR THE NAME 
  
 DPEXT4   GETE                     SEPERATOR
          IF.EQ  EL.EOS,PH1SCAN    EXIT IF EOS
          IF.NE  EL.COMMA,DPEXTE1  IF NOT A , 
          NEXTE 
          EQ     DPEXT.L
  
*         FIRST OCCURANCE 
  
 DPEXT.D  CFO    EXT               CHECK SETTING OF DEBUG BITS
          IX2    X6+X2             ADD TYPE TO WORD B 
          EQ     DPEXT3 
  
 DPEXTE1  POSTER SEV=FE,NR=E.EXTE,FMT=ELIST,TXT=X4,RETURN=PH1SCAN 
  
 DPEXTE2  SA5    SELIST 
          POSTER SEV=FE,NR=E.CUN,FMT=ELIST,TXT=X5+1,RETURN=DPEXT4 
          TITLE              MAIN LOOP
*** 
*         MAIN LOOP FOR DECLARATIVE STATEMENT PROCESSING
* 
 PH1SCAN  SA5    RSELECT
          SA2    TEMPB7 
          BX6    X2 
          SA6    =XLASTTYP
          ZR     X5,PH1S           IF R = 0 
          ADDREF B0                TERMINATE THE LINE OF REFERENCES 
  
 PH1S     SA1    DFLAG
          ZR     X1,PH1SA          IF NOT DEBUG MODE
  
 PH1SA1   SA1    DTYPE
          ZR     X1,PH1SA          IF NEXT STMT IS NOT A DEBUG STMT 
          CALL   DBGINT            PROCESS DEBUG STMT 
  
 PH1SA    CALL   SCANNER           GET THE STATEMENT TYPE 
          SA3    ATYPE
          SX2    B7 
          LX3    20 
          MX6    -20
          BX3    X6*X3
          BX6    X3+X2
          SA6    TEMPB7 
  
 PH1S1    NE     B7,PH1SA2         NOT PROGRAM OR BAD DEBUG CARD
          SA1    =XTYPFLAG
          ZR     X1,PH1SE          PROGRAM CARD 
          EQ     PH1SA1 
  
 PH1SA2   SB1    DBGFSTT
          LT     B7,B1,PH1S2       NOT DEBUG CARD 
          CALL   DBGINTX           PROCESS DEBUG CARD 
          EQ     PH1SA
  
 PH1S2    LE     B7,B5,PH1SE IF SECOND (ILLEGAL) PROGRAM UNIT HEADER
          SB2    ST.FMT      GREATEST TYPE CODE FOR DECLARATIVE STMTS 
          LE     B7,B2,VECJP       IF DECLARATIVE STATEMENT, PROCESS
          SB2    ST.BAD 
          EQ     B7,B2,PH1SCAN     IGNORE *BAD* STATEMENT 
          EQ     =XDPCLOSE         TERMINATE DECLARATIVE PROCESSING 
  
 VECJP    JP     VECTAB+B7
  
 VECTAB   BSS    0
          LOC    0
          EQ     DPROG       PROGRAM, BLOCK DATA, SUBROUTINE
          EQ     DPFUN       FUNCTION 
          EQX    DPLEV       LEVEL
          EQX    DPIMP        PROCESS IMPLICIT STATEMENT
          EQX    DPCOM             COMMON 
          EQX    DPDIM             DIMENSION
          EQ     DPEXT             EXTERNAL 
          EQX    DPEQU             EQUIVALENCE
          EQX    DPTYP             TYPE ... 
          RJ     =XFORMAT          FORMAT(
          EQ     PH1SCAN
          LOC    *O 
  
 TEMPB7   BSSZ   1
          SPACE  3
 PH1SE    SB6    -E.HCNF           HEADER CARD AFTER THE FIRST CARD 
          NZ     B7,PH1SE2   IF NOT *OVERLAY* 
          SA1    ATYPE
          SB2    X1-3 
          NZ     B2,PH1SE2
          SB6    -E315
 PH1SE2   POSTER SEV=FE,NR=**,RETURN=PH1S 
 ESF      SPACE  4,8
**        ESF - ENTER SPECIAL SYMBOLS IN *SYMTAB* FOR SUBROUTINE
*                 OR FUNCTION SUBPROGRAMS.
* 
*         ENTRY  (FUNTYPE) = LENGTH (IN WORDS) OF SET FUNCTION RESULT 
*                             TO X6 (AND X7 IF 2 WORD RESULT) CODE
*                          = 0 IF NOT A FUNCTION SUBPROGRAM 
* 
*                (TEMPA0.) = LENGTH (IN WORDS) OF SAVE AND RESTORE (A0) 
*                             CODE
*                          = 0 IF NO FORMAL PARAMETERS OR RETURNS 
* 
*                (N.FP)    = NUMBER OF F.P. S OR ZERO IF NONE.
*                            USED AS A FLAG TO DETERMINE WHETHER
*                            *SPA.* IS NEEDED OR NOT. (NOTE - *ESS* 
*                            SETS PROGRAM RELATIVE BIT.)
* 
*         EXIT   (START.)  = LENGTH OF *START.* BLOCK 
* 
*                (TRACE.)  = *SYMTAB* ORDINAL OF CGS *TRACE.* - (ADDR OF
*                             TRACEBACK INFORMATION FOR OBJECT PROGRAM) 
* 
*                (TEMPA0.) = *SYMTAB* ORDINAL OF CGS *TEMPA0.* - (ADDR
*                             OF WORD CONTAINING THE SAVED CONTENTS 
*                             OF A0)
*                          = 0 IF NO FORMAL PARAMETERS OR RETURNS 
* 
*                (EXIT.)   = *SYMTAB* ORDINAL OF CGS *EXIT.* - (ADDR OF 
*                             FOLDED EXIT CODE FOR OBJECT PROGRAM)
* 
*                (ENTRY.)  = *SYMTAB* ORDINAL OF CGS *ENTRY.* - (ADDR OF
*                             ENTRY POINT TO OBJECT PROGRAM)
* 
*         USES   ALL
* 
*         CALLS  ESS
  
  
 ESF      ENTRY. **          ** ENTRY/EXIT ** 
  
          ESS    TRACE.      *TRACE.* TO SYMTAB, RA = 0 IN *START.* 
  
          SX6    B5 
          SA4    =XTEMPA0.
          SA6    =XSTART.    LENGTH OF *START.* = 1 
          ZR     X4,ESF2     IF NO FPS OR RETURNS 
  
          ESS    TEMPA0.     *TEMPA0.* TO SYMTAB
  
          MX0    -1 
          SA2    =XSTART. 
          SX7    X2+B5       LENGTH OF *START.* + 1 
          IX3    X7+X0       RA = LENGTH OF *START.* - 1
          SA7    A2 
          LX3    P.RA 
          BX6    X6+X3
          SA6    A6 
  
 ESF2     ESS    EXIT.       *EXIT.* TO SYMTAB
  
          MX0    -1 
          SA2    =XSTART. 
          SX7    X2+B5
          IX3    X7+X0       RA = LENGTH OF *START.* - 1
          SA7    A2 
          LX3    P.RA 
          BX6    X6+X3
          SA6    A6 
  
          ESS    ENTRY.      *ENTRY.* TO SYMTAB 
  
          SB2    -B5         (B2) = -1
          SA1    =XTEMPA0.
          SA2    =XSTART. 
          ZR     X1,ESF3     IF NO FPS OR RETURNS 
          SB2    B2+B2       (B2) = -2
          SX2    X2+L.SVCD   (X2) = LEN *START.* + LEN SAVE/REST A0 CODE
  
 ESF3     SA3    =XFUNTYPE
          SA5    =XCO.ER
          IX7    X2+X3       (X7) = LENGTH OF *START.* BLOCK
          SX4    X7+B2       (X4) = RA OF *ENTRY.*
          LX5    1
          IX4    X4+X5
          SA7    A2 
          LX4    P.RA 
          BX6    X6+X4
          MX0    L.ADF
          SA6    A6 
          LX0    L.ADF+P.ADF
          BX6    X6*X0
          SA6    ENTRY.D     SAVE ADDR DEF BITS FOR *ENDPRO*
  
*         SET *SPA.* IN SYMTAB IF NEEDED. 
  
          SA1    N.FP 
          ZR     X1,ESF      IF NO F.P. S, EXIT.. 
          ADEXTS =8RSPA.
          LX0    T.CGS-P.EXT ADD IN *CGS* BIT 
          BX7    X0+X7
          SA7    A7 
          EQ     ESF         EXIT.. 
          EQ     ESF         EXIT...
 ESS      SPACE  4,8
**        ESS - ENTER SPECIAL SYMBOL IN SYMTAB. 
* 
*         SETS TYPE TO CGS AND RL = 1 ( PROGRAM RELOCATABLE ).
* 
*         ENTRY  (X1) = SYMBOL, DISPLAY CODE. 
  
  
 ESS1     SA3    WB.ESS            TYPE , RL AND RB 
          BX6    X2+X3
          SA6    A2 
  
 ESS      ENTRY. *                 ** ENTRY/EXIT ** 
          SYMBOL ,ESS1             ENTER NAME IN SYMTAB 
          TITLE              PHASE 1 INITIALIZATION 
************************************************************************
* 
*         THIS CODE OVERLAID AFTER HEADER CARD PROCESSING 
* 
  
*         IF (BREAK=21) WAS SELECTED, ENTRY TO OVERLAY(2,1) WILL BE TO
*         *FTN21-1* TO CALL THE COMPILE-TIME INTERACTIVE DEBUG PACKAGE. 
  
 FTN21    BREAK 
  
          ENTRY  FTN21
 FTN21    BSS    0           ** LOADER ENTRY POINT ** 
 PH1CTL   BSS    0
  
*         COPY MASTER LIST CONTROL FLAGS TO WORKING LIST CONTROL FLAGS. 
  
          MOVE   =XL.MSTR,=XLSTMSTR,=XLSTWRKG 
  
          MX6    1
          SA6    =XNOLIST    SET TO *LIST,ALL* MODE 
  
*         INITIALIZE LISTING TITLE LINE.
  
          SA1    =1H
          SB1    1
          BX6    X1 
          MX7    18 
          SA6    =XTL.PTYP
          SA6    =XTL.PNAM
  
*         CLEAR STATIC LOAD SELECTIONS. 
  
          SA1    =XSTLTAB+1  *STLCRM.* MUST REMAIN PERMANENTLY SELECTED 
 CTL1     BX6    -X7*X1 
          SA6    A1 
          SA1    A1+B1
          NZ     X1,CTL1     IF NOT END OF STATIC LOAD TABLE
          SA1    =XSTLTAB+1  SELECT *STLRP2.* IF *ER* OPTION ON 
          SA2    =XCO.ER
          BX6    X1+X2
          SA6    A1 
  
*         INITALIZE WORKING STORAGE ADDRESSES.
  
          SA1    =XSYM1      (X1) = INVERTED FWA SYMBOL TABLE 
          SX7    F.WORK1     LWA PASS 1 CODE
          BX6    X1 
          NO
          SA7    =XFWAWORK
          SA6    =XSYMEND    INITIALIZE SYMBOL TABLE LWA = FWA
          PLUG   AT=(=XLFER),TO=(=XFATALER) 
          SA1    =XANSI 
          SX6    027B 
          NO
          LX6    51          (X6) = / JP B7 / INSTRUCTION 
          NZ     X1,CTL2     IF NON-ANSI DIAGNOSTIC LIST (X) OPTION ON
          PLUG   AT=(=XASAER),FROM=X6 
 CTL2     SA1    =XIEFLG
          NZ     X1,CTL3     IF INFORMATIVE DIAGNOSTICS DESIRED 
          PLUG   AT=(=XINFORM),FROM=X6
 CTL3     SA1    =XPROGNAM   NAME OF LAST PROGRAM UNIT COMPILED 
          BX6    X1 
          MX7    0
          ZR     X1,CTL4     IF FIRST COMPILATION 
          SA6    NULL2       NAME TO *NULL PROG ...* MESSAGE TEXT 
 CTL4     SA7    A1          CLEAR PROGRAM UNIT NAME FOR -ERPRO-
 CTL5     SA2    DFLAG
          ZR     X2,CTL6     IF DEBUG NOT SELECTED
          CALL   DBGEPKT     PROCESS EXTERNAL PACKET
          EQ     CTL7 
  
 CTL6     CALL   SCANNER     GET NEXT STATEMENT 
 CTL7     SB6    ST.END 
          EQ     B6,B7,CTL8  IF NORMAL *END*
          SB6    ST.INV 
          NE     B6,B7,CTL9  IF NOT INVENTED *END*
  
*         FALL THROUGH HERE MEANS -END- WAS ENCOUNTERED BEFORE
*         ANY VALID FORTRAN STATEMENTS. 
  
 CTL8     CALL   DSL         DUMP SAVED LINES (*SCANNER* MAY STILL BE 
*                            IN DEFERRED LIST MODE IF A VALID HEADER
*                            LINE HAS NOT BEEN FOUND.)
          SA1    =XCER.FL 
          SX6    1
          SA6    A1 
          MESSAGE   NULL1,,RCL     *NULL PROGRAM IGNORED AFTER ...* 
          SA3    =XCO.ABT 
          LX3    59-29
          PL     X3,CTL8A    IF NO A PARAMETER
          MESSAGE NULL3,,RCL
 CTL8A    SA1    =XN.FERR 
          ZR     X1,=XFTNEND  IF NO ERRORS DETECTED BEFORE *END* LINE 
  
 CTL9     SB6    2
          SA3    ATYPE
          SX2    B7 
          LX3    20 
          MX6    -20
          BX3    X6*X3
          BX6    X3+X2
          SA6    TEMPB7 
          LT     B7,B6,VECJP       IF PROGRAM,SUBROUTINE,FUNCTION, ETC. 
  
*         INSERT FAKE PROGRAM CARD "PROGRAM START.(INPUT,OUTPUT)" 
  
 PROGC    POSTER SEV=INF,NR=E217
  
*         RESET TYPE TO PREVENT PROPAGATED ERRORS 
*         CAUSED BY FAULTY HEADER CARD
  
          SA1    TEMPB7 
          MX6    -20
          BX6    X6*X1
          SA6    A1 
  
 PTR57    SA1    DFLAG
          MX6    59 
          ZR     X1,PTR57A    IF NOT IN DEBUG MODE
          SA6    NOPROG      SET TO NO PROGRAM CARD CONDITION 
          RJ     DBGIPKT
 PTR57A   SA1    SELIST 
          SX6    DUMMY
          BX7    X1 
          SA6    A1                SELIST = DUMMY ELIST ADDRESS 
          SA7    SVELIST           SAVE E LIST POINTER
          EQ     PROG.D       GO PROCESS DUMMY PROGRAM CARD 
          SPACE  3
          PURGMAC   ELIST 
 ELIST    MACRO  T,NAME            ASSEMBLY TIME E - LIST 
+         VFD    12/2000B+T 
          IFC    NE,//NAME/ 
          VFD    48/8H_NAME 
          ELSE
          VFD    48/0 
          ENDIF 
          ENDM
  
          ELIST  4                 EOS
          ELIST  2                 )
          ELIST  1,OUTPUT 
          ELIST  3                 ,
          ELIST  1,INPUT
          ELIST  6                 (
 DUMMY    ELIST  1,START. 
 SVELIST                           SAVED VALUE OF THE E LIST POINTER
  
  
 NULL1    DIS    3,  NULL PROGRAM IGNORED AFTER 
 NULL2    DIS    ,/*B-O-I*/ 
 NULL3    DIS    ,/ NULL PROGRAM - HONOR THE A PARAMETER/ 
          TITLE              EXITS FROM THE HEADER CARD PROCESSORS
 PROGRTN  OUTUSE DATA.             SET RELOCATION BASE
  
*         ENTER SPECIAL SYMBOLS IN SYMTAB 
  
          SA1    =8RST. 
          RJ     ECGS              ENTER ST. IN SYMTAB AND SET DEF BIT
          SX7    B1 
          SA7    ST.               SAVE SYMTAB ORDINAL
          SA5    PROGRAM
          SB2    B5+B5
          UX5    B3,X5
          NE     B3,B2,PROGR1      IF NOT A FUNCTION
          SYMBOL =8RVALUE.         VALUE. TO SYMTAB 
          SA4    VALUE.            (VALUE.)=FUNCTION TYPE 
          LX4    P.TYP
          BX7    X4+X2
          SX0    B5 
          LX0    P.VAR
          BX7    X0+X7             SET VAR BIT
          SA7    A2                UPDATE WORD B
          SX6    B1 
          SA6    A4                (VALUE.)=SYMTAB ORD OF *VALUE.*
 PROGR1   SA1    PFLAG
          ZR     X1,PROGR2         IF NOT A PROGRAM 
          ADEXTS X1                ADD Q8NTRY. TO SYMTAB
  
*         ALLOCATE TABLES FOR PHASE 1 , OVERLAY HEADER CARD CODE
  
 PROGR2   SX6    PH1CTL 
          RJ     INITBL            INITIALIZE TABLES FOR PHASE 1
          SA5    DFLAG
          ZR     X5,PROGR3         IF NOT DEBUG MODE
          SA4    N.FP 
          ZR     X4,PROGR3         IF NO FORMAL PARAMETERS
          SA1    =8RFP. 
          RJ     ECGS              FP. TO SYMTAB
          SX7    B1 
          SA7    FP.               SAVE SYMTAB ORDINAL
 PROGR3   SA1    SVELIST
          ZR     X1,PROGR4         IF WE DIDNT SAVE ANYTHING
          SA2    TYPE 
          BX6    X1 
          SB7    X2                B7 = STATEMENT TYPE
          SA6    SELIST            RESTORE E LIST POINTER 
          SB3    B7-13
          LE     B7,B5,PH1SCAN     IF BAD HEADER LINE, DONT REPROCESS IT
          SB4    B7-37
          ZR     B3,=XLDPS2    IF END CARD FOUND
          ZR     B4,=XLDPS2    IF EOR ENCOUNTERED 
          EQ     PH1S1             PROCESS THE STMT 
  
 PROGR4   SA1    DFLAG
          ZR     X1,PH1SCAN        IF NOT DEBUG MODE
          CALL   DBGIPKT           PROCESS INTERNAL PACKET
          EQ     PH1SCAN
          TITLE              PROGRAM CARD PROCESSOR 
 M.BUF    EQU    360BS9            MAXIMUM BUFFER SIZE
 M.FILES  EQU    49D               MAXIMUM NUMBER OF FILES ALLOWED
  
*         ERROR NUMBERS 
  
 E.HCSE   EQU    23                HEADER CARD SYNTAX ERROR 
 E.TMC    EQU    24                FILE NAME MORE THAN 6 CHARACTERS 
 E.DFN    EQU    25                DUPLICATE FILE NAME
 E.FEE    EQU    27                FILE NAME EQUIVALENCE ERROR
 E.TMF    EQU    108               TOO MANY FILES 
 E.FSTB   EQU    234               FILE SIZE TOO BIG ( INFORMATIVE )
 E.RLTB   =      177               RECORD LENGTH TOO BIG
  
 PFLAG
 LI                                LOOP INDEX ( A TEMPORARY ) 
 RLFLAG   =      LI          FLAG TO INDICATE RECORD LENGTH PROCESSING
  
*** 
*         PLFN - PREPARE FILE NAME FOR SYMTAB 
* 
*         ON ENTRY: 
*                X1 = 8R_NAME 
* 
*         ON EXIT:  
*                X1 = 8R_NAME"C" - NAME WITH SPECIAL CHARACTER APPENDED 
* 
  
          QUAL   PLFN 
  
 PLFN     SUBR               ** ENTRY/EXIT ** 
          RJ     RTB         REMOVE TRAILING BLANKS 
          BX1    X6 
          AX1    5*6
          MX0    -6 
          BX0    -X0*X1      THIRD CHARACTER
          SX1    1R$
          BX0    X1-X0
          NZ     X0,PLFN1    IF THIRD CHARACTER NOT *$* 
          LX1    5*6
          BX6    X6-X1
 PLFN1    BX1    X6 
          LX1    2*6+6*6
          AX1    6*6
          NZ     X1,PLFN2    IF NAME LENGTH .GT. 6 CHARACTERS, ERROR
          SA1    =1H"C"      (X1) = SPECIAL CHARACTER, BLANK FILLED 
          SB7    =XGT1       (B7) = WSA FOR *MCS* 
          SA6    =XGT1
          RJ     MCS         MERGE CHARACTER STRINGS
          SA1    =XGT1
          EQ     EXIT.
  
 PLFN2    POSTER SEV=FE,NR=E.TMC,FMT=ELIST,TXT=X4,RETURN=PROGRTN
 PLFN     SPACE  4,2
          QUAL   *
 PLFN     =      /PLFN/PLFN 
          SPACE  3
 PROG.SE  POSTER SEV=FE,NR=E.HCSE,FMT=ELIST,TXT=X4,RETURN=PROGRTN 
          EJECT 
 DPROG    SA2    ATYPE
          SB7    X2 
          JP     PRGTYP+B7         SPLIT PROGRAM,BLOCK DATA,SUBROUTINE
 PRGTYP   EQ     DPBDA             BLOCK DATA 
          EQ     DPSUB             SUBROUTINE 
          EQ     PROG0             *PROGRAM*
          EQ     PLD               *OVERLAY*
  
 PROG0    POSTERR   SEV=ANSI,NR=E299
 PROG.D   SX7    T.ENT        BEGIN DPROG 
          RJ     PPN               PROCESS PROGRAM NAME 
          MX5    0
          PX6    X5 
          SA6    PROGRAM           PROGRAM = 12/2000B,48/0
          SA2    =XPROGNAM
          BX7    X2 
          SA7    XFRNAME           SAVE XFER NAME 
  
          GETE                     FIRST ELEMENT AFTER NAME 
          IF.EQ  EL.EOS,PROG.X     IF END OF STMT 
          IF.NE  EL.(,PROG.SE      IF NO OPENING PAREN
  
*         PROCESS FILE NAME DECLARATIONS
*         SAVE INFORMATION IN TEMPORARY TABLE, FORMAT:  
*                6/0,18/RECORD LENGTH,18/ORD(LFN),18/BUFFER SIZE
*                1/1,23/0,18/ORD(LFN1),18/ORD(LFN2) 
  
 PROG1    NEXTE 
          IF.NE  NAME,PROG.SE      IF NOT A NAME
          UPDATE
          SA2    N.FILES
          SX0    X2-M.FILES 
          MI     X0,PROG1A         IF NOT TOO MANY FILES
          POSTER SEV=FE,NR=E.TMF,RETURN=PROGRTN      *TOO MANY FILES* 
  
 PROG1A   SX6    X2+B5             N.FILES = N.FILES + 1
          SA6    A2 
          RJ     PLFN              PREPARE NAME 
          SYMBOL                   AND ENTER IN SYMTAB
          SA3    WB.LFN            TYPE , RL AND RB 
          EQ     PROG2
  
          SA5    SELIST 
          POSTERR   NR=E.DFN,SEV=FE,FMT=ELIST,TXT=X5+1,RETURN=PROGRTN 
  
 PROG2    SA4    N.FILES
          BX7    X3+X2             SET WORD B BITS
          SA7    A2 
          SX6    B1 
          SA5    =XOT.RM
          SX7    L.IOBUF6 
          ZR     X5,PROG2A   IF 6RM OBJECT MODE 
          SX7    L.IOBUF7 
 PROG2A   LX6    18 
          BX6    X6+X7
          SA6    O.LFN-1+X4        STORE LFN TAB ENTRY
  
          GETE                     NEXT ELEMENT - A SEPERATOR 
          IF.EQ  EL.COMMA,PROG1    LOOP IF A ,
          IF.NE  EL.=,PROG4        IF NOT AN = S
  
          NEXTE 
          UPDATE
          IF.EQ  NAME,PROG.N       IF A NAME
          MX6    0
          SA6    RLFLAG            CLEAR *PROCESSING MRL* FLAG
          IF.NE  EL.SLASH,PROG.B2  IF NOT A SLASH 
 PROG.B1  NEXTE 
          UPDATE
          SA3    RLFLAG 
          NZ     X3,PROG.SE        IF A SLASH (/) HAS BEEN PROCESSED
          MX6    10 
          SA6    A3                TURN *PROCESSING MRL* FLAG ON
 PROG.B2  IF.NE  CON,PROG.SE       IF NOT A CONSTANT
  
*         PROCESS BUFFER LENGTH OR RECORD LENGTH. 
  
          AX1    45 
          SX2    X1-T.OCT 
          SX3    X1-T.INT 
          ZR     X2,PROG.C         IF OCTAL 
          NZ     X3,PROG.SE        IF NOT INTEGER 
  
 PROG.C   BX1    X4                E-LIST 
          SB1    -B5
          RJ     CONVERT           CONVERT CONSTANT TO BINARY 
          SA4    N.FILES
          SA5    O.LFN-1+X4 
          SA3    RLFLAG 
          NZ     X3,PROG.B3        IF PROCESSING RECORD LENGTH
  
*         PROCESS BUFFER LENGTH.  (BUF LEN IGNORED IF 7RM SELECTED.)
  
          PL     X1,PROG.C1  IF BUFFER LENGTH NOT NEGATIVE
          POSTER SEV=FE,NR=E.HCSE,RETURN=PROGRTN
  
 PROG.C1  SA3    =XOT.RM
          NZ     X3,PROG3    IF 7RM OBJECT MODE IGNORE BUFFER LENGTH
          SX2    M.BUF             MAXIMUM PERMISSIBLE BUFFER LENGTH
          IX3    X2-X1
          AX3    59 
          BX1    -X3*X1 
          BX2    X3*X2
          IX1    X1+X2             MIN OF (REQUESTED LENGTH, MAX LENGTH)
          MX0    42 
          SX6    X1 
          ZR     X1,PROG.C2 
          SX6    X1+3        INCR 3 TO PREVENT S-TAPE PROBLEMS
 PROG.C2  BX5    X0*X5       REMOVE DEFAULT BUFFER LENGTH 
          IX7    X5+X6             INSERT NEW BUFFER LENGTH 
          SA7    A5 
          PL     X3,PROG3          IF REQUESTED LENGTH .LE. MAX LENGTH
          SA5    SELIST 
          POSTERR   NR=E.FSTB,SEV=INF,FMT=ELIST,TXT=X5+3,RETURN=PROG3 
 PROG.B3  SX3    X1 
          AX1    17 
          ZR     X1,PROG.B4        IF LEN<18 BITS 
          SA5    SELIST 
          POSTERR   NR=E.RLTB,SEV=FE,FMT=ELIST,TXT=X5+1,RETURN=PROGRTN
 PROG.B4  LX3    36 
          IX6    X5+X3             INSERT MRL INTO FILE WORD
          SA6    A5 
  
 PROG3    GETE                     SEPERATOR
          IF.EQ  EL.COMMA,PROG1    LOOP IF A COMMA
          IF.EQ  EL.SLASH,PROG.B1  IF TO CHECK FOR RECORD LENGTH
          EQ     PROG4
  
*         FILE NAME EQUIVALENCING - LFN1 = LFN2 
  
 PROG.N   RJ     PLFN 
          SYMBOL                   GET SYMTAB ORDINAL 
          EQ     PROG.EE           IF LFN2 NOT IN THE TABLE 
  
+         SA4    N.FILES
          SA5    O.LFN-1+X4 
          AX5    18 
          SB3    X5 
          EQ     B3,B1,PROG.EE     X = X IS ILLEGAL 
          LX5    18 
          SX6    B1 
          MX7    1
          BX5    X5+X6
          IX6    X7+X5             1/1,23/0,18/ORD(LFN1),18/ORD(LFN2) 
          SA6    A5 
          EQ     PROG3
  
 PROG.EE  SA5    SELIST 
          POSTERR   NR=E.FEE,SEV=FE,FMT=ELIST,TXT=X5+1,RETURN=PROG3 
  
 PROG4    IF.NE  EL.),PROG.SE      IF NOT A ) 
          NEXTE 
          IF.NE  EL.EOS,PROG.SE    IF NEXT IS NOT EOS 
  
*         STORE ADDRESS"S OF FILE NAMES IN WORD B OF SYMTAB ENTRIES 
  
          SA5    SYM1 
          SA4    N.FILES
          SA0    X5                A0 = SYM1
          SB1    O.LFN             FWA
          SB2    B1+X4             LWA+1
          SB3    18-1 
          SB7    P.RA 
          MX0    L.RA 
          LX0    L.RA+P.RA
          SX7    B0                X7 = LENGTH OF START.
  
 PROG5    SA1    B1                LFN TAB ENTRY
          SB1    B1+B5
          AX3    B3,X1
          SX5    X1                LENGTH OR ORD OF LFN2
          SB4    X3+B5             2*ORD+1
          SA2    A0-B4             WORD B OF LFN1 
          MI     X1,PROG5B   IF EQUIVALENCED FILE 
          LX3    X7,B7
          BX6    X2+X3       INSERT (START.) IN SYMTAB WORD B 
          SA6    A2 
          BX2    X1 
          SX3    X1          (X3) = BFS 
          AX2    36          (X2) = MRL IN CHARS
          SX7    X7+L.FIT6   (START.) + FIT LEN 
          SA4    =XOT.RM
          ZR     X4,PROG5.2  IF CRM OBJECT MODE 
          SX7    X7+L.FIT7-L.FIT6 
          ZR     X2,PROG5.2  IF MRL=0 OR OMITTED
          SX4    4           CREATE 4-WD WORKSPACE BELOW WSA FOR FCL
          IX6    X1+X4
          SX3    X6 
          SA6    A1          UPDATE LFN TAB ENTRY 
 PROG5.2  IX7    X7+X3       (START.) + BFS 
          CW     X3,X2       (X3) = MRL IN WORDS
          IX7    X7+X3       (START.) + MRL 
 PROG5.4  LT     B1,B2,PROG5 IF MORE FILES
          EQ     PROG6
  
 PROG5B   LX5    1
          SB4    X5+B5
          SA3    A0-B4             WORD B OF LFN2 
          BX4    X0*X3
          IX6    X4+X2             ADD LFN 1 = ADD LFN 2
          SA6    A2 
          SA1    =XOT.RM
          ZR     X1,PROG5C   IF CRM OBJECT MODE 
          SA1    N.EQUF      NR OF EQUIVALENCED FILES 
          SX6    X1+1        NR OF EQUIVALENCED FILES + 1 
          SA6    N.EQUF      UPDATE NR OF EQUIVALENCED FILES
 PROG5C   LT     B1,B2,PROG5 IF MORE FILES
 PROG6    SA7    START.            SAVE LENGTH OF START.
          SX6    0
          SA6    LI 
  
*         WRITE *FILCRM*, *FIL7RM* OR *FEQU* MACRO TO *COMPS*.
  
 PROG7    SA1    O.LFN+X6 
          INTARG
          NG     X1,PROG7A         IF EQUIV 
          LX1    0-18 
          SX6    X1 
          SVARG  NAME,1      ARG 1 = FILE NAME
          LX1    18-0 
          SX6    X1 
          SVARG  OCT,2       ARG 2 = BUFFER LENGTH
          LX1    0-36 
          SX6    X1 
          SVARG  OCT,3       ARG 3 = MAX RECORD LEN 
          SA3    =XCO.STA 
          ZR     X3,PROG7.2  IF STATIC LOAD OPTION NOT SELECTED 
          SX6    B5 
          SVARG  OCT,4       ARG 4 = STATIC LOAD FLAG 
 PROG7.2  SA3    =XF.LFN
          SX6    B5 
          LX3    59-P.EXT 
          MI     X3,PROG7.3  IF *SYSEDIT* OPTION NOT SELECTED 
          SVARG  OCT,5       ARG 5 = NO ENTRY POINT FLAG
 PROG7.3  NARGS= B7 
          SA1    =XOT.RM
          NZ     X1,PROG7.4  IF 7RM OBJECT MODE 
          FMAC   FILCRM 
          EQ     PROG7B 
  
 PROG7.4  FMAC   FIL7RM 
          EQ     PROG7B 
  
 PROG7A   LX1    60-18
          SX6    X1 
          SVARG  NAME,1            ARG 1 = LFN1 
          LX1    18 
          SX6    X1 
          SVARG  NAME,2            ARG 2 = LFN2 
          SA3    F.LFN
          SX6    B5 
          LX3    59-P.EXT 
          NG     X3,PROG7BB        IF FILES OPTION NOT SELECTED 
          SVARG  OCT,3             ADD THIRD ARG
 PROG7BB  NARGS= B7 
          FMAC   FEQU              OUTPUT MACRO CALL
  
 PROG7B   SA1    LI 
          SA2    N.FILES
          SX6    X1+B5
          SA6    A1 
          IX0    X6-X2             I - L
          NG     X0,PROG7          IF NOT FINISHED
  
 PROG.X   SA1    =XOT.RM
          NZ     X1,PROG.X4  IF 7RM OBJECT MODE 
  
*         ENTER *LIBLNK.* IN SYMTAB.  WRITE *LIBLNK BSS 0B.* AND
*         *LIBLNK* MACRO TO *COMPS*.
  
          SA1    =8RLIBLNK. 
          RJ     ESS
          SA1    START. 
          SX7    X1+3        START. = START. + LIBLNK LENGTH
          LX1    P.RA 
          BX6    X6+X1       LIBLNK ADDR TO SYMTAB WORD B 
          SA7    A1 
          SA6    A6 
          SB1    1
          WRITEC F.CMPS,LNK.CD,2
          SB5    B1 
          INTARG
          SA1    =XN.FILES
          BX6    X1 
          SVARG  OCT,1       ARG 1 = NR OF FILES
          SA1    =XPLIMIT 
          BX6    X1 
          SVARG  OCT,2       ARG 2 = PRINT LIMIT
          SA1    =XCO.STA 
          NARGS= B7 
          ZR     X1,PROG.X2  IF STATIC LOAD OPTION NOT SELECTED 
          SX6    B5 
          SVARG  OCT,3       ARG 3 = STATIC LOAD FLAG 
          SA1    N.FILES
          NARGS= B7 
          NZ     X1,PROG.X2  IF MAIN PROGRAM WITH FILES 
          SX6    B5 
          SVARG  OCT,4       ARG 4 = WEAK EXT TABLE FLAG
          NARGS= B7 
          SA1    =8RWXTTAB. 
          RJ     ESS
          SA1    START. 
          SX1    X1+B5       LIBLNK ADDR + 1 = W.EXT. TABLE ADDRESS 
          SX7    X1+L.STL    W.EXT. TAB ADDR + L.STL = LIBLNK ADDR
          LX1    P.RA 
          SA7    A1          RESTORE BUMPED START.
          BX6    X6+X1
          SA6    A6          W.EXT. TAB ADDR TO SYMTAB WORD B 
  
 PROG.X2  FMAC   LIBLNK 
  
*         ENTER "FILES." IN SYMTAB, OUTPUT FLINK MACROS 
  
 PROG.X4  SA1    =8RFILES.
          RJ     ESS
          SA3    START. 
          SA4    N.FILES
          IX7    X4+X3             START. = START. + N.FILES
          SA7    A3 
          LX3    P.RA 
          BX6    X3+X6             DEFINE ADDRESS OF FILES. 
          SA6    A6 
          SB1    1
          WRITEC F.CMPS,FILZ.CD,2 
          SA1    N.FILES
          SB5    B1+
          ZR     X1,PROG9          IF NO FILES
          MX6    0
          SA6    LI 
  
 PROG8    SX6    X6+2 
          F1AMAC FLINK             OUTPUT FLINK MACRO 
          SA1    LI 
          SA2    N.FILES
          SX6    X1+B5
          SA6    A1 
          IX0    X6-X2             I - L
          NG     X0,PROG8          IF NOT FINISHED
  
 PROG9    SA1    =XOT.RM
          NZ     X1,PROG9.2  IF 7RM OBJECT MODE 
          SB1    1
          WRITEC F.CMPS,APLT.CD,1  *FLINK* APLIST TERMINATOR
          SA1    START. 
          SX6    X1+B1       START. = START.+1 FOR APLIST TERMINATOR
          SA6    A1 
          EQ     PROG9.4
  
 PROG9.2  SA1    =XPLIMIT    RUN-TIME PRINT LIMIT 
          BX1    -X1
          CALL   BTOCT             CONVERT TO OCTAL DISPLAY CODE
          SB1    1
          SB6    DATAPL            (B6) = PRINT LIMIT TEXT LINE FWA 
          SA6    B6+B1             PRINT LIMIT TO LINE
          SA7    A6+B1
          WRITEC F.CMPS,B6,4       PRINT LIMIT TO -COMPS- 
          SA1    START. 
          SX6    X1+B1       START. = START.+1 FOR  *DATA -(PRINT LIM)* 
          SA6    A1 
 PROG9.4  WRITEC F.CMPS,APLT.CD,1  RESERVE POSSIBLE DEBUG ENTRY 
          SB5    B1+
          SA3    START. 
          SX7    X3+B5       START.=START.+1 FOR DEBUG ENTRY
          SA7    A3 
          ESS    TRACE.            TRACE. TO SYMTAB 
          SA3    START. 
          SX7    X3+B5       START. = START. + 1 FOR TRACE. 
          SA7    A3 
          LX3    P.RA 
          BX6    X3+X6             DEFINE TRACE.
          SA6    A6 
  
          INTARG
          SX6    B5 
          SVARG  NAME,1 
          SX6    B5 
          SVARG  NAME,2 
          NARGS= B7 
          FMAC   TRACE             OUTPUT TRACEBACK MACRO 
  
          OUTUSE CODE.             SWITCH TO CODE.
          INTARG
          SX6    B5 
          SVARG  NAME,1      ARG1=PROG NAME 
          SA5    =XCO.ER
          BX6    X5 
          LX6    1
          SVARG  INT,4       ARG4=ER
          NARGS= B7 
          FMAC   PENTRY      OUTPUT PENTRY MACRO CALL 
  
          SA5    CODE.
          SX6    X5+B5             CODE. = CODE.+1
          SA6    A5 
          SA1    =XOT.RM
          SB6    SA1.LIB     PRESET  *SA1 LIBLNK.*
          ZR     X1,PROG9.6  IF CRM OBJECT MODE 
          SB6    SA1.FIL     SET  *SA1 FILES.*
 PROG9.6  SB1    1
          WRITEC F.CMPS,B6,2
          SA1    =XCO.ER
          ZR     X1,PROG10   IF ER=0
          SA5    CODE.
          SX6    X5+1        CODE. = CODE. + 1  */ PENTRY WORD
          SA6    A5 
          SA1    =XPMDFLAG
          NZ     X1,PROG11
          WRITEC F.CMPS,RJRP.CD,2 
          SX6    =8RFTNRP2. 
          SB5    B1+
          SA6    PFLAG
          EQ     PROGRTN
  
 PROG10   SA1    =XPMDFLAG
          NZ     X1,PROG11
          WRITEC F.CMPS,RJQN.CD,2 
          SX6    =8RQ2NTRY. 
          SB5    B1+
          SA6    PFLAG             SET ADD Q8NTRY. TO SYMTAB
          EQ     PROGRTN
  
 PROG11   WRITEC F.CMPS,RJQ4.CD,2 
          SX6    =8RQ4PMD.
          SB5    B1+
          SA6    PFLAG
          EQ     PROGRTN
  
 DATAPL   DATA   30L  DATA
          DATA   1LB
 LNK.CD   LIT    14CLIBLNK. BSS 0B
 FILZ.CD  LIT    13CFILES. BSS 0B 
 APLT.CD  LIT    8C  DATA 0 
 SA1.FIL  LIT    12C  SA1 FILES.
 SA1.LIB  LIT    13C  SA1 LIBLNK. 
 RJQN.CD  LIT    12C  RJ Q2NTRY.
 RJRP.CD  LIT    14C  RJ FTNRP2.
 RJQ4.CD  LIT    11C  RJ Q4PMD. 
  
 O.LFN    BSS    0                 FWA OF TEMPORARY FILE NAME TABLE 
          TITLE              PPN - PROCESS PROGRAM NAME 
*** 
*         PPN - PROCESS PROGRAM NAME
* 
*         ON ENTRY: 
*                X7 = TYPE TO BE GIVE TO PROG NAME ( RIGHT JUSTIFIED )
* 
  
 PPN      ENTRY. *                 ** ENTRY/EXIT ** 
          ADVIN 
          LX7    P.TYP
          SA7    LI 
          IF.NE  NAME,PPN.SE       IF NOT A NAME
          SYMBOL                   ENTER NAME IN SYMTAB 
          SA3    LI 
          LX6    60-P.TYP 
          BX7    X3+X2             SET TYPE 
          SA6    A3                SAVE NATURAL TYPE IN CASE OF FUNC SUB
          SA7    A2 
          MX0    L.NAME 
          BX6    X0*X1
          SA6    IDENT+2           PROGRAM NAME TO *IDENT* LINE 
          SA6    =XPROGNAM                      TO *COMPILING...* MSG 
          SA1    HDRBLNK
          BX7    X6+X1       BLANK FILL 
          LX7    -6 
          SA7    =XTL.PNAM   NAME TO LISTING TITLE LINE 
          SA3    UFLAG
          ZR     X3,PPN2     IF *E* OPTION OFF
          SB7    DECK        (B7) = ADDRESS OF /*DECK,/ LINE
          BX1    X6          (X1) = PROGRAM UNIT NAME 
          CALL   MCS         MERGE CHARACTER STRINGS
          WRITEC =XF.CMPS,DECK,0
  
          IFEQ   TEST,0,2 
 PPN2     MESSAGE   =XCOMPMSG,1    /COMPILING NNN.../ TO B-DISPLAY ONLY 
          SKIP   1
 PPN2     MESSAGE   =XCOMPMSG,,RCL /COMPILING NNN.../ TO ALL DAYFILES 
  
          WRITEC F.CMPS,IDENT,3    /IDENT NNN/ LINES TO COMPS FILE
          WRITEC F.CMPS,USE.CD,1
          SA3    CAFLAG 
          ZR     X3,PPN2A          IF WE ARE USING FAX TO ASSEMBLE
  
*         IF THE O OPTION IS NOT SELECTED PUT OUT A LIST -L,-R CARD 
  
          SA4    OLIST
          NZ     X4,PPN2A          IF WE SHOULD PRODUCE OCTAL LISTING 
          WRITEC F.CMPS,NLST.CD,2 
 PPN2A    SA3    CAFLAG 
          SA4    UFLAG
          BX2    X3+X4
          ZR     X2,PPN2A1   IF NEITHER *E* OR *C* OPTION SELECTED
          WRITEC F.CMPS,NSST.CD,1 
 PPN2A1   SA1    SVELIST
          SA2    HDRPROG
          NZ     X1,PPN2B    IF DUMMY *PROGRAM START.*
          SA1    TYPE 
          SA2    HDRFUNC
          NZ     X1,PPN2B    IF FUNCTION SUBPROGRAM 
          SA1    ATYPE
          SA2    HDRTBL+X1
 PPN2B    BX6    X2 
          SA6    =XTL.PTYP   PROGRAM UNIT TYPE TO LISTING TITLE LINE
          SA6    =XIDENTOK   MARK *IDENT* LINE ILLEGAL NOW
          CALL   DSL         DUMP SAVED LINES 
          RJ     WLD         WRITE LOADER DIRECTIVES TO *COMPS* 
 PPN3     WRITEC F.CMPS,LDST.CD,L.LDST
 PPN4     OUTUSE START.      SET RELOCATION BASE
  
          SA5    RSELECT
          ZR     X5,PPN            IF R = 0 
          ADDREF B5,DEF            DEFINITION OF SUBPROGRAM NAME
          EQ     PPN
  
          SB5    B1+
  
 DECK     DATA   L$*DECK,$,0
 IDENT    DATA   10H               *C* OPTION REQUIRES *IDENT* IN 11-16 
          DATA   11CIDENT 
  
 LDST.CD  DIS    ,$  LDSET   LIB=FORTRAN$ 
 L.LDST   EQU    *-LDST.CD
  
 NLST.CD  LIT    12C  LIST -L,-R
 NSST.CD  LIT    5C  SST
 USE.CD   LIT    8C  USEBLK 
  
 HDRBLNK  DATA   3R 
 HDRFUNC  DATA   10H  FUNCTION
 HDRTBL   DATA   10HBLOCK DATA
          DATA   10HSUBROUTINE
 HDRPROG  DATA   10H   PROGRAM
 PPN.SE   SPACE  4,8
**        PPN.SE - POST ERROR MESSAGE, *HEADER CARD SYNTAX ERROR*.
* 
 PPN.SE   POSTERR   NR=E.HCSE,SEV=FE,FMT=ELIST,TXT=X4,RETURN=PTR57
          TITLE              BLOCK DATA , SUBROUTINE AND FUNCTION CARD P
,ROCESSORS
 BLKDAT   VFD    12/2001B,48/8LBLKDAT.
*** 
*         DPBDA - PROCESS "BLOCK DATA" STATEMENT
*         NOTE: PROGRAM = 0 FOR A BLOCK DATA SUBPROGRAM 
* 
  
 DPBDA    GETE
          MX6    0
          SA6    PROGRAM           BLKDTA = 60/0
          IF.EQ  EL.EOS,DPBDA1  IF EOS
          POSTER SEV=ANSI,NR=E323  NON-ANSI FORM OF BLKDATA 
          EQ     DPBDA2 
 DPBDA1   SA2    BLKDAT      DEFAULT NAME 
          BX6    X2 
          SA6    A4 
 DPBDA2   SX7    T.CGS       TYPE=T.CGS SO IT DISAPPEARS IN THE 
          RJ     PPN               REF MAP
          EQ     PROGRTN
          SPACE  3
*** 
*         DPSUB - PROCESS "SUBROUTINE" SUBPROGRAM HEADER CARD 
* 
  
 DPSUB    SX7    T.ENT
          RJ     PPN               PROCESS PROGRAM NAME 
          SX5    B0 
          PX6    B5,X5
          SA6    PROGRAM           SUBR = 12/2001B,48/0 
  
          RJ     PPL               PROCESS PARAMETER LIST 
          EQ     PROGRTN
          SPACE  2
*** 
*         DPFUN - PROCESS FUNCTION SUBPROGRAM HEADER CARD 
* 
 DPFUN    SX7    T.ENT
          RJ     PPN               PROCESS PROGRAM NAME 
          SA4    ATYPE
          PL     X4,DPFUN1         IF TYPED ON THE HEADER CARD
          SA4    LI                NATURAL TYPE 
  
 DPFUN1   BX6    X4 
          SA6    =XVALUE.          USE *VALUE.* AS TEMP CELL TO HOLD
*                                  FUNCTION TYPE FOR *PROGRTN*
          MX7    1
          SX4    X4-T.DBL 
          BX6    -X4*X7 
          LX6    1
          SX7    X6+B5             FUNTYPE = NUMBER OF WDS IN FUNCTION R
          SA7    =XFUNTYPE
          SX7    2002B
          LX7    48 
          SA7    PROGRAM           FUNC = 12/2002B,48/0 
  
          RJ     PPL               PROCESS PARAMETER LIST 
          EQ     PROGRTN
          TITLE              PPL - PROCESS PARAMETER LIST 
*** 
*         PPL - PROCESS PARAMETER LIST FOR SUBROUTINE OR FUNCTION 
*         SUBPROGRAM
* 
*         ENTERS F.P. S AND RETURNS NAMES IN SYMTAB 
*         ENTERS TRACE. , TEMPA0. , AND ENTRY. IN SYMTAB AS NECESSARY 
*         OUTPUTS ALL NECESSARY INFORMATION FOR TRACEBACK AND ENTRY 
*         POINT FORMATION 
* 
  
 E.RSL    EQU    39                RETURNS LIST SYNTAX ERROR
 E.DFP    EQU    40                DUPLICATE F.P. 
 E.TMFP   EQU    108               TOO MANY F.P. S
  
 M.FPS    EQU    63                MAXIMUM NUMBER OF F.P. S 
  
*         ERROR EXITS 
  
 PPL.SE   SB6    E.HCSE            HEADER CARD SYNTAX ERROR 
  
 PPL.EX   POSTER SEV=FE,NR=** 
          RJ     ESF               ENTER SPECIAL SYMBOLS
  
  
  
 PPL      ENTRY. *                 ** ENTRY/EXIT ** 
          GETE                     , ( OR EOS 
          IF.EQ  EL.COMMA,PPL4     IF A , 
          IF.NE  EL.(,PPL5         IF NOT A ( 
  
*         PROCESS F.P. LIST, ENTER NAMES IN SYMTAB, SET F.P. AND DEFINED
*         BITS AND TYPE 
  
 PPL1     NEXTE 
          IF.NE  NAME,PPL.SE       IF NOT A NAME
          UPDATE
          SYMBOL                   ENTER IN SYMTAB
          MX0    1
          LX0    1+P.FP 
          EQ     PPL2 
  
          BSS    0           *SYMBOL FOUND* RETURNS HERE
          SA5    SELIST      (X5) = ADDRESS OF CURRENT E-LIST ENTRY 
          POSTER SEV=FE,NR=E.DFP,FMT=ELIST,TXT=X5+1,RETURN=PPL3 
  
 PPL2     BX7    X6+X2             SET NATURAL TYPE 
          SA3    N.FP 
          BX6    X0+X1       SET F.P. BIT 
          LX0    -P.FP
          BX7    X0+X7       AND IN WORD B
          SA7    A2 
          SA6    A1 
          SX0    X3-M.FPS 
          SB6    -E.TMFP
          SX6    X3+B5             INCREMENT NUMBER OF F.P. S 
          SA6    A3 
          PL     X0,PPL.EX         IF TOO MANY F.P. S 
  
          SA5    RSELECT
          ZR     X5,PPL3           IF R = 0 
          ADDREF B1,DEF            HEADER LINE DEFINES THE F.P.S
  
 PPL3     GETE                     NEXT AFTER THE NAME
          IF.EQ  EL.COMMA,PPL1     LOOP IF A COMMA
          IF.NE  EL.),PPL.SE       IF NOT A ) 
  
*         (TEMPA0.).NE.0 MEANS THAT *ESF* IS TO DEFINE *TEMPA0.* AND
*         SPECIFIES THAT CODE WILL BE PUT OUT TO SAVE AND RESTORE 
*         *TEMPA0.*.
  
          SX7    L.SVCD 
          SA7    =XTEMPA0.
  
          NEXTE 
          IF.NE  EL.COMMA,PPL5     IF NOT A COMMA 
  
 PPL4     RJ     PRP               PROCESS RETURNS PARAMETERS 
  
 PPL5     IF.NE  EL.EOS,PPL.SE     IF NO EOS
  
          EQ     PPL
          TITLE              PRP - PROCESS RETURNS PARAMETER LIST 
 RTNS     VFD    12/2001B,48/8RRETURNS
  
*** 
*         PRP - PROCESS RETURNS PARAMETER LIST
*         ENTER NAMES IN SYMTAB AND SET TYPE TO T.RTN 
* 
  
 PRP.SE   SB6    E.RSL             RETURNS LIST ERROR 
          EQ     PPL.EX 
  
  
  
 PRP      ENTRY. *                 ** ENTRY/EXIT ** 
          NEXTE 
          SA2    RTNS              CODE FOR RETURNS 
          IX3    X4-X2
          NZ     X3,PPL.SE         IF NOT ,RETURNS
          SA1    PROGRAM
          SB3    B5+B5
          UX1    B2,X1
          EQ     B2,B3,PPL.SE      IF A FUNCTION
  
*         (TEMPA0.).NE.0 MEANS THAT *ESF* IS TO DEFINE *TEMPA0.* AND
*         SPECIFIES THAT CODE WILL BE PUT OUT TO SAVE AND RESTORE 
*         *TEMPA0.*.
  
          SX7    L.SVCD 
          SA7    =XTEMPA0.
          NEXTE 
          IF.NE  EL.(,PRP.SE       IF NOT A ( 
  
*         PROCESS THE LIST OF NAMES 
  
 PRP1     NEXTE 
          IF.NE  NAME,PRP.SE       IF NOT A NAME
          UPDATE
          SYMBOL                   ENTER NAME IN SYMTAB 
          SX0    T.RTN
          EQ     PRP2 
  
          BSS    0           *SYMBOL FOUND* RETURNS HERE
          SA5    SELIST      (X5) = ADDRESS OF CURRENT E-LIST ENTRY 
          POSTER SEV=FE,NR=E.DFP,FMT=ELIST,TXT=X5+1,RETURN=PRP3 
  
 PRP2     LX0    P.TYP
          BX7    X0+X2
          SA7    A2                SET TYPE IN WORD B 
          SA5    RSELECT
          ZR     X5,PRP3           IF R = 0 
  
 PRP3     GETE                     NEXT AFTER THE NAME
          IF.EQ  EL.COMMA,PRP1     LOOP IF A COMMA
          IF.NE  EL.),PRP.SE       IF NOT A ) 
          SA1    =XSYMORD 
          SX2    X1-M.FPS-3 
          SB6    -E.TMFP
          PL     X2,PPL.EX
          NEXTE 
          EQ     PRP
 CCS      SPACE  4,8
**        CCS - CHECK FOR AND COPY COMPASS SOURCE INPUT.
* 
* 
*         ENTRY  (B1) = 1 
* 
*         EXIT   (B7) = .ZR. IF CURRENT SOURCE LINE NOT *IDENT* 
*                     = .NZ. IF IT WAS *IDENT* AND COMPASS SOURCE COPIED
* 
*         USES   ALL
* 
*         CALLS  DSL, MCS, MPP, READC, WLD, WRITEC
  
  
          QUAL   CCS
  
 CCS      SUBR               ** ENTRY/EXIT ** 
          SA1    =XCP.CARD
          SA2    =1H
          SA3    A1+B1
          MX6    36 
          SA4    =6LIDENT 
          BX1    X1-X2
          SB7    B0+         RETURN *IDENT NOT FOUND* STATUS
          BX6    X6*X3
          BX3    X6-X4
          BX4    X1+X3
          NZ     X4,EXIT.    IF NOT *IDENT* LINE
          MI     X4,EXIT. 
          SA1    L.LCC
          ZR     X1,CCS1     IF NO SAVED LOADER DIRECTIVES
          SA1    =H*LOADER DIRECTIVES*
          SA2    A1+B1
          BX6    X1 
          SA6    =XTL.PTYP
          BX7    X2 
          SA7    A6+B1
 CCS1     CALL   DSL         DUMP SAVED LINES (LDR DIRS, COMMENTS, ETC) 
          CALL   MPP         MAINTAIN PAGE PARITY 
          SA1    =1H
          MX6    0
          BX7    X1 
          SA6    =XN.LINES   FORCE PAGE EJECT ON NEXT *LISTL* CALL
          SA7    =XTL.PTYP   CLEAR TITLE LINE 
          SA7    A7+B1
          SA1    =XUFLAG
          SA2    =XCAFLAG 
          NZ     X1,CCS2     IF *E* OPTION SELECTED 
          NZ     X2,CCS6     IF *C* OPTION SELECTED 
          WRITER =XF.OUT,RCL FLUSH OUTPUT BUFFER
          EQ     =XLDCOM     GO LOAD *COMPASS*
  
*         *E* OPTION SELECTED.  FORM -*DECK,PROGNAM- LINE AND WRITE IT
*         TO THE *COMPS* FILE.
  
 CCS2     SA1    DECK        (X1) =IMAGE OF *DECK,
          SA2    =XSBUFF+5   (X2) = 1ST CHARACTER AFTER *IDENT* 
          SB7    CCSA        (B7) = FWA OF LINE ASSEMBLY AREA 
          BX6    X1 
          MX7    0
          SX1    B0          CLEAR PACK REGISTER
          SB2    54          PACK SHIFT COUNTER 
          SA6    B7 
          SB3    6           PACK SHIFT DECREMENT 
          MX3    -1R         SHIFT TEST MASK BASED ON MAX NON-TERM CHAR 
          SA7    B7+B1
 CCS3     SB4    X2+7777B    BIAS TERM CHAR TO 7777B OR 10055_10076B
          UX2    X2 
          AX6    X3,B4
          ZR     X6,CCS4     IF TERMINATING CHARACTER 
          LX2    B2 
          SB2    B2-B3
          BX1    X1+X2       PACK NEW CHARACTER 
          SA2    A2+B1       (X2) = NEXT CHARACTER
          PL     B2,CCS3     IF MORE TO PACK
 CCS4     NZ     X1,CCS5     IF NAME NOT NULL 
          SA1    =8L*******  INVENTED NAME
 CCS5     RJ     MCS         MERGE CODED STRINGS
          WRITEC =XF.CMPS,CCSA,0
  
*         COPY ASSEMBLY-LANGUAGE SOURCE CODE TO THE *COMPS* FILE. 
  
 CCS6     WRITEC =XF.CMPS,=XCP.CARD,0    *IDENT* LINE TO *COMPS*
          RJ     WLD         WRITE LOADER DIRECTIVE(S) TO *COMPS* 
          SX6    B0+
          SA6    CCSB 
  
*         COPY LOOP - COPY UNTIL END LINE FOUND.
*         AN END LINE IS A NON-COMMENT, NON-CONTINUATION LINE WITH
*         THE CHARACTERS * END * IN COLUMNS 10 - 14.
  
 CCS7     READC  =XF.IN,=XCP.CARD,=XL.MAXCD 
          NZ     X1,CCS9     IF END (EOS/EOP/EOI) OF SOURCE INPUT 
          SA1    CCSB 
          SB7    B6          LINE LWA+1, DOUBLES AS *IDENT FOUND* STATUS
          MX6    -6 
          SA2    =XCP.CARD
          NZ     X1,EXIT.    IF *END* LINE FOUND
          LX2    -54
          SA3    A2+B1
          SB6    A2          (B6) = LINE FWA
          BX6    -X6*X2      EXTRACT COL 1
          SX7    1S7+1S0     SHIFT TEST MASK FOR * AND ,
          SB2    X6+59-7-1R* ADJUST FOR TEST MASK POSITION
          SA4    =4LEND 
          LX7    B2 
          MX6    4*6
          SB7    B7-B6       (B7) = LINE LENGTH (WORDS) 
          BX3    X6*X3       EXTRACT COLS 11-14 
          MI     X7,CCS8     IF *COMPASS* COMMENT OR CONTINUATION LINE
          EQ     B7,B1,CCS8  IF LENGTH = 1, *END* NOT POSSIBLE
          BX3    X3-X4
          NZ     X3,CCS8     IF NOT POSSIBLE *END* LINE 
          LX2    -6 
          MX1    -6 
          BX3    -X1*X2      EXTRACT COL 10 
          SX4    1R 
          BX5    X3-X4
          NZ     X5,CCS8     IF END CARD NOT PRECEEDED BY BLANK 
          SA6    A1          SET *END FOUND* STATUS 
 CCS8     WRITEC =XF.CMPS,B6,B7    LINE TO *COMPS* FILE 
          EQ     CCS7 
  
*         HERE IF EMPTY INPUT FILE. 
  
 CCS9     SX6    0
          SA6    =XCP.CARD   MARK END OF INPUT
          EQ     =XFTNEND    GO TERMINATE COMPILATION 
  
  
  
 CCSA     BSSZ   2           ASSEMBLY AREA FOR -*DECK,PROGNAM- LINE 
 CCSB     BSSZ   1           .NZ. WHEN *END* LINE FOUND ON SOURCE FILE
          SPACE  4
          QUAL   *
 CCS      =      /CCS/CCS 
          ENTRY  CCS
 MCS      TITLE  MERGE CODED STRINGS
**        MCS - MERGE CODED STRINGS.
* 
*                CONCATENATES NEW CHARACTER STRING IN (X1) WITH OLD 
*         STRING AT (B7).  STORES RESULT AT (B7) AND, IF NEW STRING 
*         LENGTH REQUIRES, AT (B7)+1.  BOTH OLD AND NEW STRINGS ARE 
*         ASSUMED TO BE LEFT JUSTIFIED WITH ZERO FILL.  EITHER MAY BE 
*         NULL OR FULL. 
* 
*                ***  LIMITATION -- TRAILING COLONS ARE IDENTICAL TO
*         ZERO FILL, AND WILL BE LOST.
* 
* 
*         ENTRY  (X1) = *NEW* STRING
*                (B7) = ADDRESS OF *OLD* STRING 
* 
*         EXIT   MERGED STRING STORED AT (B7) AND, POSSIBLY, AT (B7)+1
*                (X1) = UNCHANGED 
*                (X2) = ORIGINAL *OLD* STRING 
*                (X6) = *OLD* .AND. UPPER *NEW* 
*                (X7) = LOWER *NEW*, IF ANY, ELSE = 0 
*                (B1) = 1 
*                (B7) = ADDRESS OF *OLD*, UPDATED IF LOWER *NEW* .NZ. 
* 
*         USES   X - 2, 3, 6, 7 
*                A - 2, 3, 6, 7 
*                B - 1, 2, 7
* 
*         CALLS  NONE 
  
  
          QUAL   MCS
  
 MCS      SUBR               ** ENTRY/EXIT ** 
          SA2    B7          (X2) = *OLD* STRING
          MX7    -1 
          SA3    MCSA 
          IX6    X2+X7       BORROW RIPPLES LEFT TO 1ST NON-ZERO CHAR 
          BX7    -X2*X6      EXTRACT BORROWS
          SB1    1
          BX3    X3*X7       EXTRACT NULL BYTES 
          BX7    X3          EACH NULL BYTE = 40
          LX3    -5          EACH NULL BYTE = 01
          IX6    X7-X3       EACH NULL BYTE = 37
          BX7    X6+X7       EACH NULL BYTE = 77 ... EXTRACTION MASK
          CX6    X7 
          SB2    X6 
          LX3    X1,B2       ALIGN *NEW* WITH NULL PART OF *OLD*
          BX6    X7*X3
          BX7    -X7*X3      (X7) = LOWER *NEW* 
          BX6    X2+X6       (X6) = *OLD* .OR. UPPER *NEW*
          SA6    B7 
          NZ     X7,MCS2     IF LOWER *NEW* NOT EMPTY 
          PL     X7,EXIT. 
 MCS2     SA7    B7+B1
          SB7    B7+B1       (B7) = UPDATED STRING ADDRESS
          EQ     EXIT.
  
  
  
 MCSA     DATA   40404040404040404040B   NULL CHARACTER BYTE MASK 
          SPACE  4
          QUAL   *
 MCS      =      /MCS/MCS 
 PLD      TITLE  PROCESS LOADER DIRECTIVE.
**        PLD - PROCESS LOADER DIRECTIVE. 
* 
* 
*         EXIT
*                (B1) = 1 
*                (B5) = 1 
* 
*         USES   X - 1, 2, 3, 4, 6, 7 
*                A - 1, 2, 3, 6, 7
*                B - 1, 2, 5, 6, 7
* 
*         CALLS  GETE, IF., NEXTE, PCS, RTB, WRITER, WRITEW 
  
  
          QUAL   PLD
  
 PLD      SA1    O.LCC
          SA2    L.LCC
          SA3    =XFWAWORK
          SA4    SYMEND 
          BX6    X1          SET SAVED FWA
          NZ     X2,PLD2     IF NOT FIRST LOADER DIRECTIVE
          BX6    X3          SET INITIAL FWA
 PLD2     SA6    A1          (X6) = FWA LOADER DIRECTIVE SAVE AREA
          SB1    1
          IX7    X6+X2
          SB7    X7          (B7) = FWA UNUSED SAVE AREA
          SX7    X7+4 
          IX4    X7-X4
          PL     X4,PLD.ER2  IF NOT ENOUGH ROOM FOR SAVING NEW LINE 
          SA7    A3          RESERVE MEMORY 
          SB5    B1 
          SA1    =7LOVERLAY 
          BX6    X1 
          SA6    B7 
          GETE
 PLD3     IF.EQ  EL.EOS,PLD4
          BX1    X4 
          LX4    15D         PUT CONST INDICATOR IN LOW ORDER BITS
          MX6    -3 
          BX6    -X6*X4      EXTRACT CONSTANT 
          SX6    X6-6 
          NZ     X6,PLD31    IF NOT HOLL CONSTANT 
          SA1    =6L=HOLL=
          EQ     PLD32
 PLD31    CALL   CED         CONVERT E-LIST TO DISPLAY CODE 
          BX1    X6 
          CALL   RTB         REMOVE TRAILING BLANKS 
          BX1    X6 
 PLD32    CALL   MCS         MERGE CODED STRINGS
          NEXTE 
          EQ     PLD3 
  
*         TERMINATE PROCESSING. 
  
 PLD4     SA1    B7 
          MX6    -12
          BX7    -X6*X1 
          MX6    0
          ZR     X7,PLD5     IF ZERO BYTE LINE TERMINATOR IN LAST WORD
          SA6    B7+B1       TERMINATE LINE 
          SB7    B7+B1
 PLD5     SA1    O.LCC
          SA2    L.LCC
          SX7    B7+B1       (X7) = LWA+1 OF SAVED LINES
          SB7    B7+B1
          IX3    X1+X2
          SB6    X3          (B6) = FWA OF LAST LINE SAVED
          SA7    =XFWAWORK   UPDATE FWA *SCANNER* WSA 
          SB7    B7-B6       (B7) = LENGTH OF LAST LINE 
          SX6    X2+B7
          SA6    A2          UPDATE LENGTH OF ALL SAVED LINES 
          SA1    =XCAFLAG 
          SA2    =XUFLAG
          SA3    =XFV.LGO 
          BX6    X1+X2
          NZ     X6,PLD7     IF *C* OR *E* OPTION SELECTED
          ZR     X3,PLD7     IF BINARY OUTPUT SUPPRESSED  ( B=0 ) 
          WRITEW =XF.LGO,B6,B7
          WRITER =XF.LGO,RCL
 PLD7     EQ     CTL5        EXIT ... 
  
  
  
*         ERROR PROCESSING FOR LOADER DIRECTIVES. 
  
 PLD.ER2  POSTER SEV=FC,NR=E225    (DOES NOT RETURN CONTROL HERE) 
          SPACE  4
          QUAL   *
 PLD      =      /PLD/PLD 
          SPACE  4,2
 L.LCC    BSSZ   1           LENGTH OF SAVED LOADER CONTROL DIRECTIVES
 O.LCC    BSSZ   1           FWA OF SAVED LOADER CONTROL DIRECTIVES 
 RTB      TITLE  REMOVE TRAILING BLANKS 
**        RTB - REMOVE TRAILING BLANKS. 
* 
*                REMOVES ALL TRAILING DISPLAY-CODED BLANKS FROM (X1). 
* 
* 
*         ENTRY  (X1) = STRING WITH TRAILING BLANK FILL 
* 
*         EXIT   (X1) = UNCHANGED 
*                (X6) = STRING, ZERO FILLED 
* 
*         USES   X - 2, 6, 7
*                A - 2
*                B - NONE 
* 
*         CALLS  NONE 
  
  
          QUAL   RTB
  
 RTB      SUBR               ** ENTRY/EXIT ** 
          SA2    RTBA 
          MX6    -1 
          BX7    X1-X2       CONVERT BLANKS TO ZEROS
          SA2    RTBB 
          IX6    X7+X6       BORROW RIPPLES LEFT TO NON-ZERO CHAR BYTE
          BX7    -X7*X6      EXTRACT BORROWS
          BX6    X2*X7       EACH ZERO (BLANK) BYTE = 40
          BX2    X6 
          LX6    -5                                 = 01
          IX7    X2-X6                              = 37
          BX2    X2+X7                              = 77
          BX6    -X2*X1      (X6) = STRING, ZERO FILLED 
          EQ     EXIT.
  
  
  
 RTBA     DATA   1H 
 RTBB     DATA   40404040404040404040B
          SPACE  4
          QUAL   *
 RTB      =      /RTB/RTB 
 WLD      TITLE  WRITE LOADER DIRECTIVES TO *COMPS* FILE
**        WLD - WRITE LOADER DIRECTIVES TO *COMPS* FILE.
* 
*                PREFIXES LOADER DIRECTIVES WITH *  LCC * AND WRITES
*         THEM TO THE *COMPS* FILE.  RESETS (FWAWORK) TO (O.LCC) ON 
*         ENTRY, TO RELEASE THE MEMORY IN WHICH THE LOADER DIRECTIVES 
*         WERE SAVED. 
* 
* 
*         ENTRY  LOADER DIRECTIVES, FORMATTED AS LEFT-JUSTIFIED DPC 
*                  LINES, SAVED AT ((O.LCC)). 
*                (L.LCC) = LENGTH OF SAVED DIRECTIVES 
*                (O.LCC) = FWA OF SAVED DIRECTIVES
* 
*         EXIT   (FWAWORK) = (O.LCC) ON ENTRY 
*                (L.LCC) = 0
*                (O.LCC) = DESTROYED
*                (B1) = 1 
* 
*         USES   X - 1, 2, 3, 6, 7
*                A - 1, 2, 6 ,7 
*                B - 1, 6, 7
* 
*         CALLS  PCS, WRITEC
  
  
          QUAL   WLD
  
 WLD      SUBR               ** ENTRY/EXIT ** 
          SA1    L.LCC
          SB1    1
          ZR     X1,EXIT.    IF NO LOADER DIRECTIVES SAVED
          SA1    O.LCC
          SA2    =XMACFLAG
          BX6    X1 
          SA6    =XFWAWORK   RELEASE WORKING STORAGE
          ZR     X2,EXIT.    IF MACROS NOT TO BE OUTPUT 
 WLD2     SA2    =6L  LCC 
          SB6    X1          (B6) = FWA OF SAVED LINE 
          SA1    X1          (X1) = 1ST WORD OF SAVED LOADER DIRECTIVE
          SB7    WLDA        (B7) = FWA OF REFORMATTED DIRECTIVE
          BX6    X2 
          SA6    B7          *  LCC * TO FORMATTING BUFFER
 WLD3     CALL   MCS         MERGE CODED STRINGS
          MX6    -12
          NO
          BX7    -X6*X1 
          SA1    A1+B1       (X1) = NEXT WORD OF SAVED LINE 
          NZ     X7,WLD3     IF NOT END OF SAVED LINE 
          SA2    L.LCC
          SX6    A1          (X6) = FWA OF NEXT SAVED LINE
          MX7    0
          SB7    B7+B1
          SX3    A1-B6       (X3) = LENGTH OF CURRENT SAVED LINE
          SA7    B7          MARK EOL 
          SA6    O.LCC
          IX7    X2-X3       (X7) = LENGTH OF REMAINING SAVED LINES 
          SB7    B7-WLDA+1   (B7) = LENGTH OF REFORMATTED LINE
          SA7    A2 
          WRITEC =XF.CMPS,WLDA,B7 
          SA2    L.LCC
          SA1    O.LCC
          NZ     X2,WLD2     IF ANY MORE SAVED LINES
          EQ     EXIT.
  
  
  
 WLDA     BSS    6           WSA FOR FORMATTING *LCC* DIRECTIVES
          SPACE  4
          QUAL   *
 WLD      =      /WLD/WLD 
          SPACE  4
          LIST   D
          SPACE  4
 F.WORK1  END    FTN21
