programs/fortran/src/frtn_4_of_5.asm

   1 *                       TAPE 4 OF 5 - BEGIN
   2 *
   3 EX34    LDA     B       IF B = 0
   4         SUB     EXT7
   5         SZE
   6         JMP     EX40    NO, GO TO EX40
   7         LDA     T0EX    IF T (0) = 0
   8         SZE
   9         JMP     EX38    NO, GO TO EX38
  10 EX35    CRA
  11         STA     IFLG    IFLG = 0
  12         LDA     F
  13         AOA
  14         SMI             F . GE. -1
  15         JMP     EX36    YES
  16         JMP*    EX00    RETURN - NO
  17 EX36    JST     CA00    SCAN
  18         JST     OT00    OUTPUT TRIADS
  19         JMP*    EX00    RETURN
  20 EX38    JST     STXI
  21         LDA     B
  22         SUB     K109
  23         STA     B
  24         LDA     K103
  25         STA     MFL
  26         LDA     T0EX
  27         LGL     9       O (I) = T (0)
  28         ADD     B       I (I) = B+9
  29         ADD     K124    I = I+2
  30         STA     DP+1,1
  31         JST     EX99    DATA POOL CHECK
  32         CRA
  33         STA     T0EX    T0 = 0
  34         STA     EXT7    T7 = 0
  35 EX39    LDA     L0
  36         STA     A       A = L0
  37         STA     IM      IM NOT EQ 0
  38         JMP     EX10
  39 EX40    LDA     TC      TC 0 ,
  40         CAS     K5      ='254 (,) IN BCD MODE
  41         JMP     *+2
  42         JMP     EX41
  43         SUB     K134    =17
  44         SZE
  45         JMP     EX44    NO, GO TO EX44
  46 EX41    LDA     I
  47 EX42    SUB     K102
  48         STA     XR      B VS. I (J)
  49         LDA     DP+1,1
  50         ANA     K118
  51         CAS     B
  52         JMP     *+3
  53         JMP     EX24    EQUAL, GO TO EX24
  54         JMP*    EX00    LESS, RETURN
  55         LDA     XR      GREATER, REPEAT LOOP
  56         JMP     EX42
  57 EX44    JST     IP00    ) - INPUT OPERATOR
  58         JMP     EX30    GO TO EX30
  59 EX46    LDA*    A
  60         STA     T6EX    IF O1(O1(A)) = L(0)
  61         LDA*    T6EX
  62         CAS     L0
  63         JMP     *+2
  64         JMP     EX34    GO TO EX34
  65         STA     O2      O2 = L0
  66 EX48    JST     ET00    ENTER TRIAD
  67         JMP     EX34
  68 EX50    JST     STXI
  69         LDA     A       A(I) = A
  70         STA     DP,1
  71         LDA     IU      IU = SUB OR ARR
  72         SLN
  73         JMP     EX30    NO, GO TO EX30
  74         LDA     TC
  75         SUB     K17     TC = (
  76         SZE
  77         JMP     EX76    NO, GO TO EX76
  78         LDA     B       YES, B = B+16
  79         ADD     K109
  80         STA     B
  81         LDA     IU      IU = ARR
  82         SUB     K103
  83         SZE
  84         JMP     EX75    NO, GO TO EX75
  85         CRA
  86         STA     DP,1    A(I) = 0
  87         STA     X4      X4 = 0
  88         STA     T3EX    T3 = 0
  89         STA     K       T5 = A
  90         LDA     D0
  91         STA     T9EX    T9 = D0
  92         LDA     A
  93         STA     T5EX    T5 = A
  94         LDA     AT
  95         SUB     K105    AT = DUM
  96         SZE
  97         JMP     EX74    NO, GO TO EX74
  98         CRA
  99         STA     T2EX    YES, T (0) = 0
 100         JST     EX99    DATA POOL CHECK
 101         JST     STXI
 102         LDA     A
 103         STA     DP,1    A(I) = A
 104         LDA     K132    OI (I) = A, 11
 105         LGL     9
 106         ADD     K124
 107         STA     DP+1,1  I=9
 108 EX54    LDA     D0      IF D0 = 1, GO TO EX56
 109         SUB     K101
 110         SNZ
 111         JMP     EX56
 112         JST     EX99    DATA POOL CHECK
 113         JMP     *+2
 114 EX55    IRS     K       K = K+1
 115         LDA     K
 116         STA     XR
 117         LDA     X,1
 118         STA     T6EX    T6 = X (K)
 119         JST     STXI
 120         LDA     T6EX
 121         STA     DP,1    O(I) = *
 122         LDA     K103    I (I) = T3+13
 123         LGL     9       T3 = T3+16
 124         ADD     T3EX    A (A) = T6
 125         ADD     K129    =13
 126         STA     DP+1,1
 127         ANA     K118
 128         ADD     K103
 129         STA     T3EX    T3 = A(A)
 130 EX56    JST     IV00    INPUT INTEGER VARIABLE
 131         JST     EX99    DATA POOL CHECK
 132         JST     STXI
 133         LDA     A       A(I) = A
 134         STA     DP,1
 135         LDA     NT
 136         SZE
 137         JMP     EX68    CONSTANT ENCOUNTERED
 138         JST     UC00    UNINPUT COLUMN
 139         JST     DN00    INPUT DO NOT ASSIGN
 140         SNZ
 141         JMP     EX57    IM = 0
 142         SUB     K101
 143         SNZ
 144         JMP     EX57    IM * INTEGEH
 145         JST     ER00
 146         BCI     1,SU    SUBSCRIPT INCREMENTER NOT A CONSTANT
 147 EX57    JST     STXI
 148         LDA     K101
 149         LGL     9
 150         ADD     T3EX
 151         ADD     K127
 152         STA     DP+1,1  O(1) = +, I(I) = T3+11
 153         JST     EX99    DATA POOL CHECK
 154 EX58    LDA     T9EX
 155         STA     D0      RESET D(0)
 156         LDA     ID      SUBSCRIPT SIZE
 157         SUB     K101    ID = ID-1
 158         STA     ID
 159         SNZ             IF ZERO, GO TO EX60
 160         JMP     EX60
 161         LDA     K
 162         STA     0
 163         LDA     D0,1    D(K) = 0
 164         SNZ
 165         JMP     EX67    YES - (DUMMY DIMENSION)
 166         IAB
 167         LDA     ID
 168         JST     IM00
 169         ADD     T2EX
 170         STA     T2EX    T2 = T2+ID*D(K)
 171 EX60    LDA     T9EX
 172         STA     D0      RESET D(0)
 173         LDA     K
 174         STA     0
 175         LDA     X+2,1   X(K+2) = 0
 176         SNZ
 177         JMP     EX62    YES - FINISHED
 178         LDA     K134    =17
 179         JST     TS00    COMMA TEST
 180         LDA     D0+1,1
 181         IAB
 182         LDA     D0,1
 183         JST     IM00
 184         STA     D0+1,1  D(K+1) = D(K+1)*D(K)
 185         JMP     EX55
 186 EX62    JST     STXI
 187         LDA     DP-1,1  DOES O(--2) = *
 188         SSP
 189         LGR     9
 190         CAS     K103
 191         JMP     *+2
 192         JMP     EX66    YES.
 193         SNZ             NO.
 194         JMP     EX64    O(I-2) = 0 - YES
 195         CAS     K132    DOES O(I-2) = A
 196         JMP     EX63
 197         JMP     *+2     YES
 198         JMP     EX63
 199         LDA     T2EX    IS T2 = 0
 200         SNZ
 201         JMP     EX65    YES (DUMMY ARRAY (1,1,1))
 202 EX63    LDA     K101
 203         STA     DP-1,1  01(I-2) = 1
 204         LDA     T2EX    A(I) = T2
 205         STA     DP,1
 206         LDA     K137    0='X' ('24),   I=2
 207         STA     DP+1,1
 208         CRA
 209         STA     DP+3,1  O1(1+2) = 0
 210         LDA     T5EX
 211         STA     DP+2,1  A(I+2) = T5
 212         JST     EX99    DATA POOL CHECK
 213         JST     CA00    SCAN
 214         LDA     O1
 215         STA     A       A = O1
 216         JST     STXA
 217         LDA     DP+2,1  S(A) = NON-ZERO
 218         SSM
 219         STA     DP+2,1  S(A) = 1
 220         JMP     EX44
 221 EX64    LDA     L0
 222         STA     DP,1    A(I) = L0
 223         JST     EX99    DATA POOL CHECK
 224         JST     STXI
 225         JMP     EX63
 226 EX65    LDA     I
 227         SUB     K104
 228         STA     I       I = I-4
 229         LDA     T5EX
 230         STA     DP-4,1  A (I) = T5
 231         JMP     EX44
 232 EX66    LDA     I
 233         SUB     K102
 234         STA     I       I = I-2
 235         JMP     EX62    ASSIGN INT CONSTANT
 236 EX67    JST     AI00
 237         JST     STXI    SET XR TO I
 238         LDA     A
 239         STA     DP,1    A(I) = A
 240         LDA     K101
 241         LGL     9
 242         ADD     T3EX
 243         ADD     K127
 244         STA     DP+1,1  OI(I) = +, T3+11
 245         JST     EX99    DATA POOL CHECK
 246         JMP     EX60
 247 EX68    LDA     TC      IS TC
 248         CAS     K103    = *
 249         JMP     *+2
 250         JMP     *+2
 251         JMP     EX58    NO
 252         LGL     9
 253         ADD     T3EX
 254         ADD     K129    =13
 255         STA     DP+1,1  OI(I) = *, T3+13
 256         JST     IR00    INPUT INTEGER VAR/CON
 257         JMP     EX56+1
 258 EX69    CRA             SET LISTING FOR OCTAL ADDR
 259         STA     A
 260         LDA     OMI5    JMP 0  INSTRUCTION
 261         STA     DF      SET LISTING FOR SYMBOLIC A INSTR,
 262         JST     OA00    OUTPUT ABSOLUTE
 263         LDA     RPL
 264         STA     O2
 265         LDA     K138
 266         STA     P       P = H
 267         JST     ET00    ENTER TRIAD
 268         JST     HS00    TRANSFER HOLLERITH STRING
 269         LDA     CRET    (A) = C/R
 270         JST     OK00    OUTPUT PACK
 271         CRA
 272         STA     0       SET LISTING FOR OCTAL ADDR.
 273         STA     A       SET LISTING FOR OCTAL ADDR.
 274         LDA     O2
 275         SUB     K101
 276         JST     OS00    OUTPUT STRING RPL-1
 277         JST     CH00    INPUT CHARACTER
 278         JST     FN00
 279         JST     STXI    RESET INDEX TO I
 280         LDA     L
 281         STA     DP,1    A(I) = L
 282         JMP     EX76
 283 EX74    LDA     AF
 284         STA     T2EX    T2 = AF
 285         JMP     EX54    GO TO EX54
 286 EX75    LDA     K134
 287         STA     TC      TC = ,
 288         JMP     EX24    GO TO EX24
 289 EX76    LDA     DP-1,1
 290         LGR     9
 291         ANA     K133
 292         SUB     K134
 293         SNZ
 294         JMP     EX34    WITHIN AN ARGUMENT LIST
 295         JST     ER00
 296         BCI     1,AG    SUBROUTINE OR ARRAY NAME NOT IN ARG. LIST
 297 EX78    LDA     K127
 298 EX79    STA     T1EX    T (1) = 11
 299         JMP     EX22
 300 EX80    LDA     K129    T (1) = 13
 301         JMP     EX79
 302 EX81    LDA     K106
 303         STA     T1EX    T (1) = 6
 304         JMP     EX20
 305 EX82    LDA     K104    T (1) = 4
 306         JMP     EX81+1
 307 EX83    LDA     T0EX    T (0) =0
 308         SZE
 309         JMP     EX84
 310         LDA     TC      YES,
 311         STA     T0EX    T (0) = TC
 312         LDA     EX92+1
 313         STA     TC      TC = -
 314         LDA     B
 315         ADD     K109
 316         STA     B
 317         STA     EXT7
 318         LDA     *+2
 319         JMP     EX79
 320         DEC     -5
 321 EX84    JST     ER00    ERROR
 322         BCI     1,RL    MORE THAN 1 RELATIONAL OPERATOR
 323 EX85    LDA     F
 324         ADD     K102    T (5) = T (5) +2 = B = 0
 325         STA     F
 326         ADD     B
 327         SNZ
 328         JMP     EX24
 329         JST     ER00    ERROR
 330         BCI     1,EQ    MULTIPLE ='S, OR EXPRESSIUN TO LEFT OF =
 331 EX90    OCT     250     (
 332         OCT     3       *
 333         OCT     5       NOT
 334         OCT     1       +
 335         OCT     2       -
 336         OCT     310     H
 337 EX91    DAC     EX12    (
 338         DAC     EX16    *
 339         DAC     EX18    NOT
 340         DAC     EX26    +
 341         DAC     EX26    -
 342         DAC     EX69    H
 343 EX92    OCT     1       +
 344         OCT     2       -
 345         OCT     3       *
 346         OCT     4       /
 347         OCT     6       AND
 348         OCT     7       OR
 349         OCT     15      NE
 350         OCT     12      EQ
 351         OCT     14      GT
 352         OCT     10      LT
 353         OCT     13      GE
 354         OCT     11      LE
 355         OCT     16      =
 356         OCT     16      = (ERROR)
 357 EX93    DAC     EX78    +
 358         DAC     EX78
 359         DAC     EX80    *
 360         DAC     EX80    /
 361         DAC     EX81    AND
 362         DAC     EX82    OR
 363         DAC     EX83    NE
 364         DAC     EX83    EQ
 365         DAC     EX83    GT
 366         DAC     EX83    LT
 367         DAC     EX83    GE
 368         DAC     EX83    LE
 369         DAC     EX85    =
 370         DAC     EX34    NONE OF THESE
 371 EX95    JST     ER00
 372         BCI     1,OP    MURE THAN ONE OPERATOR IN A ROW
 373 EX96    JST     ER00    ERROR
 374         BCI     1,PA    OPERATOR MUST BE WITHIN PARENTHESES
 375 EX97    JST     ER00    ERROR
 376         BCI     1,UO    MULTIPLE + OR - SIGNS NOT AS UNARY OPS
 377 *    BUMP THE I COUNT BY TWO AND CHECK FOR DATA OVERFLOW
 378 EX99    DAC     **
 379         IRS     I
 380         IRS     I
 381         LDA     I
 382         AOA
 383         CAS     L
 384         NOP
 385         JMP     AS50
 386         JMP*    EX99
 387 K133    OCT     77
 388 K130    DEC     -6
 389 K141    DEC     33
 390 K       PZE     0
 391 KM8     DEC     -8
 392 *
 393 *
 394 *
 395 *
 396 *             ******************
 397 *             *SCAN            *
 398 *             *TRIAD SEARCH    *
 399 *             *TEMP STORE CHECK*
 400 *             ******************
 401 T0CA    PZE     0
 402 T1CA    PZE     0
 403 T2CA    PZE     0
 404 T9CA    PZE     0
 405 *          THE AOIN TABLE IS PROCESSED FROM THE BOTTOM
 406 *               UP AND ENTRIES ARE FORMED FOR INCLUSION
 407 *               IN THE TRIAD TABLE, LEVELS ARE USED
 408 *               TO CONTROL THE ORDER OF ENTRY INTO
 409 *               THE TRIADS. SIGN CONTROL IS ALSO
 410 *               ACCOMPLISHED IN THIS ROUTINE.
 411 CA00    DAC     **
 412         LDA     L0
 413         STA     ACCP    INDICATE EMPTY ACCUM
 414 CA04    JST     STXI    ESTABLISH I
 415         STA     T1CA    T1 = I
 416         LDA     DP-1,1
 417         ANA     K118    IF I (I-2) = 0,
 418 *                            OR .LT. I (I)
 419         STA     T9CA
 420         LDA     DP+1,1
 421         ANA     K118
 422         CAS     T9CA
 423         JMP     CA08    GO TO CA08
 424         NOP
 425         LDA     I
 426         SUB     K102
 427         STA     I       I = I-2
 428         STA     0
 429 CA08    LDA     DP+3,1
 430         ERA     DP+1,1
 431         STA     T0CA
 432         LDA     DP+1,1
 433         ANA     K118
 434         STA     T2CA
 435         LDA     DP+1,1
 436         SSP
 437         LGR     9       P = O (I)
 438         STA     P
 439         CAS     K102    IF P IS NOT * OR /, GO TO CCA10
 440         CAS     K105
 441         JMP     CA10
 442         JMP     CA10
 443         JMP     CA14    GO T0 CA14
 444 CA10    LDA     T0CA
 445         SMI
 446         JMP     CA13
 447         LDA     KM8
 448         IMA     XR
 449         IAB
 450         LDA     P
 451         CAS     CA90+8,1
 452         JMP     *+2
 453         JMP     *+4
 454         IRS     XR
 455         JMP     *-4
 456         JMP     CA45
 457         LDA     CA91+8,1
 458         STA     P
 459         IAB
 460         STA     XR
 461 CA13    LDA     K130
 462         IMA     XR
 463         IAB
 464         LDA     P
 465         CAS     CA90+8,1
 466         JMP     *+2
 467         JMP     CA50
 468         IRS     XR
 469         JMP     *-4
 470         IAB
 471         STA     XR
 472         IAB
 473         LDA     DP+1,1
 474         JMP     *+2
 475 CA50    CRA
 476         STA     T0CA
 477         IAB
 478         STA     XR
 479 CA14    LDA     DP,1
 480         STA     O1      O1=A(I)
 481         LDA     DP+2,1
 482         STA     O2      O2 = A (I+2)
 483         LDA     T2CA
 484         SNZ
 485         JMP     CA37    IF ZER0, GO TO CA37
 486         LDA     DP-1,1
 487         SSP
 488         LGR     9
 489         STA     T1CA
 490         LDA     DP-1,1
 491         ANA     K118    IF T2 .GT. I (I-2)
 492         SUB     T2CA
 493         SPL
 494         JMP     CA18
 495         SZE
 496         JMP     CA04
 497         LDA     O2
 498         SUB     ACCP
 499         SZE
 500         JMP     CA04
 501         LDA     P
 502         SUB     K103
 503         SMI
 504         JMP     CA39
 505         LDA     T1CA
 506         SUB     P
 507         SZE
 508         LDA     K101    GO TO
 509         ADD     K101    P = - OR +
 510         STA     P
 511 CA18    LDA     I
 512         STA     0       J=I
 513 CA20    LDA     DP+2,1
 514         STA     DP,1    AOIN(J) = AOIN(J+2)
 515         LDA     DP+3,1
 516         STA     DP+1,1
 517         SSP
 518         SNZ
 519         JMP     CA22
 520         IRS     XR      J = J+2
 521         IRS     XR
 522         JMP     CA20
 523 CA22    JST     STXI
 524         LDA     DP+1,1
 525         SSP             IF O (I) = ,
 526         LGR     9
 527         CAS     P
 528         JMP     CA24
 529         CAS     K134
 530         JMP     CA24
 531         JMP     CA30    GO TO CA30
 532 CA24    JST     ST00    TRIAD SEARCH
 533         LDA     P
 534         CAS     K132    IF P = +,*, AND, OR
 535         JMP     CA28
 536         JMP     CA37    GO TO CA37
 537         CAS     K107
 538         JMP     CA28    ELSE, GO TO CA26
 539         JMP     CA37
 540         CAS     K106
 541         JMP     CA28
 542         JMP     CA37
 543         CAS     K103
 544         JMP     CA28
 545         JMP     CA37
 546         CAS     K101
 547         JMP     CA26
 548 *
 549 *
 550 *
 551         JMP     CA37
 552 CA26    CAS     K102
 553         JMP     *+2     IF P = -
 554         JMP     CA35    GO TO
 555 CA28    LDA     O1
 556         JST     TC00    TEMP STORE CHECK
 557 CA30    LDA     O2
 558         JST     TC00    TEMP STORE CHECK
 559 CA31    JST     ET00    ENTER TRIAD
 560 CA32    JST     STXI
 561         LDA     O1
 562         STA     DP,1
 563         LDA     DP+1,1
 564         LRL     15
 565         LDA     T0CA
 566         LGR     15
 567         LLL     15
 568         STA     DP+1,1
 569         LDA     T2CA    IF T2 NOT ZERO,
 570         SZE
 571         JMP     CA04    GO TU CA04
 572         JMP*    CA00    ELSE, RETURN
 573 CA35    LDA     T0CA
 574         ERA     ='100000
 575         STA     T0CA
 576 CA37    LDA     O2
 577         IMA     O1      O1 * = O2
 578         STA     O2
 579         SNZ             IF 02 = 0,
 580         JMP     CA32    GO TO CA32
 581 *
 582 *
 583 *
 584         JST     ST00    TRIAD SEARCH
 585         LDA     T0CA
 586         SMI
 587         JMP     CA28    GO TO CA28
 588         LDA     P
 589         JMP     CA26    ELSE, GO TO CA26
 590 CA39    SUB     K128
 591         SNZ             IF P = , OR
 592         JMP     CA04
 593         LDA     T1CA
 594         SUB     K104
 595         SZE             ELSE,
 596         JMP     CA18    GO TO CA18
 597         JMP     CA04
 598 CA45    LDA     T1CA
 599         STA     I       I = T1
 600         STA     T2CA
 601         CRA
 602         STA     T0CA    * * * * * * * * * * *
 603         STA     O2      O2 = C = 0
 604         SUB     K110    P = C
 605         STA     P
 606         JMP     CA24    GO TO CA24
 607 *          IF THE CURRENT TRIAD (IN WORKING STORAGE) MATCHES
 608 *               ANY TRIAD TABLE ENTRY, EXIT WITH THE
 609 *               POINTER VALUE OF THE MATCHING ENTRY
 610 *               (THIS ACCOMPLISHES ELIMINATION OF REDUNDANT
 611 *               SUBEXPRESSION CALCULATIONS.
 612 ST00    DAC     **      TRIAD SEARCH
 613         LDA     F
 614         ADD     K103
 615         SZE
 616         JMP     ST10    GO TO ST10
 617 ST05    LDA     P       ELSE, IF P = X
 618         SUB     K139
 619         SNZ
 620         JMP     CA31    GO TO CA31
 621         LDA     O1      ELSE, IF 01=ACCP
 622         SUB     ACCP
 623         SNZ
 624         JMP     CA30    GO TO CA30
 625         JMP*    ST00    ELSE, RETURN
 626 ST10    LDA     L0
 627         STA     XR
 628 ST20    LDA     XR
 629         SUB     K103
 630         STA     XR      J = J-2
 631         SUB     L       IF J .LT. L
 632         SPL
 633         JMP     ST05    GO TO ST05
 634         LDA     O2
 635         SUB     DP,1    IF O1/P/O2 .NE. O1/P/O2(J)
 636         SZE
 637         JMP     ST20    GO TO ST20
 638         LDA     DP+2,1
 639         SSP             EXTRACT OFF STORE BIT
 640         SUB     P
 641         SZE
 642         JMP     ST20
 643         LDA     O1
 644         SUB     DP+1,1
 645         SZE
 646         JMP     ST20    O1 = J
 647         LDA     XR
 648         STA     O1
 649         JST     STXI    ESTABLISH I
 650         JMP     CA32    GO T0 CA32
 651 *          IF J IS A REFERENCE TO A TRIAD , THE TEMP
 652 *               STORE BIT 0F THE REFERENCED TRIAD IS SET.)
 653 TC00    DAC     **      TEMP STORE CHECK
 654         STA     XR
 655         LDA     ABAR
 656         SUB     XR
 657         SMI             IS J .GR. ABAR
 658         JMP*    TC00    NO.
 659         LDA     DP+2,1  YES.
 660         SSM
 661         STA     DP+2,1  S(J) = 1
 662         JMP*    TC00
 663 CA90    OCT     1,2,11,10,13,14,12,15
 664 CA91    OCT     2,1,13,14,11,10,12,15
 665 *
 666 *
 667 *             *************
 668 *             *ENTER TRIAD*
 669 *             *************
 670 *          STORE CURRENT TRIAD INTO THE NEXT TRIAD ENTRY
 671 *               LOCATION.
 672 ET00    DAC     **
 673         JST     SAV
 674         LDA     L
 675         SUB     K103    =3
 676         STA     L       L=L-3
 677         STA     ACCP    SET ACCUM PTR TO LAST TRIAD ENTRY
 678         STA     0       J=L
 679         LDA     P
 680         STA     DP+2,1  P(J) = P
 681         LDA     O1
 682         STA     DP+1,1  O1(J) = O1
 683         LDA     O2
 684         STA     DP,1    O2(J) = O2
 685         LDA     0
 686         STA     O1      O1=J
 687         JST     RST
 688         JMP*    ET00
 689 ACCP    DAC     **      ACCUM POINTER
 690 *
 691 *
 692 SFTB    BSS     36      SUBFUNCTION TABLE
 693 *              **************************
 694 *              *GENERATE SUBPRO ENTRANCE*
 695 *              **************************
 696 *           OUTPUT SUBPROGRAM ENTRANCE CODE , INCLUDING THE
 697 *                CALL TO ARGUMENT ADDRESS TRANSFER.
 698 T0GE    PZE     0
 699 GE00    DAC     **
 700         CRA
 701         STA     T0GE
 702         LDA     K17     (  TEST
 703         JST     TS00
 704 GE10    JST     NA00    INPUT NAME
 705         LDA     I       IFF I=0,
 706         SNZ
 707         JMP     GE20    GO TO GE20
 708         CAS     K141
 709         NOP
 710         JMP     GE30    MAKE ENTRY IN SFTB TABLE
 711         ADD     K103
 712         STA     I       IF FULL, GO TO GE30
 713         JST     STXA    SET XR TO A
 714         LDA     DP,1
 715         IAB
 716         JST     STXI    ESTABLISH I
 717         IAB
 718         STA     SFTB,1
 719         JST     STXA    SET XR TO A
 720         LDA     DP+1,1
 721         IAB
 722         JST     STXI    SET XR TO I
 723         IAB
 724         STA     SFTB+1,1
 725         LDA     A
 726         STA     SFTB+2,1
 727         JST     STXA    SET XR TO A
 728         CRA
 729         STA     DP+1,1  CLEAR OLD USACE
 730 GE20    LDA     K105
 731         IAB
 732         LDA     RPL
 733         ADD     T0GE
 734         ADD     K103    (B) = DUM
 735         JST     AF00    DEFINE AFT (A=RPL+T0+3)
 736         IRS     T0GE    T0 = T0+1
 737         LDA     K134
 738         SUB     TC      IF TC = ,
 739         SNZ
 740         JMP     GE10    GO TO GE10
 741         JST     IP00    INPUT OPERATOR
 742         CRA
 743         STA     DF
 744         JST     OA00    OUTPUT ABS (0)
 745         LDA     T0GE
 746         STA     ID      ID = T0
 747         LDA     K69
 748         STA     NAMF+1  NAMF = AT
 749         JST     NF00    FILL IN REMAINING NAME
 750         JST     OL00    OUTPUT OBJECT LINK
 751         LDA     T0GE
 752         TCA
 753         STA     T0GE
 754         CRA
 755         JST     OA00    OUTPUT NUMBER OF ARGS
 756         IRS     T0GE    OUTPUT SPACE FOR ARG. ADDR.
 757         JMP     *-3
 758         JMP*    GE00    RETURN
 759 GE30    JST     ER00    CONSTR, ERROR
 760         BCI     1,AE
 761 K69     BCI     1,AT    AT
 762 *
 763 *             ****************
 764 *             *EXCHANGE LINKS*
 765 *             ****************
 766 *          CL SUBA IS INTERCHANGED WITH CL SUBF
 767 EL00    DAC     **
 768         JST     STXA
 769         LDA     DP,1
 770         STA     EL90    CL (F) == CL (A)
 771         LDA     F
 772         STA     0
 773         JST     EL40
 774         JST     STXA
 775         JST     EL40
 776         JMP*    EL00
 777 EL40    DAC     **
 778         LDA     DP,1
 779         IMA     EL90
 780         ANA     K118
 781         IMA     DP,1
 782         ANA     K119
 783         ADD     DP,1
 784         STA     DP,1
 785         JMP*    EL40
 786 EL90    PZE     0
 787 *
 788 *
 789 *             *****************
 790 *             *NON COMMON TEST*
 791 *             *****************
 792 NM00    DAC     **      NON-COMMON TEST
 793         LDA     AT
 794         SUB     K104
 795         SZE
 796         JMP*    NM00
 797         JST     ER00
 798         BCI     1,CR    ILLEGAL COMMON REFERENCE
 799 *
 800 *
 801 *             **************************
 802 *             *NON DUMMY OR SUBPRO TEST*
 803 *             **************************
 804 ND00    DAC     **
 805         LDA     AT      TEST
 806         SUB     K105
 807         SZE
 808         JMP     ND10
 809         JST     ER00
 810         BCI     1,DA    ILLEGAL USE OF A DUMMY ARGUMENT
 811         JMP*    ND00
 812 ND10    JST     NS00
 813         JMP*    ND00
 814 *
 815 *
 816 *             *****************
 817 *             *INPUT SUBSCRIPT*
 818 *             *****************
 819 SCT0    PZE     0
 820 SC00    DAC     **
 821         STA     SCT0    T0 = (A)
 822         CRA
 823         STA     NS
 824         STA     S2      NS = S2 = S3 = 0
 825         STA     S3
 826         LDA     K17     (-TEST
 827         JST     TS00
 828 SC10    LDA     EBAR
 829         SMI
 830         JMP     SC15    EBAR .GR. 0
 831         JST     XN00    EXAMINE NEXT CHAR,
 832         SZE
 833         JMP     SC70    IF (A) NON ZERO,
 834 SC15    JST     IG00    GO TO SC70
 835         LDA     SCT0    INPUT INTEGER
 836         SZE
 837         SPL
 838         JMP     SC60
 839         LDA     ID
 840         SUB     K101
 841         JMP     SC30
 842 SC60    JST     AS00    ASSIGN ITEM
 843 SC20    LDA     A       S (NS+1) = A
 844 SC30    IAB
 845         LDA     SC90
 846         ADD     NS
 847         STA     SC91
 848         IAB             S(NS + 1) = A
 849         STA*    SC91
 850         LDA     NS
 851         AOA
 852         STA     NS      NS = NS + 1
 853         SUB     K103
 854         SZE
 855         JMP     SC50    MORE SUBSCRIPTS PERMITTED
 856 SC40    JST     IP00    )-INPUT OPERATOR
 857         JMP*    SC00    RETURN
 858 SC50    LDA     TC
 859         SUB     K134
 860         SZE
 861         JMP     SC40    TERMINATOR NOT A COMMA
 862         JMP     SC10    G0 TO SC10
 863 SC70    JST     IR00    INPUT INT VARIABLE
 864         LDA     SCT0    CHECK FOR NON-DUMMY
 865         SNZ             VARIABLE DIMENSIONS
 866         JMP     SC20
 867         LDA     AT
 868         SUB     K105
 869         SNZ
 870         JMP     SC20
 871         JST     ER00
 872         BCI     1,VD    ILLEGAL SYMBOLIC SUBSCRIPT
 873 SC90    DAC     S1
 874 SC91    DAC     **
 875 *
 876 *
 877 *             ********************
 878 *             *INPUT LIST ELEMENT*
 879 *             ********************
 880 *          IF THE ITEM IS AN ARRAY, PROCESS THE SUBSCRIPT
 881 IL00    DAC     **
 882         JST     NA00    INPUT NAME
 883         LDA     AT
 884         SUB     K105    NON-DUMMY TEST
 885         SZE
 886         JMP     *+3
 887         JST     ER00    USAGE ERROR
 888         BCI     1,DD    DUMMY ITEM IN AN EQUIV, OR DATA LIST
 889         LDA     IU      IF IU NOT ARR,
 890         SUB     K103
 891         SZE
 892         JMP     IL30    GO TO IL30
 893         LDA     K103
 894         JST     SC00    INPUT SUBSCRIPTS
 895         JST     FA00    FETCH ASSIGNS
 896         LDA     ND      IF ND = NS
 897         SUB     NS
 898         SZE             S1 = D* (S1 + D1* (S2+D2*S3)
 899         JMP     IL10    ELSE, GO TO IL10
 900         LDA     S3
 901         IAB
 902         LDA     D2
 903         JST     IM00
 904         ADD     S2
 905         IAB
 906         LDA     D1
 907         JST     IM00
 908         ADD     S1
 909         IAB
 910         LDA     D0
 911         JST     IM00
 912         STA     S1
 913         JMP*    IL00    RETURN
 914 IL10    LDA     NS      IF NS NOT 1
 915         SUB     K101
 916         SZE
 917         JMP     IL20    GO TO IL20
 918         LDA     S1      ELSE,  20
 919         IAB             S1 * D0*S1
 920         LDA     D0
 921         JST     IM00
 922 IL18    STA     S1
 923         JMP*    IL00    RETURN
 924 IL20    JST     ER00
 925         BCI     1,ND    WRONG NUMBER OF DIMENSIONS IN ARRAY ELEMENT
 926         JMP*    IL00    RETURN
 927 IL30    JST     TV00    TAG VARIABLE
 928         CRA             S1 = 0
 929         JMP     IL18    RETURN
 930 *
 931 *
 932 *             ************
 933 *             *FUNCTION *
 934 *             *SUBROUTINE*
 935 *             ************
 936 *          IF LSTF IS ZERO, THE STATEMENT IS OUT OF ORDER
 937 *               FUNCTIONS ARE CHECKED TO ENSURE ARGUMENTS
 938 R1      LDA     K101
 939         STA     SFF     SFF = 1
 940 R2      LDA     LSTF
 941         SZE             IF LSTF = 0
 942         JMP     R2A
 943         JST     ER00    ILLEGAL STATEMENT
 944         BCI     1,FS    NOT FIRST STATEMENT IN SUBPROGRAM
 945 R2A     JST     NA00    INPUT NAME
 946         LDA     A
 947         STA     SBF     SBF = A
 948         CRA             ADDR=0, S/C CODE =0
 949         JST     ON00    OUTPUT NAME BLOCK TO THE LOADER
 950         LDA     MFL
 951         SZE
 952         JST     DM00    DEFINE IM
 953         LDA     TC
 954         SUB     CRET    IF IC NOT C/R
 955         SZE
 956         JMP     R2C     GO TO
 957         LDA     SFF     IF SFF = 0
 958         SNZ
 959         JMP     R2D     GO TO R2D
 960         JST     ER00    ERROR
 961         BCI     1,FA    FUNCTION HAS NO ARGUMENTS
 962 R2C     CRA
 963         STA     I       I = 0
 964         JST     GE00    GENERATE SUBPROGRAM ENTRY
 965         JMP     A1      GO TO C/R TEST
 966 R2D     CRA
 967         JST     OA00    OUTPUT ABS
 968         JMP     C6      GO TO CONTINUE
 969 *
 970 *
 971 *             ******************
 972 *             *INTEGER         *
 973 *             *REAL            *
 974 *             *DOUBLE PRECISION*
 975 *             *COMPLEX         *
 976 *             *LOGICAL         *
 977 *             ******************
 978 *          THE MODE FLAG (MFL) IS SET TO THE APPROPRIATE
 979 *               VALUE AND ANY ARRAY INFO IS PROCESSED
 980 A3      LDA     K101    INTEGER
 981         JMP     A7A     TMFL = INT
 982 A4      LDA     K102    REAL
 983         JMP     A7A     TMFL = REAL
 984 A5      LDA     K106    DOUBLE PRECISION
 985         JMP     A7A     TMFL = DBL
 986 A6      LDA     K105    COMPLEX
 987         JMP     A7A     TMFL = CPX
 988 A7      LDA     K103    LOGICAL
 989 A7A     STA     MFL     TMFL = LOG
 990         LDA     LSTF    IF LSTF = 0, GO TO A7B (2)
 991         SNZ
 992         JMP     A7B     ELSE,
 993         LDA     CC      SAVE CC
 994         STA     A790
 995         CRA
 996         STA     ICSW
 997         JST     DN00    INPUT DNA
 998         LDA     A790    RESTORE CC
 999         STA     CC
1000         STA     ICSW    ICSW = IPL
1001         LDA     DFL     IF DFL NOT = 0, GO TO A7B
1002         SZE
1003         JMP     A7B
1004         LDA     TID     IF ID = FUNCTI,
1005         SUB     A7K     GO TO A9
1006         SNZ             SKIP IF NOT 'FUNCTION'
1007         JMP     A9      FUNCTION PROCESSOR
1008 A7A5    JST     ER00    CONSTRUCTION ERROR
1009         BCI     1,TF    'TYPE' NOT FOLLOWED BY 'FUNCTION' OR LIST
1010 A7K     BCI     1,FU    CONSTANT FOR 'FUNCTION' CHECK
1011 A7B     JST     NA00    INPUT NAME
1012         LDA     MFL
1013         JST     DM00    DEFINE IM
1014         JMP     B7      GO TO INPUT DIMENSION
1015 A790    PZE     0
1016 *
1017 *
1018 *   -      B2   EXTERNAL
1019 *          TAGS NAME AS SUBPROGRAM
1020 B2      JST     NA00    EXTERNAL, INPUT NAME
1021         JST     TG00    TAG SUBPROGRAM
1022         JMP     B1      GO TO , OR C/R TEST
1023 *
1024 *
1025 *             *****************
1026 *             *DIMENSION     *
1027 *             *INPUT DIMENSION*
1028 *             *****************
1029 *          PROCESS ARRAYS, PUT DIMENSION INFO IN SPECIAL
1030 *               ARRAY POINTER ITEM
1031 B3T0    PZE     0
1032 B3T1    PZE     0
1033 B3T2    PZE     0
1034 B3T3    PZE     0
1035 B3      JST     NA00
1036 B3A     LDA     AT      IF AT = DUM
1037         SUB     K105    (A) = 0
1038         SZE             ELSE (A) = .LT. 0
1039         SSM
1040 B3B     STA     B3T0    T0 = (A)
1041         LDA     AF
1042         STA     B3T3    T3 = AF
1043         LDA     A
1044         STA     B3T1    T1 = A
1045         LDA     AT      TEST FOR AT=DUMMY
1046         SUB     K105    =5
1047         SZE             SKIP NO-USAGE TEST IF DUMMY
1048         JST     NU00    NO USAGE TEST
1049         JST     STXA
1050         LDA     DP+1,1  IU (A) = ARR
1051         LRL     14
1052         LDA     K103
1053         LLL     14
1054         STA     DP+1,1
1055         LDA     B3T0    (A) = T0
1056         JST     SC00    INPUT SUBSCRIPT
1057         LDA     S1
1058         STA     ID
1059         LDA     S2      PLACE SUBSCRIPTS IN ID
1060         STA     ID+1
1061         LDA     S3
1062         STA     ID+2
1063         LDA     NS      (A) = 0, B = NS
1064         LRL     16
1065         JST     AA00    ASSIGN SPECIAL.
1066         JST     STXA
1067         LDA     DP+1,1
1068         LLR     2
1069         LDA     B3T3
1070         LGL     2
1071         LRR     2
1072         STA     DP+1,1  DEFINE GF T0 GF(A)
1073         LDA     A
1074         STA     B3T2    T2 = A
1075         LDA     B3T1
1076         STA     A       A = T1
1077         JST     STXA
1078         LDA     DP+1,1
1079         LLR     2
1080         LDA     B3T2
1081         LGL     2
1082         LRR     2
1083         STA     DP+1,1  DEFINE GF TO GF(A)
1084 B3D     LDA     TC
1085         SUB     K104    IF TC NOT SLASH
1086         SZE
1087         JMP     B1      GO TO ,-C/R TEST
1088         LDA     A9T2    IF SIDSW = COMMON-4
1089         SUB     B4Z9
1090         SZE             GO T0 B4 (COMMON-0)
1091         JMP     B1      ELSE, GO TO ,-C/R TEST
1092         JMP     B40
1093 B7      LDA     TC      IF TC = (
1094         SUB     K17
1095         SZE
1096         JMP     B3D
1097         JMP     B3A
1098 *
1099 *
1100 *             ********
1101 *             *COMMON*
1102 *             ********
1103 *          INPUT BLOCK NAMES AND LINK THEM WITH THE
1104 *               FOLLOWING VAR/ARRAY NAMES, BLOCK NAMES
1105 *               ARE LINKED TOGETHER THROUGH THEIR GENERAL FIELDS
1106 B4      LDA     K81
1107         STA     ID
1108         STA     ID+1
1109         STA     ID+2
1110         LDA     B4Z9    SET SWITCH IN INPUT DIMENSION
1111         STA     A9T2
1112         JST     CH00    INPUT CHAR
1113         SUB     K9      IF NOT SLASH
1114         SZE             GO TO
1115         JMP     B4E
1116 B40     JST     DN00    INPUT DNA
1117         LDA     K104    SLASH TEST
1118         JST     TS00
1119 B4B     LRL     32
1120         LDA     K101    (A) = SUB, (B) = 0
1121         JST     AA00    ASSIGN SPECIAL
1122         LDA     CFL
1123         SNZ
1124         LDA     A
1125         STA     CFL
1126         LDA     A
1127         STA     F
1128         JST     FL00    FETCH LINK
1129         SZE
1130         JMP     B4D
1131         LDA     CFL
1132         STA     0
1133         LDA     DP+1,1  GF(CFL)
1134         IMA     A
1135         STA     0       INDEX = A
1136         IMA     A
1137         STA     DP+1,1  GF(A) = GF(CFL)
1138         LDA     CFL
1139         STA     0       INDEX = CFL
1140         LDA     A
1141         ADD     K122    ='040000
1142         STA     DP+1,1  GF(CFL) = A
1143 B4D     JST     NA00    INPUT NAME
1144         JST     ND00    NON DUMMY/SUBPROG TEST
1145         JST     NM00    NON-COMMON TEST
1146         JST     EL00    EXCHANGE LINKS
1147         LDA     DP,1
1148         ANA     B4F     ='107777
1149         ADD     K122    AT(A) = COM  (='040000)
1150         STA     DP,1
1151         JMP     B7
1152 B4E     JST     UC00    UNINPUT COLUMN
1153         JMP     B4B
1154 B4Z9    DAC     B4D     GO TO INPUT DIMENSION
1155 B4F     OCT     107777  EXTRACT MASK TO STRIP OFF AT FIELD
1156 *
1157 *
1158 *             *************
1159 *             *EQUIVALENCE*
1160 *             *************
1161 *          STORE EQUIV INFO IN THE DATA POOL FOR LATER
1162 *               PROCESSING BY GROUP EQUIV (PART OF SPECS WRAPUP)
1163 B5      LDA     E0      L = NEXT WORD IN EQUIVALENCE TABLE
1164         STA     I       I=L
1165         SUB     K101    (=1)
1166         STA     E0      L=L-1
1167         SUB     ABAR
1168         SMI
1169         JMP     *+3
1170         JST     ER00    DATA POOL FULL
1171         BCI     1,MO    MEMORY OVERFLOW
1172         JST     STXI    ESTABLISH I
1173         CRA
1174         STA     DP,1    DP (I) = 0
1175 B5B     JST     CH00
1176         LDA     DP,1    INPUT CHAR
1177         SZE
1178         JMP     B5D
1179         LDA     TC      PUT IN FIRST CHARACTER
1180         LGL     8       PACK INTO DP (I)
1181 B5C     STA     DP,1
1182         LDA     TC
1183         SUB     CRET
1184         SNZ
1185         JMP     C6      CHARACTER E C/R - EXIT
1186         LDA     DP,1
1187         ANA     K100
1188         SNZ
1189         JMP     B5B     WORD NOT FULL
1190         JMP     B5      OBTAIN NEW WORD
1191 B5D     LDA     TC      PUT IN SECOND CHARACTER
1192         ERA     DP,1
1193         JMP     B5C
1194 *
1195 *
1196 *             *********************
1197 *             *RELATE COMMON ITEMS*
1198 *             *********************
1199 *          ALL ITEMS LINKED TO A COMMON BLOCK ARE PROCESSED
1200 *               AND THEIR INVERSE OFFSETS CALCULATED. THESE
1201 *               WILL BE INVERTED LATER TO GIVE TRUE
1202 *               POSITION IN THE BLOCK.
1203 C2T0    PZE     0
1204 C2      LDA     CFL
1205         STA     A       A = F = CFL
1206 C2A     CRA
1207         STA     C2T0    T0 = 0
1208         LDA     A
1209         STA     F       F = A
1210 C2B     JST     FL00    FETCH LINK
1211         SNZ
1212         JMP     C2D
1213         LDA     D0
1214         ADD     C2T0    T0 = T0 + D0
1215         STA     C2T0
1216         JST     DA00    DEFINE ADDRESS FIELD
1217         JMP     C2B
1218 C2D     JST     FL00    FETCH LINK
1219         SZE
1220         JMP     C2F
1221         LDA     AF
1222         STA     A       A = AF
1223         SUB     CFL
1224         SZE
1225         JMP     C2A     AF = CFL. NO
1226         JMP     C3      YES - GROUP EQUIVALENCE
1227 C2F     LDA     C2T0
1228         SUB     AF      (A) = T0 - AF
1229         JST     DA00    DEFINE AF
1230         LDA     IU
1231         SZE
1232         JMP     C2D
1233         JST     TV00    TAG VARIABLE
1234         JMP     C2D
1235 *
1236 *
1237 *              *******************
1238 *              *GROUP EQUIVALENCE*
1239 *              *******************
1240 *                THE EQUIV GROUPS ARE PROCESSED NOW. ANY COMMON
1241 *                USAGE IS CHECKED TO SEE THAT THE ORIGIN
1242 *                IS NOT MOVED AND THAT ONLY ONE ITEM IS
1243 *                COMMON.
1244 C3T0    PZE     0
1245 C3T1    PZE     0
1246 C3T2    PZE     0
1247 C3T3    PZE     0
1248 C3T4    PZE     0
1249 C3T5    PZE     0
1250 T0C3    EQU     C3T0
1251 T1C3    EQU     C3T1
1252 T2C3    EQU     C3T2
1253 T3C3    EQU     C3T3
1254 T4C3    EQU     C3T4
1255 C3      LDA     E0
1256         STA     EBAR    EBAR=E(0) = END OF EQUIVALENCE TABLE
1257         LDA     L0
1258         STA     E       E=L(0) = START OF EUUIVALENCE TABLE
1259         LDA     CRET
1260         STA     TC
1261 C3B     LDA     E
1262         STA     EP      E-PRIME = E
1263         CRA
1264         STA     F       I = 0
1265         LDA     K102    T4 = STR-ABS
1266         STA     C3T4
1267         JST     CH00    INPUT CHARACTER
1268         LDA     K17
1269         JST     TS00    (TEST
1270 C3D     JST     IL00    INPUT LIST ELEMENT
1271         JST     SAF
1272         LDA     S1
1273         SUB     AF      TL = S1-AF
1274         STA     C3T1
1275         LDA     A       T2 = A
1276         STA     C3T2
1277 C3F     LDA     F       IF I=0, GO TO C3P
1278         SNZ
1279         JMP     C3P
1280 C3G     LDA     F       ELSE,
1281         SUB     A
1282         SNZ             IF A = I, GO TO C3N
1283         JMP     C3N
1284 C3H     LDA     AT
1285         SUB     K104    ELSE,
1286         SNZ             IF AT = COM, GO TO C3O
1287         JMP     C3O
1288 C3H2    LDA     T1C3
1289         ADD     AF
1290         STA     T0C3    T(0) = AF +T (1)
1291         LDA     T4C3
1292         SUB     K104    IF T(4) = 0, GO T0 C3K
1293         SZE
1294         JMP     C3K
1295         LDA     T3C3
1296         SUB     T0C3    ELSE,
1297         STA     T0C3    T(0) = T(3)-T(0)
1298         SMI
1299         JMP     C3K
1300         JST     ER00    IF T(0)<0,
1301         BCI     1,IC
1302 C3K     LDA     C3T4    IMPOSSIBLE COMMON EQUIVALENCING
1303         IAB
1304         LDA     T0C3    AT (A) = COM
1305         ALS     2
1306         LGR     2
1307         JST     AF00
1308         JST     FL00    DEFINE AF
1309         JST     SAF     FETCH LINK
1310         LDA     A
1311         SUB     C3T2
1312         SZE             IF A .NE. T (2),
1313         JMP     C3G     GO TO C3G (5)
1314 *
1315         JST     EL00    EXCHANGE CL(A) == CL(I)
1316 C3M     LDA     TC      EXCHANGE LINKS (CL(A) WITH CL(F) )
1317         SUB     K134    IF TC = ,
1318         SNZ
1319         JMP     C3D     ELSE,
1320         JST     IP00    )-INPUT OPERATOR
1321         LDA     TC
1322         SUB     K134    IF TC = , OR C/R
1323         SNZ             GO TO C3B (1)
1324         JMP     C3B
1325         LDA     TC
1326         SUB     CRET
1327         SNZ
1328         JMP     C3B     ELSE,
1329         JST     ER00
1330         BCI     1,EC    EOUIVALENCE GROUP NOT FOLLOWED BY , OR CR
1331         JMP     C3B
1332 C3N     LDA     T1C3    IF T1 = 0, GO TO C3M
1333         SNZ
1334         JMP     C3M
1335 C3N5    JST     ER00    ERROR IMPOSSIBLE GROUP
1336         BCI     1,IE    IMPOSSIBLE EQUIVALENCE GROUPING
1337 C3O     LDA     S1
1338         ADD     AF
1339         STA     T3C3
1340         LDA     K104    =4
1341         CAS     T4C3
1342         JMP     *+2
1343         JMP     C3N5
1344         STA     T4C3
1345         LDA     F
1346         CAS     A       IF A = F, GO TO C3M (B)
1347         JMP     *+2
1348         JMP     C3M     ELSE,
1349         STA     A       A = I
1350         IMA     C3T2
1351         STA     F
1352         CRA             T1 = 0
1353         STA     C3T1
1354         JST     FA00    FETCH ASSIGNS
1355         JST     SAF
1356         JMP     C3H2    GO TO C3H2
1357 C3P     LDA     A
1358         STA     F
1359         JMP     C3H
1360 *
1361 *
1362 *             ***********************
1363 *             *ASSIGN SPECIFICATIONS*
1364 *             ***********************
1365 *          NON-COMMON NON-EQUIV ITEMS ARE PROCESSED AFTER
1366 *               COMMON BLOCKS ARE OUTPUT (WITH SIZE).
1367 C4T0    PZE     0
1368 C4T1    PZE     0
1369 C4B     STA     A       A = 0
1370 C4C     LDA     A
1371         ADD     K105    I = A = A+5
1372         STA     A
1373         STA     F
1374         CAS     ABAR
1375         JMP     NP35    RETURN TO FIRST NON-SPEC CHECK (POINT 1)
1376         NOP
1377         JST     FA00    ELSE, FETCH ASSIGN
1378         LDA     AT
1379         SUB     K102    IF AT = STR-ABS
1380         SZE             IU=VAR, OR ARR, AND
1381         JMP     C4C     NT = 0
1382         LDA     IU      GO TO C4E
1383         SUB     K102    ELSE, GO TO C4C
1384         SPL
1385         JMP     C4C
1386         LDA     NT
1387         SZE
1388         JMP     C4C
1389 C4E     CRA
1390         STA     C4T0    T0 = 0. T1 =-MAX
1391         SUB     K111
1392         STA     C4T1
1393         JST     KT00    SET D(0) = NO. OF WORDS PER ITEM
1394 C4F     JST     SAF
1395         CAS     C4T0
1396         STA     C4T0
1397         NOP
1398         LDA     D0
1399         SUB     AF      (A) = D(0) - AF
1400         CAS     C4T1
1401         STA     C4T1
1402         NOP
1403         JST     FL00    FETCH LINK ( (A)=A - F  )
1404         SZE
1405         JMP     C4F     GO TO C4F
1406         LDA     RPL
1407         ADD     C4T0    RPL * RPL + T0 + TL
1408         STA     C4T0
1409         ADD     C4T1    TO = RPL-T1
1410         STA     RPL
1411 C4I     JST     SAF
1412         LDA     K101
1413         IAB             (B) = REL
1414         LDA     C4T0    (A) = TO-AF
1415         SUB     AF
1416         JST     AF00    DEFIME AFT
1417         JST     FL00    FETCH LINK
1418         SZE             IF (A) NOT ZERO,
1419         JMP     C4I     NOT END OF EQUIVALENCE GROUP
1420         JMP     C4C     CHECK NEXT ITEM IN ASSIGNMENI TABLE
1421 *
1422 C4L2    LDA     FLT1    = LINK LOCATION TO COMMON BLOCK NAME
1423         STA     C4T1
1424 C4L3    LDA     A
1425         STA     I       SAVE A FOR LATER MODIFICATION
1426         JST     FL00    FETCH LINK
1427         SNZ
1428         JMP     C4M     END OF COMMON GROUP
1429         JST     STXI    SET INDEX TO POINT TO CURRENT ITEM IN
1430 *                                       COMMON GROUP.
1431         LDA     DP,1    SET CL FIELD TO POINT AT COMMON BLOCK
1432 *                                      NAME.
1433         ANA     K119    ( = '177000)
1434         ADD     C4T1    (= LINK LOCATION OF COMMON BLOCK NAME)
1435         STA     DP,1
1436         JMP     C4L3    PROCESS NEXT ITEM IN COMMON BLOCK
1437 *
1438 C4      LDA     CFL     LOC, OF FIRST (BLANK) COMMON BLOCK
1439         STA     F
1440 C4L6    STA     A
1441         CRA
1442         STA     C4T0
1443 C4L     JST     FL00    FETCH LINK
1444         SNZ
1445         JMP     C4L2    NO MORE ITEMS IN COMMON BLOCK
1446         LDA     D0      ELSE, IF TO .LT. DO+AF,
1447         ADD     AF
1448         CAS     C4T0    T0 = D0 + AF
1449         STA     C4T0
1450         NOP
1451         JMP     C4L     GO TO C4L
1452 C4M     LDA     AF
1453         STA     F       I=AF
1454         LDA     C4T0    (A) = T0
1455         JST     DA00    DEFINE AF
1456 * OUTPUT COMMON BLOCK NAME AND SIZE TO LOADER
1457         LDA     AF      LENGTH OF COMMON BLOCK
1458         ANA     K111    ='37777
1459         ADD     K122    ='40000  (S/C CODE = 1)
1460         JST     ON00    OUTPUT NAME BLOCK TO LOADER
1461         LDA     F
1462         SUB     CFL     IF I = CFL
1463         SNZ
1464         JMP     C4B
1465         LDA     F
1466         JMP     C4L6
1467 *
1468 SAF     DAC     **
1469         LDA     AF
1470         LGL     2
1471         ARS     2
1472         STA     AF
1473         JMP*    SAF
1474 *
1475 *             **************************
1476 *             *DATA STATEMENT PROCESSOR*
1477 *             **************************
1478 *          PROCESS VARIABLE LIST .THEN OUTPUT LITERAL ITEMS
1479 *               TO APPROPRIATE LOCATIONS. MODES MUST AGREE
1480 T0W4    PZE     0
1481 T1W4    PZE     0
1482 G       PZE     0       LOWEST INDEX POINT IN LIST
1483 W4      LDA     L0
1484         STA     I       I=END OF DATA POOL
1485 W4B     JST     IL00    INPUT LIST ELEMENT
1486         LDA     AT      D (0) = =WDS/ITEM
1487         SUB     K102
1488         SNZ             IF AT = 'STR-ABS'
1489         JMP     W4T     GO TO
1490         LDA     I
1491         STA     0
1492         LDA     S1      S1 * DEFLECTION IF AN ARRAY
1493         ADD     AF
1494         STA     DP,1    DP(E) = AF + S1
1495 W4C     LDA     A
1496         STA     DP-1,1  DP (E-1) = A
1497         LDA     I
1498         SUB     K102
1499         STA     I
1500         STA     G
1501         LDA     TC      IF TC = ,
1502         SUB     K134
1503         SNZ
1504         JMP     W4B     GO TO W4B
1505         LDA     K104
1506         JST     TS00    TEST FOR SLASH TERMINATOR
1507         LDA     RPL
1508         STA     T1W4
1509         LDA     L0
1510         STA     I       I= END OF DATA POOL
1511 W4E     CRA
1512         STA     KPRM    K' = KBAR = 0
1513         STA     KBAR
1514 W4F     JST     DN00    INPUT, DNA
1515         LDA     NT
1516         SZE             IF NT = 0
1517         JMP     W4G     VARIABLE OR ARRAY
1518         LDA     TC      LAST CHARACTER
1519         CAS     K17     ='250  ( =(  )
1520         JMP     *+2
1521         JMP     *+3     START OF COMPLEX CONSTANT
1522         JST     ER00    ERROR
1523         BCI     1,CN    NON-CON DATA
1524         STA     SXF     SET SXF TO NON-ZERO
1525         JMP     W4F     FINISH INPUT OF COMPLEX CONSTANT
1526 W4G     LDA     KBAR    MULTIPLY COUNT
1527         SZE
1528         JMP     W4K     GO TO W4K
1529         LDA     TC      IF TC NOT *
1530         SUB     K103
1531         SZE
1532         JMP     W4L
1533         LDA     ID
1534         SUB     K101
1535         STA     KBAR    KBAR = ID-1
1536         JST     IT00    INTEGER TEST
1537         JMP     W4F
1538 W4K     LDA     KPRM    IF K NOT ZERO
1539         SZE
1540         JMP     W4M     GO TO W4M
1541 W4L     LDA     KBAR
1542         ALS     1       K ' = E-3* KBAR
1543         TCA
1544         ADD     I
1545         STA     KPRM
1546 W4M     JST     STXI    SET INDEX = I
1547         LDA     DP-1,1
1548         STA     A       A = DP (E-1)
1549         LDA     IM
1550         STA     T0W4    TO = IM
1551         JST     FA00
1552         LDA     BDF     IF BDF NOT ZERO
1553         SZE
1554         JMP     W4S     GO TO W4S
1555         JST     NM00    NON-COMMON TEST
1556 W4O     JST     STXI    SET INDEX = I
1557         LDA     DP,1
1558         STA     RPL     RPL = AF
1559         JST     FS00    FLUSH
1560         CRA
1561         STA     DF      DF = 0
1562         LDA     HOLF    IS IT HOLLERITH DATA
1563         SZE             NO
1564         JMP     WHOW    YES, GO TO OUTPUT IT
1565         LDA     D0
1566         STA     0
1567         JMP     *,1     SWITCH ON NUMBER OF WORDS TO OUTPUT
1568         JMP     W405
1569         JMP     W403
1570         JMP     W404
1571         LDA     TID+2
1572         JST     OA00
1573         LDA     TID+1
1574         JST     OA00
1575         LDA     TIDB+2
1576         JST     OA00
1577         LDA     TIDB+1
1578         JMP     W406
1579 *
1580 *                       TAPE 4 OF 5 - END
1581         MOR