49 lines
2.2 KiB
Plaintext
49 lines
2.2 KiB
Plaintext
* FRACTRAN 17/02/2019
|
|
FRACTRAN CSECT
|
|
USING FRACTRAN,R13 base register
|
|
B 72(R15) skip savearea
|
|
DC 17F'0' savearea
|
|
SAVE (14,12) save previous context
|
|
ST R13,4(R15) link backward
|
|
ST R15,8(R13) link forward
|
|
LR R13,R15 set addressability
|
|
LA R6,1 i=1
|
|
DO WHILE=(C,R6,LE,TERMS) do i=1 to terms
|
|
LA R7,1 j=1
|
|
DO WHILE=(C,R7,LE,=A(NF)) do j=1 to nfracs
|
|
LR R1,R7 j
|
|
SLA R1,3 ~
|
|
L R2,FRACS-4(R1) d(j)
|
|
L R4,NN nn
|
|
SRDA R4,32 ~
|
|
DR R4,R2 nn/d(j)
|
|
IF LTR,R4,Z,R4 THEN if mod(nn,d(j))=0 then
|
|
XDECO R6,XDEC edit i
|
|
MVC PG(3),XDEC+9 output i
|
|
L R1,NN nn
|
|
XDECO R1,PG+5 edit & output nn
|
|
XPRNT PG,L'PG print buffer
|
|
LR R1,R7 j
|
|
SLA R1,3 ~
|
|
L R3,FRACS-8(R1) n(j)
|
|
MR R4,R3 *n(j)
|
|
ST R5,NN nn=nn/d(j)*n(j)
|
|
B LEAVEJ leave j
|
|
ENDIF , end if
|
|
LA R7,1(R7) j++
|
|
ENDDO , end do j
|
|
LEAVEJ LA R6,1(R6) i++
|
|
ENDDO , end do i
|
|
L R13,4(0,R13) restore previous savearea pointer
|
|
RETURN (14,12),RC=0 restore registers from calling sav
|
|
NF EQU (TERMS-FRACS)/8 number of fracs
|
|
NN DC F'2' nn
|
|
FRACS DC F'17',F'91',F'78',F'85',F'19',F'51',F'23',F'38',F'29',F'33'
|
|
DC F'77',F'29',F'95',F'23',F'77',F'19',F'1',F'17',F'11',F'13'
|
|
DC F'13',F'11',F'15',F'14',F'15',F'2',F'55',F'1'
|
|
TERMS DC F'100' terms
|
|
PG DC CL80'*** :' buffer
|
|
XDEC DS CL12 temp
|
|
REGEQU
|
|
END FRACTRAN
|