return to 1401 Software Development

1401 Floating point subroutines

Floating point subroutines from W Van Snyder < van . snyder @ sbcglobal . net > - Oct 7, 2014
We also have the source code. Both Gary Mokotoff's listings, transcribed, and my reverse engineered version.

The last time I visited, I tried to run Fortran from a tape, via the emulator, but it didn't work because some of the blocks are bigger than the emulator can handle.

I wrote a program that makes short blocks and then another one that reassembles them. I used it to copy the tape, through the emulator, to a real tape. It works fine in SimH, but it didn't work on the CT machine, presumably because the tape drives were not cooperating that day. Does anybody want to try again?

It can be run from cards, but there are about 2200 of them. I can put together a single file if you want to punch that many cards....

We also have the Fortran IV compiler, not just Gary Mokotoff's Fortran II compiler.

-----------------------------

Here's the floating-point code from the Fortran II compiler, which is very similar to the one from the Fortran IV compiler. The Fortran II compiler generated pseudo code that was interpreted by the floating-point code -- long before UCSD Pascal and P-Code.

Entry is at ARITF, location 700.

The files named arith-v3m0-63.53 are from Gary Mokotoff's compiler listing.

Files named phase-63.315 are my reverse engineering from the v3m0 operational tape. This one explains the format of the pseudo code.

Do you want the intrinsic functions library?

-Van

Ed Thelen's note:
Van supplied 5 files
- arith-v3m0.63.53.s
- arith-v3m0.63.53.ps
- phase-63.315.pdf
- phase-63.315.ps
- phase-63.315.s
only type .s are presented below


arith-v3m0.63.53.s
 101 013       job  1401  Fortran arith and relocatable routines           50633
 102           ctl  644 11
 103 *
 104           sfx  b
 105 *
 106           xinitxl1,xl2,xl3,,,,xxxx
 107 *
 108           xnmbr
 109 *
 110 wkzon     equ  200
 111 top       equ  wkzon&1
 112 spot      equ  wkzon&50
 113 acchi     equ  wkzon&79
 114 *
 115           org  700
 116 *
 117 *                      arithmetic  routine  monitor
 118 *
 119 aritf     sbr  x2
 120           sbr  086            store first location of arith string
 121           sbr  stmnm&6
 122 arith     mcw  2&x2, x1
 123           sar  algrt&6
 124 sbbr1     sbr  brwhr&6
 125           bce  stsub,0&x2,$   check for subscripted store location
 126           sbr  out2&6,0&x1
 127           cs   wkzon&103      clear work area
 128           cs
 129           cs
 130           lca  @0@, acchi&1
 131 clrx      s    x1&2
 132 algrt     sbr  xl2, xxx
 133           c    4&x2, @#@
 134           mcw  4&x2, signf
 135           sw   top
 136 exit      bl   qfunct
 137           sbr  ngbmp&6,4&x2
 138           bce  opdsc,5&x2,$   check for subscripted operand
 139           mcw  7&x2, xl1
 140           sar  algrt&6
 141 sbbr2     bwz  xsize,x1-1,k   branch if fixpt computation
 142           bwz  xsize,x1-1,s
 143 *
 144 *                               float arithmetic
 145 *
 146 fsize     sbr  x3,xxx         store float size
 147           cw   fixsw#1
 148           mcw  0&x1,expb      store exponent
 149           sar  xl1
 150           mcw  0&x1,spot      initialize work area
 151           sbr  xl2
 152           lca  @0@
 153 ngbmp     bw   *&8,0
 154           mz   spot, nsign
 155           s    @0@,spot&2&x3
 156           c    1&x2, @0@
 157           a    xl3, xl2
 158           bce  fdiv,code,/    branch for division
 159           bce  fmpy,code,*    branch for multiplication -
 160 *
 161 *                                floating add / subtract
 162 *
 163           s    signf
 164 signf     za   nsign
 165           bce  nuval,acchi&1,0    br, if 1st operand of computation
 166           be   clrwk
 167           s    expb,exp
 168           za   exp&1,xl1&1
 169           c    xl3,xl1
 170           bm   rtn1,exp
 171           bh   chgex    br if prev result to be retained in wk acc
 172           a    exp,expb
 173           za   spot,spot&x1   initialize work area
 174           za   xl3&1,xl1&1
 175 ascom     mz   nsign,0&x2
 176           a    acchi&x1,0&x2
 177 mvzon     mz   0&x2,nsign
 178 nuval     za   expb,exp
 179 *
 180 *                                normalize
 181 *
 182 nmlz1     mcw  rcdmk,1&x2
 183           mz
 184           mz
 185           a
 186           mn
 187           sbr  xl1
 188           s    acchi&2&x3
 189 nloop     bce  strze,2&x1,|
 190           sbr  xl1
 191           bce  nloop, 1&x1, 0
 192           mcm  1&x1, acchi&1
 193           s    xl3, xl2
 194           cw
 195           cw
 196           s
 197           s    xl1,exp
 198 nsign     za   acchi&x3       move proper sign to work accumulator
 199           sw
 200           bce  clrwk,exp-2,0
 201           bm   strze,exp      branch on exponent underflow
 202 *
 203 *                      exponent overflow due to normalization
 204 *
 205           b    ermsg
 206           dcw  @nof@
 207 *
 208 * store  nines  in  work  accumulator  and  exp  on exponent  ovfl
 209 *
 210 str99     za   &99,exp
 211           mn   &99,acchi&x3
 212           mcw
 213           mcw  acchi-1&x3
 214 clrwk     cs   acchi-1
 215           b    clrx
 216 *
 217 *                       store  zero  in  work  accumulator
 218 *
 219 strze     s    exp
 220           s    acchi&x3
 221           b    clrwk
 222 *
 223 *                       division  by  zero  attempted
 224 *
 225 dverr     b    ermsg
 226           dcw  @dze@
 227           b    str99
 228 *
 229 rtn1      bh   nuval          branch to store new value in wk acc
 230           s    xl3&1,xl1&1    initialize index registers
 231           mz   acchi&x3,acchi&x1   initialize work accumulator
 232           b    ascom
 233 *
 234 chgex     a    expb,exp
 235           b    clrwk
 236 *
 237 *                        subscripted  variables
 238 *
 239 opdsc     sbr  x2,5&x2
 240 stsub     b    xxx
 241           mn   0&x2
 242           mn
 243           mn
 244           mn
 245           sar  algrt&6
 246 brwhr     bce  sbbr1,xxx,$
 247           b    sbbr2
 248 *
 249 *                                  floating divide
 250 *
 251 fdiv      be   dverr
 252           mn   acchi&x3, 1&x2
 253           mcw
 254           mn
 255           d    0&x1, spot&1
 256           zs   expb
 257           b    ndmdv
 258 *
 259 *                                  floating multiply
 260 *
 261 fmpy      m    acchi&x3, spot&1&x3
 262           sbr  x2,3&x2
 263           s    &2,exp
 264 ndmdv     a    expb, exp
 265           mz   acchi&x3, *&1
 266           za   nsign
 267           b    nmlz1
 268 *
 269 *                                  exit routine
 270 *
 271 qfunct    bce  out1,4&x2,|    br if contents of wk acc to be stored
 272           sbr  algrt&6,1&x2
 273           c    acchi&1,@0@
 274           b    xxx            branch to function selection routine
 275 out1      bce  out2,acchi&1,0
 276           bw   out2,fixsw
 277           bw   finst,4&x2     branch if final storage of comp
 278           sbr  x3,2&x3
 279 mvexp     mcm  exp-1,acchi-1&x3
 280 out2      lca  acchi&x3,xxx
 281           bw   5&x2,4&x2   br to prog mainline if end of arith str
 282           sar  xl2
 283           b    arith
 284 *
 285 *                 rounding  for  final  storage
 286 *
 287 finst     a    &5,acchi-1&x3
 288           bwz  rdovf,acchi&1,s
 289 zonmv     mz   acchi&x3,acchi-2&x3
 290           b    mvexp
 291 rdovf     a    &1,exp
 292           bce  nornd,exp-2,1
 293           s    acchi&x3
 294           lca  @1@,acchi&1
 295           b    zonmv
 296 *
 297 *             no  rounding  if  exponent  overflow  would  occur
 298 *
 299 nornd     mn   &99,acchi&x3
 300           mcw
 301           mcw  acchi-1&x3
 302           s    &1,exp
 303           b    zonmv
 304 *
 305 *                      print  error  message
 306 *
 307 ermsg     sbr  strx2&6
 308           cs   top&1&x3
 309           sbr  rinx2&6,0&x3
 310 strx2     sbr  x3,xxx
 311           mcw  2&x3,top&11
 312 stmnm     sbr  top&16,xxx
 313           w
 314           sw   top
 315           sbr  ermxt&3,3&x3
 316 rinx2     sbr  x3,xxx
 317 ermxt     b    xxx
 318 *
 319 *                                fixed point entry
 320 *
 321 xsize     sbr  x3,xxx         store fix-size
 322           sw   fixsw
 323 *
 324 fixpt     mcs  0&x1, spot
 325           bce  xdiv, code, /
 326           bce  xmpy, code, *
 327 *
 328 *                                fixed add / subtract
 329 *
 330           bwz  subtr, code, k     q. subtract
 331           a    0&x1, acchi&x3
 332 addrt     za   acchi&x3
 333           b    clrwk
 334 *
 335 subtr     s    0&x1, acchi&x3
 336           b    addrt
 337 *
 338 *                                fixed multiply
 339 *
 340 xmpy      lca  0&x1, spot
 341           m    acchi&x3, spot&1&x3
 342           mcw  spot&1&x3, acchi&x3
 343           b    clrwk
 344 *
 345 *                                fixed divide
 346 *
 347 xdiv      bce  dverr, spot,
 348           mcw  0&x1,spot&x3
 349           mn
 350           sbr  mvqut&3
 351           lca  acchi&x3
 352           za   acchi&x3, spot&x3
 353           d    0&x1, spot&1
 354 mvqut     mcw  spot-1,acchi&x3
 355           b    clrwk
 356 *
 357           dcw  000
 358 rcdmk     dcw  @|@
 359           dcw  0
 360 exp       dcw  000
 361           dc   @|@
 362 expb      dcw  00
 363           dc   0
 364 code      equ  signf
 365 zrosw     equ  *&1
 366 basez     equ  *&1
 367 xpnum     dcw  @8@
 368           ltorg
 369           ds   1
 370           dcw  @0@
 371           dcw  @}@               system group mark
 372           job  1401 Fortran  relocatable package                      50533
 373 divid     equ  14000
 374 calc      equ  divid&47
 375 calc1     equ  divid&58
 376 logm1     equ  divid&149
 377 logm2     equ  divid&171
 378 calxt     equ  divid&187
 379 str1      equ  divid&191
 380 ln10      equ  divid&226
 381 upby      equ  divid&250
 382 ncon      equ  divid&253
 383 nctr      equ  divid&256
 384 dec       equ  divid&259
 385 twtch     equ  divid&260
 386 delta     equ  acchi-200
 387           param
 388 xlinks    equ  840
 389 atanfn    equ  894
 390           reloc
 391           job  1401 Fortran  object time do                           50533
 392           sfx  a
 393 x1        equ  089
 394 x2        equ  94
 395 x3        equ  099
 396           org  2000
 397 do1       sbr  exitl
 398           sbr  x2
 399           sbr  x2,4&x2
 400           b    initl&4
 401 initl     equ  *&74
 402 exitl     equ  *&123
 403           xfr  0
 404           org  2000
 405 do2       sbr  x2
 406           mcw  11&x2,do3&6
 407           mcw
 408           mcw  5&x2,limt&3
 409           mcw  11&x2,sbix&3
 410           mcw  14&x2,testl&3
 411           sbr  exdo3&3,15&x2
 412 do3       equ  *&1
 413 limt      equ  *&8
 414 sbix      equ  *&15
 415 testl     equ  *&22
 416 exdo3     equ  *&30
 417           xfr  0
 418           org  2000
 419           a    0,0
 420           bfixwza,000,fixword
 421           bfixws,000,fixword
 422           bfixwbwz,000,fixword,,k
 423           b    0
 424           xfr  0
 425           job  1401 Fortran  initialization of do loops for do,list   50533
 426           org  2000
 427 initil    sbr  exitel&3
 428           mcw  2&x2,*&4
 429 *  note - address of fixword initialized by later pass
 430           bfixwza,000,fixword
 431           mcw  8&x2,*&4
 432           bfixws,000,fixword
 433           mcw  11&x2,*&7
 434           afixwlca,fixword,,000
 435 exitel    b    000
 436           ltorg*
 437           xfr  0
 438           job  1401 Fortran  object time list                         50533
 439           org  2000
 440 objlst    sbr  x2
 441           sbr  bstan&6,2&x2
 442           sbr  xtlst&3,3&x2
 443           mcw  2&x2,adlst#3
 444 xyz       mcw  adlst,x2
 445           bw   smple,0&x2
 446           bce  array,0&x2,,
 447           bce  subscr,0&x2,$
 448           bce  indx1,0&x2,%                 begin of do-type
 449           bce  indx4,0&x2,)       end of innermost do
 450           bce  indx2,0&x2,#                 end of outer do-type
 451           mcw  blank#3,x1                   end of list
 452 bstan     mcw  adlst,0
 453 xtlst     b    0
 454 ray       dcw  @xxxxxx@
 455 smple     mcw  2&x2,x1
 456           sbr  adlst,3&x2
 457           b    bstan
 458 array     mz   2136,*&8   fmtzon  change on reasm of obj format
 459           bce  noswt,@2s@,2
 460           bce
 461           bwz  inray,ray-4,2
 462           mcw  6&x2,ray
 463           mn   parama&4,sbrlt&6
 464           mn
 465           bwz  *&9,ray-4,k
 466           mn   parama&6,sbrlt&6
 467           mn
 468           mz   *-4,ray-4
 469 inray     mcw  ray-3,x1
 470 sbrlt     sbr  x1,0&x1
 471           mcw  x1,ray-3
 472           c    ray,ray-3
 473           bu   bstan
 474           mz   *-6,ray-4
 475           b    dun1
 476 noswt     mcw  6&x2,ray
 477           mcw  @.@,x1
 478 dun1      sbr  adlst,7&x2
 479           b    bstan
 480 subscr       t dosbsc
 481           mz   *-4,x1-1
 482           mcw  x2,adlst
 483           b    bstan
 484 indx1     sbr  x2,1&x2
 485              t doinit
 486           mn   0&x2
 487           sbr  x2
 488           b    setup
 489 indx2     mcw  3&x2,x2
 490 setup     mcw  12&x2,indx3&6
 491           mcw
 492           mcw  6&x2,limit&3
 493           mcw  12&x2,subix&3
 494           sbr  lparn#3,0&x2       save addr of left paren
 495 indx4     mcw  lparn,x2           set x2 to addr of left paren
 496 indx3     a    0,0
 497 *  note - address of fixword initialized by later phase of compiler
 498 limit     bfixwza,000,fixword
 499 subix     bfixws,000,fixword
 500 *  important note - the operand -satfy- in the following macro
 501 *     will not be coded as relocatable by the relocatable
 502 *     condensing routine.  This is due to the fact that the
 503 *     condenser does not recognize dc or dcw statements as having
 504 *     relocatable operands.  It is necessary to manually zone the
 505 *     set word mark instruction with and 11-punch to cause
 506 *     relocation.
 507           bfixwbwz,satfy,fixword,,k
 508           sbr  adlst,16&x2
 509           b    xyz
 510 satfy     mcw  15&x2,adlst
 511           b    xyz
 512           ltorg*
 513           xfr  0
 514           job  1401 Fortran  object time subscripts                   50533
 515           org  2000
 516 otsub     sbr  exits&3
 517           mcw  3&x2,aaa#3
 518           s    prod#5
 519           bav  *&1
 520 sbr1      mcw  9&x2,lca&3
 521           mcw  6&x2,za&3
 522 za        za   000,work#5
 523 lca       lca  000,bfeel-6
 524           m    work,bfeel#11
 525           a    bfeel,prod
 526           c    prod-3,@15@
 527           bl   ohalt
 528           bce  pack,10&x2,$
 529           sbr  x2,6&x2
 530           b    sbr1
 531 pack      a    &96,prod-3
 532           bav  pack
 533           mz   prod-4,prod
 534           za   prod-2,x1&1
 535           mz   zones-99&x1,prod-2
 536           mcw  prod,x1
 537           mcw  x1,sbr&6
 538           mz   zones-2,sbr&5
 539           mcw  aaa,x1
 540 sbr       sbr  x1,0&x1                      compute address
 541           mz   aaa-1,x1-1
 542           sbr  x2,11&x2
 543 exits     b    000
 544 ohalt     nop  2002
 545           h
 546           b    ohalt
 547 zones     dcw  @2skb@
 548           ltorg*
 549           xfr  0
 550           job  1401  Floating  point  sine - cosine  subroutine       50533
 551           sfx  b
 552 *             insert function common deck here
 553           org  2000
 554 *
 555 trigf     bce  cosf,code,c
 556 sinf      be   strze              sine 0 # 0
 557           mz   acchi&x3,za1       sine -x # -sine x
 558           b    sncs
 559 cosf      be   str1               cosine 0 # 1
 560           mz   &1,za1             cos -x # cos x
 561 sncs      mcw  @ @,box
 562           za   exp,expb
 563           s    &1,exp
 564           bm   small,exp
 565           a    &2,exp
 566           s    x3,exp
 567           bwz  arglg,exp,b
 568           za   expb,exp
 569           sbr  x1,piov2&x3        reduce argument
 570           za   exp&1,x2&1
 571           b    divid              divide argument by pi/2
 572           za   1&x1,x2&1
 573 sub4      s    &40,x2&1           determine quadrant in which
 574           bwz  sub4,x2&1,b        angle is located and whether
 575           bce  *&8,code,c         sine or cosine function is to
 576           sbr  x2,1&x2
 577           mz   zonz&x2,nsign
 578           mn   zonz&x2,box#1
 579           s    dec                dec # 0
 580           s    exp
 581           bce  cos,box,2
 582 *
 583 *                            sine initialization
 584 *
 585 sine      za   acchi&x3,top&1&x3
 586           b    sqrx
 587           za   top&1&x3,spot-1    first term # x
 588           za   spot&1
 589           zs   &2,ncon            ncon # -2
 590 *
 591 *                general  initialization  for  series  evaluation
 592 *
 593 scgen     za   &8,upby            upby # &8
 594           s    nctr               nctr # 8
 595           b    calc
 596 *
 597 *                   prepare  fields  for  normalization
 598 *
 599 za1       za   nsign
 600           sbr  x2,top&x3
 601           b    nmlz1
 602 *
 603 *                                 cosine initialization
 604 *
 605 cos       b    sqrx
 606           mn   &1,0&x1            first term # 1
 607           zs   &6,ncon            ncon # -6
 608           s    exp
 609           b    scgen
 610 *
 611 *                                square argument
 612 *
 613 sqrx      sbr  sqrxt&3
 614           mcw  acchi&x3,spot
 615           sbr  x1
 616           lca  @0@
 617           m    acchi&x3,spot&1&x3
 618           zs   spot&2,acchi&x3    change to -% x squared )
 619           s    spot&1
 620 sqrxt     b    xxx
 621 *
 622 *                                small  values  of  x
 623 *
 624 small     a    x3,exp
 625           bm   tstfc,exp
 626           za   expb,exp
 627           mz   acchi&x3,acchi-1&x3      shift contents of acchi&x3
 628           za   acchi-1&x3,acchi&x3      one position right
 629           a    expb
 630           zs   expb&1,dec         dec # 20*exp
 631           mz   &1,nsign
 632           bce  cos,code,c
 633           b    sine
 634 tstfc     bce  str1,code,c
 635           za   expb,exp
 636           b    clrwk
 637 arglg     b    ermsg
 638           dcw  @scl@
 639           b    strze
 640 *
 641 zonz      equ  *
 642           dcw  @akjba@
 643 *
 644 piov2     equ  *
 645           dcw  1570796326794896619231
 646           ex   trigf
 647           job  1401  floating  point  natural  logarithm              50533
 648 *
 649           org  2000
 650 *
 651 logf      mz   acchi&x3,basez
 652 logf2     be   log99
 653           bm   loger, acchi&x3    q. negative argument
 654 logf1     c    spot-2,acchi&x3
 655           sar  x1
 656           sw   0&x1
 657           mn   &1, 2&x1           set up constant one
 658 * for fastest rate of convergence, place arg between .32 and 3.2
 659           c    acchi&2,@31@
 660           bh   noshf
 661           za   acchi-1&x3,acchi&x3
 662           a    &1, exp            shift dec point 1 to left
 663 *
 664 noshf     s    acchi&x3, spot-1   compute 1-x
 665           zs   spot-1,lzone       correct sign
 666           s    &1, exp            shift dec point 1 to right
 667           a    &1, acchi&1        compute x&1
 668           s    &0, spot&x3        create quotient field
 669           d    acchi&x3, spot-1   compute u # x-1 / x&1
 670           lca  spot-1, hold
 671           m    hold, spot&1&x3    compute u **2
 672           za   spot-1, acchi&x3
 673           za   hold, spot&1
 674           za   linit,dec          dec  set to 0
 675           za                      nctr set to 1
 676           za                      ncon set to 2
 677           za                      upby set to 0
 678           sw   logm1,logm2
 679           sbr  logm1-4,hold
 680           sbr  logm2-1
 681           sbr  calxt&3,logrt
 682           b    calc1
 683 logrt     a    top&1&x3           double result
 684           mz   lzone, top&x3      get proper sign
 685           za   ln10&1&x3,spot-2
 686           m    exp, spot&2        compute n * log10
 687           a    top&x3, spot&2     add n * log10 to result
 688           sbr  x2, spot&2
 689           s    expb
 690           b    mvzon
 691 *
 692 loger     bw   *&8,4&x2
 693           b    ermsg
 694           dcw  @lnn@
 695           mz   linit,acchi&x3     make sign plus and find
 696           b    logf1                    log of absolute value
 697 log99     bw   power,4&x2
 698           b    ermsg
 699           dcw  @lnz@
 700           mz   -0,acchi&x3        give large neg number as result
 701           b    str99
 702 power     cw   zrosw
 703           b    str1
 704 *
 705           dcw  &0                 upby
 706           dcw  &2                 ncon
 707           dcw  &1                 nctr
 708 linit     dcw  &0                 dec
 709 hold      dcw  #26
 710 lzone     dcw  #1
 711           ex   logf
 712           job  1401  Fortran  floating  point  exponential            50533
 713 *
 714           org  2000
 715 *
 716 expf      mz   one,nsign
 717           mn   xpnum,*&8
 718           bce  outm1,@02468@,0
 719           chain4
 720           mz   basez,nsign
 721           mn   @8@,xpnum
 722 outm1     bw   runml,zrosw
 723           sw   zrosw         base is zero
 724           zs   acchi&x3
 725           bu   qsign     branch if arg not zero
 726           b    ermsg
 727           dcw  @ztz@          zero to zero power
 728 petty     mz   nsign,twtch
 729           b    str1
 730 runml     be   petty
 731 nrml      za   exp,expb
 732           s    one,expb
 733           bm   sml,expb           branch if exp less or # to zero
 734           s    three,expb
 735           bm   reduc,expb         branch if exp greater than zero
 736 *                                     and less than four
 737 *
 738 *             determine  whether  exponent  overflow  or  underflow
 739 *
 740 qsign     bm   strze,acchi&x3     branch if argument negative
 741           b    ermsg              exponent overflow
 742           dcw  @eof@
 743           b    str99
 744 *
 745 *                  exponent  #  &1,  &2,  or  &3
 746 *
 747 reduc     sbr  x1,ln10&x3         store address of divisor
 748           za   exp&1,x2&1
 749           b    divid
 750           c    0&x1,thc99
 751           bl   qsign              branch if quot greater than 99
 752           za   0&x1,exp
 753           mz   acchi&x3,exp
 754 *
 755 *                 prepare  fields  for  series  calculation
 756 *
 757           s    dec
 758 fterm     c    spot,acchi&x3      set up term development area
 759           sar  x1
 760           sw   0&x1
 761           s    spot&1             clear term development area
 762           mn   one,0&x1           first term # 1
 763           za   thc99-2,nctr       set nctr # zero
 764           za                      set ncon # 1
 765           za                      set upby # zero
 766           b    calc
 767 *
 768 *                 prepare  fields  for  normalizing
 769 *
 770           mz   top&1&x3,top&x3
 771           sbr  x2,top&x3
 772           b    nmlz1
 773 *
 774 *                 exponents  less  or  #  to  zero
 775 *
 776 sml       a    x3,expb
 777           bm   petty,expb    branch if -e greater than precision
 778           zs   exp&1,dec          set dec # e
 779           s    exp
 780           mz   acchi&x3,acchi-1&x3    set up series multiplier
 781           za   acchi-1&x3,acchi&x3
 782           b    fterm
 783           dcw  0
 784 one       dcw  &1
 785 thc99     dcw  &099
 786 three     dcw  &3
 787           ex   expf
 788           job  1401  floating  point  arctangent                      50533
 789 *
 790           org  2000
 791 *
 792 case1     be   strze
 793           mz   &1,initl
 794           za   acchi-1&x3,acchi&x3
 795           s    dec
 796           s    top&1&x3
 797           c    spot-2,acchi&x3
 798           sar  x1
 799           sw   0&x1
 800           za   @0?@,spot&x3
 801           mcw  @0?@,expb
 802           mn   exp,expb
 803           mn
 804           c    expb,@0?@
 805           be   zerex
 806           s    x3,expb
 807           bm   test,expb
 808           bm   case2,exp
 809           b    case7
 810 case2     mcw  acchi&x3,top&x3
 811           a    &1,exp
 812           b    sign
 813 case7     s    exp
 814 addpi2    a    piov4&1&x3,top&1&x3
 815 addpi4    a    piov4&1&x3,top&1&x3
 816 sign      sbr  x2,top&x3
 817           b    nmlz1
 818 test      bm   case3,exp
 819           mn   &1,2&x1
 820 shift     za   spot-1&x3,spot&x3
 821           s    &1,exp
 822           c    exp,@0?@
 823           bl   shift
 824           d    acchi&x3,spot-1
 825           c    2&x1,@042@
 826           bh   case6
 827           zs   initl
 828           mcw  spot-3,acchi&x3
 829           za   @0?@,spot&x3
 830           b    case4
 831 case6     sbr  calxt&3,addpi2
 832           zs   initl
 833           b    mltply
 834 case3     sbr  calxt&3,sign
 835           za   exp,expb
 836           a    expb
 837           zs   expb&1,dec
 838           mcw  acchi&x3,spot-3
 839           b    mltply
 840 zerex     c    acchi&3,@042@
 841           bh   case3
 842 case4     sbr  calxt&3,addpi4
 843           zs   initl
 844           mn   &1,2&x1
 845           s    acchi&x3,spot-1
 846           a    &1,acchi&1
 847           a    @0?@,spot&x3
 848           d    acchi&x3,spot-1
 849 mltply    lca  spot-1,holdd
 850           m    holdd,spot&2&x3
 851           zs   spot-1,acchi&x3
 852 initl     za   holdd
 853           za   holdd,spot&1
 854           za   &2,ncon
 855           s    upby
 856           za   &1,nctr
 857           sw   logm1,logm2
 858           sbr  logm1-4,holdd
 859           sbr  logm2-1
 860           b    calc1
 861 piov4     equ  *&1
 862           dcw  @078539816339744830961566@
 863 holdd     dcw  #24
 864           ex   case1
 865           job  1401  absolute  value - negate  subroutine             50533
 866 *
 867           org  2000
 868 absvl     mz   *&1,acchi&x3       negate absolute value of argument
 869           ex   absvl
 870 *
 871           org  2000
 872 negf      zs   acchi&x3
 873           b    clrwk
 874           ex   negf
 875           job  float  to  fix  conversion                             50533
 876 *
 877           org  2000
 878 *
 879 fixf      sw   fixsw
 880           sbr  x1,0&x3
 881           mcw  parama&4,*&7
 882           sbr  x3,000
 883           s    &1,exp
 884           bm   strze,exp    store zero if char of arg less than 1
 885           za   exp&1,x2&1
 886           c    x1,x2
 887           bl   expls
 888           s    x1&1,x2&1
 889           c    x3,x2
 890           bh   strze
 891           s    spot&1&x2
 892           za   acchi&x1,spot
 893           mz   spot,spot&1&x2
 894           za   spot&1&x2,acchi&x3   store fixpt numbers modulo k
 895           b    clrwk
 896 expls     mz   acchi&x1,acchi&1&x2  add only integer places
 897           lca  acchi&1&x2,spot
 898           za   spot,acchi&x3
 899           b    clrwk
 900           ex   fixf
 901           job  fix  to  float  conversion                             50533
 902 *
 903           org  2000
 904 *
 905 flot      cw   fixsw
 906           bw   *&5,4&x2
 907           b    *&8
 908           mn   acchi&x3,xpnum
 909           sbr  x2,spot
 910           lca  acchi&x3
 911           mcw  parama&6,*&7
 912           sbr  x3,000
 913           za   x3,expb
 914           b    mvzon
 915           ex   flot
 916           job  1401 floating point square root                        50533
 917 *
 918           org  2000
 919 *
 920 sqrtf     bm   qerr,acchi&x3      branch if argument negative
 921           mn   acchi&x3,top&21&x3
 922           mcw
 923           sw
 924           sbr  x1
 925           lca  &1,top             initialize subtrahend
 926           sbr  x2
 927           za   exp&1,acchi&4      determine exponent of root
 928           a    &1, acchi&3
 929           m    &50,acchi&6
 930           mn   acchi&4, exp
 931           mn
 932           bce  cksgn,acchi&5,0
 933           sbr  x1,1&x1
 934           b    qstrt
 935 cksgn     bwz  qstrt,exp,b
 936           a    &1,exp
 937 qstrt     s    acchi&x3
 938 qrtn      s    &11,2&x2           adjust subtrahend
 939           sw   21&x2
 940           cw
 941           sbr  x2, 1&x2
 942           zs   &1, cntr#1
 943 qloop     a    &1,cntr            compute result digits
 944           a    &2,1&x2            increase subtrahend
 945           s    1&x2,2&x1          do odd-integer subtractions
 946           bwz  qloop, 2&x1, b
 947           a    1&x2, 2&x1
 948           mn   cntr, delta&x2
 949           sbr  x1, 2&x1
 950           bwz  qrtn, delta&x2, 2
 951           b    clrwk
 952 qerr      b    ermsg
 953           dcw  @sqn@
 954           mz   &1,acchi&x3
 955           cs   acchi-1
 956           b    sqrtf&8
 957           ex   sqrtf
 958           job  1401 fortran  user functions                           50533
 959           sfx  a
 960           org  2000
 961           dcw  @user function  1 goes here@
 962           xfr  0
 963           org  2000
 964           dcw  @user function  2 goes here@
 965           xfr  0
 966           org  2000
 967           dcw  @user function  3 goes here@
 968           xfr  0
 969           org  2000
 970           dcw  @user function  4 goes here@
 971           xfr  0
 972           org  2000
 973           dcw  @user function  5 goes here@
 974           xfr  0
 975           org  2000
 976           dcw  @user function  6 goes here@
 977           xfr  0
 978           org  2000
 979           dcw  @user function  7 goes here@
 980           xfr  0
 981           org  2000
 982           dcw  @user function  8 goes here@
 983           xfr  0
 984           org  2000
 985           dcw  @user function  9 goes here@
 986           xfr  0
 987           org  2000
 988           dcw  @user function 10 goes here@
 989           xfr  0
 990           org  2000
 991           dcw  @user function 11 goes here@
 992           xfr  0
 993           org  2000
 994           dcw  @user function 12 goes here@
 995           xfr  0
 996           job  1401 Fortran relocatable xlinkf                        50533
 997           org  2000
 998 start     mcw  clrcon,359     chang on reasm of fixed xlink
 999           b    337
1000 clrcon    dcw  #3
1001           ex   start
1002           job  1401 Fortran  function branch routine                  50533
1003           org  2000
1004              t sinfun,4&x2,s
1005           xfr  0
1006           org  2000
1007              t sinfun,4&x2,C
1008           xfr  0
1009           org  2000
1010              t logfun,4&x2,g
1011           xfr  0
1012           org  2000
1013              t xpnetl,4&x2,e
1014           xfr  0
1015           org  2000
1016              t atanfn,4&x2,t
1017           xfr  0
1018           org  2000
1019              t absval,4&x2,a
1020           xfr  0
1021           org  2000
1022              t negtfn,4&x2,n
1023           xfr  0
1024           org  2000
1025              t fixfun,4&x2,x
1026           xfr  0
1027           org  2000
1028              t fltfun,4&x2,f
1029           xfr  0
1030           org  2000
1031              t sqrtfn,4&x2,q
1032           xfr  0
1033           org  2000
1034              t yuser1,4&x2,r
1035           xfr  0
1036           org  2000
1037              t yuser2,4&x2,u
1038           xfr  0
1039           org  2000
1040              t yuser3,4&x2,p
1041           xfr  0
1042           org  2000
1043              t yuser4,4&x2,w
1044           xfr  0
1045           org  2000
1046              t yuser5,4&x2,y
1047           xfr  0
1048           org  2000
1049              t yuser6,4&x2,z
1050           xfr  0
1051           org  2000
1052              t yuser7,4&x2,j
1053           xfr  0
1054           org  2000
1055              t yuser8,4&x2,k
1056           xfr  0
1057           org  2000
1058              t yuser9,4&x2,l
1059           xfr  0
1060           org  2000
1061              t yusr10,4&x2,m
1062           xfr  0
1063           org  2000
1064              t yusr11,4&x2,d
1065           xfr  0
1066           org  2000
1067              t yusr12,4&x2,h
1068           xfr  0
1069           org  2000
1070              t xlinks,4&x2,i
1071           xfr  0
1072           end


phase-63.315.s
               JOB  Fortran compiler -- Arithmetic package -- Phase 63
               CTL  6611
     *
     * This phase is comprised of the arithmetic routine which is
     * loaded by GEAUX phase 2.
     *
               ORG  87
   89x1        DCW  000
   91          DC   00
   94x2        DCW  000
   96          dc   00
   99x3        DCW  000
  100          dc   0
     *
     * Arithmetic interpreter
     *
     * General form of interpreted string is
     * operand [ operator operand ... ],
     * however, if operand has a word mark, it's an operator,
     * usually a function call.  Operands are machine addresses,
     * with a tag in the tens digit to indicate type: A- or B-
     * zone alone indicates integer.  Operators are one character.
     * Subscript calculations are surrounded by $...$.
     *
     * Two accumulators in the print area are used.  The low-order
     * digit of an operand is loaded into accumulator 1 at 250; it
     * extends leftward  by the length of the operand, and rightward
     * from the left end by the mantissa width.  Accumulator 2 has its
     * high-order digit at acchi&1; it extends rightward by the mantissa
     * width.
     *
     * In the Fortran manual C24-1455, the high-order digit of
     * accum 2 is labeled ACCHI&1.
     *
     acchi     equ  279
     *
     * Mostly, index register usage is
     * X1 = operand address
     * X2 = interpreter's counter, low-order digit of accum 1
     * X3 = operand width
     *
     * Address in phase 62
     *
     ldret     equ  227  Return here after loading
     *
               ORG  700
  700aritf     SBR  x2
  704          SBR  x1-3        Interpreter address for dumps
  708          SBR  ermsi&6     Interpreter address for err msgs
  712nxtop     MCW  2&X2,x1     x1 = Operand (result) address
  719          SAR  sx2a&6      Save x2-1
  723nxtop0    SBR  sx2b&6        twice
  727          BCE  dosub,0&X2,$  Subscript?
  735          SBR  res&6,0&X1  Save x1 (result address)
  742          CS   303         Clear accumumulators
  746          CS
  747          CS
  748          LCA  kz1,acchi&1     Set high-order zero in accum 2
  755nxtop1    S    x1&2        Clear x1
  759sx2a      SBR  x2,0-0      recover x2 = addr(operand) - 1
  766          C    4&X2,asgop  Compare op to assignment op
  773          MCW  4&X2,savop  Save whatever operator it is
  780          SW   201
  784          BL   func        func if assignment op .lt. operator
     *
     * Assignment op greater or equal to operator, i.e., operator is
     * blank, ., ) lozenge, } group mark, &, $, *, -, /, comma, %, #
     *
  789          SBR  nxtop2&6,4&X2  Save addr of operator
  796          BCE  dosub5,5&X2,$  Subscript?
  804          MCW  7&X2,x1     Second operand address to x1
  811          SAR  sx2a&6      save 4&x2
  815tstzon    BWZ  ariti,x1-1,K  Operand 2 tag is B zone (integer)?
  823          BWZ  ariti,x1-1,S  Operand 2 tag is A zone (integer)?
  831          SBR  x3,0        Loader plugs mantissa width into B
  838          CW   iflag       Indicate floating point
  842          MCW  0&X1,exp1-1   Save exponent 1
  849          SAR  x1          Save mantissa 1 address
  853          MCW  0&X1,250    mantissa 1 to accumulator 1
     * From here, X2 indexes accum 1, first high, then low digit
  860          SBR  x2          Set X2 to accum 1 address - op width
  864          LCA  kz1         Append a high-order zero to accum 1
  868nxtop2    BW   nosign,0-0  WM under operator?
  876          MZ   250,zas     Sign of operand 1 determines ZA or ZS
  883nosign    S    kz1,252&X3  Add zeros below mantissa
  890          C    1&X2,kz1    Compare operand high-order digit to 0
  897          A    x3,x2       x2 now at low-order digit of accum 1
  904          BCE  fdiv,savop,/  Divide?
  912          BCE  fmpy,savop,*  Multiply?
  920          S    savop         Turn it back to ZA
  924savop     ZA   zas           Copy this op code
  928          BCE  nmlz1,acchi&1,0   high-order digit of accum 2 zero?
  936          BE   clrwk         Accum 1 high-order digit is zero
  941          S    exp1-1,exp2-1  exp2 is now exp2 - exp1
  948          ZA   exp2,x1&1     Move abs(exp2-exp1) to x1
  955          C    x3,x1  compare mantissa width and abs(exp2-exp1)
  962          BM   e1gte2,exp2-1  exp1 .gt. exp2
  970          BH   exdgmw        abs(exp2-exp1) .gt. mantissa width
  975          A    exp2-1,exp1-1  Add exp2-exp1 to exp1
  982          ZA   250,250&X1    Shift mantissa right by exp2-exp1
  989          ZA   x3&1,x1&1     X1 and X3 now both mantissa width
  996addsub    MZ   zas,0&X2      Sign of accum 1 depends on op
 1003          A    acchi&X1,0&X2   Add (subtract) mantissas
     *
     * Relocatable functions return here too
     *
 1010fret      MZ   0&X2,zas
     *
     * Normalize floating-point result of a single arithmetic
     * operation; place the normalized result in the working
     * accumulator.  If exponent overflow is detected, go to ERMSG to
     * print message (NOF); then go to STR99.  If exponent underflow
     * is detected, go to STRZE.  Here, the low-order digit of the
     * result is indexed by x2.
     *
     * The normalized result is left in accum 2.
     *
 1017nmlz1     ZA   exp1-1,exp2-1
 1024nmlz2     MCW  rm,1&X2    Insert RM after low-order digit
 1031          MZ              Chain
 1032          MZ                two zeros
 1033          A               and add another one
 1034          MN              Decr A and B (copies junk to unused)
 1035          SBR  x1         X1 is now two below accum 1 high-order
 1039          S    acchi&2&X3    Clear accum 2
 1043nmlzl     BCE  strze,2&X1,|  Record mark indicates zero result
 1051          SBR  x1            Bump x1
 1055          BCE  nmlzl,1&X1,0  Zero means more normalization needed
 1063          MCM  1&X1,acchi&1      Normalize
 1070          S    x3,x2
 1077          CW                 Decrease AS and BS to
 1078          CW                   refer to X2 and X1
 1079          S                  S    x2,x1
 1080          S    x1,exp2-1     Store normalized exponent
 1087zas       ZA   acchi&X3        ZS if accum 1 negative
 1091          SW
 1092          BCE  clrwk,exp2-3,0
 1100          BM   strze,exp2-1  Exponent underflow
 1108          B    ermsg         Exponent overflow
 1114          DCW  @NOF@
     *
     * Exponent overflow; set result magnitude equal to largest
     * value possible in floating-point notation; set result sign
     * as appropriate.
     *
 1115str99     ZA   kp99,exp2-1   -99 to exp2
 1122          MN   kp99,acchi&X3   All 9's
 1129          MCW                  to mantissa
 1130          MCW  acchi-1&X3            in accum2
     *
     * Clear accum 1 after an individual arithmetic operation
     *
 1134clrwk     CS   acchi-1
 1138          B    nxtop1
     *
     * Exponent underflow, or result is zero.  Set floating-point
     * result to zero
     *
 1142strze     S    exp2-1  exp2 = 0
 1146          S    acchi&X3  accum 2 mantissa = 0
 1150          B    clrwk
     *
     * Division by zero
     *
 1154dverr     B    ermsg
 1160          dcw  @DZE@  Divide by zero message
 1161          B    str99  Insert overflow exponent
     *
     * exp1 is greater than exp2
     *
 1165e1gte2    BH   nmlz1  abs(exp2-exp1) .gt. mantissa width
 1170          S    x3&1,x1&1  subtr man. width from abs(exp2-exp1) 
 1177          MZ   acchi&X3,acchi&X1  Move zone over to new width
 1184          B    addsub  Go add (or subtract) mantissas
     *
     * abs(exp2-exp1) .gt. mantissa width
     *
 1188exdgmw    A    exp1-1,exp2-1  Restore exp2
 1195          B    clrwk
     *
     * Calculate subscripted address using a relocatable routine that
     * is only loaded if needed.
     *
 1199dosub5    SBR  x2,5&X2  Bump x2 to beginning of subscript info
 1206dosub     B    0-0  Loader plugs subscript routine address here
     *
 1210          MN   0&X2  Subtract 4 from x2
 1214          MN
 1215          MN
 1216          MN
 1217          SAR  sx2a&6
 1221sx2b      BCE  nxtop0,0-0,$
 1229          B    tstzon
     *
     * Floating-point divide
     *
 1233fdiv      BE   dverr     Divide by zero (compare was at nosign)
 1238          MN   acchi&X3,1&X2
 1245          MCW
 1246          MN
 1247          D    0&X1,251  Divide mantissas.
 1254          ZS   exp1-1    Negate exponent
 1258          B    exps      Go add exponents, normalize, etc.
     *
     * Floating-point multiply
     *
 1262fmpy      M    acchi&X3,251&X3  Multiply mantissas
 1269          SBR  x2,3&X2
 1276          S    kp2,exp2-1
 1283exps      A    exp1-1,exp2-1  Add exponents
 1290          MZ   acchi&X3,*&1  Prepare to
 1297          ZA   zas           set sign of result
 1301          B    nmlz2       Normalize
     *
     * Assignment operator is less than current operator, i.e.,
     * current operator is one of @, ?, A-I, !, J-R, |, S-Z, 0-9.
     * If not record mark, it's the first character of what would
     * otherwise be an operand, so bump the operand address.
     *
 1305func      BCE  done,4&X2,|  Done (record mark)?
 1313          SBR  sx2a&6,1&X2  Bump operand addr
 1320          C    acchi&1,kz1      High-order accum 2 mantissa digit
     * The loader plugs the relocatable function selector address here
 1327qfunct    B    0            Go to function selector
 1331done      BCE  res,acchi&1,0    Floating-point result zero?
 1339          BW   res,iflag    Integer result?
 1347          BW   fpres,4&X2   WM under operator?
 1355          SBR  x3,2&X3
 1362sexp2     MCM  exp2-2,acchi-1&X3  Move exp2 to accum 2
 1369res       LCA  acchi&X3,0     Store accumulator to saved B
 1376          BW   5&X2,4&X2    Return if done (word mark)
 1384          SAR  x2           Bump x2 to next operand
 1388          B    nxtop
     *
     * Round nonzero floating-point result
     *
 1392fpres     A    kp5,acchi-1&X3   Round mantissa
 1399          BWZ  carry,acchi&1,S  Carry in acc2 shown by A-zone?
 1407cpzone    MZ   acchi&X3,acchi-2&X3  Move zone from exp to man
 1414          B    sexp2
 1418carry     A    kp1,exp2-1   Bump exponent
 1425          BCE  fovfl,exp2-3,1  Overflow?
 1433          S    acchi&X3       Clear mantissa
 1437          LCA  k1b-1,acchi&1  and put 1 in its high-order digit
 1444          B    cpzone
     *
     * Floating-point overflow -- high-order digit of exp2 is 1
     *
 1448fovfl     MN   kp99,acchi&X3  99 to
 1455          MCW                 exponent
 1456          MCW  acchi-1&X3     all 9s to mantissa
 1460          S    kp1,exp2-1
 1467          B    cpzone
     *
     * Print appropriate error messages, which includes a mnemonic
     * three-character code and the display address in the generated
     * procedure of the source program statement being executed.  This
     * subroutine is used to record circumstances, occurring during
     * arithmetic operations, which may affect the calculation
     * adversely.
     *
 1471ermsg     SBR  ersvx&6    Save return address
 1475          CS   202&X3
 1479          SBR  ersx3&6,0&X3  Save x3
 1486ersvx     SBR  x3,0       Return address to x3
 1493          MCW  2&X3,212   Mnemonic to print area
 1500ermsi     SBR  217,0      Interpreter address to print area
 1507          W
 1508          SW   201
 1512          SBR  ermsgx&3,3&X3  Return address to exit
 1519ersx3     SBR  x3,0       Restore x3
 1526ermsgx    B    0
     *
     * Operand tens digit has A or B but not AB zone (integer arith.)
     *
 1530ariti     SBR  x3,0          Loader puts integer size in B
 1537          SW   iflag         Indicate integer
 1541          MCS  0&X1,250      Operand to accumulator 1
 1548          BCE  xdiv,savop,/  Divide?
 1556          BCE  xmpy,savop,*  Multiply?
 1564          BM   xsub,savop    Subtract?
 1572          A    0&X1,acchi&X3   Add operand to accumulator 2
 1579xsign     ZA   acchi&X3        Put a sign on the accumulator
 1583          B    clrwk
 1587xsub      S    0&X1,acchi&X3   Subtract operand from accumulator 2
 1594          B    xsign
 1598xmpy      LCA  0&X1,250      Move operand to accumulator 1
 1605          M    acchi&X3,251&X3
 1612          MCW  251&X3,acchi&X3
 1619          B    clrwk
 1623xdiv      BCE  dverr,250,    Divide by zero?
 1631          MCW  0&X1,250&X3
 1638          MN
 1639          SBR  moveq&3       Store addr to move to accum 2
 1643          LCA  acchi&X3
 1647          ZA   acchi&X3,250&X3
 1654          D    0&X1,251
 1661moveq     MCW  249,acchi&X3
 1668          B    clrwk
     *
     * Data
     *
 1674          dcw  000     Chained to RM
 1675rm        DCW  @|@
 1676          DCW  0
 1680exp2      DCW  @000|@  Exponent of accum 2, and zero and RM
 1683exp1      dcw  000     Exponent of accum 1, and zero
 1684k8        dcw  8
 1685kz1       DCW  0
 1686asgop     dcw  @#@     Assignment operator
 1687iflag     DCW  #1      Word mark indicates integer
 1689kp99      dcw  &99     Used for overflow
 1690kp2       DCW  &2
 1691kp5       dcw  &5
 1692kp1       dcw  &1
 1694k1b       dcw  @1 @
 1695          DCW  0
 1696gmwm      DCW  @}@
               ex   ldret
               END


Started Jan 21, 2012
Last updated Oct 6, 2014
Return to main page
test stuff 1401 - FORTRAN - SIMH