*        Roman numerals Encode     - 11/05/2020
ROMAENC  CSECT
         USING  ROMAENC,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,=A(8))       do i=1 to hbound(nums)
         LR     R1,R6                i
         SLA    R1,1                 ~
         LH     R8,NUMS-2(R1)        n=nums(i)
         MVC    PG,=CL80'.... :'     clear buffer
         LA     R9,PG                @pg
         XDECO  R8,XDEC              edit n
         MVC    0(4,R9),XDEC+8       output n
         LA     R9,7(R9)             @pg+=7
         LA     R7,1                 j=1
   DO  WHILE=(C,R7,LE,=A(13))        do j=1 to 13
         LR     R1,R7                  j
         SLA    R1,1                   ~
         LH     R3,ARABIC-2(R1)        aj=arabic(j)
   DO WHILE=(CR,R8,GE,R3)              while n>=aj
         LR     R1,R7                    j
         SLA    R1,1                     ~
         LA     R4,ROMAN-2(R1)           roman(j)
         MVC    0(2,R9),0(R4)            output roman(j)
       IF   CLI,1(R9),NE,C' ' THEN       if roman(j)[2]=' ' then
         LA     R9,2(R9)                   @pg+=2
       ELSE     ,                        else
         LA     R9,1(R9)                   @pg+=1
       ENDIF    ,                        endif
         SR     R8,R3                    n-=aj
   ENDDO        ,                      endwile
         LA     R7,1(R7)               j++
   ENDDO        ,                    enddo j
         XPRNT  PG,L'PG              print buffer
         LA     R6,1(R6)             i++
   ENDDO        ,                  enddo i
         L      R13,4(0,R13)       restore previous savearea pointer
         RETURN (14,12),RC=0       restore registers from calling save
ARABIC   DC     H'1000',H'900',H'500',H'400',H'100',H'90'
         DC     H'50',H'40',H'10',H'9',H'5',H'4',H'1'
ROMAN    DC     CL2'M',CL2'CM',CL2'D',CL2'CD',CL2'C',CL2'XC'
         DC     CL2'L',CL2'XL',CL2'X',CL2'IX',CL2'V',CL2'IV',CL2'I'
NUMS     DC   H'14',H'16',H'21',H'888',H'1492',H'1999',H'2020',H'3999'
PG       DS     CL80               buffer
XDEC     DS     CL12               temp for xdeco
         REGEQU
         END    ROMAENC