 101           job  1401 Fortran  Snapshot routine                         5059a
 102           ctl  644 11
 103           sfx  #
 104 xxx       equ  0
 105 xl1       equ  089
 106 xl2       equ  094
 107 xl3       equ  099
 109           org  333
 110           sbr  prtxt&3
 111           sbr  hldxt&6
 112           mcw  @000@,linct-2
 113           mcw  xl3, hld32&6
 114           mcw  xl1, hld31&6
 115           sbr  xl1, 1
 116           sbr  xl3, 202
 117           cs   332
 118           cs
 119           nop  110,210
 120           bss  only,f
 121           cc   1
 122           mcw  094,250
 123 hldxt     sbr  216,xxx
 124 hld32     sbr  256,xxx
 125 hld31     sbr  244,xxx
 126           w
 127           cc   k
 128           za   &2,pgctr#2
 129 nulin     cs   332
 130           cs
 131           cc   j
 132           mcw  linct,306
 133           mcw
 134           sbr  mvhed&6
 135           mcw  @9@, ctr-1
 136 mvhed     mcw  ctr-1,xxx
 137           mcw  head
 138           sbr  mvhed&6
 139           a    @i0@, ctr#2
 140           bwz  mvhed, ctr-1, 2
 141           a    &1,linct-2
 142           w
 143 loop      sw   0&x3
 144           mcw  0&x1,0&x3
 145           bw   cmpab,0&x1
 146           cw   0&x3
 147 cmpab     c    xl1,parama&2
 148           bu   cpl
 149           w
 150           wm
 151 rstrx     mcw  hld31&6,xl1
 152           mcw  hld32&6,xl3
 153           cs   332
 154           cs
 155           bss  *&5,g
 156           b    prtxt
 157           h
 158 prtxt     h    0
 159 cpl       sbr  xl1, 1&x1
 160           bce  inc, xl3-2, 2
 161           sbr  xl3, 201
 162           w
 163           wm
 164           a    &1,pgctr
 165           c    pgctr,&15
 166           bu   nulin
 167           s    pgctr
 168           ccb  nulin,1
 169 only      mcw  @executed@,220
 170           w    rstrx
 171 inc       a    &1,xl3
 172           b    loop
 173 head      dcw  @9........@
 174           dcw  @9-@
 175 linct     dcw  00000
 176           ltorg*
 177           xfr  0
 178           job  1401 Fortran fixed xlink routine                       5059b
 179           org  333
 180           h    333
 181 start     mcw  86,xl2             x2 follows b700
 182           cs   80
 183           bce  array,0&x2,$
 184 clear     cs   000
 185           sbr  adr3
 186           c    adr3,@699@
 187           bu   clear
 188           sw   acchi-5&x3
 189           mz   acchi&x3,field
 190           c    field,acchi&x3
 191           be   cards
 192           bm   getm,acchi&x3
 193           mz   zero,acchi&x3
 194           c    699,acchi&x3
 195           be   getm
 196           sw   22
 197           mcw  gm,22
 198 serch     rt   1,1
 199           bef  out
 200           c    10,@lib@
 201           bu   serch
 202           c    17,acchi&x3
 203           be   t1
 254           b    serch
 205 out       nop  cards
 206           mcw  tperm,out                                       v3m4
 207           rwd  1
 208           b    serch
 209 t1        lca  zeros,101
 210           lca  zeros
 211           lca  zeros
 212           rtw  1,333
 213           ber  err
 214           mcw  zero,ctrr
 215           sbr  tperm-1,t2
 216 t2        rtw  1,700
 217           ber  err
 218 tboot     b    000                from libed
 219 err       a    one,ctrr
 220           bce  tperm,ctrr,9
 221           bsp  1
 222           b    t1
 223 tperm     h    tperm
 224 array     mcw  3&x2,adr3
 225           mz   zero,adr3-1
 226           b    clear
 227 cards     sw   1
 228           r
 229           bce  1,1,,
 230           b    cards
 231 getm      rwd  1
 232           rtw  1,1
 233           b    1        execute monitor program
 234 adr3      equ  clear&3
 235 field     dcw  @000000@
 236 zeros     equ  field-1
 237 zero      equ  zeros-4
 238 ctrr      equ  zeros
 239 acchi     equ  279
 240 one       equ  679
 241 gm        equ  680
 242           ltorg*
 243           org  679
 244           dcw  @1}@                group mark in 680
 245           xfr  0
 246           job  1401  Fortran arith and relocatable routines           5059c
 247 *
 248           sfx  b
 249 *
 250           xinitxl1,xl2,xl3,,,,xxxx
 251 *
 252           xnmbr
 253 *
 254 wkzon     equ  200
 255 top       equ  wkzon&1
 256 spot      equ  wkzon&50
 257 acchi     equ  wkzon&79
 258 *
 259           org  700
 260 *
 261 *                      arithmetic  routine  monitor
 262 *
 263 aritf     sbr  x2
 264           sbr  086            store first location of arith string
 265           sbr  stmnm&6
 266 arith     mcw  2&x2, x1
 267           sar  algrt&6
 268 sbbr1     sbr  brwhr&6
 269           bce  stsub,0&x2,$   check for subscripted store location
 270           sbr  out2&6,0&x1
 271           cs   wkzon&103      clear work area
 272           cs
 273           cs
 274           lca  @0@, acchi&1
 275 clrx      s    x1&2
 276 algrt     sbr  xl2, xxx
 277           c    4&x2, @#@
 278           mcw  4&x2, signf
 279           sw   top
 280 exit      bl   qfunct
 281           sbr  ngbmp&6,4&x2
 282           bce  opdsc,5&x2,$   check for subscripted operand
 283           mcw  7&x2, xl1
 284           sar  algrt&6
 285 sbbr2     bwz  xsize,x1-1,k   branch if fixpt computation
 286           bwz  xsize,x1-1,s
 287 *
 288 *                               float arithmetic
 289 *
 290 fsize     sbr  x3,xxx         store float size
 291           cw   fixsw#1
 292           mcw  0&x1,expb      store exponent
 293           sar  xl1
 294           mcw  0&x1,spot      initialize work area
 295           sbr  xl2
 296           lca  @0@
 297 ngbmp     bw   *&8,0
 298           mz   spot, nsign
 299           s    @0@,spot&2&x3
 300           c    1&x2, @0@
 301           a    xl3, xl2
 302           bce  fdiv,code,/    branch for division
 303           bce  fmpy,code,*    branch for multiplication -
 304 *
 305 *                                floating add / subtract
 306 *
 307           s    signf
 308 signf     za   nsign
 309           bce  nuval,acchi&1,0    br, if 1st operand of computation
 310           be   clrwk
 311           s    expb,exp
 312           za   exp&1,xl1&1
 313           c    xl3,xl1
 314           bm   rtn1,exp
 315           bh   chgex    br if prev result to be retained in wk acc
 316           a    exp,expb
 317           za   spot,spot&x1   initialize work area
 318           za   xl3&1,xl1&1
 319 ascom     mz   nsign,0&x2
 320           a    acchi&x1,0&x2
 321 mvzon     mz   0&x2,nsign
 322 nuval     za   expb,exp
 323 *
 324 *                                normalize
 325 *
 326 nmlz1     mcw  rcdmk,1&x2
 327           mz
 328           mz
 329           a
 330           mn
 331           sbr  xl1
 332           s    acchi&2&x3
 333 nloop     bce  strze,2&x1,|
 334           sbr  xl1
 335           bce  nloop, 1&x1, 0
 336           mcm  1&x1, acchi&1
 337           s    xl3, xl2
 398           cw
 339           cw
 340           s
 341           s    xl1,exp
 342 nsign     za   acchi&x3       move proper sign to work accumulator
 343           sw
 344           bce  clrwk,exp-2,0
 345           bm   strze,exp      branch on exponent underflow
 346 *
 347 *                      exponent overflow due to normalization
 348 *
 349           b    ermsg
 350           dcw  @nof@
 351 *
 352 * store  nines  in  work  accumulator  and  exp  on exponent  ovfl
 353 *
 354 str99     za   &99,exp
 355           mn   &99,acchi&x3
 356           mcw
 357           mcw  acchi-1&x3
 358 clrwk     cs   acchi-1
 359           b    clrx
 360 *
 361 *                       store  zero  in  work  accumulator
 362 *
 363 strze     s    exp
 364           s    acchi&x3
 365           b    clrwk
 366 *
 367 *                       division  by  zero  attempted
 368 *
 369 dverr     b    ermsg
 370           dcw  @dze@
 371           b    str99
 372 *
 373 rtn1      bh   nuval          branch to store new value in wk acc
 374           s    xl3&1,xl1&1    initialize index registers
 375           mz   acchi&x3,acchi&x1   initialize work accumulator
 376           b    ascom
 377 *
 378 chgex     a    expb,exp
 379           b    clrwk
 380 *
 381 *                        subscripted  variables
 332 *
 383 opdsc     sbr  x2,5&x2
 384 stsub     b    xxx
 385           mn   0&x2
 386           mn
 387           mn
 388           mn
 389           sar  algrt&6
 390 brwhr     bce  sbbr1,xxx,$
 391           b    sbbr2
 392 *
 393 *                                  floating divide
 394 *
 395 fdiv      be   dverr
 396           mn   acchi&x3, 1&x2
 397           mcw
 398           mn
 399           d    0&x1, spot&1
 400           zs   expb
 401           b    ndmdv
 402 *
 403 *                                  floating multiply
 404 *
 405 fmpy      m    acchi&x3, spot&1&x3
 406           sbr  x2,3&x2
 407           s    &2,exp
 408 ndmdv     a    expb, exp
 409           mz   acchi&x3, *&1
 410           za   nsign
 411           b    nmlz1
 412 *
 413 *                                  exit routine
 414 *
 415 qfunct    bce  out1,4&x2,|    br if contents of wk acc to be stored
 416           sbr  algrt&6,1&x2
 417           c    acchi&1,@0@
 418           b    xxx            branch to function selection routine
 419 out1      bce  out2,acchi&1,0
 420           bw   out2,fixsw
 421           bw   finst,4&x2     branch if final storage of comp
 422           sbr  x3,2&x3
 423 mvexp     mcm  exp-1,acchi-1&x3
 424 out2      lca  acchi&x3,xxx
 425           bw   5&x2,4&x2   br to prog mainline if end of arith str
 426           sar  xl2
 427           b    arith
 428 *
 429 *                 rounding  for  final  storage
 430 *
 431 finst     a    &5,acchi-1&x3
 482           bwz  rdovf,acchi&1,s
 433 zonmv     mz   acchi&x3,acchi-2&x3
 434           b    mvexp
 435 rdovf     a    &1,exp
 436           bce  nornd,exp-2,1
 437           s    acchi&x3
 438           lca  @1@,acchi&1
 439           b    zonmv
 440 *
 441 *             no  rounding  if  exponent  overflow  would  occur
 442 *
 443 nornd     mn   &99,acchi&x3
 444           mcw
 445           mcw  acchi-1&x3
 446           s    &1,exp
 447           b    zonmv
 448 *
 449 *                      print  error  message
 450 *
 451 ermsg     sbr  strx2&6
 452           cs   top&1&x3
 453           sbr  rinx2&6,0&x3
 454 strx2     sbr  x3,xxx
 455           mcw  2&x3,top&11
 456 stmnm     sbr  top&16,xxx
 457           w
 458           sw   top
 459           sbr  ermxt&3,3&x3
 460 rinx2     sbr  x3,xxx
 461 ermxt     b    xxx
 462 *
 463 *                                fixed point entry
 464 *
 465 xsize     sbr  x3,xxx         store fix-size
 466           sw   fixsw
 467 *
 468 fixpt     mcs  0&x1, spot
 469           bce  xdiv, code, /
 470           bce  xmpy, code, *
 471 *
 472 *                                fixed add / subtract
 473 *
 474           bwz  subtr, code, k     q. subtract
 475           a    0&x1, acchi&x3
 476 addrt     za   acchi&x3
 477           b    clrwk
 478 *
 479 subtr     s    0&x1, acchi&x3
 480           b    addrt
 481 *
 482 *                                fixed multiply
 483 *
 484 xmpy      lca  0&x1, spot
 485           m    acchi&x3, spot&1&x3
 486           mcw  spot&1&x3, acchi&x3
 487           b    clrwk
 488 *
 489 *                                fixed divide
 490 *
 491 xdiv      bce  dverr, spot,
 492           mcw  0&x1,spot&x3
 493           mn
 494           sbr  mvqut&3
 495           lca  acchi&x3
 496           za   acchi&x3, spot&x3
 497           d    0&x1, spot&1
 498 mvqut     mcw  spot-1,acchi&x3
 499           b    clrwk
 500 *
 501           dcw  000
 502 rcdmk     dcw  @|@
 503           dcw  0
 504 exp       dcw  000
 505           dc   @|@
 506 expb      dcw  00
 507           dc   0
 508 code      equ  signf
 509 zrosw     equ  *&1
 510 basez     equ  *&1
 511 xpnum     dcw  @8@
 512           ltorg
 513           ds   1
 514           dcw  @0@
 515           dc   @}@               system group mark
 516           xfr  0
 586           end
