*        Digital root              21/04/2017
DIGROOT  CSECT
         USING  DIGROOT,R13        base register
         B      72(R15)            skip savearea
         DC     17F'0'             savearea
         STM    R14,R12,12(R13)    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,=A((PG-T)/4))  do i=1 to hbound(t)
         LR     R1,R6                i
         SLA    R1,2                 *4
         L      R10,T-4(R1)          nn=t(i)
         LR     R7,R10               n=nn
         SR     R9,R9                ap=0
       DO WHILE=(C,R7,GE,=A(10))     do while(n>=10)
         SR     R8,R8                  x=0
       DO WHILE=(C,R7,GE,=A(10))       do while(n>=10)
         LR     R4,R7                    n
         SRDA   R4,32                    >>r5
         D      R4,=A(10)                m=n//10
         LR     R7,R5                    n=n/10
         AR     R8,R4                    x=x+m
       ENDDO    ,                      end
         AR     R7,R8                  n=x+n
         LA     R9,1(R9)               ap=ap+1
       ENDDO    ,                    end
         XDECO  R10,XDEC             nn
         MVC    PG+7(10),XDEC+2
         XDECO  R9,XDEC              ap
         MVC    PG+31(3),XDEC+9
         XDECO  R7,XDEC              n
         MVC    PG+41(1),XDEC+11
         XPRNT  PG,L'PG              print
         LA     R6,1(R6)             i++
       ENDDO    ,                  enddo i
         L      R13,4(0,R13)       restore previous savearea pointer
         LM     R14,R12,12(R13)    restore previous context
         XR     R15,R15            rc=0
         BR     R14                exit
T        DC     F'627615',F'39390',F'588225',F'2147483647'
PG       DC     CL80'number=xxxxxxxxxx  persistence=xxx  root=x'
XDEC     DS     CL12
         YREGS
         END    DIGROOT