*DECK     INIT00             FIRST TIME ONLY INITIALIZATION 
          IDENT  INIT00 
 INIT00   SECT   (FIRST TIME ONLY INITIALIZATION.)
 INIT00   SPACE  4,10 
*         IN FEC
          EXT    OSTACK 
  
*         IN FTN
          EXT    CO.AL,ABTFTN,CO.ANSI,CO.ARGC,CO.ARGF,CO.BRK,CO.CPL 
          EXT    CO.CS,CO.DBER,CO.DBID,CO.DBPM
          EXT    CO.DBSB,CO.DBSL,CO.DBST,CO.DBTB
          EXT    CO.DOLG,CO.DOOT,CO.DS,CO.EC,CO.EL,CO.ET,CO.GO,CO.IDP 
          EXT    CO.LCM,CO.LL,CO.LOA,CO.LOC,CO.LOM,CO.LOO,CO.LOR,CO.LOS 
          EXT    CO.MD,CO.OPT,CO.PS,CO.PW,CO.PWT,CO.QC,CO.REWB,CO.REWE
          EXT    CO.REWI,CO.REWL,CO.RFL,CO.RNDA,CO.RNDD,CO.RNDM,CO.RNDS 
          EXT    CO.SEQ,CO.SNAP,CO.SPP,CO.STAT,CO.TMLC,CO.UO
          EXT    CO.WPL,CO.WPE,CP.ABT 
          EXT    CP.AFLL,CP.AFLS,CP.BLF,CP.CARD,CP.CPU,CP.ILFL,CP.LIB 
          EXT    CP.LSTF,CP.MODL,CP.MXFL,CP.NFLL,CP.NFLS,CP.PAGE,CP.PCOM
          EXT    CP.PD,CP.PS,CP.PW,CP.STXT,CP.XTXT,ENOT=L,ERFO,FTIFL
          EXT    FTNHHA,FTNLDR,FTNLFN,FVLEN,FVTBL,FV.IN,FV.ERRS 
          EXT    FV.LGO,FV.OUT,F.IN,F.ERRS,F.LGO,F.OUT,F.PB,F.REF,GT1 
          EXT    IBUF,IDPCHK,INT.FL,JOT,LDPRI,L.PWA,L.PWB,MAX.FL,MSG= 
          EXT    MEMERR,NOM.FL,ONSPY,O.C,O.CC,O.CPV,O.TA,O.TTLA,RAPFLAG 
          EXT    SPYW,SYS=,TIMER,TIME0,TIME1,TL.CPU,TL.CSOP,TL.DATE 
          EXT    TL.PAGE,TL.PNAM,TL.TIME,WNB= 
  
*         IN IDP
          EXT    IDP=,IDP=USY,UKT=FE,UKT=LNK
  
*         IN LIST 
          EXT    FIN.OL 
  
*         IN MAP
          EXT    FIN,FIN.MAP
  
*         IN PEM
          EXT    ANSI.SW
  
*         IN PUC
          EXT    ERRTYP,L.TABS,O.TABS,PUC,SCR,THRESH
          EXT    RS.PD
  
*         IN QCGC 
          EXT    WIN,WTE
  
*         IN QSKEL
          EXT    F.SKEL 
  
*         IN UTILITY
          EXT    CDD,CIO=,DXB,FA=SET,MVE=,RDC=,RPV=,SFN=
 INIT00   SPACE  4,10 
**        (DC.) - BITS IN O.S. LOADER CONTROL WORD. 
  
          DESCRIBE  DC. 
          DEFINE 24 
 FID      DEFINE             SYSTEM GLOBAL DEBUG SWITCH 
          DEFINE 35 
  
  
**        (MC.) - BITS IN REPLY FROM *GETMC* MACRO CALL.
  
          DESCRIBE  MC. 
          DEFINE 39 
 800      DEFINE             SET IF CPU IS MODEL 800
 176      DEFINE 2           NZ IF CPU IS MODEL 176 
          DEFINE 18 
  
  
          LIST   -X          COMFCIP IS LISTED IN DECK *FTN*
*CALL     COMFCIP            COMPILER INSTALLATION PARAMETERS 
          LIST   *
 FTN      SPACE  4,10 
**        FTN - INITIALIZATION MAIN LOOP. 
* 
*         THE OPERATING SYSTEM RESPONDS TO AN *FTN* CONTROL STATEMENT 
*         BY LOADING THE (0,0) OVERLAY AND TRANSFERRING CONTROL HERE. 
* 
*         THIS CONTROLLER CALLS A SERIES OF INITIALIZATION SUBROUTINES
*         AND TRANSFERS CONTROL TO THE PRIMARY OVERLAY.  IF OPT=0 A 
*         COPY OF THE PRIMARY HAS ALREADY BEEN LOADED AS AN EXTENSION 
*         TO THE MAIN OVERLAY.
* 
*         ENTRY  (A0) =  CM/SCM FIELD LENGTH
*                (X0) = ECS/LCM FIELD LENGTH
* 
*         EXIT   TO PRIMARY OVERLAY LOADER (OPT=1,2)
*                TO MAIN BATCH CONTROL (OPT=0)
*                (B1) = 1 
* 
*         CALLS  CFL, GOI, IDPCHK, MIA, MIB, ONSPY, PAC 
  
  
 FTN      BSSENT 0           ** SYSTEM LOADER ENTRY POINT **
  
          SB1    1
          SA1    CP.NFLS     LWA
          SA2    FTNLDR      LOADER BITS
          LX1    18 
          BX7    X2+X1
          SA7    RA.ORG      DUMMY LOADER REQUEST FOR (0,0) 
          RJ     MIA         MISCELLANEOUS INITIALIZATION, PART A 
          RJ     GPP         INITIATE PRINT PARAMETERS
  
**        MOVE CONTROL CARD IMAGE TO TEMPLET FOR OUTPUT ON THIRD LINE 
  
          SB3    8-1
          SA2    RA.CCD 
          LX6    X2 
          SA6    O.CC+1 
  
 FTN.1    SA2    A2+1 
          ZR     X2,FTN.2    IF ZERO WORD 
          LX6    X2 
          SB3    B3-B1
          SA6    A6+1 
          NZ     B3,FTN.1    IF NOT EIGHT WORDS 
  
 FTN.2    MX0    9*CHAR 
          BX2    -X0*X6 
          ZR     X2,FTN.3    IF AT LEAST ONE ZERO BYTE
          MX6    0
          SA6    A6+1 
  
 FTN.3    SX7    A6 
          SA7    NXA         LWA OF LAST STORE IN CONTROL CARD TEMPLET
  
          SX1    KEYS        PARAMETER TABLE FWA
          SX2    Z.KEYS      PARAMETER TABLE LENGTH 
          BX5    0           STANDARD FIRST PARAMETER PROCESSOR 
          MX6    0           STANDARD ERROR PROCESSING
          SX7    0           STANDARD CONTINUATION PROCESSING 
          RJ     PAC         PROCESS ARGUMENTS FROM CONTROL STATEMENT 
  
**        BLANK FILL LAST WORD OF CONTROL CARD IN TEMPLET 
  
          SA2    NXA         LWA OF LAST STORE IN CONTROL CARD TEMPLET
          SA3    X2 
          SB4    60-6+1 
          MX6    -1 
          IX4    X3+X6
          SA2    =40404040404040404040B 
          SA1    =10H 
          BX6    -X4+X3 
          BX4    X6*X2
          LX6    X4,B4
          IX2    X4-X6
          BX6    X4+X2
          BX1    -X6*X1 
          IX6    X3+X1
          SA6    A3 
          SA1    CO.OPT 
          SB3    X1-4 
          PL     B3,E.OPT    IF OPT .GT. 3
  
 FTN1     RJ     CFL         CHECK FIELD LENGTH 
          RJ     MIB         MISCELLANEOUS INITIALIZATION, PART B 
          RJ     CPV         UPDATE CURRENT VALUES OF SELECTED CONTROL
                             CARD PARAMETERS
          SA1    FTNOVM      OVERLAY MODE FLAG
          NZ     X1,LDPRI    EXIT TO LOAD PRIMARY OVERLAY...
  
  
**        FOR OPT=0 A COPY OF THE (1,0) EXISTS ON THE (0,0) 
*         OVERLAY.  THEREFORE NO OVERLAY LOAD NEED BE DONE. 
  
          IFEQ   .SPY,ON,1   IF USING SPY 
          CALL   ONSPY       TURN ON PP PROGRAM SPY 
  
          RJ     GOI         GLOBAL OVERLAY INITIALIZATION (QCG ONLY) 
  
*         CHECK FOR IDP BREAK REQUEST.
* 
*         LINK *FRONT END* IDP USER KEYWORD TABLE.
  
 .TEST    IFEQ   TEST,ON     IF TEST MODE 
 #OS      IFNE   .OS,2
          SX6    UKT=FE      FWA OF *FRONT END* IDP KEYWORD TABLE 
          SA6    UKT=LNK
          SX6    =YUSY=FE    (X6) = ADDR OF IDP SYMBOL SEARCH SUBR
          SA6    IDP=USY
          CALL   IDPCHK 
          PL     B7,FTN2     IF IDP NOT REQUESTED 
 FTN00    BREAK 
 FTN2     BSS    0
 #OS      ENDIF 
 .TEST    ENDIF 
  
          EQ     PUC         EXIT TO PROGRAM UNIT CONTROLLER... 
  
 FTNOVM   BSS    1           OVERLAY MODE 
*CALL     COMCPAC            PROCESS ARGUMENTS FROM CONTROL STATEMENT 
 KEYS     TITLE  CONTROL STATEMENT PARAMETER TABLE
 KEYS     SPACE  4,10 
**        KEYS - CONTROL CARD PARAMETER KEYWORD DEFINITIONS.
  
  
 LFN      MICRO  1,, AT=2 
 DECIMAL  MICRO  1,, AT=3 
 OCTAL    MICRO  1,, AT=4 
 SWITCH   MICRO  1,, SD=-1
 MBV      MICRO  1,, MBV=/MBV/
 CO       MICRO  1,, POA==XCO.
 SPECIAL  MICRO  1,, POA=-PAC=
 IGNORE   MICRO  1,, POA=IGNORE 
  
 KEYS     BSS                START OF PARAMETER KEYWORD TABLE 
          QUAL   KEYS 
  
 AL       PARAM  "CO"AL,"SWITCH"
 ANSI     PARAM  "CO"ANSI,SD=(=1RT),AT=1
 ARG      PARAM  "MBV"ARG,NOP=2 
 B        PARAM  "CO"B,SD=(=3LBIN),"LFN"
 BL       PARAM  POA=CP.BLF,"SWITCH"
 CS       PARAM  "CO"CS,SD=(=5LFIXED) 
 DB       PARAM  "MBV"DB,NOP=7
 DO       PARAM  "MBV"DO,NOP=2
 DS       PARAM  "CO"DS,"SWITCH"
 EC       PARAM  "CO"EC,"SWITCH"
 E        PARAM  "CO"E,SD=(=4LERRS),"LFN" 
 EL       PARAM  "CO"EL,SD=(=1RF),AT=1
 ET       PARAM  "CO"ET,SD=(=1RF),AT=1
 G        PARAM  "SPECIAL"G,SD=(=7LSYSTEXT) 
 GO       PARAM  "CO"GO,"SWITCH"
 I        PARAM  "CO"I,SD=(=7LCOMPILE),"LFN"
  
          IFEQ   TEST,ON,2
 L        PARAM  "CO"L,SD=(=7LZZZZZVO),"LFN"
          SKIP   1
 L        PARAM  "CO"L,SD=(=4LLIST),"LFN" 
  
 LCM      PARAM  "CO"LCM,SD=(=1RI),AT=1 
 PL       PARAM  "CO"LL,SD=(=50000),"DECIMAL" 
 LO       PARAM  "MBV"LO,NOP=5
 MD       PARAM  "CO"MD,SD=(=1RT),AT=1
 ML       PARAM  POA=CP.MODL,SD=CP.MODL,AT=STRING,NOP=9 
 OPT      PARAM  "CO"OPT,SD=(=2),"DECIMAL"
 PC       PARAM  POA=CP.PCOM,SD=CP.PCOM,AT=STRING,NOP=30
 PD       PARAM  "CO"PD,SD=(=8),"DECIMAL" 
 PN       PARAM  POA=CP.PAGE,"SWITCH" 
 PS       PARAM  "CO"PS,"DECIMAL" 
 PW       PARAM  "CO"PW,SD=(=72),"DECIMAL"
 QC       PARAM  "CO"QC,"SWITCH"
 REW      PARAM  "MBV"REW,NOP=4 
 ROUND    PARAM  "MBV"ROUND,NOP=4 
 S        PARAM  "SPECIAL"S,SD=(=7LSYSTEXT) 
 SEQ      PARAM  "CO"SEQ,"SWITCH" 
 STATIC   PARAM  "CO"STAT,"SWITCH"
          IFEQ   .MI,1,1
 TM       PARAM  "MBV"TM,NOP=1
 X        PARAM  POA=CP.XTXT,SD=(=3LOPL),"LFN"
  
*         TEST MODE ONLY KEYWORDS.
  
 .TEST    IFEQ   TEST,ON     IF TEST MODE 
          IFNE   .OS,2,1     IF NOT SCOPE 2 
 BREAK    PARAM  "CO"BRK,SD=(=1)
 CPL      PARAM  "CO"CPL,SD=(=999),"DECIMAL"
 IDP      PARAM  "SPECIAL"IDP,SD=(=1) 
 RFL      PARAM  "CO"RFL,SD=(=0),"OCTAL"
 SNAP     PARAM  "SPECIAL"SNAP,SD=(=1)
 SPP      PARAM  "CO"SPP,"SWITCH" 
  
** FV            REMOVE FOR RELEASE.
 .TEST    ELSE               **** FOR SVL ONLY **** 
 CPL      PARAM  "IGNORE",SD=(=999),"DECIMAL" 
 .TEST    ENDIF 
  
          IFEQ   .SPY,ON,2   IF USING SPY OPTION
          IFNE   .OS,2,1     IF NOT SCOPE 2 
 SPY      PARAM  "CO"SPY,SD=SD.SPY,AT=(4,4),NOP=2 
  
          QUAL   *
 Z.KEYS   EQU    *-KEYS      LENGTH OF KEYWORD TABLE
  
          PURGMAC PARAM 
 MBVOPS   SPACE  4,10 
**        MULTIPLE BINARY VALUE OPTION DESCRIPTIONS.
  
  
          QUAL   MBV
  
 ARG      BSS 
 COMMON   MBVOP  CO.ARGC,OFF,"IV.ARGC"
 FIXED    MBVOP  CO.ARGF,ON,"IV.ARGF" 
  
 DB       BSS 
 ER       MBVOP  CO.DBER,ON,"IV.DBER0"
 ID       MBVOP  CO.DBID,OFF,"IV.DBID"
 PMD      MBVOP  CO.DBPM,ON,"IV.DBPM" 
 SB       MBVOP  CO.DBSB,ON,"IV.DBSB" 
 SL       MBVOP  CO.DBSL,ON,"IV.DBSL" 
 ST       MBVOP  CO.DBST,OFF,"IV.DBST"
 TB       MBVOP  CO.DBTB,ON,"IV.DBTB" 
  
 DO       BSS 
 LONG     MBVOP  CO.DOLG,OFF,"IV.DOLG"
 OT       MBVOP  CO.DOOT,ON,"IV.DOOT" 
  
 LO       BSS 
 A        MBVOP  CO.LOA,ON,"IV.LOA" 
 M        MBVOP  CO.LOM,OFF,"IV.LOM"
 O        MBVOP  CO.LOO,OFF,"IV.LOO"
 R        MBVOP  CO.LOR,ON,"IV.LOR" 
 S        MBVOP  CO.LOS,ON,"IV.LOS" 
  
 REW      BSS 
 B        MBVOP  CO.REWB,ON,"IV.REWB" 
 E        MBVOP  CO.REWE,OFF,"IV.REWE"
 I        MBVOP  CO.REWI,ON,"IV.REWI" 
 L        MBVOP  CO.REWL,OFF,"IV.REWL"
  
 ROUND    BSS 
 A        MBVOP  CO.RNDA,ON,"IV.RNDA" 
 S        MBVOP  CO.RNDS,ON,"IV.RNDS" 
 M        MBVOP  CO.RNDM,ON,"IV.RNDM" 
 D        MBVOP  CO.RNDD,ON,"IV.RNDD" 
  
          IFEQ   .MI,1,2
 TM       BSS 
 LCM      MBVOP  =XCO.TMLC,OFF,"IV.TMLC"
  
          QUAL   *
          PURGMAC MBVOP 
 SPECIAL  TITLE  PROCESS SPECIAL ARGUMENTS
 ARGDEFS  SPACE  4,10 
**        VARIOUS CELLS/VALUES NEEDED BY THE ARGUMENT PROCESSORS. 
  
          IFC    NE,/"SV.B"/0/,2
 CO.B     CON    0L"SV.B"    LGO FILE NAME
          SKIP   1
 CO.B     CON    0           (NO LGO FILE)
  
 CO.E     CON    0L"SV.E"    ERROR FILE NAME
 CO.I     CON    0L"SV.I"    INPUT FILE NAME
  
          IFC    NE,/"SV.L"/0/,2
 CO.L     CON    0L"SV.L"    LISTING FILE NAME
          SKIP   1
 CO.L     CON    0
 CO.PD    CON    0
  
 .SPY     IFEQ   .SPY,ON     IF SPY OPTION
 CO.SPY   DATA   -1,-1       SPY LOW, HIGH
 SD.SPY   CON    RA.ORG      LOWER LIMIT
          CON    FIN.OL      UPPER LIMIT
 Z.BINS   =      2046B       NUMBER OF SPY BINS 
 .SPY     ENDIF 
  
 IGNORE   BSS    1           GENERAL WASTE CELL 
  
 WARN     CON    8L WARNING 
  
 GP.PAGE  BSS    0           PRINT PARAMETER BLOCK
 GP.JPD   BSSZ   1           JOB DEFAULT PD 
 GP.JPS   BSSZ   1                       PS 
 GP.JPW   BSSZ   1                       PW 
  
 Z.TXTS   EQU    7           NUMBER OF S AND G TEXTS ALLOWED
 PAC=G    SPACE  4,10 
**        PROCESS G PARAMETER.
* 
*         1.  G 
*         2.  G=0 
*         3.  G=ST1/.../STN 
*               WHERE ST(I) IS EITHER *LFN* OR *LFN-OVL1...-OVLN* 
  
  
 PAC=G    BSS 
          SA1    X1          DEFAULT LFN
          MX6    0           DEFAULT OVL NAME = NONE
          BX7    X1 
          NZ     X3,PACG3    IF NO =
          SX0    B1          .GT. 10 CHAR NOT ALLOWED 
          RJ     GNA         GET NEXT ITEM
          SB7    B0 
          NZ     X6,PACG1A   IF NOT FOLLOWED BY SEP. OR TERM. 
          EQ     B4,B1,PAC.RET     IF G=, 
          EQ     PACG1A 
 PACG1    SX0    B1          DO NOT ALLOW .GT. 10 CHARACTERS
          RJ     GNA         GET FILE NAME
          ZR     X6,E.IGS    IF NO LFN
  
 PACG1A   BX1    X6 
          RJ     CFV         CHECK FILENAME VALIDITY
          NZ     X4,E.IGS    IF ILLEGAL FILE NAME 
          BX7    X6          LFN
          SB7    /COMCPAC/O.MINUS 
          MX6    0           OVL
          NE     B7,B4,PACG3 IF NO *-*
          ZR     X7,E.IGS    IF ILLEGAL SYNTAX
 PACG2    SX0    B1          DO NOT ALLOW .GT. 10 CHARACTERS
          RJ     GNA         GET OVERLAY NAME 
 PACG3    ZR     X7,PACG4    IF G=0, IGNORE 
          SX2    B1 
          BX6    X6+X2       SET *G* FLAG 
          SA2    CP.STXT     COUNT OF TEXTS 
          SB6    X2-Z.TXTS
          SB7    X2+B1
          ZR     B6,E.S7     IF MORE THAN 7 TEXTS SPECIFIED 
          SA6    A2+B7       STORE OVERLAY NAME 
          SA7    CP.LIB+B7   STORE FILE NAME
          SX6    B7 
          SA6    A2          UPDATE COUNT 
 PACG4    SB7    /COMCPAC/O.MINUS 
          EQ     B7,B4,PACG2 IF *-* IS NEXT 
          SB7    /COMCPAC/O.SLASH 
          EQ     B7,B4,PACG1 IF */* IS NEXT 
          SB7    B0 
          EQ     PAC.RET     RETURN TO MAIN LOOP... 
 PAC=IDP  SPACE  4,10 
**        PROCESS IDP OPTION (TEST MODE ONLY).
  
  
 .TEST    IFEQ   TEST,ON     IF TEST MODE 
 PAC=IDP  SA1    X1 
          BX6    X1          GET DEFAULT
          NZ     X3,PACIDP2  IF NO =
          BX6    0
          MX7    1
 PACIDP1  RJ     GNC         GET NEXT CHARACTER 
          NZ     B4,PACIDP3  IF SEPARATOR 
          SB7    X4-60
          AX3    X7,B7       SET BIT 2**(59-CHARACTER)
          BX6    X6+X3
          EQ     PACIDP1
  
 PACIDP2  LX6    59-0 
 PACIDP3  SA6    CO.IDP 
          SB7    B0 
          EQ     PAC.RET     RETURN MAIN LOOP...
 .TEST    ENDIF 
 PAC=S    SPACE  4,10 
**        PROCESS S PARAMETER.
* 
*         1.  S 
*         2.  S=0 
*         3.  S=ST1/.../STN 
*               WHERE ST(I) IS EITHER *OVL* OR *LIB-OVL1...-OVLN* 
  
  
 PAC=S    BSS 
          SA1    X1          DEFAULT OVL
          MX7    0           DEFAULT LIB = NONE 
          BX6    X1 
          NZ     X3,PACS3    IF NO *=*
          SX0    B1          .GT. 10 CHAR NOT ALLOWED 
          RJ     GNA         GET NEXT ITEM
          SB7    B0 
          NZ     X6,PACS1A   IF NOT FOLLOWD BY SEP. OR TERM.
          EQ     B4,B1,PAC.RET     IF S=, 
          EQ     PACS1A 
  
 PACS1    SX0    B1          .GT. 10 CHAR NOT ALLOWED 
          RJ     GNA         GET LIB OR OVL NAME
          ZR     X6,E.ISS    IF NULL OPTION 
  
 PACS1A   BX1    X6 
          RJ     CFV         CHECK FILENAME VALIDITY
          NZ     X4,E.ISS    IF ILLEGAL FILE NAME 
          SX7    0           DEFAULT = NO LIB 
          SB7    /COMCPAC/O.MINUS 
          NE     B7,B4,PACS3 IF NO *-*
          ZR     X6,E.ISS    IF NO LIB (S=-OVL) 
          BX7    X6          SET LIB NAME 
  
 PACS2    SX0    B1          .GT. 10 CHAR NOT ALLOWED 
          RJ     GNA         GET OVL NAME 
  
 PACS3    NZ     X6,PACS4    IF NOT S=0 
          SA6    CP.LIB      SET S=0 FLAG 
          EQ     PACS5       CONTINUE 
  
 PACS4    SA2    CP.STXT
          SB6    X2-Z.TXTS
          SB7    X2+B1
          ZR     B6,E.S7     IF MORE THAN 7 TEXTS SPECIFIED 
          SA6    A2+B7       STORE OVERLAY NAME 
          SA7    CP.LIB+B7   STORE LIB NAME 
          SX6    B7 
          SA6    A2          UPDATE COUNT 
  
 PACS5    SB7    /COMCPAC/O.MINUS 
          EQ     B7,B4,PACS2 IF *-* IS NEXT 
          SB7    /COMCPAC/O.SLASH 
          EQ     B7,B4,PACS1 IF */* IS NEXT 
          SB7    B0 
          EQ     PAC.RET     RETURN TO MAIN LOOP... 
 PAC=SNAP SPACE  4,10 
**        PROCESS SNAP OPTION (TEST MODE ONLY). 
  
 .TEST    IFEQ   TEST,ON     IF TEST MODE 
 PAC=SNAP BSS 
          SA1    X1 
          BX6    X1          GET DEFAULT
          NZ     X3,PACSNP2  IF NO =
          BX6    0
          MX7    1
 PACSNP1  RJ     GNC         GET NEXT CHARACTER 
          NZ     B4,PACSNP3  IF SEPARATOR 
          SB7    X4-60
          AX3    X7,B7       SET BIT 2**(59-CHARACTER)
          BX6    X6+X3
          EQ     PACSNP1
  
 PACSNP2  LX6    59-0 
 PACSNP3  SA6    CO.SNAP
          SB7    B0 
          EQ     PAC.RET     RETURN MAIN LOOP...
 .TEST    ENDIF 
 CSERRS   TITLE  CONTROL STATEMENT ERRORS 
*         ERROR MESSAGES. 
  
  
 E.ANSI   CSERR  (ANSI MUST BE 0, T OR F) 
          EQ     MIB4        CONTINUE INITIALIZATION
  
 E.ARG    SA6    ERR.FLD
          CSERR  (ARG CANT BE BOTH COMMON AND FIXED)
          EQ     MIB7 
  
 E.BGO    SA6    ERR.FLD
          CSERR  (B=0 AND GO IS INCONSISTENT) 
          EQ     MIB35
  
 E.CS     SA6    ERR.FLD
          CSERR  (CS MUST BE USER OR FIXED) 
          SX6    1
          EQ     MIB55
  
 E.ID     MX6    0
          SA6    ERR.FLD
          CSERR  (INTERACTIVE DEBUG REQUIRES OPT=0) 
          EQ     MIB100 
  
 E.EF     CSERR  (E=0 IS ILLEGAL) 
          EQ     MIB125 
  
          IFEQ   TEST,ON,2
 E.EL     CSERR  (EL MUST BE D, T, W, F, OR C)
          SKIP   1
 E.EL     CSERR  (EL MUST BE T, W, F, OR C) 
          EQ     MIB2        CONTINUE INITIALIZATION
  
 E.ET     CSERR  (ET MUST BE 0, T, W, F, OR C)
          EQ     MIB22       CONTINUE INITIALIZATION
  
 E.LFNC   CSERR  (FILE USE CONFLICT)
          EQ     MIB125 
  
  
 E.IZ     CSERR  (I=0 IS NOT ALLOWED) 
          EQ     MIB125 
  
 E.XZ     CSERR  (X=0 IS NOT ALLOWED) 
          EQ     MIB125 
  
 E.IGS    SX6    0
          SA6    ERR.FLD
          CSERR  (ILLEGAL G OPTION SYNTAX)
          EQ     PAC.RET
  
 E.ISS    SX6    0
          SA6    ERR.FLD
          CSERR  (ILLEGAL S OPTION SYNTAX)
          EQ     PAC.RET
  
 E.LCM    CSERR  (LCM OPTION MUST BE G, I OR D) 
          EQ     MIB53
  
 E.MD     CSERR  (MD MUST BE 0, T OR F) 
          EQ     MIB10
  
 E.OPT    =X6    2
          SA6    A1          RESET CO.OPT TO OPT=2
          SX6    0
          SA6    ERR.FLD
          CSERR  (OPT LEVEL NOT 0,1,2, OR 3)
          EQ     FTN1 
  
 E.PD     SA6    ERR.FLD
          CSERR  (PD ARGUMENT NOT 6 OR 8) 
          EQ     MIB72
  
 E.PL     SX6    0
          SA6    ERR.FLD
          CSERR  (PL MUST NOT EXCEED 999999999) 
          EQ     MIB80
  
 E.PS     SA1    WARN 
          BX6    X1 
          SA6    ERR.FLD     ADD WARN MESSAGE 
          CSERR  (PAGE SIZE RANGE .GT. 3) 
          SX6    0
          SA6    ERR.FLD
          SA1    ERR.CNT
          SX6    X1-1 
          SA6    A1          DONT COUNT IT
          SX6    4           SET TO LOW LIMIT 
          EQ     MIB75
  
 E.PW     SB2    X6          SAVE FILE ORDINAL
          SB3    X1          NEG. IF VALUE TO LOW 
          SA1    WARN 
          BX6    X1 
          SA6    ERR.FLD
          CSERR  (PAGE WIDTH RANGE 50 - 136)
          SA1    ERR.CNT
          SX6    X1-1 
          SA6    A1 
          SX6    B2 
          SX2    50          LOW LIMIT OF WIDTH 
          MI     B3,PPW60.1  IF TOO LOW 
          SX2    136         SET TO HIGH LIMIT
          EQ     PPW60.1
  
 E.S7     SX6    0
          SA6    ERR.FLD
          CSERR  (ONLY 7 SYSTEMS TEXTS ALLOWED) 
          EQ     PAC.RET
          PURGMAC CSERR 
 SUBRS    TITLE  COMPILER INITIALIZATION SUBROUTINES
 CFL      SPACE  4,10 
**        CFL - CHECK FIELD LENGTH. 
* 
*         COMPARES CURRENT FIELD LENGTH VS. MINIMUM FIELD LENGTH. 
*         EXITS IF CURRENT FL IS ABOVE MINIMUM. OTHERWISE, REQUESTS 
*         FIELD LENGTH EQUAL TO THE NOMINAL FIELD LENGTH FOR THIS MODE
*         (I.E. OPT=0,1,2) OR THE MAXIMUM FOR THIS JOB STEP - WHICHEVER 
*         IS SMALLER. 
* 
*         ENTRY  (CP.AFLS) = CURRENT FL.
* 
*         EXITS  NORMAL--    RETURNS TO CALLER VIA ENTRY POINT. 
*                            (CP.AFLS) = NEW CURRENT FL.
*                            (CP.NFLS) = (CP.AFLS)-10 
*                            (CP.MXFL) = (CP.AFLS)
* 
*                ERROR--     ABORTS JOB.
* 
*         USES   ALL
* 
*         CALLS  ABTFTN, COD, DXB, MEMORY, MESSAGE
  
  
 CFL      SUBR               ...ENTRY/EXIT... 
  
          MEMORY SCM,MAX.FL,RCL    GET MAXIMUM FL 
          SA1    CP.AFLS
          SB6    X1          INITIAL FL 
          SX6    B6 
  
*         IF TEST MODE - SUBSTITUTE RFL VALUE IF REQUESTED. 
  
 .TEST    IFEQ   TEST,ON     IF TEST MODE 
          SA5    CO.RFL 
          ZR     X5,CFL5     IF NO RFL ON CONTROL STATEMENT 
          SB7    0           ASSUME OCTAL FOR DXB 
          CALL   DXB         CONVERT REQUESTED FL 
          ZR     X6,CFL3     IF DEFAULT RFL 
          SB6    X6          NEW FL 
 .TEST    ENDIF 
  
 CFL3     SA1    MAX.FL 
          AX1    30 
          SB7    X1 
          SX6    B7-B6
          MI     X6,MEMERR   IF NOT ENOUGH MEMORY 
          SX6    B6 
  
*         REQUEST MORE MEMORY.
  
          LX6    30 
          SA6    GT1
          MEMORY SCM,GT1,RCL
          SA1    GT1           GET NEW FL 
          AX1    30 
          BX6    X1 
  
*         UPDATE FIELD LENGTH CELLS.
  
 CFL5     SX7    X6-FLSZ     LEAVE 10 WORD SAFETY ZONE
          SA7    CP.NFLS     UPDATE TO CURRENT UNRESERVED FL
          SA6    CP.AFLS     UPDATE TO CURRENT FL 
          SA6    CP.MXFL     INITIALIZE MAX FL USED 
  
*         CHECK LCM AVAILABILITY. 
  
          SA1    CO.EC
          ZR     X1,EXIT.    IF NO OPT=2 LCM REQUIRED 
          MX6    29          (-1, BITS 50-30) 
          SA6    GT1         MEMORY REQUEST WORD
          MEMORY LCM,GT1,RCL
          SA1    GT1
          AX1    30 
          BX6    X1 
          NZ     X1,EXIT.    IF LCM AVAILABLE 
          SA6    CO.EC       OTHERWISE, TURN OFF
          EQ     EXIT.       EXIT...
 CFN      SPACE  4,10 
**        CFN - CHANGE FILE NAME. 
* 
*         CHANGES OR CLEARS ENTRY IN THE FILE VECTOR TABLE .
*         EXITS WITHOUT ACTION IF THE VECTOR TABLE ENTRY IS ZERO. 
* 
*         (CIO I/O) - CHANGES OR CLEARS FILE NAME IN FET. 
*         FOR A NAME CHANGE, THE EXISTING FET FILE MODE BIT IS RETAINED 
*         AND THE CIO COMPLETE BIT IS SET.
*         FOR A NAME CLEAR, FET WORD 1 IS CLEARED TO ZERO.
* 
*         (7RM I/O) - CHANGES OR CLEARS FILE NAME IN FIT. 
* 
*         ENTRY  (X2) = FILE VECTOR TABLE ENTRY 
*                (A2) = ADDRESS OF (X2) ENTRY 
*                (X6) = NEW NAME, MAX 7 CHARACTERS, LEFT ADJUSTED 
*                       ACTION REQUEST -- 
*                       .ZR. = CLEAR ENTRY
*                       .NZ. = CHANGE NAME; KEEP PREVIOUS FET/FIT ADDR
* 
*         USES   B - 6
*                A - 1, 3, 6, 7 
*                X - 1, 3, 6, 7 
* 
*         CALLS  STORE (7RM I/O ONLY) 
  
  
 CFN      SUBR               ...ENTRY/EXIT... 
          ZR     X2,EXIT.    IF EMPTY TABLE ENTRY, DONE...
          MX7    0
          SX3    X2          FET/FIT ADDRESS
          ZR     X6,CFN2     IF CLEARING NAME 
          IX7    X6+X3       42/NEW NAME, 18/FET OR FIT ADDRESS 
 CFN2     SA7    A2          UPDATE TABLE 
  
 .RM      IFEQ   CP#RM,0     IF CIO I/O 
          ZR     X6,CFN3     IF NAME TO BE CLEARED
          SA3    X2          (X3) = FET WORD 1
          SX7    2
          BX3    X7*X3       EXTRACT FILE MODE BIT
          SX7    X3+1        TURN CIO COMPLETE BIT ON 
          IX6    X6+X7       42/NEW FILE NAME,16/0,1/OLD MODE BIT,1/1 
 CFN3     SA6    X2          UPDATE FET WORD 1
  
 .RM      ELSE               IF 7RM I/O 
  
          SA1    A5          SAVE (A5) AND (X5) 
          BX3    X5 
          SB6    B5          SAVE (B5)
          STORE  X2,LFN=X6   NEW NAME TO FIT
          SA5    A1          RESTORE (A5) AND (X5)
          BX5    X3 
          SB5    B6          RESTORE (B5) 
 .RM      ENDIF 
  
          EQ     EXIT.       DONE...
 MIA      SPACE  4,10 
**        MIA - MISCELLANEOUS INITIALIZATION, PART A. 
* 
*         ENTRY  (X0) = ECS/LCM FIELD LENGTH
*                (A0) = CM /SCM FIELD LENGTH
*                (B1) = 1 
* 
*         EXIT   (B1) = 1 
* 
*         USES   X - 0, 1, 6, 7 
*                A - 1, 6, 7
*                B - 2, 3 
* 
*         CALLS  TIMER, DATE, CLOCK 
  
  
 MIA      SUBR               ...ENTRY/EXIT... 
  
**        SAVE HHA
  
          SA1    RA.ORG+4    FWA 5400 TABLE + 4 (HHA) 
          MX6    -18
          BX6    -X6*X1      X6 = HHA 
          SA6    FTNHHA 
  
**        SAVE FIELD LENGTHS. 
  
          SX6    A0          CM/SCM FIELD LENGTH
          BX7    X0          ECS/LCM FIELD LENGTH 
          SA6    CP.AFLS
          SA7    CP.AFLL     SAVE FOR *COMPASS* 
          SA6    CP.NFLS
          SA7    CP.NFLL     SAVE FOR *COMPASS* 
          SA7    CP.ILFL
          NO
          LX6    30 
          SA6    FTIFL       SAVE FOR EXIT RESTORATION
  
  
**        OBTAIN CURRENT SENSE SWITCH VALUES (CYBER 76/ 7600 ONLY.) 
  
 .OS      IFEQ   .OS,2       IF SCOPE 2 
          SSW                UPDATE RA.SSW
 .OS      ENDIF 
  
  
**        IF SWITCH 5 IS SET - CALL IDP 
  
 .TEST    IFEQ   TEST,ON     IF TEST MODE 
          SA1    RA.SSW 
          LX1    59-5-5 
          PL     X1,MIA2     IF SWITCH 5 IS OFF 
  
 #OS      IFNE   .OS,2,1
 INIT00   BREAK 
  
 MIA2     BSS    0
          LX1    10-5-6 
          MI     X1,MIA4     IF SWITCH 6 ON, SKIP *RPV* REQUEST 
 .TEST    ENDIF 
  
          RPVON              TURN ON REPRIEVE 
 MIA4     BSS    0
  
  
**        INSERT DATE AND TIME IN HEADER LINE 
  
          DATE   TL.DATE
          CLOCK  TL.TIME
  
*         INSERT DATE AND TIME IN ERR-LIST HEADER.
  
          SA1    TL.DATE
          SA2    TL.TIME
          BX6    X1 
          LX7    X2 
          SA6    A1+ERFO
          SA6    A2+ERFO
  
  
**        SAVE CPU START TIME.
  
          CALL   TIMER
          SA6    TIME0       SAVE COMPILATION START TIME
  
  
**        CHANGE NAME OF FTN OVERLAY LIBRARY IF (0,0) OVERLAY LOADED
*         FROM A NON-STANDARD LIBRARY OR FILE.
  
          SA1    RA.LWP      (X1) = LOADER REPLY WORD 
          SA2    RA.PGN      (X2) = ACTUAL LIBRARY NAME 
          LX1    59-18       LIBRARY FLAG TO B59
          MX6    42 
          MI     X1,MIA6     IF FTN LOADED FROM LIBRARY FILE
          SX7    2040B       CLEAR LIBRARY BIT
          LX7    36 
          SA7    FTNLDR      RESET LOAD REQUEST WORD
 MIA6     SA3    =0L"FTNMAIN"      (X3) = STANDARD SYSTEM LIBRARY NAME
          BX6    X6*X2
          IX2    X6-X3
          ZR     X2,MIA8     IF USER DID NOT CHANGE NAME
          SA6    FTNLFN      SAVE FOR *LOVER* CALLS 
 MIA8     BSS    0
  
  
**        MOVE FILE VECTOR TABLE TO JOB COMMUNICATIONS AREA, BEGINNING
*         AT *RA.ARG*.
  
          MOVE   FVLEN,FVTBL,RA.ARG 
  
  
**        DEFAULT (CO.DBID) = VALUE OF SYSTEM GLOBAL DEBUG SWITCH.
  
 #FID     IFEQ   .FID,ON
          GETLC  CO.DBID
          SA1    CO.DBID
          MX7    1
          HX1    DC.FID      EXTRACT VALUE OF SWITCH
          BX6    X7*X1
          SA6    A1 
 #FID     ENDIF 
  
  
**        OBTAIN  JOB ORIGIN TYPE FROM BITS 24-35 OF RA+66.  IF VALUE IS
*         0, 1, OR 2, JOT IS TYPE BATCH.  IF GREATER, JOT IS TYPE 
*         TERMINAL. 
  
          SA1    RA.JOT 
          MX0    -12
          AX1    24          RIGHT JUSTIFY JOT
          BX1    -X0*X1      ISOLATE THAT FIELD 
          MX7    0
          SX1    X1-3 
          MI     X1,MIA10    IF JOT LESS THAN 3 (BATCH) 
          SX7    1           JOT FOR TERMINAL JOB 
 MIA10    SA7    JOT         STORE JOB ORIGIN TYPE
          EQ     EXIT.       DONE...
 MIB      SPACE  4,10 
**        MIB - MISCELLANEOUS INITIALIZATION, PART B. 
* 
*         ENTRY  (B1) = 1 
* 
*         EXIT   (B1) = 1 
* 
*         USES   ALL
  
  
 MIB      SUBR               ...ENTRY/EXIT... 
  
**        SET A FLAG THAT INDICATES WHETHER OR NOT THE OBJECT TIME
*         MACHINE WILL HAVE LCM. (ONLY IF .MI = 1)
  
 #MI      IFEQ   .MI,1
          MX6    0
          SA6    MIBA        (*GETMC* EXPECTS CELL TO CONTAIN ZERO) 
          GETMC  MIBA        GET MACHINE CHARACTERISTICS
          SA2    MIBA 
          HX2    MC.800 
          MX6    -3*CHAR
          PL     X2,MIB.5    IF NOT 800-SERIES MODEL
          SX3    3R800       CHANGE TITLE LINE TO INDICATE
          BX3    -X6*X3       TARGET MACHINE OF 800-SERIES
          LX6    2*CHAR 
          SA1    TL.CPU      *  70/176  * 
          BX6    X6*X1
          LX3    2*CHAR 
          BX6    X6+X3
          SA6    A1 
  
 MIB.5    SA1    CO.TMLC
          ZR     X1,MIB0     IF TM= OR TM OR TM=-LCM APPEARED 
          MI     X1,MIB0     IF TM=LCM APPEARED ON CONTROL CARD 
          SA2    MIBA 
          MX0    -MC.176L-1  MASK SIZE OF (MC.176L + 1) 
          LX0    MC.176P
          BX6    -X0*X2      NZ IF EITHER 176 OR 800-SERIES 
          SA6    A1 
 #MI      ENDIF 
  
**        PROCESS EL OPTION.  TRANSFORM EL= T, W, F OR C INTO NUMERIC 
*         VALUES. 
  
 MIB0     SA1    CO.EL       ERROR LEVEL (ALPHABETIC) 
          BX7    X1 
          LX7    -CHAR
          SA7    ERR.FLD     FOR POSSIBLE DIAGNOSTIC
          SX6    EL=C 
          SX3    X1-1RC 
          ZR     X3,MIB1     IF EL=CATISTROPHIC 
          =X6    X6-EL=C+EL=F 
          SX3    X1-1RF 
          ZR     X3,MIB1     IF EL=FATAL
          =X6    X6-EL=F+EL=W 
          SX3    X1-1RW 
          ZR     X3,MIB1     IF EL=WARNING
          =X6    X6-EL=W+EL=T 
          SX3    X1-1RT 
  
 .T       IFEQ   TEST,ON
          ZR     X3,MIB1     IF EL=TRIVIAL
          =X6    X6-EL=T+EL=D 
          SX3    X1-1RD 
 .T       ENDIF 
  
          NZ     X3,E.EL     IF EL= IS IN ERROR 
  
 MIB1     SA6    A1          RESET CO.EL WITH NUMERIC TRANSFORMATION
  
**        PROCESS ANSI OPTION.  TRANSFORM ANSI= 0, T OR F INTO NUMERIC
*         VALUES. 
  
 MIB2     SA1    CO.ANSI     ANSI OPTION (ALPHANUMERIC) 
          BX7    X1 
          LX7    -CHAR
          SA7    ERR.FLD     FOR POSSIBLE DIAGNOSTIC
          =X6    OFF
          SX3    X1-1R0 
          ZR     X3,MIB3     IF ANSI=0 (OFF)
          =X6    EL=T 
          SX3    X1-1RT 
          ZR     X3,MIB3     IF ANSI=T
          =X6    EL=F 
          SX3    X1-1RF 
          NZ     X3,E.ANSI   IF ANSI= IN ERROR
  
 MIB3     SA6    A1          RESET CO.ANSI WITH NUMERIC TRANSFORMATION
  
**        IF QUICK CHECK (QC OPTION) SELECTED, CLEAR BINARY 
*         OUTPUT FILE NAME. 
  
 MIB4     SA1    CO.QC
          ZR     X1,MIB5     IF QC OPTION OFF 
          BX6    OFF
          SA6    CO.B        CLEAR BINARY OUTPUT FILE NAME
  
**        RESOLVE ANY CONFLICT IN ARG=COMMON/FIXED. 
  
 MIB5     SA1    CO.ARGC
          SA2    CO.ARGF
          MX6    0
          BX1    X1*X2
          NZ     X1,E.ARG    IF BOTH COMMON AND FIXED SPECIFIED 
  
**        PROCESS THE MD OPTION. TRANSFORM MD= 0, T, OR F INTO
*         NUMERIC VALUES. 
  
 MIB7     SA1    CO.MD       MD OPTION (ALPHANUMERIC) 
          BX7    X1 
          LX7    -CHAR
          SA7    ERR.FLD     FOR POSSIBLE DIAGNOSTIC
          =X6    OFF
          SX3    X1-1R0 
          ZR     X3,MIB9     IF MD = 0  (OFF) 
          =X6    EL=T 
          SX3    X1-1RT 
          ZR     X3,MIB9     IF MD = T
          =X6    EL=F 
          SX3    X1-1RF 
          NZ     X3,E.MD     IF MD= IN ERROR
  
 MIB9     SA6    A1          RESET CO.MD WITH NUMERIC TRANSFORMATION
  
**        IF L=0 TURN OFF ALL LIST OPTIONS. 
  
 MIB10    BSS 
          SA1    CO.L 
          NZ     X1,MIB12    IF L NOT 0 
          BX6    OFF
          SA6    CP.LSTF
          SA6    CO.LOA 
          SA6    CO.LOM 
          SA6    CO.LOO 
          SA6    CO.LOR 
          SA6    CO.LOS 
          EQ     MIB20
  
 MIB12    SX6    1
          SA6    CP.LSTF
  
  
**        SET OVERLAY MODE
  
 MIB20    SA1    CO.OPT 
          SA2    CO.LOO 
          SA3    CO.LOM 
          SA4    CO.LOA 
          SA5    CO.LOR 
          BX6    X1+X2
          BX6    X6+X3
          BX6    X6+X4
          BX6    X6+X5
          SA6    FTNOVM      .EQ. 0 IF SHORT MODE, .NZ. IF LONG MODE
  
  
**        PROCESS ET OPTION.  TRANSFORM ET= 0, T, W, F OR C INTO NUMERIC
*         VALUES. 
  
          SA1    CO.ET       ERROR TERMINATION (ALPHANUMERIC) 
          MX7    OFF
          =X6    OFF
          SX3    X1-1R0 
          ZR     X3,MIB21    IF ET=0 (OFF)
          BX6    X1 
          LX6    -CHAR
          SA6    ERR.FLD     FOR POSSIBLE DIAGNOSTIC
          MX7    ON 
          SX6    EL=C 
          SX3    X1-1RC 
          ZR     X3,MIB21    IF ET=CATASTROPHIC 
          SX6    X6-EL=C+EL=F 
          SX3    X1-1RF 
          ZR     X3,MIB21    IF ET=FATAL
          SX6    X6-EL=F+EL=W 
          SX3    X1-1RW 
          ZR     X3,MIB21    IF ET=WARNING
          SX6    X6-EL=W+EL=T 
          SX3    X1-1RT 
          NZ     X3,E.ET     IF ET= IS IN ERROR 
  
 MIB21    SA6    A1          RESET CO.ET WITH NUMERIC TRANSFORMATION
          LX7    59-29
          SA1    CP.ABT 
          MX3    59 
          LX3    29 
          BX1    X3*X1
          BX7    X1+X7       ADD IN ABORT FLAG
          SA7    A1 
  
**        CHANGE FILE NAMES.
  
 MIB22    BSS 
  
  
 .CFN     ECHO   ,A=(B,I,L,E),B=(LGO,IN,OUT,ERRS) 
          SA1    =XCO._A
          SA2    =XFV._B
          BX6    X1 
          RJ     CFN
 .CFN     ENDD
  
  
**        ADJUST OPT LEVEL
  
          SA2    CO.OPT 
          SX2    X2-3 
          NZ     X2,MIB30    IF OPT .NE. 3
          =X6    ON 
          SA6    CO.UO       TURN UO ON 
          =X6    2
          SA6    A2          SET OPT = 2
  
  
**        CHECK FOR B=0 AND GO SELECTION. 
  
 MIB30    BSS 
          SA2    CO.GO
          ZR     X2,MIB40    IF GO NOT SELECTED 
          SA3    FV.LGO 
          NZ     X3,MIB35    IF B SELECTED
          SX6    0
          EQ     E.BGO       B=0 AND GO IS INCONSISTENT 
  
  
**        IF AUTOMATIC EXECUTION (GO) SELECTED, MOVE THE BINARY 
*         OUTPUT FILE NAME TO THE GO FLAG CELL. 
  
 MIB35    SA2    FV.LGO 
          MX1    7*CHAR 
          BX6    X1*X2
          SA6    CO.GO       UPDATE GO NAME 
  
  
**        SET UP DB=ER OPTION.
  
 MIB40    BSS 
          SX0    2RER 
          SA1    CO.DBER
          IX2    X0-X1
          ZR     X2,MIB41    IF DB=ER NOT ON CONTROL STATEMENT
          BX6    X1 
          EQ     MIB43       SET ER OPTION
  
 MIB41    SA2    CO.OPT 
          SB7    X2+MIB42 
          JP     B7 
  
 MIB42    BSS 
+         MX6    "BV.DBER0"  OPT=0
          EQ     MIB43
+         MX6    "BV.DBER1"  OPT=1
          EQ     MIB43
+         MX6    "BV.DBER2"  OPT=2
  
 MIB43    SA6    CO.DBER
  
  
**        CONVERT LCM OPTION VALUE. (G,D,I) = (-1,0,+1) 
  
 MIB50    BSS 
          SA1    CO.LCM 
          BX7    X1 
          LX7    -CHAR
          SA7    ERR.FLD     FOR POSSIBLE DIAGNOSTIC
          SX6    1
          SX3    X1-1RI 
          ZR     X3,MIB51    IF I 
          BX6    0
          SX3    X1-1RD 
          ZR     X3,MIB51    IF D 
          SX6    -1 
          SX3    X1-1RG 
          NZ     X3,E.LCM    IF NOT G 
  
 MIB51    SA6    CO.LCM      STORE CONVERTED VALUE
          =B2    X6+1 
          MX6    ON 
          NZ     B2,MIB53    IF NOT LCM=G 
          SA6    CO.DOLG     LCM=G IMPLIES DO=LONG
  
**        CONVERT CS OPTION VALUE.  USER=1, FIXED=0.
  
 MIB53    SA1    CO.CS
          SA2    =4LUSER
          =X6    1
          IX3    X1-X2
          ZR     X3,MIB55    IF USER
          SA2    =5LFIXED 
          =X6    0
          IX3    X1-X2
          NZ     X3,E.CS     IF NOT FIXED 
  
 MIB55    SA6    CO.CS       STORE CONVERTED VALUE
  
**        TOGLE CP.PAGE BIT 59 TO KEEP COMPASS PAGINATION CONSISTENT
*         WITH FTN5 PAGINATION. 
  
 MIB70    SA4    CP.PAGE
          MX7    1
          BX7    X7-X4
          SA7    A4 
  
  
  
**        CONVERT PD AND PS OPTIONS.
  
          SA4    CO.PD
          SX1    1RS
          SX3    6
          IX2    X4-X3
          ZR     X2,MIB71    IF PD = 6
          SX1    1RT
          SX3    8
          IX2    X4-X3
          MX6    0
          ZR     X2,MIB71    IF PD = 8
          EQ     E.PD 
  
 MIB71    LX1    -CHAR
          BX6    X1 
          SA6    CP.PD
 MIB72    SA2    CO.PS
          BX6    X2 
          BX7    -X6         FOR COMPASS
          SX6    X6-3        ALLOW FOR HEADER (FTN5)
          ZR     X6,E.PS     IF PS .LT. 4 
          MI     X6,E.PS     IF PS .LT. 4 
  
 MIB75    SA6    CO.PS
          SA7    CP.PS
  
*         DIAGNOSE OUT-OF-RANGE PRINT LIMIT.
  
          SA1    CO.LL
          SA2    =999999999 
          IX6    X2-X1
          MI     X6,E.PL     IF PL GT 999999999 
  
 MIB80    BSS    0
  
**        CONVERT DO OPTION FLAGS FROM SWITCHES TO VALUES.
  
          SA1    CO.DOLG
          SA2    CO.DOOT
          LX6    X1,B1
          LX7    X2,B1
          SA6    A1 
          SA7    A2 
  
  
**        DETECT INTERACTIVE DEBUG WITHOUT OPT=0. 
  
          SA2    CO.OPT 
          ZR     X2,MIB100   IF OPT=0 
          SA2    CO.DBID
          SA3    CO.DBST
          BX3    X2+X3
          NZ     X3,E.ID     ** INTERACTIVE DEBUG REQUIRES OPT=0
  
  
**        MOVE OPT LEVEL TO TITLE LINE. 
  
 MIB100   BSS 
          SA3    TL.CSOP
          SA2    CO.OPT      OPTIMIZATION LEVEL 
          SA1    CO.UO
          ZR     X1,MIB102   IF OPT = 3 NOT SELECTED
          SX2    3
  
 MIB102   SX1    1R0
          MX0    1*CHAR 
          IX1    X1+X2
          LX0    6*CHAR 
          LX1    5*CHAR 
          BX3    -X0*X3 
          BX6    X3+X1
          SA6    TL.CSOP
          SA6    A6+ERFO     INSERT OPTIONS INTO E-LIST HEADER
  
  
**        DETERMINE PRESENT COMPUTER MODEL AND PLACE IN TITLE LINE. 
  
          MX1    1
          SB2    1S6
          AX1    B2 
          SX3    6
          MI     X1,MIB112   IF MODEL 76 / 7600 
          SX6    0220B
          SB2    MIB112 
          LX6    48 
          BX4    X6          FORM  +         JP     B2
          LX4    30                -         JP     B2
          BX6    X4+X6
+         SA6    *+1         STORE *JP B2* (BOTH UPPER AND LOWER) 
          SX3    3
+         SX3    4           EXECUTE IF MODEL 74/6600, JUMP IF 73/6400
  
 MIB112   SA1    TL.CPU        *  70/7X   * 
          LX3    6*6
          IX6    X1+X3
          SA6    A1          CURRENT CPU TYPE TO TITLE LINE 
          SA6    A6+ERFO     INSERT TYPE INTO ERROR LIST HEADER 
          SX4    2R70 
          LX4    8*CHAR 
          LX3    2*CHAR 
          IX6    X3+X4
          SA6    CP.CPU 
  
  
**        REMOVE PERIOD FROM END OF TIME IN TITLE LINE. 
  
          SA1    TL.TIME
          SX2    1R 
          MX3    9*CHAR 
          BX1    X3*X1
          BX6    X1+X2
          SA6    A1          BLANK FINAL PERIOD IN TIME 
          SA6    A6+ERFO     ALSO IN ERROR LIST HEADER
  
  
 .RM      IFEQ   CP#RM,0     IF CIO I/O 
  
  
*         IF IN SHORT OVERLAY MODE, MINIMIZE INPUT AND OUTPUT BUFFER LEN
  
          SA1    FTNOVM 
          NZ     X1,MIB120   IF LONG MODE 
          SX7    Z.INSB      INPUT BUFFER LENGTH
          SX6    Z.OUTSB     OUTPUT BUFFER LENGTH 
          LX7    18 
          LX6    18 
          SA7    F.IN+I.CBSET 
          SA6    F.OUT+I.CBSET
          SB2    IBUF+Z.INSB
          SETFIL FILE=F.OUT,MODE=INIT,FWA=B2
          SETFIL FILE=F.IN,MODE=INIT,FWA=IBUF 
 .RM      ENDIF 
  
  
*         CARVE SPACE FOR EFILE BUFFER IF EFILE .NE. LFILE. 
  
 CLFN     MACRO  LFN1,LFN2
          LOCAL  EXIT 
          SA1    CO.LFN1
          SA2    CO.LFN2
          ZR     X1,EXIT     IF LFN1 = 0
          ZR     X2,EXIT     IF LFN2 = 0
          BX1    X1-X2
          ZR     X1,E.LFNC   IF LFN1 = LFN2 
 EXIT     BSS    0
 CLFN     ENDM
  
 CO.X     EQU    CP.XTXT
  
 MIB120   BSS    0
          SX6    0
          SA6    ERR.FLD     CLEAR FOR DIAGNOSTICS
          CLFN   B,I
          CLFN   B,L
          CLFN   B,E
          CLFN   I,L
          CLFN   I,E
          CLFN   X,B
          CLFN   X,L
          CLFN   X,I
          CLFN   X,E
          SA1    CO.L 
          SA2    CO.E 
          ZR     X2,E.EF     E=0 IS ILLEGAL 
          SA3    CO.I 
          ZR     X3,E.IZ     E=0 ILLEGAL
          SA3    CP.XTXT
          ZR     X3,E.XZ     X=0 ILLEGAL
          BX1    X1-X2
          =X6    1
          ZR     X1,MIB125   IF EFILE = LFILE 
          SA6    ENOT=L      SET FLAG 
  
 .RM      IFEQ   CP#RM,0     IF CIO I/O 
          SA1    F.OUT+I.CBSET     X1 = OLD LENGTH OF LFILE BUFFER
          LX1    -18
          SX1    X1 
          SA2    A1-I.CBSET+I.FIRST 
          SX2    X2          X2 = FWA OF LFILE BUFFER 
          BX7    X1 
          AX7    1           X7 =  LENGTH OF EFILE BUFFER 
          IX6    X1-X7       X6 = NEW LENGTH OF LFILE BUFFER
          IX5    X2+X6       X5 = FWA OF EFILE BUFFER, LWA+1 OF LFILE 
          LX6    18 
          LX7    18 
          SA6    F.OUT+I.CBSET
          SA7    F.ERRS+I.CBSET 
          SETFIL FILE=F.ERRS,MODE=INIT,FWA=X5 
          SETFIL FILE=F.OUT,MODE=INIT,LWA1=X5 
.RM       ENDIF 
  
  
*         IF QCG WAS SELECTED, RESET BUFFER SIZES.
  
 MIB125   SA1    CO.OPT 
          NZ     X1,MIB130   IF CCG SELECTED
          SX6    Z.LGOQB     QCG MINIMAL BUFFER LENGTH
          LX6    18 
  
          IFEQ   CP#RM,0,2   IF CIO I/O 
          SA6    F.LGO+I.CBSET
          SKIP   1           SKIP 7RM CODE
          SA6    F.LGO+I.HBSET
  
          SX6    Z.PBQB      QCG MINIMAL BUFFER LENGTH
          LX6    18 
          IFEQ   CP#RM,0,2   IF CIO I/O 
          SA6    F.PB+I.CBSET 
          SKIP   1           SKIP 7RM CODE
          SA6    F.PB+I.HBSET 
          SX6    Z.REFQB     MINIMAL QCG BUFFER LENGTH
          LX6    18 
  
          IFEQ   CP#RM,0,2   IF CIO I/O 
          SA6    F.REF+I.CBSET
          SKIP   1           SKIP 7RM CODE
          SA6    F.REF+I.HBSET
  
 MIB130   BSS 
  
*         PROCESS PW OPTION FOR L AND E FILES.
  
          SA1    CO.PW
          NZ     X1,MIB135   IF PW OPTION ON CONTROL STATEMENT
          SA1    GP.JPW      INSTALLATION JOB DEFAULT 
          BX6    X1 
          SA6    CO.PW       SET JOB DEFAULT
          EQ     MIB136 
 MIB135   SX6    1           FLAG FOR PW OPTION ON CONTROL CARD 
          SA6    CO.PWU 
  
 MIB136   SA1    CO.PW
          BX6    X1 
          =A6    A1+1        CO.PWE = CO.PW 
          =X6    0
          RJ     PPW         PROCESS PW (L=FILE)
          SA1    ENOT=L 
          ZR     X1,MIB140   IF NO UNIQUE EFILE 
          =X6    1
          RJ     PPW         PROCESS PW (E=FILE)
  
  
*         OPEN INPUT AND OUTPUT FILES (SCOPE 2 ONLY). 
  
 MIB140   BSS 
  
**        CHECK FOR CONTROL STATEMENT ERRORS. 
  
          SA1    ERR.CNT
          ZR     X1,MIB140A  IF NO ERRORS 
          MESSAGE (=C/**  NO COMPILATION./),,RCL
          EQ     ABTFTN      ABORT
  
 MIB140A  BSS    0
 .RM      IFNE   CP#RM,0
          OPEN   F.IN 
          STORE  X2,MRL=100D
          SA1    FV.OUT 
          ZR     X1,MIB141   IF NO OUTPUT FILE
          OPEN   F.OUT
 MIB141   BSS    0
          OPEN   F.ERRS 
 .RM      ENDIF 
  
*         IF *REW* OPTION IS ON, REWIND INPUT, OUTPUT, AND ERROR FILES. 
  
          SA1    CO.REWI
          PL     X1,MIB142   NO REW OF I
  
 .RM      IFEQ   CP#RM,0
          SX2    F.IN 
          RJ     STF         SEE IF INPUT FILE CONNECTED
          ZR     X6,MIB142   IF CONNECTED INPUT 
          REWIND X2 
 .RM      ELSE
          REWIND F.IN 
 .RM      ENDIF 
  
 MIB142   SA1    CO.REWL
          PL     X1,MIB143   IF NO REW OF L 
  
 .RM      IFEQ   CP#RM,0
          SX2    F.OUT
          RJ     STF         SEE IF OUTPUT FILE CONNECTED 
          ZR     X6,MIB143   IF CONNECTED OUTPUT
          REWIND X2 
 .RM      ELSE
          REWIND F.OUT
 .RM      ENDIF 
  
 MIB143   SA1    CO.REWE
          SA2    ENOT=L 
          ZR     X2,MIB144   IF NO UNIQUE E-FILE
          PL     X1,MIB144   IF NO REW OF E 
  
 .RM      IFEQ   CP#RM,0
          SX2    F.ERRS 
          RJ     STF         SEE IF ERRORS FILE CONNECTED 
          ZR     X6,MIB144   IF ERRORS CONNECTED
          REWIND X2 
 .RM      ELSE
          REWIND F.ERRS 
 .RM      ENDIF 
  
*         OPEN LGO AND REWIND IF REQUESTED. 
  
 MIB144   SA1    FV.LGO 
          ZR     X1,MIB150   IF B=0 
  
          IFNE   CP#RM,0,1
          OPEN   F.LGO
  
          SA1    CO.REWB
          PL     X1,MIB150   IF NO REWIND 
          REWIND F.LGO
  
  
**        IF *SPY* IS SELECTED, SET UP PARAMETER LIST.
  
 MIB150   BSS 
  
 .SPY     IFEQ   .SPY,ON     IF USING SPY OPTION
 .OS      IFNE   .OS,2       IF NOT SCOPE 2 
          SA1    CO.SPY      SPY LOWER LIMIT
          MI     X1,MIB166   IF NO SPY
          NZ     X1,MIB162   IF LOWER LIMIT GIVEN 
          SA1    SD.SPY      USE SECOND DEFAULT 
  
 MIB162   AX1    6           IN HUNDREDS
          SA2    CO.SPY+1    UPPER LIMIT
          NZ     X2,MIB163   IF UPPER LIMIT GIVEN 
          SA2    SD.SPY+1    USE SECOND DEFAULT 
  
 MIB163   AX2    6           IN HUNDREDS
          IX3    X2-X1       HIGH-LOW 
          LX3    6           TIMES 100
          SX4    Z.BINS      MAX NUMBER OF BINS 
          SX3    X3+Z.BINS-1
          IX5    X3/X4       BIN WIDTH (NOT POWER OF 2 YET) 
          MX0    9
          LX5    59-8 
          BX5    X0*X5
          SB6    8+48        POSITION FOR BINWIDTH FIELD
          ZR     X5,"BLOWUP" IF BINWIDTH BAD
  
 MIB164   LX5    1
          SB6    B6-1 
          PL     X5,MIB164   IF NOT SET YET 
          CX3    X5 
          SB7    X3 
          EQ     B7,B1,MIB165      IF POWER OF 2
          SB6    B6+1        NEXT POWER OF 2
  
 MIB165   SX5    1
          LX5    B6          POSITION BINWIDTH
          LX1    24          POSITION LOWER 
          BX7    X1+X5
          LX2    12          POSITION UPPER 
          BX7    X7+X2
          SA2    =0LPRNTSPY  NAME OF REPORT GENERATOR 
          SA7    SPYW        STORE PARAMETER WORD 
          BX6    X2 
          SA6    CO.GO       POST CALL (SIMULATED GO OPTION)
  
 MIB166   BSS 
 .OS      ENDIF 
 .SPY     ENDIF 
  
  
**        READ IN FIRST LINE. 
  
 MIB200   BSS 
          IFEQ   CP#RM,0,2
          RECALL F.IN 
          READ   F.IN        PRIME THE PUMP 
          READC  F.IN,CP.CARD,16
          MX6    1
          SA6    RAPFLAG     SET READ ALREADY PERFORMED FLAG
          ZR     X1,EXIT.    IF NOT EOR, EXIT...
          MESSAGE (=C/ EMPTY INPUT FILE.  NO COMPILATION./),,RCL
  
 .RM      IFNE   CP#RM,0
          CLOSE  F.IN 
          SA1    FV.OUT 
          ZR     X1,MIB201   IF NO OUTPUT FILE
          CLOSE  F.OUT
          EQ     MIB202 
  
 MIB201   CLOSE  F.ERRS 
  
 MIB202   SA1    FV.LGO 
          ZR     X1,ABTFTN   IF NO LGO FILE, ABORT EXIT 
          CLOSE  F.LGO
 .RM      ENDIF 
  
          EQ     ABTFTN      ABORT
  
          IFEQ   .MI,1,1
 MIBA     EQU    SCR         TEMPORARY STORAGE
 PPW      SPACE  4,8
**        PPW - PROCESS PW OPTION FOR AN OUTPUT FILE. 
* 
*         ENTRY  X6 = 0 FOR L FILE, 1 FOR E FILE
  
 PPW      SUBR
          SA6    PPWA        SAVE FLAG
          SA2    CO.PW+X6 
  
 #OS      IFNE   .OS,2       IF NOT SCOPE 2 
          SA2    PPWB+X6
          RECALL X2 
          CALL   STF         SEE IF TERMINAL FILE 
          SA2    PPWA 
          SA2    CO.PW+X2 
          ZR     X6,PPW57    IF TTY 
          EQ     PPW60       SET JOB DEFAULT
  
 PPW57    SA3    CO.PWU 
          NZ     X3,PPW58    IF PW OPTION ON CONTROL STATEMENT
          SX2    CO.PWT      SET JOB DEFAULT FOR TTY
 PPW58    BSS 
          IFEQ   .OS,1,4     IF OPERATING SYSTEM IS NOS 
          SX3    X2-50       LOW LIMIT BOUNDARY CHECK 
          NZ     X3,PPW59    IF NOT ON THE LOW BOUNDARY 
          SX2    51          ALLOW SPACE FOR CARRIAGE RETURN
 PPW59    SX2    X2-1        ADJUST FOR LACK OF CARRIAGE RETURN 
          SX6    X2+1 
          MX3    1
          BX6    X3+X6       MARK FILE CONNECTED
          SA6    A2          PUTS CO.PW IN FORM NEEDED BY REFMAP
  
          EQ     PPW60
 #OS      ELSE
          SX6    136         ASSUME PW NOT ON CONTROL CARD
          NZ     X2,PPW60    IF ASSUMPTION WRONG
          SA6    A2          PUTS CO.PW IN FORM NEEDED BY REFMAP
          EQ     EXIT.
 #OS      ENDIF 
  
 PPW60    SX1    X2-50
          MI     X1,E.PW     IF .LT. 50 
          SX1    X2-137 
          PL     X1,E.PW     IF PW .GE. 137 
          EQ     PPW60.2
  
 PPW60.1  BX6    X2          (X6) -> DEFAULT LIMIT
          SA1    PPWA 
          SA6    CO.PW+X1    DEFAULT LIMIT TO CO.PW 
          SA1    CO.PW
          =A6    A1+1        MAKE THE ADJUSTMENT FOR E FILE 
  
 PPW60.2  SX1    X2-126 
          PL     X1,EXIT.    IF PW .GE. 126 
  
 PPW61    SA3    PPWA 
          MX0    2*CHAR 
          SX1    ERFO 
          SA1    TL.PNAM+1+X1 
          SX6    ERFO 
          NZ     X3,PPW62     IF ERROR FILE CALL
          SA1    O.TTLA-1 
          SA4    =2L1         SET FOR PAGE EJECT
          =A3    A1+1 
          BX5    -X0*X3 
          BX6    X5+X4
          SA6    A3          ADD CARRIAGE CONTROL TO O.TTLA 
          MX6    0
  
 PPW62    SA4    =2L1        SET FOR PAGE EJECT 
          =A3    O.TTLA+X6
          BX5    -X0*X3 
          BX7    X5+X4
          SA7    A3          ADD CARRIAGE CONTROL TO O.TTLA 
          SX0    52429
          SA1    TL.PAGE-1+X6   (X1) = ......PAGE   (.=BLANK(55B))
          IX3    X2*X0
          AX3    19          (X3) = [PAGE WIDTH/10] 
          SX4    10 
          IX5    X4*X3
          LX1    10*CHAR-4*CHAR 
          IX2    X2-X5       (X2) = REMAINDER AFTER DIVIDE BY 10
          SX4    CHAR 
          IX2    X2*X4       (X2) = REMAINDER IN BITS 
          BX7    X1          (X7) = PAGE......   (.=BLANK(55B)) 
          LX2    30 
          BX6    X3+X2
          SA7    A1 
          SA3    PPWA        GET FILE ORDINAL (E/L) 
          SA6    CO.WPL+X3   (X6) = 30/CHAR,30 WORDS
          EQ     EXIT.       DONE...
  
 PPWA     BSS    1
 CO.PWU   BSSZ   1
 PPWB     CON    F.OUT,F.ERRS 
 GPP      SPACE  4,10 
**        GPP - INITIALIZE PAGE SIZE PARAMETER BLOCK, GP.PAGE 
*               AND SET INITIAL VALUES FOR PD, PS, AND PW.
* 
*         ENTRY  (B1) = 1 
* 
*         EXIT   PS, PD, AND PW INITIALIZED WITH JOB DEFAULT VALUES 
* 
*         CALLS  CPM= 
  
 GPP      SUBR               ...ENTRY/EXIT... 
          GETPAGE GP.PAGE    GET PAGE SIZE PARAMETERS 
          SA1    GP.PAGE
          MX0    -8 
          AX1    12          POSITION FOR *PW*
          BX6    -X0*X1 
          SA6    GP.JPW 
          AX1    8           POSITION FOR *PS*
          BX6    -X0*X1 
          SA6    CO.PS
          SA6    GP.JPS 
          MX0    -4 
          AX1    8           POSITION FOR *PD*
          BX6    -X0*X1 
          SA6    CO.PD
          SA6    GP.JPD 
          SX7    1RS         6LPI 
          SX6    X6-6 
          ZR     X6,GPP1     IF 6LPI
          SX7    1RT         8LPI 
  
 GPP1     LX7    -CHAR
          SA7    RS.PD       STORE *RESTORE* PD 
          EQ     EXIT.       RETURN 
  
 #OS      IFNE   .OS,2
*CALL COMCCPM 
 #OS      ENDIF 
 CPV      SPACE  4,10 
**        CPV - CURRENT PARAMETER VALUES
* 
*         UPDATE CURRENT VALUES OF THE FOLLOWING FORTRAN CALL CARD
*         PARAMETERS - ARG,CS,DB,DO,DS,PL AND ROUND ON THE FIRST AND
*         SECOND LINES OF THE FIRST PAGE AND THE FIRST 120 CHARACTERS 
*         OF THE FORTRAN CALL CARD ON THE THIRD LINE OF THE FIRST PAGE
*         OF EACH PROGRAM UNIT OUTPUT LISTING.
* 
*         ENTRY - NO ENTRY REQUIRENTS 
* 
*         USES   B - 3
*                A - 1,4
*                X - 2,3,4,6,7
* 
*         CALLS  NONE 
  
  
 IFON     MACRO  CCOPT,ADD
          SA4    =X_CCOPT 
          NZ     X4,ADD 
          ENDM
  
 SETOFF   MACRO  SHIFT
          BX4    X3          X3 PRESET TO 7 
          IFNE   SHIFT,0,1   IF SHIFT COUNT NOT ZERO
          LX4    SHIFT_*CHAR
          BX6    X6+X4
          ENDM
  
 CPV      SUBR               ...ENTRY/EXIT... 
          MX6    0
          SX3    7
  
**        CURRENT VALUES OF ROUNDING OPTIONS
  
          IFON   CO.RNDA,CPV2     IF ROUNDING ADDS IS ON
          SETOFF 7                ELSE SET CURRENT VALUE TO OFF 
  
 CPV2     IFON  CO.RNDS,CPV4      IF ROUNDING SUBTRACT IS ON
          SETOFF 4                ELSE SET CURRENT VALUE TO OFF 
  
 CPV4     IFON  CO.RNDM,CPV6      IF ROUNDING MULTIPLY IS ON
          SETOFF 1                ELSE SET CURRENT VALUE TO OFF 
  
 CPV6     ZR     X6,CPV8          IF CURRENT VALUES ON
          SA1    TL.CSOP+1
          IX6    X1-X6            MERGE VALUES WITH TEMPLET 
          SA6    A1 
          SA6    A6+ERFO          E-LIST
          MX6    0
  
**        CURRENT VALUES OF ROUNDING DIVIDE AND DIRECTIVE SUPPRESSION 
  
 CPV8     IFON   CO.RNDD,CPV10    IF ROUNDING DIVIDE IS ON
          SETOFF 8                ELSE SET CURRENT VALUE TO OFF 
  
 CPV10    IFON   CO.DS,CPV12      IF DIRECTIVE SUPPRESSION IS ON
          SETOFF 5                ELSE SET CURRENT VALUE TO OFF 
  
 CPV12    ZR     X6,CPV14         IF VALUES ON
          SA1    TL.CSOP+2
          IX6    X1-X6            MERGE CURRENT VALUES WITH TEMPLET 
          SA6    A1 
          SA6    A6+ERFO          E-LIST
          MX6    0
  
**        CURRENT DO PARAMETER VALUES 
  
 CPV14    IFON   CO.DOLG,CPV16    IF DO LOOP TRIP COUNT LESS THEN 131072
          SETOFF 6                ELSE SET CURRENT VALUE OFF
  
 CPV16    IFON   CO.DOOT,CPV18    IF ONE TRIP DO LOOPS
          SETOFF 0                ELSE SET CURRENT VALUE OFF
  
 CPV18    ZR     X6,CPV20         IF VALUES ON
          SA1    O.CPV+1
          IX6    X1-X6            MERGE VALUES WITH TEMPLET 
          SA6    A1 
          MX6    0
  
**        CURRENT ARG VALUES
  
 CPV20    IFON   CO.ARGC,CPV22    IF NOT COMMON ARGUMENT LISTS
          SETOFF 2                ELSE SET CURRENT VALUE OFF
          SA1    O.CPV+2
          IX6    X1-X6            MERGE WITH TEMPLET
          SA6    A1 
          MX6    0
  
 CPV22    IFON   CO.ARGF,CPV24    IF NOT FIXED LENGTH ARGUMENT LISTS
          SETOFF 4                ELSE SET CURRENT VALUE OFF
          SA1    O.CPV+3
          IX6    X1-X6            MERGE WITH TEMPLET
          SA6    A1 
          MX6    0
  
**        CURRENT COLLATING SEQUENCE VALUE
  
 CPV24    IFON   CO.CS,CPV26      IF COLLATING SEQUENCE USER
          SA1    O.CPV+4
          SETOFF 4                USER COLLATING SEQUENCE IS OFF
          EQ     CPV28
  
 CPV26    SETOFF 8                FIXED COLLATING SEQUENCE IS OFF 
          SA1    O.TA 
  
 CPV28    IX6    X1-X6            MERGE WITH TEMPLET
          SA6    A1 
          MX6    0
  
**        CURRENT VALUES OF DEBUG OPTIONS 
  
          IFON   CO.DBTB,CPV30    IF FULL ERROR TRACEBACK ON
          SETOFF 8                ELSE SET CURRENT VALUE OFF
  
 CPV30    IFON   CO.DBSB,CPV32    IF SUBSCRIPT BOUNDS CHECKING IS ON
          SETOFF 4                ELSE SET CURRENT VALUE OFF
  
 CPV32    IFON   CO.DBSL,CPV34    IF SUBSTRING LIMITS CHECKING IS ON
          SETOFF 0                ELSE SET CURRENT VALUE OFF
  
 CPV34    ZR     X6,CPV36         IF VALUES ON
          SA1    O.TA+1 
          IX6    X1-X6            MERGE VALUES WITH TEMPLET 
          SA6    A1 
          MX6    0
  
 CPV36    IFON   CO.DBER,CPV38    IF OBJECT TIME REPRIEVE OF EXCUTION 
                                  ERRORS IS ON
          SETOFF 6                ELSE SET CURRENT VALUE OFF
  
 CPV38    IFON   CO.DBID,CPV40    IF INTERACTIVE DEBUG IS ON
          SETOFF 2                ELSE SET CURRENT VALUE OFF
  
 CPV40    ZR     X6,CPV42         IF CURRENT VALUES ON
          SA1    O.TA+2 
          IX6    X1-X6            MERGE CURRENT VALUES WITH TEMPLET 
          SA6    A1 
          MX6    0
  
 CPV42    IFON   CO.DBPM,CPV44    IF POST MORTEM DUMP ON
          SETOFF 8                ELSE SET CURRENT VALUE OFF
  
 CPV44    IFON   CO.DBST,CPV46    IF SYMBOL TABLE TO BINARY 
          SETOFF 3                ELSE SET CURRENT VALUE OFF
  
 CPV46    ZR     X6,CPV48         IF CURRENT VALUES ON
          SA1    O.TA+3 
          IX6    X1-X6            MERGE CURRENT VALUES WITH TEMPLET 
          SA6    A1 
  
**        CURRENT PRINT LIMIT 
  
 CPV48    SA1    CO.LL
          CALL   CDD
          AX4    1*CHAR      XXXXXXXXX0  -  !XXXXXXXXX
          MX0    7*CHAR      XXXXXXX000 
          LX0    6*CHAR      X000XXXXXX 
          BX2    -X0*X4      0XXX000000 
          AX2    6*CHAR      0000000XXX 
          SX6    1R 
          SA1    CO.AL
          NZ     X1,CPV50    IF AUTOMATIC LEVEL IS ON 
          SX6    1R-
 CPV50    LX6    -CHAR
          SA1    O.TA+4       AL,PL=000 
          BX7    X2+X1        AL,PL=XXX 
          BX7    X7+X6       ?AL,PL=XXX 
          SA7    A1 
          MX0    4*CHAR      XXXX000000 
          BX6    -X0*X4      0000XXXXXX 
          LX6    4*CHAR      XXXXXX0000 
          SA1    =4R         000000BBBB 
          BX7    X6+X1       XXXXXXBBBB 
          SA7    O.TA+5 
  
**        CHECK FOR PAGE WIDTH MODE 
  
          SA2    =XWOF=ERR
          SA1    CO.PW+X2 
          SX1    X1-126 
          PL     X1,EXIT.    IF NOT PAGE WIDTH MODE 
  
*         PW MODE BREAK UP SECOND LINE. 
  
          SA2    L.PWA       PRELOAD
          LX7    X2          BLANKS 
          SB2    6           LOOP CONTROL 
  
 CPV52    SA2    A2-1 
          BX6    X2 
          SB2    B2-B1
          SA6    A2+B1
          NE     B2,B0,CPV52 IF NOT FINISHED
          SA7    O.TA        FIRST WORD = 1H  FOR CARRAGE CONTROL 
  
*         PW MODE BREAK UP THIRD LINE 
  
          SA2    L.PWB
          LX7    X2 
          SB2    6          LOOP CONTROL
  
 CPV54    SA2    A2-1 
          BX6    X2 
          SB2    B2-B1
          SA6    A2+B1
          NE     B2,B0,CPV54  IF NOT FINISHED 
          SA7    O.C
          EQ     EXIT.
  
 FCA      SPACE  4,10 
**        FIND CHARACTER ADDRESS
* 
*         FIND NEXT AVAILABLE CHARACTER POSITION IN CONTROL CARD TEMPLET
* 
*         ENTRY - CELL NXA CONTAINS LAST WORD ADDRESS STORED IN TEMPLET 
* 
*         USES   B - 3
*                A - 2,3,6
*                X - 0,1,2,3,6
* 
*         CALLS  NONE 
  
  
 FCA      SUBR               ...ENTRY/EXIT... 
          MX0    9*CHAR 
          SB4    B0 
          SA2    NXA         LWA OF LAST STORE IN CONTROL CARD TEMPLET
          SA3    X2 
          ZR     X3,FCA7     IF LAST WORD STORED IS ZERO
  
 FCA1     LX1    X0,B4
          BX2    -X1*X3 
          NZ     X2,FCA2     IF NON ZERO BYTE 
          SB4    B4+CHAR
          EQ     FCA1 
  
 FCA2     LX2    X2,-B4 
          SX2    X2-1R
          NZ     X2,FCA4     IF NOT BLANK 
          BX6    X1*X3       BLANK GET RID OF IT. 
          SA6    A3 
          SX6    B4 
  
 FCA3     SA6    CP          SHIFT REQUIRED TO STORE NEXT CHARACTER.
          EQ     EXIT.
  
 FCA4     SX6    B4-CHAR
          EQ     FCA3 
  
 FCA6     SX6    9*CHAR 
          EQ     FCA3 
  
 FCA7     SA3    A3-1        GET PREVIOUS WORD
          BX2    -X0*X3 
          SX2    X2-1R
          NZ     X2,FCA6     IF NOT BLANK 
          BX6    X0*X3       GET RID OF BLANK 
          SA6    A3          STORE LAST WORD
          SA2    =10H 
          LX6    X2 
          SA6    A3+1        BLANKS TO LWA + 1
          SX6    A3 
          SA6    NXA         LWA OF LAST STORE IN TEMPLET 
          MX6    0           SHIFT REQUIRED TO STORE NEXT CHARACTER 
          EQ     FCA3 
  
 CP       CON    0           SHIFT REQUIRED TO STORE NEXT CHARACTER 
*                            IN CONTROL CARD TEMPLET. 
 NXA      CON    0           LWA STORED IN CONTROL CARD TEMPLET 
 TCC      SPACE  4,10 
**        TRANSFER CONTINUATION CONTROL CARD TO TEMPLET 
* 
*         ENTRY - NO ENTRY REQUIRENTS 
* 
*         USES   B - 4,5    RESTORES B5 
*                A - 0,1,2,3,4,6    RESTORES A0 
*                X - 0,1,2,3,4,6
* 
*         CALLS NONE
  
  
 TCC      SUBR               ...ENTRY/EXIT... 
          SA2    TFF
          NZ     X2,EXIT.    IF TEMPLET FULL
          SX6    B5 
          SA6    SB5         SAVE B5
          SX6    A0 
          SA6    SA0         SAVE A0
          SA1    RA.CCD 
          SB5    9*CHAR 
          MX0    9*CHAR 
          SA3    CP 
          SB4    X3          SHIFT REQUIRED TO STORE NEXT CHARACTER 
*                            IN CONTROL CARD TEMPLET. 
          SA3    NXA
          SA4    X3          LWA OF STORE IN TEMPLET
          SA0    A4-1        NEXT LOCATION - 1 TO STORE IN TEMPLET
          LX6    X4 
  
 TCC2     AX2    X1,B5
          BX2    -X0*X2 
          GT     B5,B0,TCC4  IF MORE CHARACTERS IN WORD 
          SA1    A1+1 
          SB5    10*CHAR
  
 TCC4     SB5    B5-CHAR
          AX3    X1,B5
          BX3    -X0*X3 
          NZ     X3,TCC5     IF CHARACTER FOLLOWING CURRENT CHARACTER 
*                            NOT ZERO.
          SX3    X2-1R
          ZR     X3,TCC6     IF CURRENT CHARACTER BLANK - FINISHED
  
 TCC5     ZR     X2,TCC6     IF CURRENT CHARACTER ZERO  - FINISHED. 
          LX2    X2,B4
          BX6    X6+X2
          SB4    B4-CHAR
          PL     B4,TCC2     IF CURRENT WORD NOT FULL 
          SB4    L.PWB-1
          SX2    A0-B4
          PL     X2,TCC8     IF CONTROL CARD TEMPLET FULL 
          SB4    9*CHAR 
          SA0    A0+1 
          SA6    A0          STORE CURRENT WORD IN CC TEMPLET 
          MX6    0
          EQ     TCC2 
  
 TCC6     SB5    L.PWB-1
          SX2    A0-B5
          PL     X2,TCC8     IF CC TEMPLET FULL 
          SA0    A0+1 
          SA6    A0          SAVE CURRENT WORD
  
 TCC7     SX6    A0 
          SA6    NXA         SAVE CURRENT ADDRESS 
          SX6    B4 
          SA6    CP          SAVE CURRENT CHARACTER POSITION
          EQ     TCC10
  
 TCC8     SX6    A0 
          SA6    NXA         SAVE CURRENT ADDRESS 
          MX6    1
          SA6    TFF         TEMPLET FULL FLAG
  
 TCC10    SA2    SB5
          SB5    X2          RESTORE B5 
          SA2    SA0
          SA0    X2          RESTORE A0 
          EQ     EXIT.
  
 TFF      CON    0           TEMPLET FULL FLAG
 SB5      CON    0           B5 SAVED HERE
 SA0      CON    0           A0 SAVED HERE
*CALL     COMCSTF            SET TERMINAL FILE
*CALL     COMFGOI            GLOBAL OVERLAY INITIALIZATION (QCG ONLY) 
  
*CALL     COMFFEI                  FRONT END INITIALIZATION 
  
*CALL     COMSEIS            DEFINE SK. DATA STRUCTURE
*CALL     COMFROR            RESET OPCODE OF ROUNDABLES 
          LIST   D
          ENTRY  B=LWA00
 B=LWA00  END                MARK LWA OF OVERLAY FOR RPV
