*        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