ASMB,Q,C
      HED ** FTN4 COMPILER (SEG: F4.4) INITIALIZE THE COMPILER ** 
      NAM F4.4,5 92060-16098 REV.2026 800423
* 
***************************************** 
*     FORTRAN-4 COMPILER OVERLAY 4
***************************************** 
* 
*     THIS OVERLAY SETS UP THE SYMBOL TABLE AND ENTERS THE FIXED ENTRIES
*     IT ALSO INITIALIZES THE COMPILER AND READS THE FTN STATEMENT IF 
*     SETTING UP FOR THE FIRST MODULE IN THIS COMPILE.
* 
*************************************************************** 
* (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1977.  ALL RIGHTS     * 
* RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE-  * 
* REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * 
* OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.   * 
*************************************************************** 
*     NAME:   F4.4, PART OF FTN4 COMPILER.                    * 
*     SOURCE: 92060-18098                                     * 
*     RELOC:  92060-16098                                     * 
*     PGMR:   BILL GIBBONS.                                   * 
*************************************************************** 
* 
*     EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS 
* 
*     THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS 
*     DEFINED IN AS FOLLOWS 
*                2 -- OA.F  (WRITE PASS FILE ROUTINES)
*                 3 -- NEX.F  (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) 
*                  4  -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) 
*                   5  -- EX.F  (STATEMEXTS USING THE EXPRESSION EVALUATOR) 
*                    6  -- IC.F  (THE CHARACTER INPUT ROUTINES) 
*                     7  -- IDN.F   (THE TOKEN INPUT ROUTINES)
*                      8  -- FTN4    ( THE MAIN)
       EXT F..DP    BASE OF SYMBOL TABLE
   EXT     F.A      ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY)
     EXT   F.ABT    ABORT COMPILE EXTRY 
       EXT F.AT.    SUBSCRIPT INFO FLAG 
     EXT   F.CC     CHARACTER COUNT 
       EXT F.CCW    FTN OPTION WORD 
       EXT F.D      DO TABLE POINTER
       EXT F.DNB    DEF OF NBUF (NAM RECORD)
       EXT F.DO     LWAM - END OF DO TABLE
   EXT     F.DP     BASE OF USER SYMBOL TABLE 
      EXT  F.DTY    IMPLICIT TYPE TABLE 
      EXT  F.E      EQUIVALENCE TABLE POINTER 
       EXT F.EMA    F.A OF EMA EXT ENTRY, WINDOW SIZE 
     EXT   F.EQE    EQUVALENCE ERROR FLAG 
       EXT F.EQF    EQUIVALENCE FLAG
       EXT F.ER0    'RX' OF ERRX  LIB ERROR ROUTINE 
     EXT   F.ERF    ERROR FLAG (# OF ER.F CALLS)
     EXT   F.ERN    ERROR ARRAY 
      EXT  F.IDI    INPUT ARRAY NON-NUMERIC 
       EXT F.INT    TEMP VARIABLE ARRAY 
     EXT   F.HDL    LENGTH OF HEAD MESSAGE
      EXT  F.LLT    ADDRESS OF LINE LOCATION TABLE (SET BY INIT)
       EXT F.LO     END OF ASSIGNMEXT TABLE+1 
       EXT F.LSF    EXPECT FIRST STATEMEXT FLAG 
       EXT F.LSP    LAST OPERATION FLAG 
   EXT     F.NT     NAME TAG  0= VAR, 1=CONSTANT. 
     EXT   F.NXN    NO INPUT FLAG 
      EXT  F.PAK    PACK BUFFER WORD
       EXT F.S1B    BOTTOM OF STACK 1 
       EXT F.S1T    TOP    OF STACK 1 
   EXT     F.S2B    BOTTOM OF STACK 2 
       EXT F.S2T    TOP    OF STACK 2 
       EXT F.SEG    LOAD A NEW SEGMENT
       EXT F.SID    STATEMEXT ID PHASE FLAG 
       EXT F.STA    FLAG THAT IS ZERO UNTIL THE FTN STATEMEXT IS READ 
     EXT   F.TC     NEXT CHARACTER
     EXT   F.TIM    TIME ARRAY ADDRESS IN HEAD
* 
*     EXT'S WITH A TRAILING '.F' ARE SUBROUTINES
* 
     EXT   ASC.F    CONVERT TO 4 ASCII DIGITS 
     EXT   BOM.F    DISASTOR ERROR REPORT (NO RETURN) 
      EXT  CDI.F    CLEAR IDI ROUTINE 
   EXT     DAF.F    DEFINE (F.AF) 
   EXT     DAT.F    DEFINE (AT) 
     EXT   ER.F     ERROR PRINT SUBROUTINE
     EXT   IA.F     INPUT (A) CHARACTERS SUBROUTINE 
     EXT   IC.F     GET NEXT CHARACTER
     EXT   ICH.F    GET NEXT NON BLANK CHAR. AND TYPE IT
      EXT  IDN.F    INPUT DO NOT ASSIGN (GET NEXT OPERAND)
 EXT       IN2.F    INIT FOR OA.F MODULE
  EXT      IN3.F    INIT FOR ENX.F MODULE 
   EXT     IN4.F    INIT FOR FA.F MODULE
    EXT    IN5.F    INIT FOR EX.F MODULE
     EXT   IN6.F    INIT FOR IC.F MODULE
      EXT  IN7.F    INIT FOR IDN.F MODULE 
     EXT   INM.F    INPUT NAME
     EXT   MCC.F    RESET TO FIRST COLUMN OF STATEMEXT
     EXT   MPN.F    MOVE PROGRAM NAME (TO NAM RECORD ECT.)
       EXT NEW.F    SUB TO CLEAR TEMPS FOR A NEW MODULE 
   EXT     NTI.F    MOVE NID TO F.IDI (PACKS) 
     EXT   SNC.F    START NEXT CARD SUBROUTINE
   EXT     TS.F     TAG SUBPROGRAM SUB. 
* 
*     COMPILER LIBRARY ENTS 
* 
      EXT SUP.C     COMP LIB SUPER
      EXT C.BIN     BINARY FCB
      EXT RWN.C     REWIND ROUTINE
      EXT C.SAU     INPUT FCB 
      EXT OPN.C     OPEN ROUTINE
      EXT EOF.C     EOF WRITE ROUTINE 
      EXT END.C     END ROUTINE 
      EXT C.LST     LIST FCB
      EXT GMM.C     GET MAIN MEMORY 
      EXT END.C     TERMINATE 
      EXT PRM.C     GET PRAMETER
      EXT C.SC1     SCRATCH FILE FCB
      EXT C.SC0     SCRATCH FILE FCB
      EXT C.TTY     TTY FCB 
      EXT WRT.C     WRITE TO FCB ROUTINE
* 
*     FTN UNIQUE SUB
* 
      EXT SEG.F     GET SEGMENT ID SUB
* 
*     LIBRARY ROUTINES
* 
* 
      EXT .MVW      MOVE WORDS MACRO
      EXT Z$DBL     3/4 WORD DEFAULT OPTION 
* 
A     EQU 0 
B     EQU 1 
K4    DEC 4         SEGMENT NUMBER
      SUP 
* 
*     WE BEGIN *************
* 
BEGIN LDB F.STA     THE COMPILER LIB.  FIRST ENTRY? 
      CCA           SET F.CC TO NOT PRINT 
      STA F.CC      CARD ON ERROR 
      SZB           F.STA =0 IF FIRST 
      JMP NEW       NO JUST A NEW MODULE
* 
      STB BOM.F     CLEAR THE DISASTER FLAG 
      LDA DFTM      MAKE SURE THE DEF 
      RAL,CLE,SLA,ERA IS DIRECT 
      LDA A,I 
      STA DFTM
      DLD F.IDI     RESTORE THE REG'S AND 
      JSB SUP.C     CALL THE COMP LIB SUPER 
DFTM  DEF F.TIM     ADDRESS OF TIME ARRAY 
      NOP 
      ADB K10       ADD LENGTH OF PREAMBLE TO TIME LENGTH 
      STB F.HDL     SET HEAD LENGTH FOR MAIN
* 
      LDA PRMPT     GET PROMPT CHAR. ']'
      JSB OPN.C     OPEN THE INPUT FILE 
      DEF C.SAU     LIST FCB
      JMP INERR     OPEN TRM
* 
      JSB OPN.C     OPEN THE LIST DEVICE
      DEF C.LST 
      JMP TRML      IF ERROR  JUST EXIT 
      UNL 
      IFN 
      LST 
      JSB PRM.C 
      DEF K4
      STA DBLU
      SZA,RSS 
      JMP XDBUG 
      ADA N35 
      SSA,RSS 
      JMP XDBUG 
      JSB DBUG
      EXT DBUG
      DEF *+2 
      DEF DBLU
* 
XDBUG EQU * 
      XIF 
      LST 
      CLB           WANT A RELOCATABLE
      JSB OPN.C     OPEN THE BINARY OUTPUT FILE 
      DEF C.BIN 
      JMP BERR
* 
BERX  JSB OPN.C     OPEN THE SCRATCH FILE 
      DEF C.SC1 
      JMP ERROR 
* 
      JSB OPN.C     OPEN THE CARD FILE
      DEF C.SC0 
      JMP ERROR 
* 
      CCB 
NEW   SSB,RSS       IF TERMINATE CALL 
      JMP TRM       GO TO TERM CODE 
* 
      JSB GMM.C     GET MAIN MENORY BOUNDS
      DEF K6        SIX SEGMENTS (NOW)
      DEF LSE.F     NAME OF LOCAL  SEG. NAME FINDER 
* 
      STB F.DO      SET TOP OF SYMBOL TABLE 
      STA F.CRB     SET ADDRESS OF CARD BUFFER
      JSB GMM.C     NOW GET THE END OF SEGMENT 2 (IT
      DEF K1           DOESN'T USE THE CARD BUFFER) 
      DEF LS2.F     ROUTINE TO GET NAME OF SEGMENT 2 ONLY 
      STA L..DP     TENATIVE BASE OF SYMBOL TABLE 
      LDB F.CRB     SEE IF CARD 
      ADB K98       BUFFER EXTENDS BEYOND 
      CMA,INA       IT
      ADA B         IF SO 
      SSA,RSS       SET 
      STB L..DP     NEW BASE OF SYMBOL TABLE ABOVE THE CARD BUFFER
      LDA L..DP 
      ADA LFIX      CACULATE START OF USER TABLE
      ADA N1
      STA L.DP      USER DATA POOL
      CMA           MAKE SURE THERE IS ROOM 
      ADA F.DO      IF NEGATIVE RESULT THEN NO ROOM FOR FIX-EXT 
      SSA           TABLE SO QUIT ON SYMBOL TABLE OVERFLOW
      JMP ERR3      THERE IS ROOM 
* 
      LDA DK4       GET THE SIZE OF THIS SEGMENT
      STA DSNO      AND 
      JSB GMM.C 
      DEF K1
      DEF LS2.F 
      STA T1        SAVE IT 
      ADA LFIX      CHECK IF ROOM ABOVE 
      ADA K8        FOR FIX-EXT-TBL 
      ADA K98       KEEP ROOM FOR CARD BUFFER TOO 
      CMA 
      ADA F.DO
      SSA           IF NO ROOM
      JMP ERR3      ABORT 
* 
      LDB F.DO      SET UP TO MOVE
      ADB KM8       FIX-EXT-TBL 
      ADB MLFIX     TO HIGH MEMORY
      STB F..DP 
      ADB LFIX      SET USER BASE FOR THIS LOCATION 
      ADA N1
      STA F.DP      FOR NOW  SEG F4.0 MOVES IT DOWN 
      LDA F..DP     SET 
      ADA KM98      CARD BUFFER 
      STA F.CRB     LOCATION
      CLB           NOW CLEAR THE CARD BUFFER 
      STB A,I       PLANT A ZERO
      INB           AND 
      ADB A 
      JSB .MVW      WATCH IT GROW 
      DEF K98       (IT SLOPS OVER BY ONE BUT 
      NOP            WE DON'T HAVE THE FIX-EXT-TABLE THERE YET
      LDA F.CRB     NOW PLANT THE REQUIRED BLANKS 
      ADA K2        FOR BETWEEN THE LINE NUMBER 
      LDB BLNK
      STB A,I 
      ADA K49       DO FOR BOTH BUFFERS 
      STB A,I 
      JMP NEWMD     GO FINISH UP
* 
ERR3  LDA K3        03 SYMBOL TABLE OVERFLOW
      JMP ABT       REPORT ERROR AND EXIT 
* 
K2    DEC 2 
T1    NOP 
MLFIX ABS DFIX+1-LFIX NEGATIVE OF FIX-EXT TBL LENGTH
L..DP NOP 
L.DP  NOP 
DK4   DEF K4
      UNL 
      IFN 
      LST 
DBLU  NOP 
      XIF 
      LST 
K3    DEC 3 
K6    DEC 6 
K10   DEC 10
K5    DEC 5 
N1    DEC -1
RSAVE NOP 
NOLIN NOP           NUMBER OF LINES/PAGE
K98   DEC 98
KM98  DEC -98 
KM8   DEC -8
K49   DEC 49
* 
NEWMD JSB NEW.F     GO TO MAIN TO INITIALIZE
      DLD F.ERN+1   GET THE ERROR SUM 
      ADA F.ERF     ADD TOTALS FOR THIS MODULE
      ADB F.ERF+1 
      DST F.ERN+1 
      CLA           CLEAR THE COUNTERS FOR
      CLB           THE NEW MODULE
      DST F.ERF 
      CLA 
      LDB F.CRB     SET TOP OF BUFFER ADDRESS FOR 
      DST F.LLT     SET EQUV LINE LOCATION TABLE
      JSB RWN.C     REWIND THE SCRATCH FILE 
      DEF C.SC1 
      JMP ERROR     OPEN ERROR
      LDA F.STA     GET STATUS FLAG 
      SZA           IF NOT FIRST MODULE 
      JMP NOFTN     SKIP READING THE FTN STATEMENT
* 
      JSB PRM.C     GET THE NO LINES/PAGE 
      DEF K4
      SZA,RSS       IF ZERO 
      LDA K55       USE 55 LINES/ PAGE
      INA           COMPENSATE FOR CALCULATION METHOD 
      STA NOLIN     GET NUMBER TO A FOR INITIALIZE
      ADA KN10      IF LESS THAN
      CLB,CCE       TEN 
      SSA 
      STB NOLIN     USE INFINITE SIZE PAGE
* 
      JSB INIT      INITIALIZE ALL THE FLAGS
* 
*     READ "FTN/FTN4,B,L,A/M,T" 
* 
* 
*         ********************* 
*         * COMPILER ENTRANCE * 
*         ********************* 
      SPC 1 
*     WHERE IN WE BUILD THE OPTION CONTROL WORD FROM THE 'FTN' CONTROL
*     STATEMENT.
* 
*     THE FORMAT OF THE WORD IS (ONE BIT PER LETTER  LEAST BIT IS ZERO):
* 
*     QXY EFD BCT AML 
* 
*     Q = LIST LOAD ADDRESS OF EACH STATEMENT.
*     X = USE 48 BIT DOUBLE PRECISION (VS 64-BIT) 
*     Y = USE 64 BIT DOUBLE PRECISION (VS 48-BIT) 
*     E = USE .EMAP ARRAY CALLING SEQUENCE (VS ..MAP) 
*     F = DO FULL FORM FEEDS EVEN IF A TTY. 
*     D = COMPILE LINES THAT START WITH 'D' (VS THEIR COMMENTS) 
*     B = SET INTERNALLY IF BINARY OUTPUT FILE IS PRESENT 
*     C = PRODUCE A CROSS REFERENCE 
*     T = PRODUCE A SYMBOL TABLE LISTING
*     A = PRODUCE AN ASSEMBLY LISTING 
*     M = PRODUCE A MIXED LISTING 
*     L = PRODUCE A SOURCE LISTING
* 
      JSB IC.F      FORCE A CARD READ IN
      CLA,INA       SET TO GET FIRST
      STA F.CC      CHAR
      CCA 
      STA F.STA     SET FTN STMNT. READ FLAG
      STA F.EQF     NOT PROCESSING EQUIV
      STA F.NXN     SET NO INPUT FLAG.
      JSB IDN.F     INPUT DO NOT ASSIGN 
      JSB NTI.F     MOVE NID TO F.IDI 
      DLD F.IDI 
      CPA "FT"      'FT'
      JMP CME04 
CME02 CLA,INA       FTN4 CONTROL CARD MISSING 
      JMP F.ABT     EXIT TRANSLATOR.
      SPC 1 
CME04 LDA B         GET NEXT TWO CHAR.
      ALF,ALF       TO LOW A
      AND B377      ISOLATE 
      CPA "N"       'N' 
      JMP CME06 
      JMP CME02     FTN CONTROL CARD MISSING
      SPC 1 
CME05 JSB ICH.F     NEXT CHARACTER. 
CME06 LDB F.TC
      CPB B15 
      JMP PCONT 
      CPB B54       ',' 
      RSS 
      JMP CME08     ERROR IN FTN CARD 
      JSB ICH.F     INPUT CHARACTER 
      LDB A         SAVE CHARACTER IN (B) 
      JSB CCO.F     CONVERT CONTROL OPTION. 
      SZA,RSS       FOUND ? 
      JMP CME10     NO. 
      IOR NLTEM     YES. SET THE OPTION(S)
      STA NLTEM 
      AND B3000     X & Y OPTIONS.
      CPA B3000     BOTH SET NOW ?
      JMP CME08     YES, ERROR. 
      LDA B         THE OPTION BY ITSELF. 
      IOR DUPS      REPEATED ?
      CPA DUPS
      JMP CME08     YES, ERROR. 
      STA DUPS
      JMP CME05     GO FOR MORE.
CME10 LDB OPTSE     B = CHAR. 
      CPB B15 
      JMP PCONT     ENDS ON COMMA.
      ADB BM61      CHECK FOR DIGIT.
SW.N  SSB 
      JMP CME08 
      ADB KM9.
      SSB,RSS 
      JMP CME08     NONE OF THE ABOVE.
      ADB ERR0      DIGIT; BUILD ERR ROUTINE NAME 
      STB F.ER0 
      CLB 
      STB SW.N
      JMP CME05 
      SPC 1 
CME08 LDA K2
      JMP F.ABT     ERROR IN FTN CONTROL CARD 
      SPC 1 
PCONT CLA           END OF CTRL STMT. 
      STA F.NXN 
      LDA NLTEM     X OR Y SELECTED ? 
      AND B3000 
      SZA 
      JMP PCON1     YES.
      LDB Z.DBL     NO... Y DEFAULT ? 
      CPB K4
      LDA B1000     YES, SET Y. 
PCON1 STA NEWOP 
      IOR NLTEM     SET THE 
      STA F.CCW     CONTROL WORD
      SPC 1 
      JSB IN2.F     INITIALIZE OA.F AGAIN 
      CLA 
      JSB IN7.F     GET IDN TO PICK THE 'Y' BIT 
      JSB PRM.C     GET THE OPTIONAL CONTROL PRAMS
      DEF K5
      STB AD        SET THE PARAMETER ADDRESS 
      LDA KM6       SET COUNTER FOR NO. OF PRAMS
      STA COUNT 
CLOP  LDB AD        START LOOP
      CLE,ERB       CONVERT TO A WORD ADDRESS 
      LDA B,I       GET THE WORD
      SEZ,RSS       ROTATE IF 
      ALF,ALF       NEEDED
      AND B377      ISOLATE THE WORD
      SZA,RSS       ANY ZERO'S INVALIDATE THE WHOLE THING 
      JMP NIXOP     SO BAIL OUT 
* 
      LDB A         PUT CHAR TO B 
      JSB CCO.F     CONVERT CONTROL OPTION. 
      AND KK01      DISALLOW X,Y. 
      IOR NEWOP 
      STA NEWOP     SET DOWN THE NEW WORD 
      ISZ AD        STEP THE ADDRESS
      ISZ COUNT     AND THE COUNT 
      JMP CLOP      DO THE NEXT CHAR. 
* 
      STA F.CCW     IF WE GET HERE THEN SET THE NEW CONTROL WORD
NIXOP LDA DNIX      SET F.EQE TO POINT TO HERE INCASE 
      STA F.EQE     OF ERROR 90  (FIRST STMT. IS A CONTINUE)
      CLE           CLEAR E FOR IN6.F (NOT A NEW MODULE)
      JSB INIT      SET UP TO CHECK FOR CONTINUED LINES 
      JSB SNC.F     DISMISS THE FTN STATEMENT 
      CLA           CLEAR THE ERROR SWITCH
      STA F.EQE     SO OTHER ERRORS DO STD. THING 
      LDA F.CCW     MODIFY THE CONTROL WORD 
      IOR B40       ALWAYS DO BINARY
      LDB BFLG      UNLESS
      SZB,RSS       NO
      XOR B40       FILE GIVEN FOR OUTPUT 
      STA F.CCW     SET THE FLAG WORD 
* 
      JMP PPNM      FINISH SETTING UP 
* 
DNIX  DEF NIXOP 
* 
ERROR LDA K99       ERROR ON PASS FILE WRITE IT 
      JMP ABT       IS AN ERROR 99
* 
BERR  CPA KM201     IF NO BINARY FILE 
      JMP NOBIN     GO SET IT UP
* 
      LDA K97       OPEN ERROR ON BINARY FILE 
      JMP ABT 
* 
NOBIN CLA           CLEAR THE 
      STA BFLG      BINARY FLAG 
      JMP BERX      CONTINUE THE SET UP 
      SPC 2 
CCO.F NOP           CONVERT CONTROL OPTIONS.
      LDA DOPTS     SET UP POINTER. 
      STA T1CME 
      STB OPTSE     USE ORIGINAL VALUE TO END TABLE.
      CLA,INA       START WITH L=1. 
CCO01 CPB T1CME,I   THIS ONE ?
      JMP CCO02     YUP.
      RAL           NO. TRY NEXT. 
      ISZ T1CME 
      JMP CCO01 
CCO02 LDB A         SAVE ACTUAL OPTION. 
      CPA K2        M ? 
      IOR B14       YES, SET A & T. 
      CPA K4        A ? 
      IOR B10       YES, SET T. 
      CPA B4000     Q ? 
      IOR K1        YES, SET L. 
      CPA OPTSX     NOT FOUND ? 
      CLA           IF SO, RETURN A=0.
      JMP CCO.F,I   EXIT. A=OPTIONS, B=SINGLE OPTION. 
* 
DOPTS DEF *+1       OPTIONS TABLE.
      OCT 114       L =    1
      OCT 115       M =    2
      OCT 101       A =    4
      OCT 124       T =   10
      OCT 103       C =   20
      OCT 102       B =   40
      OCT 104       D =  100
      OCT 106       F =  200
      OCT 105       E =  400
      OCT 131       Y = 1000
      OCT 130       X = 2000
      OCT 121       Q = 4000
OPTSE BSS 1         MISSING = 10000 
OPTSX OCT 10000 
* 
N35   DEC -35       ************DBUG ONLY************************** 
PRMPT ASC 1,]_      PROMPT WITH ']' 
NLTEM NOP 
T1CME NOP           TEMP FOR CME & CCO. 
DUPS  NOP           FOR CATCHING DUPLICATES.
BM61  OCT -61 
KM9.  DEC -9
"N"   OCT 116       'N' 
"FT"  ASC 1,FT
ERR0  OCT 51072     ASC 1,R0 +10
Z.DBL DEF Z$DBL+0   3/4 WORD DEFAULT. 
KM6   DEC -6
AD    NOP 
COUNT NOP 
B377  OCT 377 
NEWOP NOP 
B15   OCT 15
B14   OCT 14
B54   OCT 54        ',' 
K8    DEC 8 
B10   EQU K8
K55   DEC 55
KN10  DEC -10 
K99   DEC 99
K67   DEC 67
KM201 DEC -201
B40   OCT 40
B1000 OCT 1000
B3000 OCT 3000
B4000 OCT 4000
KK01  OCT 174777
BFLG  OCT 40        BINARY FLAG (SET FOR BINARY)
K97   DEC 97
DMAN  DEF NOFTN     ERROR RETURN ON INPUT ERROR 
* 
INIT  NOP           CALL ALL THE INIT SUBS IN THE MAIN
      LDA NOLIN     PASS THE LINE COUNT 
      LDB F.CRB     AND THE CARD BUFFER ADDRESS 
      JSB IN6.F     TO IC.F 
      CCA           SET THE 
      STA F.EQF     NOT PROCESSING EQU'S FLAG 
      CLA 
      JSB IN2.F     OA.F
      CLA 
      JSB IN3.F     ENX.F 
      CLA 
      JSB IN4.F     FA.F
      CLA 
      JSB IN5.F     EX.F
      CLA 
      JSB IN7.F     IDN.F 
      JMP INIT,I    RETURN
* 
* 
NOFTN CLE 
      JSB INIT      CALL INIT SUBS
      LDA MFLC      MOVE "FTN.  " 
      JSB MPN.F     TO NBUF,ERBF,HEADL
      LDA DMAN      SET UP ERROR RETURN 
      STA F.EQE     FOR POSSIBLE INPUT ERROR
      JSB SNC.F     TEST FOR END$ CARD
      CLA,INA 
      STA F.CC      SET CC=1
      STA F.NXN     SET NO INPUT FLAG 
      LDA K2
      JSB IA.F      INPUT 2 CHARS.
      LDA F.PAK 
      CPA EN        'EN' ?
      RSS           YES 
      JMP MAIN4     NO
* 
      LDA K2
      JSB IA.F      INPUT 2 CHARS.
      LDA F.PAK 
      CPA EN+1      'D$' ?
      JMP TRM        YES. NO MORE; WRAP IT UP.
* 
MAIN4 CLA 
      STA F.EQE     CLEAR THE ERROR RETURN FLAG 
      STA F.NXN     RESET NO INPUT FLAG 
      STA SUBFN     CLEAR CARD INPUT FOR PROGRAM. 
      INA 
      STA F.CC      SET CC=1
      STA F.SID     AND THE SCAN FLAG 
      SKP 
*         ************************* 
*         * POSSIBLE PROGRAM NAME * 
*         ************************* 
      SPC 1 
PPNM  JSB IN4.F     MAKE SURE FA.F GETS THE Y BIT 
      LDA F.ER0 
      STA ER.R0     NAME OF ERROR ROUTINE.
      LDA F.CCW     Y OPTION ?
      AND B1000 
      SZA,RSS 
      JMP PPNM1     NO. 
      LDA .DSIN     YES, ADD ERROR RETURNS FOR
      IOR B60       .SIN, .COS, & .ATN2 
      STA .DSIN 
      LDA .DCOS 
      IOR B60 
      STA .DCOS 
      LDA .DAT2 
      IOR B60 
      STA .DAT2 
      STA .DAT3 
PPNM1 LDB F..DP     SET UP TO MOVE IN THE 
      LDA DFIX      FIX-EXTERNAL SYMBOLES 
      JSB .MVW      USE MOVE WORDS
      DEF LFIX      LENGTH OF TABLE 
      NOP 
      LDB F.DNB     GET ADDRESS OF NAM RECORD BUFFER
      LDA PRNM      GET ADDRESS OF PROTO NAM RECORD 
      JSB .MVW      MOVE PROTO TO BUFFER
      DEF K17.      17 WORDS
      NOP 
      LDA DTYP      SET UP THE IMPLICIT TYPE
      LDB F.DTY     TABLE 
      JSB .MVW      IN F.IDN
      DEF K13       IT IS 13 WORDS LONG 
      NOP 
      LDA MFLC      GET THE DEFAULT NAME
      JSB MPN.F     AND REINSERT IT IN THE NAM BUFFER 
      LDB INITB     CLEAR 
      RBL,CLE,SLB,ERB 
      LDB B,I 
      CLA 
      STA B,I 
      LDA F.AT.-1   GET SIZE OF AREA
      STA RSAVE     SAVE IT 
      STB A 
      INB 
      JSB .MVW      CLEAR THE AREA
      DEF RSAVE 
      NOP 
      JSB CDI.F     SET F.IDI TO 0. 
      LDA PPNK3     MOVE FROM KK36
      LDB PPNK4     TO F.INT
      RBL,CLE,SLB,ERB REMOVE POSSIBLE INDIRECT
      LDB B,I 
      JSB .MVW      INITIALIZE TEMP CELL START LOCS.
      DEF K7
      NOP 
      LDA F..DP     DATA POOL START LOCATION
      ADA LFIX
      STA F.LO      END OF ASSI TABLE LOC. +1 
      STA F.S2B 
      STA F.S2T     F.S2T=F.S2B=LO
      STA F.LSF     F.LSF NON-0 (EXPECT 1ST STATEMNT) 
      STA F.LSP 
      ADA N1        COMPUTE START OF USER SYMBOL TABLE
      STA F.DP      AND SET IT
      LDA F.DO      LAST AVAILABLE MEMORY LOCATION
      STA F.E 
      STA F.D 
      STA F.S1B 
      STA F.S1T     F.S1T=F.S1B=D 
      CCA 
      STA F.EQF     F.EQF=-1
      STA F.EMA     NO EMA IS -1
SUBFN JSB IC.F      READ THE "PROGRAM" STATEMENT. 
      CLA,INA       SET F.CC
      STA F.CC      TO 1
      STA F.NXN     SET NO INPUT FLAG 
      JSB IC.F      GET THE FIRST CHAR. IN THE LINE 
      CPA "$"       IS IT A CONTROL STMT.?
      JMP EMA       YES GO TEST FOR EMA 
* 
NOEMA LDA L..DP     PASS THE ACTUAL S.T. BASE TO F4.0 
      STA F.IDI     IN F.IDI
      CLB           GO TO SEGMENT 
      STB F.NXN     CLEAR THE NO INPUT FLAG 
      CLA,INA       RESET 
      STA F.CC      THE COLUMN COUNTER
      JMP F.SEG     0.
* 
MFLC  DEF KK32
KK32  ASC 3,FTN.    DEFAULT OBJ PROG NAME 
PPNK3 DEF KK36
PPNK4 DEF F.INT 
INITB DEF F.AT.     INIT. TO 0 AREA BEGIN ADDR. 
EN    ASC 2,END$
* 
PRNM  DEF *+1       PROTO NAM RECORD
K17.  DEC 17,0,0,0,0,0,0,0,0,3,99,0,0,0,0,0,0 
K13   DEC 13
B60   OCT 60
DTYP  DEF *+1 
BLNK  ASC 4,                  BLANKS HAPPEN TO BE REAL (A-H)
      OCT 10020,10020,10020   THESE ARE INTEGER        (I-N)
      ASC 6,                  MORE REALS               (M-Z)
K1    DEC 1 
K7    DEC 7 
KK36  OCT -1000,-2000,-3000,-4000,-5000,-6000,-7000 
K14   DEC 14
K20   DEC 20
K25   DEC 25
F.CRB NOP           CARD BUFFER ADDRESS 
"$"   OCT 44
**
* 
LSE.F NOP           LOCAL SEGMENT NAME FINDER 
      LDA LSE.F,I    TO FIND ALL BUT
      ISZ LSE.F      SEGMENT 2
      LDA A,I       GET NUMBER OF REQUESTED SEGMENT 
      CPA K4        IGNOR 4 (CURRENT) 
      CLA 
      CPA K2        AND 2 
      CLA           SET TO 0
      STA LS2.F     SET FOR CALL
      JSB SEG.F     CALL THE EXTERNAL NAME FINDER 
      DEF LS2.F 
      JMP LSE.F,I   RETURN
* 
* 
LS2.F NOP           ROUTINE TO FINE NAME OF SEGMENT 2 ONLY
      JSB SEG.F     USE EXTERNAL NAME FINDER
DSNO  DEF K2        PASS 2 AT ALL TIMES 
      ISZ LS2.F 
      JMP LS2.F,I   RETURN
* 
INERR JSB OPN.C     ERROR ON SOURCE FILE  TRY LIST
      DEF C.LST 
      JMP TRMSL     IF PROBLEMS SKIP ON OUT 
* 
      LDA K67       INPUT FILE PROBLEMS 
ABT   JSB BOM.F     DISASTOR SEND THE MESSAGE 
TRM   LDA F.CCW     CHECK IF BINARY FILE
      AND B40       IF SO 
      SZA,RSS       THEN
      JMP NXBIN 
* 
      JSB EOF.C     MUST EOF ON IT
      DEF C.BIN 
      JMP EOFBE     ERROR  REPORT IT
* 
NXBIN DLD F.ERN+1   ACCUMULATE THE ERROR TOTALS 
      ADA F.ERF 
      ADB F.ERF+1 
      STA ERMX      SET THE NUMBER OF ERRORS
      STB TOTER     AND THE TOTAL ERROR COUNT 
      LDA BOM.F     DISASTOR EXIT?
      SZA           SKIP IF NOT 
      CLA,INA       SET DISASTOR COUNT OTHERWISE
      STA DISCT     PUT COUNT IN MATRIX 
      ADA ERMX      SUBTRACT
      CMA,INA       THE ERRORS FROM THE TOTAL COUNT 
      ADA B         TO GET THE WARNINGS 
      STA WAR       SET THE # OF WARNINGS 
      JSB EOF.C     CLOSE THE LIST FILE 
      DEF C.LST 
      JMP EOFLI     IF ERROR REPORT IT
* 
TRM1  CLA           CLEAR 
      CLB           THE ERROR COUNTERS
      DST F.ERN+1   FOR POSSIBLE RE RUN 
      STA F.STA     ALSO THE BEEN HERE FLAG 
      LDA DISCT     GET THE DISASTER COUNT
      JSB ASC.F     CONVERT IT
      CPA "00"      IF NONE 
      LDA "NO"      USE NO
      STA ENMES+6    SET IN THE MESSAGE 
      DLD "NOX" 
      DST ENMES+12
      DST ENMES+18
      LDA ERMX      GET THE ERROR COUNT 
      SZA,RSS       IF NONE 
      JMP EXIT2     SKIP
* 
      JSB ASC.F     ELSE CONVERT IT 
      STA ENMES+13   SET
      STB ENMES+12   IN THE MESSAGE 
EXIT2 LDA WAR       GET THE WARNNING COUNT
      SZA,RSS       IF NONE 
      JMP EXIT3     SKIP
* 
      JSB ASC.F     CONVERT IT
      STA ENMES+19
      STB ENMES+18
EXIT3 JSB WRT.C     SEND THE NEWS 
      DEF C.TTY     TO THE TTY
      DEF ENMES 
      DEF K25 
      NOP           IGNOR ERRORS
EXIT  JSB END.C     END IT ALL
      DEF TOTER     SEND THE ERROR MATRIC 
      JMP EXIT      TRY AGAIN IF CLOSE ERROR
* 
TOTER NOP 
DISCT NOP           ERROR MATRIX
ERMX  NOP 
WAR   NOP 
      DEC 2026      DATE CODE 
* 
TRML  LDA K14       GET COUNT FOR MESSAGE 
      RSS           SKIP DOUBLE FAILURE 
TRMSL LDA K20       BOTH SOURCE AND LIST FAILED TO OPEN 
      CLB           CLEAR THE 
      STB ERMX      ERROR 
      STB WAR       AND WARNING COUNTS
      STB TOTER 
                                                                                                                                                                                                                                          