*                                *
**  CODE TO COMPUTE AN ELEMENT  **
*                                *
MADD  JSB .FAD      ADD 
      DEF BS3,I       SOURCE
      JMP MLOP1         ELEMENTS
* 
MSUB  JSB .FSB      SUBTRACT
      DEF BS3,I       SOURCE
      JMP MLOP1         ELEMENTS
* qq
IDN   ISZ ID1       DIAGONAL ELEMENT? 
      JMP MLOP3     NO
      LDA ID0       YES, RESET
      STA ID1         DIAGONAL COUNTER
      DLD F1.0      LOAD
      JMP MLOP3       1.0 
* *q
SMULT JSB .FMP      MULTIPLY
      DEF SCALR       SOURCE ELEMENT
      JMP MLOP2         BY SCALAR 
* 
MCPY  SSA           GET 
      JSB ARINV       ABSOLUTE
      DST SCALR         VALUE 
      JSB .FSB      SUBTRACT
      DEF MAXE        PREVIOUS
      SZA               MAXIMUM 
      SSA           POSITIVE RESULT?
      JMP MCPY1     NO
      DLD SCALR     YES, RECORD 
      DST MAXE        NEW MAXIMUM 
MCPY1 DLD BS2,I     RELOAD VALUE
      JMP MLP2A,I 
**                              **
***  CHECK VALIDITY OF MATRIX  ***
**                              **
* *q
*  ENTER WITH (B) POINTING TO THE DYNAMIC ARRAY DIMENSIONS. 
*  COMPUTE THE NUMBER OF ELEMENTS AND CHECK EACH ONE.  EXIT 
*  TO ERROR IF ANY ELEMENT HAS VALUE 'UNDEFINED'. 
* 
#VCHK LDA 1,I       LOAD ROW DIMENSION
      INB 
      STB VT0 
      MPY VT0,I     MULTIPLY BY 
      LDB VT0         COLUMN DIMENSION
      CMA           SAVE 1'S COMPLEMENT 
      STA VT0         OF MATRIX SIZE
VCHK1 ISZ VT0       DONE? 
      INB,RSS       NO, MOVE TO NEXT ELEMENT
      JMP VCHK,I    YES 
      LDA 1,I 
      RAL,RAL       IS
      INA             OPERAND 
      RAR,SLA           NORMALIZED? 
      JMP VCHK2     YES 
      CPA BIT15     MAYBE, WAS FIRST WORD ZERO? 
      INB,RSS       YES 
      JSB RERRS+23,I NO--ERROR
      LDA 1,I       SECOND
      SZA             WORD ZERO?
      JSB RERRS+23,I NO--ERROR
      JMP VCHK1 1%
VCHK2 INB 
      JMP VCHK1 
*                                                                B] 
**                          **
***  REDIMENSION A MATRIX  ***
**                          **
* *q
*  UPON ENTRY (TEMP1)+1 POINTS TO THE REDIMENSION SUBSCRIPT IN
*  THE PROGRAM AND SBPTR POINTS TO THE CURRENT DYNAMIC DIMENSIONS 
*  OF THE ARRAY.  THE SUBSCRIPT BOUNDS ARE EVALUATED, ROUNDED,
*  AND RECORDED.  IF THE NUMBER OF ELEMENTS IS WITHIN THE 
*  PHYSICAL ARRAY ALLOWANCE, EXIT WITH TEMP1 POINTING TO THE
*  WORD FOLLOWING THE SUBSCRIPT AND SBPTR AS UPON ENTRY, ELSE 
*  EXIT TO ERROR. 
* qq
#RDIM ISZ TEMP1     COMPUTE NEW 
      JSB FETCH       ROW DIMENSION 
      JSB SBFIX     15 BIT INTEGER > 0? 
      JSB RERRS+17,I  NO
      INB           YES, SAVE 
      STB RD0       VALUE IN TEMP               (D) 
      LDB TEMP1,I   EXPLICIT NEW
      SZB,RSS         COLUMN DIMENSION? 
      JMP RDIM1     NO
      JSB FETCH     YES,
      JSB SBFIX       COMPUTE 
      JSB RERRS+17,I    IT
RDIM1 INB           SAVE TRUE VALUE 
      STB SBFIX       IN TEMP                   (D) 
      LDA RD0       COMPUTE 
      MPY SBFIX       NUMBER OF                 (D) 
      SZB,RSS           ELEMENTS
      CMA,SSA,INA,RSS     SPECIFIED 
      JSB RERRS+25,I  TOO MANY
      STA FETCH                                 (D) 
      LDB SBPTR     RESET 
      ADB .-2         ARRAY POINTER             (D) 
      LDA 1,I           AND COMPUTE 
      INB                 NUMBER OF 
      MPY 1,I               ELEMENTS AVAILABLE  (D) 
      ADA FETCH     SUFFICIENT                  (D) 
      SSA            PHYSICAL SPACE?
      JSB RERRS+25,I  NO
      LDB SBPTR     OK, REPLACE THE             (D) 
      LDA RD0       OLD DIMENSIONS              (D) 
      STA 1,I       WITH THESE                  (D) 
      INB           NEW DIMENSIONS              (D) 
      LDA SBFIX                                 (D) 
      STA 1,I                                   (D) 
      ISZ TEMP1     YES 
      JMP REDIM,I 
      HED OUTPUT ROUTINES 
**                    **
***  PRINT A NUMBER  ***
**                    **
* 
*  ENTER WITH A FLOATING POINT NUMBER IN (A) AND (B).  PRINT THE
*  NUMBER AND APPEND BLANKS TO REACH THE PRINT POSITION SPECIFIED 
*  BY -EOPF ON RETURN FROM NUMOT. 
* 
#ENOT CCE           ENABLE SIGN 
      JSB NUMOT     OUTPUT NUMBER 
      JMP *+3 
      LDA .+40B     OUTPUT
      JSB OUTCR       A BLANK 
      LDB EOPF      FIELD 
      ADB CHRCT 
      SZB             FULL? 
      JMP *-5       NO
      JMP ENOUT,I   YES 
* 
MINFX DEC -0.099999959
MAXFX DEC -999999.5 
**                     ** 
***  OUTPUT A NUMBER  *** 
**                     ** 
* 
*  ENTER WITH A FLOATING POINT NUMBER IN (A) AND (B) AND (E) = 1
*  IF A SIGN IS WANTED.  DETERMINE THE FORM OF THE NUMBER AND 
*  SET EOPF ACCORDINGLY.  NON-INTEGERS ARE ROUNDED AFTER CONVERSION 
*  TO DECIMAL.  TRAILING ZEROS ARE SUPPRESSED ON NUMBERS WITHOUT
*  EXPONENTS (AND ON NUMBERS WITH EXPONENTS IF CALLED FROM 'LIST'). 
* qq
#NMOT STA NUMBF     SAVE HIGH MANTISSA
      SEZ,RSS       SIGN? 
      JMP NUMO1     NO
      SSA,RSS       YES, NEGATIVE NUMBER? 
      JMP *+5       NO
      JSB ARINV     YES, NEGATE NUMBER
      STA NUMBF     SAVE HIGH MANTISSA
      LDA .+55B     LOAD '-'
      RSS 
      LDA .+40B     LOAD '+'
      STA SIGN      SAVE SIGN 
      LDA NUMBF     RETRIEVE HIGH MANTISSA
NUMO1 STB NUMBF+1   SAVE LOW MANTISSA 
      JSB IFIX      INTEGER?
      JMP NUMO2     NO
      SOC           YES, 16-BIT INTEGER?
      JMP NUMO2     NO
*                       * 
**  OUTPUT AN INTEGER  ** 
*                       * 
      STB NUMBF     SAVE INTEGER
      ADB M1000 0_
      LDA .+6 
      SSB,RSS       3 DIGIT INTEGER?
      ADA .+3       NO
      ADA CHRCT     COMPUTE END-OF-FIELD
      CMA,INA       SAVE
      STA EOPF        IT
      ADA .74       ENOUGH
      SSA             ROOM? 
      JSB OUTLN     NO
      LDA SIGN      YES 
      SZA           SIGN? 
      JSB OUTCR     YES, OUTPUT IT
      LDB NUMBF     NO
      JSB OUTIN     OUTPUT THE INTEGER
      JMP NUMOT,I 
*                                    *
**  OUTPUT A FLOATING POINT NUMBER  **
*                                    *
NUMO2 LDA .-2       SET 'FIXED' 
      STA FFLAG       FLAG FALSE
      DLD NUMBF     LOAD NUMBER 
      JSB .FAD      IS NUMBER 
      DEF MAXFX       LESS THAN 
      SSA,RSS           999999.5 ?
      JMP NUMO3     NO
      DLD NUMBF     YES, IS 
      JSB .FAD        NUMBER
      DEF MINFX         LESS THAN 
      SSA,RSS             0.09999995 ?
      ISZ FFLAG     NO, SET 'FIXED' FLAG TRUE 
NUMO3 DLD NUMBF     LOAD NUMBER 
      STA MANT1     UNPACK
      JSB .FLUN 
      STB MANT2       NUMBER
      STA EXP 
      CLA           INITIALIZE
      STA EXPON       DECIMAL EXPONENT
      CPA EXP       ZERO EXPONENT?
      JMP NUMO5     YES 
NUMO0 JSB MBY10     NO
      LDA EXP       MULTIPLY
      CMA,SSA,INA,SZA   NUMBER BY 10
      JMP *+3             UNTIL IT IS 
      ISZ EXPON             GREATER 
      JMP NUMO0               THAN 1
      JSB DBY10     DIVIDE BY 10
      LDA EXPON 
NUMO4 LDB EXP       DIVIDE
      CMB,INB         NUMBER
      SSB,RSS           BY 10 
      JMP NUMO5           UNTIL 
      STA EXPON             IT IS 
      JSB DBY10               LESS
      CCA                       THAN
      ADA EXPON                   1 
      JMP NUMO4 4
NUMO5 CMA           SET EXPONENT
      STA EXPON       TO TRUE VALUE-1 
      LDB .-6       SET DIGIT 
      STB DIGCT       COUNTER 
      LDB NMBFA     SET BUFFER
      STB NMPTR       POINTER 
      SKP 
*                               * 
**  CONVERT MANTISSA TO ASCII  ** 
*                               * 
NUMO6 JSB GETDG     STORE A 
      ADA .+60B       DECIMAL 
      STA NMPTR,I       DIGIT 
      ISZ NMPTR 
      ISZ DIGCT     SIXTH DIGIT?
      JMP NUMO6     NO
      JSB GETDG     YES,
      ADA .-5         NEXT DIGIT
      SSA               >= 5 ?
      JMP NUMO9+1   NO
*                          *
**  ROUND ASCII MANTISSA  **
*                          *
      LDB NMPTR 
NUMO7 ADB .-1       LOAD LAST 
      LDA 1,I         DIGIT 
      INA           INCREMENT IT
      CPA .58       WAS IT A 9? 
      RSS           YES 
      JMP NUMO9     NO
      CPB NMBFA     LEADING DIGIT?
      JMP NUMO8     YES 
      LDA .+60B     NO, OVERLAY 
      STA 1,I         A 0 
      JMP NUMO7 
NUMO8 ISZ EXPON     BUMP DECIMAL
      NOP             EXPONENT AND
      LDA .+61B         OVERLAY A 1 
NUMO9 STA 1,I 
      LDA EXPON     IS NUMBER 
      SSA,RSS         LESS THAN 1 ? 
      JMP NMO11     NO
      STA NMTMP     YES 
      LDA .+60B 
      LDB NMPTR 
NMO10 ISZ NMTMP     COUNT ZEROS 
      NOP             PLUS 1
      ADB .-1       LAST
      CPA 1,I         DIGIT 0?
      JMP NMO10     YES 
      LDA NMTMP     NO, ALL SIGNIFICANCE
      SSA             IN SIX DIGITS?
      JMP NMO11     NO
      CCA           YES, SET
      STA FFLAG       'FIXED' FLAG TRUE 
NMO11 LDB .+12      COMPUTE 
      ISZ FFLAG       FIELD 
      ADB .+3           WIDTH 
      ADB CHRCT     SAVE
      CMB,INB         END-OF-FIELD
      STB EOPF          MARKER
      ADB .75       ENOUGH
      SSB             ROOM? 
      JSB OUTLN     NO
      LDA SIGN      YES 
      SZA           SIGN? 
      JSB OUTCR     YES, OUTPUT IT
      LDB .-7       SET OUTPUT
      STB DIGCT       DIGIT COUNTER 
      LDB NMPTR 
      CCA           FIXED 
      CPA FFLAG       FORMAT? 
      JMP *+5       NONI
      LDA EXPON     YES, SET
      CMA             INDICATOR TO
      STA NMTMP         DECIMAL POINT 
      JMP NMO16 
      STA NMTMP     SET INDICATOR FOR DECIMAL POINT 
      LDA LCALL     CALLED
      CPA NUMOT       FROM 'LIST' ? 
      JMP NMO16     YES 
      JMP NMO14     NO
*                           * 
**  DELETE TRAILING ZEROS  ** 
*                           * 
NMO12 LDA DIGCT     AT RIGHT OF 
      INA             DECIMAL 
      CPA NMTMP         POINT?
      JMP *+6       NO
      STA DIGCT     YES, DELETE ZERO
NMO16 ADB .-1       LAST
      LDA 1,I         DIGIT 
      CPA .+60B         0?
      JMP NMO12     YES 
      CCA           NO, FIXED 
      CPA FFLAG       FORMAT? 
      JMP NMO14     NO
      LDA EXPON     YES, LEADING
      SSA,RSS         DECIMAL POINT?
      JMP NMO14     NO
      STA NMTMP     YES, SET LEADING ZEROS COUNTER
*                     * 
**  OUTPUT MANTISSA  ** 
*                     * 
      LDA .+56B     OUTPUT A
      RSS             DECIMAL POINT 
NMO13 LDA .+60B     OUTPUT
      JSB OUTCR       A ZERO
      ISZ NMTMP     MORE LEADING ZEROS? 
      JMP NMO13     YES 
      ISZ DIGCT     NO, COUNT DECIMAL POINT 
NMO14 LDB NMBFA     SET 
      STB NMPTR       DIGIT POINTER 
      JMP *+5 
NMO15 ISZ NMTMP     DECIMAL POINT NEXT? 
      JMP *+3       NO
      LDA .+56B     YES, LOAD IT
      JMP *+3 
      LDA NMPTR,I   LOAD NEXT 
      ISZ NMPTR       DIGIT 
      JSB OUTCR     OUTPUT CHARACTER
      ISZ DIGCT     MORE DIGITS?
      JMP NMO15     YES 
      ISZ FFLAG     NO, EXPONENT? 
      JMP NUMOT,I   NO
*                         * 
**  OUTPUT THE EXPONENT  ** 
*                         * 
      LDA E 
      JSB OUTCR     OUTPUT AN 'E' 
      LDA .+55B     OUTPUT
      LDB EXPON 
      SSB             AN
      CMB,INB,RSS 
      LDA .+53B         EXPONENT
      STB EXPON 
      JSB OUTCR           SIGN
      LDA EXPON 
      CLB           COMPUTE 
      DIV .+10
      ADA .+60B       EXPONENT'S
      ADB .+60B 
      STB EXPON         10'S DIGIT
      JSB OUTCR     OUTPUT IT 
      LDA EXPON     OUTPUT
      JSB OUTCR       1'S DIGIT 
      JMP NUMOT,I 
      HED           LIBRARY FUNCTIONS 
* *                *
**  COMPUTE INT(X)  * 
* 
*  ENTER WITH NUMBER IN (A) AND (B).  EXIT WITH FLOATING
*  POINT FORM OF ENTIER IN (A) AND (B). 
* *q
EINT  STB LBTMP     SAVE (B)
      JSB IFIX      TAKE ENTIER 
      JMP EINT1     ALL SIGNIFICANCE IN MANTISSA
      STB LBTMP     SAVE (B)
      LDB .+31      CORRECT FOR 
      STB EXP         BINARY POINT BIAS 
      LDB LBTMP     RETRIEVE (B)
      JSB .PACK     NORMALIZE AND PACK
      JMP FRET,I
EINT1 LDA TEMP6     RETRIEVE
      LDB LBTMP       NUMBER
      JMP FRET,I
* *                 * 
**  EXECUTE TIM(X)   *
* *                 * 
ETIM  JSB IFIX      INTEGERIZE ARGUMENT 
      JSB RERRS+43,I ILLEGAL ARGUMENT 
      SZA 
      JSB RERRS+43,I ILLEGAL ARGUMENT 
      LDA 1         IS ARGUMENT 
      AND .+3         <=3 AND 
      CPA 1             >=0 ? 
      RSS           YES 
      JSB RERRS+43,I NO--ILLEGAL ARGUMENT 
      ADA DTMTB     BRANCH TO 
      JMP 0,I         APPROPRIATE ROUTINE 
ETIM0 LDA DATIM+1   # OF 100 MS 
      ADA D36K        UNITS 
      CLB           CONVERT 
      DIV D600        TO MINUTES
      JMP ETIM3+1 
ETIM1 LDA DATIM     HOURS OF YEAR 
      CLB           CONVERT 
      DIV .+24        TO DAYS 
      LDA 1         REMAINDER IS HOUR OF DAY
      JMP ETIM3+1 
ETIM2 LDA DATIM     HOURS OF YEAR 
      CLB           CONVERT 
      DIV .+24        TO DAYS 
      RSS 
ETIM3 LDA YEAR      GET YEAR
      OCT 105120   CONVERT TO POATING POINT 
      JMP FRET,I    EXIT WITH RESULT IN (A) AND (B) 
DTMTB DEF *+1,I 
      DEF ETIM0 
      DEF ETIM1 [[
      DEF ETIM2 
      DEF ETIM3 
* *                *
**  COMPUTE RND(X)  * 
* *                *
* 
* THE RANDOM NUMBER FUNCTION COMPUTES A RANDOM NUMBER FROM THE
* FORMULAS: 
* 
*     X(N)=A*X(N-1)+C(MOD 2^30)    (A=5^11,C=2^30*(1/2-1/SQR(12)))
*     RND =X/2^30 MIN (1-2^-23) 
* 
ERND  SSA,RSS      IS ARGUMENT POSITIVE?
      JMP *+5      YES
      RBL,CLE,ERB         NO,INITIALIZE RANDOM
      ELA            VALUE
      STA RNDX1 
      STB RNDX2 
* 
      LDA RNDX1    COMPUTE FIRST
      MPY RNDA2      CROSS PRODUCT. 
      STA RNDX1     SAVE (ONLY NEED LOW ORDER PART) 
      LDA RNDX2     COMPUTE 2ND 
      MPY RNDA1      CROSS PRODUCT. 
      ADA RNDX1     ADD IN FIRST. 
      ADA RNDC1     ADD IN HIGH PART OF C.
      STA RNDX1     SAVE TOTAL. (THIS IS HIGH PART).
      CLA,CLE       SET EXP=0.
      STA EXP 
      LDA RNDX2     COMPUTE LOW ORDER PRODUCT.
      MPY RNDA2 2E
      ADA RNDC2     ADD IN LOW PART OF C. 
      SEZ           ADD ANY CARRY INTO
      INB            B. 
      RAL,CLE,ERA   E_A(15),A(15)_0.
      STA RNDX2     SAVE LOW ORDER RESULT.
      ELB           SHIFT HIGH ORDER PART & ADD IN
      ADB RNDX1      PREVIOUS TOTAL.
      ELB,CLE,ERB   CLEAR BIT 15 AND STORE. 
      STB RNDX1 
      RAL           SHIFT A ADJACENT TO B.
      SWP           EXCHANGE REGISTERS AND
      JSB .PACK      PACK.
      CPB .+2       TEST FOR RESULT=1.0 
      RSS 
      JMP FRET,I    EXIT IF NOT.
      LDA INF       SET RESULT TO 1-2^-23 
      LDB M256
      JMP FRET,I
* qq
* *q
RNDA1 DEC 1490      A DIV 2^15
RNDA2 DEC 3805      A MOD 2^15
RNDC1 OCT 16441     C DIV 2^15
RNDC2 OCT 7701      C MOD 2^15
* *                *
**  COMPUTE SGN(X)  * 
* *                *
* 
*  ENTER WITH ARGUMENT IN (A) AND (B).  IF ARGUMENT IS
*  NEGATIVE RETURN -1.0, IF ZERO RETURN 0, IF POSITIVE
*  RETURN 1.0 . 
* 
ESGN  CLB           CLEAR LOW PART OF NUMBER
      SZA,RSS       ZERO? 
      JMP FRET,I    YES, RETURN 0 
      SSA,RSS       POSITIVE? 
      LDB .+2       YES, LOAD EXPONENT FOR +1 
      LDA FLGBT     NO, LOAD HIGH PART OF -1
      SZB           WAS ARGUMENT POSITIVE?
      RAR           YES, SET RESULT TO +1 
      JMP FRET,I    NO
* *                *
**  COMPUTE TYP(X)  * 
* *                *
* qq
*  UPON ENTRY (A) AND (B) HOLD A FILE NUMBER IN FLOATING POINT
*  FORM.  FILE 0 REFERS TO THE <DATA STATEMENT>S.  IF THE FILE
*  NUMBER IS NEGATIVE RETURN 1.0, 2.0, 3.0, OR 4.0 IF THE NEXT
*  ITEM IN THE FILE IS A NUMBER, STRING, EMD-OF-FILE, OR END- 
*  OF-RECORD RESPECTIVELY.  IF THE FILE NUMBER IS POSITIVE RETURN 
*  WITH THE VALUE CORRESPONDING TO THE FIRST ITEM FOUND OF ONE
*  OF THE FIRST THREE TYPES.
* qq
ETYP  STB LBTMP     SAVE (B)
      LDB FILE#     SAVE VALUE
      STB PINTG       OF FILE#
      LDB FBASE     SAVE                         [E]
      STB NUMPT       POINTER                    [E]
      SZA,RSS       'DATA' FILE?
      JMP ETYP3     YES 
      CCB           NO, IGNORE
      SSA             END-OF-RECORDS
      CLB               UNLESS ARGUMENT 
      STB EORFL           IS NEGATIVE 
      LDB LBTMP     RETRIEVE (B)
      SSA           TAKE ABSOLUTE VALUE 
      JSB ARINV       OF ARGUMENT 
      JSB SBFIX     15-BIT INTEGER? 
      JSB RERRS+35,I  NO
      STB FILE#     YES 
      LDA FILE#     VALIDATE
      LDB .-2 
      JSB RQSTR       FILE
      JSB GTTYP     GET TYPE
ETYP1 LDB PINTG     RESTORE 
      STB FILE#       FILE# 
      LDB NUMPT     RESTORE                      [E]
      STB FBASE       POINTER                    [E]
      OCT 105120
      JMP FRET,I      FLOATING POINT FORM 
ETYP2 LDA .+3 
      LDB NXTDT     OUT-OF-DATA 
      CPB SYMTB       CONDITION?
      JMP ETYP1     YES, (A) = 3
      JSB SETDP     NO, SEEK NEXT <DATA STATEMENT>
ETYP3 CCA           MORE DATA IN
      CPA DCCNT       CURRENT STATEMENT?
      JMP ETYP2     NO
      LDB NXTDT,I   YES, LOAD TYPE WORD 
      CLA,INA       SET NUMBER
      SSB,RSS       NUMBER? 
      LDA .+2       NO, SET FOR STRING
      JMP ETYP1 
