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.
Files named phase-63.315 are my reverse engineering from the v3m0
operational tape. This one explains the format of the pseudo code.
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