82 lines
3.5 KiB
Plaintext
82 lines
3.5 KiB
Plaintext
* CUSIP 07/06/2018
|
|
CUSIP CSECT
|
|
USING CUSIP,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,=F'6') do i=1 to 6
|
|
LR R1,R6 i
|
|
MH R1,=H'9' *9
|
|
LA R4,T-9(R1) @t(i)
|
|
MVC X,0(R4) x=t(i)
|
|
SR R10,R10 w=0
|
|
LA R7,1 j=1
|
|
DO WHILE=(C,R7,LE,=F'8') do j=1 to 8
|
|
LA R14,X-1 x
|
|
AR R14,R7 j
|
|
MVC Y(1),0(R14) y=substr(x,j,1)
|
|
LA R9,L'XX z=length(xx)
|
|
LA R8,1 k=1
|
|
DO WHILE=(C,R8,LE,=A(L'XX)) do k=1 to length(xx)
|
|
LA R4,XX-1 xx
|
|
AR R4,R8 k
|
|
MVC C(1),0(R4) c=substr(xx,k,1)
|
|
IF CLC,Y(1),EQ,C THEN if y=c then
|
|
LR R9,R8 k
|
|
BCTR R9,0 z=k-1
|
|
ENDIF , endif
|
|
LA R8,1(R8) k++
|
|
ENDDO , enddo k
|
|
LR R4,R7 j
|
|
LA R1,2 2
|
|
SRDA R4,32 ~
|
|
DR R4,R1 j/2=0
|
|
IF LTR,R4,Z,R4 THEN if j//2=0 then
|
|
AR R9,R9 z=z+z
|
|
ENDIF , endif
|
|
LR R4,R9 z
|
|
LA R1,10 10
|
|
SRDA R4,32 ~
|
|
DR R4,R1 r4=z//10 ; r5=z/10
|
|
AR R10,R5 w+z/10
|
|
AR R10,R4 w=w+z/10+z//10
|
|
LA R7,1(R7) j++
|
|
ENDDO , enddo j
|
|
LR R4,R10 w
|
|
LA R1,10 10
|
|
SRDA R4,32 ~
|
|
DR R4,R1 w/10
|
|
LA R2,10 10
|
|
SR R2,R4 10-w//10
|
|
SRDA R2,32 ~
|
|
DR R2,R1 /10
|
|
STC R2,U u=(10-w//10)//10
|
|
OI U,X'F0' bin to char
|
|
IF CLC,U,EQ,X+8 THEN if u=substr(x,9,1) then
|
|
MVC OK,=CL3' ' ok=' '
|
|
ELSE , else
|
|
MVC OK,=C'n''t' ok='n''t'
|
|
ENDIF , endif
|
|
MVC PG+6(9),X output x
|
|
MVC PG+18(3),OK output ok
|
|
XPRNT PG,L'PG print
|
|
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
|
|
XX DC CL39'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ*@#'
|
|
U DS CL1
|
|
Y DS CL1
|
|
C DS CL1
|
|
T DC CL9'037833100',CL9'17275R102',CL9'38259P508'
|
|
DC CL9'594918104',CL9'68389X106',CL9'68389X105'
|
|
X DS CL9
|
|
OK DS CL3
|
|
PG DC CL80'CUSIP ......... is... valid'
|
|
YREGS
|
|
END CUSIP
|