*        Roman numerals Decode -   17/04/2019
ROMADEC  CSECT
         USING  ROMADEC,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(NV))   do i=1 to hbound(vals)
         LR     R1,R6                i
         SLA    R1,3                 ~
         LA     R4,VALS-L'VALS(R1)   @vals(i)
         MVC    X,0(R4)              x=vals(i)
         SR     R9,R9                prev=0
         ST     R9,Y                 y=0
         LA     R7,L'X               j=1
       DO WHILE=(C,R7,GE,=A(1))      do j=length(x) to 1 by -1
         LA     R4,X-1                 @x
         AR     R4,R7                  +j
         MVC    C,0(R4)                c=substr(x,j,1)
       IF   CLI,C,NE,C' ' THEN         if c^=' ' then
         SR     R1,R1                  r1=0
         LA     R2,1                   k=1
       DO WHILE=(C,R2,LE,=A(L'ROMAN))   do k=1 to length(roman)
         LA     R3,ROMAN-1               @roman
         AR     R3,R2                    +k
       IF   CLC,0(L'C,R3),EQ,C THEN      if substr(roman,k,1)=c
         LR     R1,R2                      index=k
         B      REINDEX                    leave k
       ENDIF    ,                        endif
         LA     R2,1(R2)                 k=k+1
       ENDDO    ,                      enddo k
REINDEX  EQU    *                      r1=index(roman,c)
         SLA    R1,2                   ~
         L      R8,DECIM-4(R1)         n=decim(index(roman,c))
       IF    CR,R8,LT,R9 THEN          if n<prev then
         LCR    R8,R8                    n=-n
       ENDIF    ,                      endif
         L      R2,Y                     y
         AR     R2,R8                    +n
         ST     R2,Y                     y=y+n
         LR     R9,R8                    prev=n
       ENDIF    ,                      endif
         BCTR   R7,0                   j--
       ENDDO    ,                    enddo j
         MVC    PG(8),X              x
         L      R1,Y                 y
         XDECO  R1,XDEC              edit y
         MVC    PG+12(4),XDEC+8      output y
         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 sav
NV       EQU    (X-VALS)/L'VALS
ROMAN    DC     CL7'MDCLXVI'
DECIM    DC     F'1000',F'500',F'100',F'50',F'10',F'5',F'1'
VALS     DC     CL8'XIV',CL8'CMI',CL8'MIC',CL8'MCMXC',CL8'MDCLXVI'
         DC     CL8'MMVIII',CL8'MMXIX',CL8'MMMCMXCV'
X        DS     CL(L'VALS)
Y        DS     F
C        DS     CL1
PG       DC     CL80'........ -> ....'
XDEC     DS     CL12
         REGEQU
         END    ROMADEC