*        Stern-Brocot sequence     - 12/03/2019
STERNBR  CSECT
         USING  STERNBR,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     R4,SB+2            k=2; @sb(k)
         LA     R2,SB+2            i=1; @sb(k-i)
         LA     R3,SB+0            j=2; @sb(k-j)
         LA     R1,NN/2            loop counter
LOOP     LA     R4,2(R4)             @sb(k)++
         LH     R0,0(R2)             sb(k-i)
         AH     R0,0(R3)             sb(k-i)+sb(k-j)
         STH    R0,0(R4)             sb(k)=sb(k-i)+sb(k-j)
         LA     R3,2(R3)             @sb(k-j)++
         LA     R4,2(R4)             @sb(k)++
         LH     R0,0(R3)             sb(k-j)
         STH    R0,0(R4)             sb(k)=sb(k-j)
         LA     R2,2(R2)             @sb(k-i)++
         BCT    R1,LOOP            end loop
         LA     R9,15              n=15
         MVC    PG(5),=CL80'FIRST'
         XDECO  R9,XDEC            edit n
         MVC    PG+5(3),XDEC+9     output n
         XPRNT  PG,L'PG            print buffer
         LA     R10,PG             @pg
         LA     R6,1               i=1
       DO WHILE=(CR,R6,LE,R9)      do i=1 to n
         LR     R1,R6                i
         SLA    R1,1                 ~
         LH     R2,SB-2(R1)          sb(i)
         XDECO  R2,XDEC              edit sb(i)
         MVC    0(4,R10),XDEC+8      output sb(i)
         LA     R10,4(R10)           @pg+=4
         LA     R6,1(R6)             i++
       ENDDO    ,                  enddo i
         XPRNT  PG,L'PG            print buffer
        LA     R7,1                j=1
       DO WHILE=(C,R7,LE,=A(11))   do j=1 to 11
       IF C,R7,EQ,=F'11' THEN        if j=11 then
         LA     R7,100                 j=100
       ENDIF    ,                    endif
         LA     R6,1                 i=1
       DO WHILE=(C,R6,LE,=A(NN))     do i=1 to nn
         LR     R1,R6                  i
         SLA    R1,1                   ~
         LH     R2,SB-2(R1)            sb(i)
         CR     R2,R7                  if sb(i)=j
         BE     EXITI                  then leave i
         LA     R6,1(R6)               i++
       ENDDO    ,                    enddo i
EXITI    MVC    PG,=CL80'FIRST INSTANCE OF'
         XDECO  R7,XDEC              edit j
         MVC    PG+17(4),XDEC+8      output j
         MVC    PG+21(7),=C' IS AT '
         XDECO  R6,XDEC              edit i
         MVC    PG+28(4),XDEC+8      output i
         XPRNT  PG,L'PG              print buffer
         LA     R7,1(R7)             j++
       ENDDO    ,                  enddo j
         L      R13,4(0,R13)       restore previous savearea pointer
         RETURN (14,12),RC=0       restore registers from calling sav
         LTORG
NN       EQU    2400               nn
PG       DC     CL80' '            buffer
XDEC     DS     CL12               temp for xdeco
SB       DC     (NN)H'1'           sb(nn)
         REGEQU
         END    STERNBR