ASMB,R,L
      HED RTE-M FORTRAN--SEGMENT 1--PASS 1
      NAM FTN1,5 92064-16046  REV.1650  761118
      SUP 
* 
* 
*   ********************************************************* 
*   * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1976.           * 
*   *                                                       * 
*   * ALL RIGHTS RESERVED.  NO PART OF THIS PROGRAM MAY BE  * 
*   * PHOTOCOPIED, REPRODUCED, OR TRANSLATED TO ANOTHER     * 
*   * PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN CONSENT OF * 
*   * HEWLETT-PACKARD COMPANY.                              * 
*   ********************************************************* 
* 
* 
      ENT FTN1
* 
      EXT .STOP,POST,FCONT,LIMEM,READF,WRITF,TERM 
      EXT IDCB0,IDCB2,IDCB3,FMPER,SEGLD,IMESS 
* 
      COM TCLIS 
      COM MCBUF(40) 
      COM PTYPE 
      COM BUFAD 
      COM OPT(3)
      COM ...T
* 
      COM AI(6),AO(6),AL(6),AS1(6)
      COM ERRS,OPTS1,OPTS2,OPTS3,NAME,LINES 
      COM FDVL,OPT4 
* 
* 
* 
* 
      SKP 
BUFOR DEF MCBUF     MULTI-COMPILE BUFFER
BUFND DEF MCBUF+40  END OF BUFFER +1
MOVA. DEF MOVA      MOVA ENTRY POINT
DOND  DEF DOEN      LWA+1 OF DO-TABLE 
MDOAD DEF DOAD      BEGIN OF DO-TABLE 
WPREV BSS 2 
.TEMP BSS 5 
RS1   EQU .TEMP 
RS2   EQU .TEMP+1 
RS3   EQU .TEMP+2 
RS4   EQU .TEMP+3 
REOSF EQU .TEMP+4 
      BSS 1 
* 
TILT  EQU *         CORE OVERFLOW ERROR 
      JSB LNK20,I   DO END,END$ SEQUENCE
* 
STYPE BSS 1         STATEMENT TYPE (SET BY SCANNER) 
TYPE  EQU STYPE 
LABL  BSS 3         ADDITIONAL INPUT FOR PUTAWAY
BCLIS BSS 1         BOTTOM OF TEMP CONLIST
HIGH  EQU BCLIS 
FWA   BSS 1         FWA OF ALPHA OR BETA
FWBET EQU FWA 
LFWA  EQU FWA 
RFWAN EQU FWA 
LWA   BSS 1         LWA+1 OF ALPHA OR BETA
ALFA  EQU LWA 
LLWA  EQU LWA       TOP OF USED CORE
NWBET EQU LWA 
ENTRY DEF START     ENTRY POINT ADDR.OF CONTROL1, 
*                   4=REAL FUNCTION 
PTYP  EQU PTYPE 
*                   OPT - OPTION FLAGS: 0 FOR NONE
*                   NE.0 FOR OPTION. ORDER: LIST. 
*                   ASSEMBLY LIST, BINARY OUTPUT
C1    OCT 52000 
C2    OCT 100       FUNCTION CODE FOR EOF 
* 
*                BEGIN COMPILATION HERE.
* 
*     FTN0, USED AT THE START OF EACH PASS, REWINDS 
*     THE READ POINTER ON THE FORTRAN MIDDLE OUTPUT FILE
*     AND THEN BRANCHES TO THE LOCATION : ENTRY.
* 
FTN1  CLA           INITIALIZE
      STA OPT4       COMMON 
      LDA C1
      STA ...T
* 
* 
NOREW LDA BUFOR     GET MULTI-COMPILE BUFFER ORIGIN 
      STA BUFAD      TO USE FOR BUFFER. 
      JMP ENTRY,I   JMP TO START PASS 1 
      SKP 
* 
*     L I S T 
* 
*     WRITES RECORD TO LIST FILE OR CAUSES PAGE EJECT.
* 
*     LDA WDCNT(-1 FOR PAGE EJECT)
*     LDB ADDRESS OF BUFFER 
*     JSB LIST
* 
LIST  NOP 
      STA SAVE1     SAVE A-REG
      LDA PNT01     INITIALIZE FMP ERROR
      STA NAME       FILE NAME POINTER
      LDA SAVE1     RESTORE A-REG 
      SSA 
      JMP PEJ 
      SZA,RSS 
      JMP PSKP
      CMA,INA 
      STA PBUFL 
      STB PBUFF 
* 
      JSB WRITF     WRITE A 
      DEF PLST1      RECORD TO
      DEF IDCB2       THE LIST
      DEF ERRS         FILE 
PBUFF BSS 1 
      DEF PBUFL 
PLST1 EQU * 
      SSA           ERROR OCCUR?
      JMP FMPER     YES.GO REPORT IT
      ISZ LCOUT     NO.DONE A PAGE? 
      JMP LIST,I    NO.RETURN 
      LDA LINES     YES.RE-INITIALIZE 
      STA LCOUT      THE LINE COUNTER 
      CCA           GO EJECT
      JMP PEJ        A PAGE 
* 
PNT01 DEF AL+1      LINK TO LIST FILE NAME
PBUFL NOP 
SAVE1 NOP 
LCOUT BSS 1         LINES PER PAGE COUNTER
      SKP 
* 
PSKP  CLA,INA 
PEJ   STA PPRAM 
      JSB FCONT     DO A
      DEF PSKP1      PAGE 
      DEF IDCB2       EJECT 
      DEF ERRS
      DEF PCNW1 
      DEF PPRAM 
PSKP1 EQU * 
      SSA,RSS       ERROR OCCUR?
      JMP LIST,I    NO.RETURN 
      LDA ERRS      YES.IS IT 
      CMA,INA        FMP ERROR
      CPA O14         -012? 
      JMP LIST,I    YES.RETURN
      JMP FMPER     NO.REPORT ERROR 
* 
PCNW1 OCT 1100
PPRAM NOP 
      SKP 
* 
****************************************************
* 
XSTOP BSS 1 
AESIZ BSS 1         SIZE OF ASF-ERAS.STORAGE
ALOC  BSS 1         SIZE OF PROG.FOR DECLAR.CODE
ARSIZ BSS 1         SIZE OF COMBINED ARRAYS 
ASFLG BSS 1         ASF-FLAG,NE.0 : ASF PROCESSING
CLOC  BSS 1         SIZE OF COMMON
CONAD OCT 0         ADDEND TO STATEMENT LABEL.
DVLS1 BSS 1         CURRENT ADDR.IN SYMBOL TABLE
LDVL  EQU DVLS1 
RALFI EQU LDVL
ERCNT BSS 1         ERAS.COUNT (ASF AND PROGRAM ) 
ERSIZ BSS 1         SIZE OF PROG.-ERAS.STORAGE
FNLIS DEF FNTAB     FWA OF INTRINSIC FUNC.TABLE 
FNLS1 DEF FNTB1     FWA OF EXT. FUNCTION TABLE
LABEL BSS 1         STATEMENT LABEL VALUE 
LBCNT BSS 1         INTERNAL-LABEL COUNT (10000 UP) 
LBORD BSS 1         CURRENT LABEL ORDINAL 
LOCNT BSS 1         LOCATION COUNTER
LVORD BSS 1         CURRENT LOCAL VAR.ORDINAL 
MODE  BSS 1         MODE OF ARITHMETIC FOR PUTAWAY
PREVS OCT 0         STATEMENT TYPE OF PREVIOUS
*                                  EXECUTABLE STATEMENT 
RTYPE BSS 1         1=PUTAWAY CODE,2=BETA CODE,3= 
*                   SOURCE LIST+ DIAGNOST.,4=DVLIS
*                   (MULTI-COMPILE) 
SFPAD BSS 1         -(NO.OF PARAMS+1) FOR ASF.USED
*                                  IN PUTAWAY,SET IN ASF PROCESSOR
TDVL  BSS 1         CONTAINS FWA OF TEMP SYMBTAB IN 
*                                  PASS 1,FWA OF POINTER TABLE
*                                  IN PASS 2
* 
* LINKS IS THE TABLE OF ENTRY POINT ADDRESSES.
* IT IS ALSO USED AS JUMP-TABLE IN CONTROL. 
* 
LINKS DEF MSP11     FORMAT
LNK1  DEF MSP6      IF
LNK2  DEF MSP4      GOTO N
LNK3  DEF MSP5      GOTO ( ),N
LNK4  DEF MSP2      STOP
LNK5  DEF MSP1      PAUSE 
LNK6  DEF MSP3      RETURN
FORMT DEF M3SFR     FORMAT (NO JUMPS) 
LNK8  DEF MSP9      CALL
LNK9  DEF MSP7      DO (BEGIN)
LNK10 DEF WARTH     ARITH 
MPYA  DEF .MPYA     MPY: DECPRO+PRO ALPHA 
LNK12 DEF LSTIO     I/O 
LNK13 DEF LSTIO     I/O 
LNK14 DEF LSTIO     I/O 
LNK15 DEF LSTIO     I/O 
LNK16 DEF LSTIO     I/O 
LNK17 DEF LSTIO     I/O 
LNK18 DEF LSTIO     I/O 
LNK19 DEF MSP10     END 
LNK20 DEF FINS1     END$
LNK21 DEF MASF1     ASF 
LNK22 DEF SCAN      SCANNER 
LNK23 DEF NEST      DECLAR. PROCESSOR 
LNK24 DEF PRA       PROCESS ALPHA 
LNK25 DEF WPRB      PROCESS BETA
LNK26 DEF WSSEV     SUBSCRIPT EVALUATOR 
LNK27 DEF WRITB     WRITE 
RROUT DEF ASCQ      ASCN
LNK29 DEF MSP8      END DO
LNK30 DEF MSP7A     IMPLIED DO
MPUT1 DEF PUTA      PUTAWAY 
LNK32 DEF MDOTL     DO-TAB SEARCH ROUTINE 
LNK33 DEF FINIS     END$ PROCESSING 
LNK34 DEF SDVL      SEARCH DECL VAR 
LNK35 DEF ECSUB     CONSTANT ROUTINE
LNK31 EQU MPUT1 
* 
.CON0 OCT 0 
O1    OCT 1 
O2    OCT 2 
O3    OCT 3 
O4    OCT 4 
O5    OCT 5 
O6    OCT 6 
O7    OCT 7 
O10   OCT 10
O11   OCT 11
O12   OCT 12
O13   OCT 13
O14   OCT 14
O15   OCT 15
O16   OCT 16
O17   OCT 17
O20   OCT 20
O21   OCT 21
O22   OCT 22
O23   OCT 23
O25   OCT 25
O26   OCT 26
O27   OCT 27
O30   OCT 30
O31   OCT 31
O32   OCT 32
O33   OCT 33
O34   OCT 34
O35   OCT 35
O36   OCT 36
O37   OCT 37
O40   OCT 40
O44   OCT 44
O52   OCT 52
O377  OCT 377 
O400  OCT 400 
O4000 OCT 4000
M1    OCT -1
M2    OCT -2
M3    OCT -3
M4    OCT -4
MO100 OCT -100
.MU1  OCT 177400    UPPER 8-BITS
IBIT  OCT 100000
M5    OCT -5
M6    OCT -6
M7    OCT -7
M8    DEC -8
M9    DEC -9
O77   OCT 77
MLBLM DEC -10000
MD1K  DEC -1000 
MD100 DEC -100
MD10  DEC -10 
RLW4Z OCT 177760
MC01  OCT 140000
MC02  OCT 40000 
MC03  OCT 37777 
W6060 OCT 30060     CONVERSION FACTOR TO ASCII
MPAR  OCT 37400 
* 
A     EQU 0 
B     EQU 1 
* 
***  BETA-FORMATS *** 
* 
W.PLS OCT 11001     + 
W.MIN OCT 21001     - 
W.TMS OCT 32001     * 
W.SLS OCT 42001     / 
W.EXP OCT 54001     **
W.EQ  OCT 67401     = 
W.LP  OCT 100002    ( 
W.RP  OCT 140002    ) 
W.LPC OCT 100042    ( FOR CONST SUBSCRIPT 
W.LPV OCT 100022    (-BASE FOR VARIABLE SUBSCRIPT 
W.CMA OCT 40002     , 
W.RPC OCT 140042    ) FOR CONST. SUBSCR 
      SKP 
* 
*CNASC CONVERTS A BINARY NUMBER LT.10000 TO ASCII.
*ENTER:A= NUMBER. RETURNS: A,B = ASCII CODE 
* 
CNASC NOP 
      LDB MD1K      -1000D
      JSB WGETD     GET 1ST DIGIT 
      STB CEQS
      LDB MD100     -100D 
      JSB WGETD     2ND DIGIT 
      STB CENTR 
      LDB MD10      -10D
      JSB WGETD     3RD DIGIT 
      STB CSFRM 
      STA RCEQS 
      LDA CEQS
      ALF,ALF 
      ADA CENTR     ADD IN 2ND DIGIT
      LDB CSFRM     3RD DIGIT 
      BLF,BLF 
      ADB RCEQS     ADD IN 4TH DIGIT
      ADA W6060     CONVERT TO ASCII
      ADB W6060 
      JMP CNASC,I 
* 
*WGETD SUPPLIES THE MOST SIGNIFICANT DEC.DIGIT FOR A
*BINARY VALUE. ENTER: A=VALUE,B=-VALUE TO CNMPARE 
*AGAINST.RETURNS: A=REMAINDER, B= DIGIT 
* 
WGETD NOP 
      STB CSAVE+1   SAVE COMPARISON VALUE 
      CLB           0 TO DIGIT
WGTD1 STA CSAVE     SAVE REMAINDER
      ADA CSAVE+1 
      SSA           LARGER ?
      JMP WGTD2     NO,READY
      INB           YES, BUMP DIGIT IN B
      JMP WGTD1     CONTINUE
* 
WGTD2 LDA CSAVE     A=REMAINDER 
      JMP WGETD,I   EXIT
      SKP 
* 
*ERRR IS THE ERROR-DIAGNOSTIC WRITE ROUTINE FOR 
*PASS1 AND PASS 2. ENTER WITH A= ERROR CODE. THE OUT
*PUT FORMAT IS:E-CODE: LABL +ADDEND,WHERE ALL NUMERIC 
*FIELDS HAVE 4 DECIMAL DIGITS.
* 
ERRR  NOP 
      STA SAVE2     SAVE ERROR CODE 
      JSB CNASC     CONVERT CODE TO ASCII 
      STA ERBUF+1 
      STB ERBUF+2 
      LDA LABEL 
      JSB CNASC     CONVERT LABEL TO ASCII
      STA ERBUF+4 
      STB ERBUF+5 
      LDA CONAD 
      JSB CNASC     CONVERT ADDEND TO ASCII 
      STA ERBUF+7 
      STB ERBUF+8 
      LDA O3
      STA RTYPE     RECORD TYPE=3 FOR ASCII OUTPUT
      LDA O22       NO. OF CHARS=18 
      LDB ERBUF-1   ADDR. OF ERBUF
      JSB LNK27,I   WRITE ERROR DIAGNOSTIC (WRITB)
      LDA SAVE2     WAS IT SYMBOL 
      CPA O16        TABLE OVERFLOW?
      JMP SYMEX     YES.GO TERMINATE FTN
      JMP ERRR,I    NO.EXIT 
* 
      DEF *+1 
ERBUF ASC 1,E-
      BSS 2 
      ASC 1,: 
      BSS 2 
      ASC 1, +
      BSS 2 
SAVE2 BSS 1         TEMPORARY STORAGE 
      SKP 
* 
*CEQS SEARCHES CONLIST. TCLIS= TOP OF CONLIST +1. 
*ENTER CEQS WITH A=CONSTANT VALUE,B= ADDR.POINTER IN
*CONLIST. ALT.EXIT  IS TO CALLING ADDR.+2 WHEN NO 
*EQUALITY IS FOUND. 
* 
CEQS  NOP 
      CPB TCLIS     TOP OF CONLIST+1
      JMP CEQS1     YES,NOT FOUND 
      CPA 1,I       EQUALITY ?
      JMP CEQS,I    YES,NORMAL EXIT 
      INB           NO,CONTINUE SEARCH
      JMP CEQS+1
* 
CEQS1 ISZ CEQS      BUMP RETURN ADDR. FOR 
      JMP CEQS,I    ALTERNATE RDTURN
* 
*ICEQS IS THE INTEGER CONSTANT LOOK-UP AND INSERT 
*ROUTINE. ENTER WITH: A=CONST.VALUE. IT RETURNS THE 
*ALPHA(BETA) FORMAT OF THE CONST.IN A. IN CASE OF 
*CORE OVERFLOW A JMP TO TILT IS EXECUTED. 
* 
ICEQS NOP 
      LDB BCLIS     BOTTOM OF CONLIST 
      JSB CEQS      SEARCH FOR INT CONST. 
      RSS           FOUND,GET FORMAT
      JSB CENTR     NOT FOUN(,ENTER CONST 
      LDA O3        B=ADDR OF CONST, A=3 FOR INT CONV 
      JSB CSFRM     FORM CONST. FORMAT IN B 
      JMP ICEQS,I   EXIT WITH FORMAT IN B 
* 
      SKP 
* 
*CENTR ENTERS A CONST.IN CONLIST AT (BCLIS)-1. IT 
*JUMPS TO TILT IN CASE OF CORE OVERFLOW. IT RETURNS 
*B= ADDR OF CONST 
* 
CENTR NOP 
      CCB 
      ADB BCLIS 
      CPB LWA       EQUAL TO LOW CORE?
      JMP TILT      YES,CORE OVERFLOW 
      STB BCLIS     SET NEW VALUE FOR BCLIS 
      STA 1,I       ENTER CONST.
      JMP CENTR,I 
* 
*CSFRM FORMS A CONST FORMAT. THE ADDR.OF THE CONST
*IS IN B UPON ENTRY, A= CLASS IDENT. (1 FOR INT. CON.,
*21B FOR REAL CONST.) 
* 
CSFRM NOP 
      CMB           COMPLEM-1 
      ADB TCLIS     POINTER= TCLIS - ADDR.-1
      BLF 
      RBL,RBL       SHIFT POINTER TO UPPER 10 BITS
      ADA 1         ADD IN CLASS IDENT (1=INT,21=RL)
      JMP CSFRM,I   EXIT
      SKP 
* 
*RCEQS IS THE REAL CONST LOOKUP AND INSERT ROUTINE
*ENTER WITH THE CONST IN A,B. IT RETURNS THE INT. 
*FORMAT IN A. A JMP TO TILT IS EXECUTED IN CASE OF
*CORE OVERFLOW. 
* 
RCEQS NOP 
      STA CSAVE     SAVE CONST
      STB CSAVE+1 
      LDB BCLIS     BOTTOM OF CONLIST 
RCEQ2 JSB CEQS      SEARCH FOR UPPER PART 
      JMP RCEQ1    FOUND, TEST LOWER PART 
RCEQ3 LDA CSAVE+1   NOT FOUND,ENTER LOWER PART
      JSB CENTR 
      LDA CSAVE     ENTER UPPER PART
      JSB CENTR 
      LDA O23       23B=CLASS IDENT. FOR REAL CONST.
      JSB CSFRM     GET FORMAT IN A 
      JMP RCEQS,I   EXIT
* 
RCEQ1 INB           BUMP ADDR 
      CPB TCLIS     TOP OF CONLIST ?
      JMP RCEQ3     YES,NOT FOUND 
      LDA CSAVE+1   LOWER PART OF CONST.
      CPA 1,I       EQUALITY ?
      JMP *+3       YES,FINISH
      LDA CSAVE     RESTORE A=UPPER PART OF CONST 
      JMP RCEQ2        CONTINUE SEARCH
      ADB M1        ADDR. BACK TO FWA 
      JMP RCEQ3+4   GET FORMAT AND EXIT 
* 
CSAVE BSS 2 
      SKP 
* 
*WFCS FETCHES A REAL CONST. ENTER WITH B=ADDR.OF
*CONST. FORMAT IN BETA. RETURNS CONST. IN A AND B.
* 
WFCS  NOP 
      LDB 1,I       CONST. FORMAT IN B
      JSB WFCS1     GET CONST IN A AND B
      JMP WFCS,I
* 
*WFCS1 FETCHES A REAL CONST.FROM TEMP.CONLIST 
* 
WFCS1 NOP 
      JSB WPFAD     GET POINTER 
      CMA 
      ADA TCLIS     LWA+1 OF TEMP CONLIST 
      LDB 0 
      INB           SET B= ADDR.OF LOWER PART 
      LDA 0,I       UPPER PART
      LDB 1,I       LOWER PART
      JMP WFCS1,I   EXIT
* 
*SDVLL SEARCHES SYMBTAB FOR A LABEL FOR WHICH THE 
*VALUE IS SUPPLIED THROUGH A. IT RETURNS:THE DVLIST 
*ORD.IN A OR -1,IF NOT FOUND,AND B= LOC.OF LABEL REL
*ADDR.IN SYMBTAB ENTRY
* 
SDVLL NOP 
      STA EDVLL     SAVE VALUE OF LABEL 
      LDB FDVL      FWA OF DECLARED VAR LIST
SDVL1 CPB LDVL      END OF SYMBOL TABLE ? 
      JMP SDVL2     YES,LABEL NOT FOUND 
      LDA 1,I       NO, TEST
      SZA           LABEL ? 
      JMP SDVL3     NO,CONTINUE SEARCH
      INB           YES,BUMP POINTER
      LDA 1,I       GET LABEL VALUE 
      INB           BUMP POINTER FOR RETURN 
      CPA EDVLL     SAME VALUE ?
      JMP SDVLL,I   YES,EXIT
      ADB M2        NO, -2 TO RESET AT ENTRY-FWA
SDVL3 JSB NDVLE,I   GET FWA OF NEXT ENTRY 
      JMP SDVL1     CONTINUE SEARCH 
* 
SDVL2 CCA           A=-1 TO INDICATE NO FIND
      JMP SDVLL,I   EXIT
* 
      SKP 
*EDVLL INSERTS A LABEL IN SYMBTAB. ENTER WITH VALUE 
*OF LABEL IN A. RETURNS WITH B=ADDR.IN SYMBTAB OF 
*REL.LOC.OF LABEL. IN ADDITION EDVLL WILL MOVE BETA 
*+ POINTER TABLE+ TEMP.CONLIST,SET INC= 4,AND ADD 4 
*TO FWAPT,FWA,LWA,AND HICOR. IN THIS PROCESS IT WILL
*CHECK FOR (HICOR) GE.(BCLIS).CORE OVERFLOW IF TRUE.
* 
EDVLL NOP 
      CLB 
      STB DVLS1,I   0 TO 1ST WORD IN ENTRY
      ISZ DVLS1     BUMP ADDR.
      STA DVLS1,I   SET VALUE IN ENTRY
      ISZ DVLS1     BUMP ADDR.IN DVLIS
      CCA 
      STA DVLS1,I   -1 TO UNDEFINE REL.ADDR.
      ISZ DVLS1 
      LDA LBORD 
      STA DVLS1,I   SET LABEL ORD.IN ENTRY
      ISZ LBORD     BUMP LABEL ORDINAL COUNT
      ISZ DVLS1     BUMP POINTER
      ISZ DORDT     BUMP ORDINAL COUNTER FOR DVLIS
      LDA FWA 
      CMA,INA 
      ADA DVLS1 
      SSA,RSS       CORE OVERFLOW IF SYMBOL 
      JMP TILT      TABLE GROWS BEYOND FWA OF BETA
      LDB DVLS1 
      ADB M2        -2 TO GET ADDR. OF LABEL ADDR.
      JMP EDVLL,I   EXIT
* 
      SKP 
*SCATR SCATTERS A SYMBTAB ENTRY FOR WHICH THE BETA
*FORMAT IS GIVEN IN A. IT RETURNS: A= ADDR.+1 OF
*ENTRY IN SYMBTAB, B= NO.OF WORDS IN NAME OF ENTRY+1
*OTHER VALUES THROUGH PARAMETERS. 
* 
SCATR NOP 
      LDB 0         FORMAT TO A FOR WPFAD 
      JSB WPFAD 
      CMA,INA 
      STA CSAVE     SET COUNT 
      LDA FDVL      FWA OF DVLIS
      JSB NENT      GET FWA OF NEXT ENTRY 
      ISZ CSAVE     READY?
      JMP *-2       NO,GET NEXT ENTRY 
      STA CSAVE     YES, SAVE FWA OF ENTRY
      INA 
      STA CSAVE+1   SAVE FWA+1
      LDA CSAVE,I   1ST WORD IN ENTRY 
      RAL,RAL 
      AND O3
      STA V         SET V-FIELD 
      ADA M3
      STA SDVLL     SAVE FLAG 
      LDA CSAVE,I 
      AND O7        GET NO. OF CHARS. 
      ADA O3
      ARS 
      STA WFCS      SAVE NO.OF WORDS IN NAME +1 
      ADA CSAVE+1   A=ADDR. OF ORD
      LDB 0,I 
      STB ORD       SET ORDINAL 
      LDB 0 
      LDA CSAVE,I 
      ALF,ALF 
      AND O77 
      STA PARAM     PARAMETER NUMBER
      SZA,RSS       FORMAL PARAM
      INB           NO,BUMP TO NEXT DVL-LOC 
      LDA 1,I 
      STA DIM1      SET 1ST DIM 
      ISZ SDVLL     ONE DIMENSION?
      INB 
      LDA 1,I 
      SKP 
      STA DIM12     DIM1*DIM2 (=DIM1 IF 1 DIM)
      LDA CSAVE,I 
      AND O20 
      STA T         T-FIELD VALUE (0 OR 20B)
      LDA CSAVE,I 
      AND O10 
      STA CBIT      C-FIELD VALUE (0 OR 10B)
      LDA CSAVE,I 
      ALF,ALF 
      RAL,RAL 
      AND O3
      STA F         F-FIELD VALUE (0-2) 
      LDA CSAVE+1   A= ADDR.OF ENTRY +1 
      LDB WFCS      B= NO.OF WORDS+1 IN NAME
      JMP SCATR,I   EXIT
* 
V     BSS 1         V-FIELD VALUE:0 THRU 3
PARAM BSS 1         PARAM NUMBER:1 THRU 63,OR 0 
F     BSS 1         F-FIELD VALUE:0 THRU 2
T     BSS 1         TYPE:0=INTEGER,20B= REAL
CBIT  BSS 1         COMMON-BIT: 1=COMMON, 0=PROG. 
ORD   BSS 1         REL.PROG.ADDR.OF FWA OF ARRAY 
DIM1  BSS 1         VALUE OF 1ST DIMENSION
DIM12 BSS 1         DIM1 * DIM2 
FFLAG BSS 1         FORMAT FLAG 
DORDT BSS 1         MAX. ORDINAL
FWAPT DEF LFNTB    FWA OF POINTER TABLE(4K ONLY)
      SKP 
*GETS POINTER OF BETA FORMAT. ENTER WITH B=BETA 
*FORMAT. RETURNS A=POINTER
* 
WPFAD NOP 
NOCHR EQU WPFAD 
      LDA 1 
      AND MO100     GET UPPER 10 BITS 
      ALF,ALF 
      RAL,RAL       SHIFT 10
      JMP WPFAD,I   EXIT
* 
*LOKUP LOOKS UP AN ENTRY IN SYMBTAB. ENTER WITH B=
*BETA FORMAT. RETURNS: A=(FWA OF ENTRY) +1,B= NO. 
*OF LOCS IN SYMBOL NAME 
* 
LOKUP NOP 
      LDA 1         OPERAND TO A
      JSB SCATR     CRACK SYMBTAB ENTRY 
      JMP LOKUP,I 
* 
**FIND LOC OF NEXT ALPHA ENTRY**********
* ENTER  A= LOC ALPHA 
* EXIT   A= LOC NEXT ALPHA
* 
NELM  NOP 
      STA LOKUP     SAVE A = CURRENT ALPHA ADDR 
      LDA 0,I       1ST WORD
      ALF,ALF 
      ALF      NO CHAR
      AND O17       MASK TO 4 BITS
      STA NOCHR     NO OF CHARS 
      ADA M6
      SSA           GT 5 ?
      JMP *+3       NO,EXIT 
      LDA O4        YES, ERROR IN NAME
      JSB ERRR      PRINT ERROR 
      LDA NOCHR     RELOAD NO OF CHARS
      ARS      NO CHAR/2+1 IS NO WORDS
      INA 
      ADA LOKUP     +LOC = NEXT LOC 
      JMP NELM,I
      SKP 
*FIND NEXT DVL ENTRY *********
*ENTER A= LOC DVL  EXIT A=LOC NEXT ENTRY
* 
NENT  NOP 
      LDB 0 
      JSB NDVLE,I 
      LDA 1 
      JMP NENT,I
* 
NDVLE BSS 1         LOC OF ROUTINE SET TO ADD 8 OR
*                   COMPUTE NEXT LOC BY DECL PROC 
* 
* 
*PERMANENT STORAGE
EPAR  BSS 1 
*INTERMEDIATE STORAGE 
LNWA  BSS 1 
NWALF EQU LNWA
TEMP  BSS 4 
ALEN  EQU TEMP
CFLG  EQU TEMP+1
PFWA  BSS 1 
NWCE  BSS 1 
BWCE  BSS 1 
CWCE  BSS 1 
SBCE  BSS 1 
LSYM  BSS 1 
MTLDO NOP 
                                                                                                                