 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           dc   @}@               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 iniitialized 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
