*        Identity matrix           31/03/2017
INDENMAT CSECT
         USING  INDENMAT,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
         L      R1,N               n
         MH     R1,N+2             n*n
         SLA    R1,2               *4
         ST     R1,LL              amount of storage required
         GETMAIN RU,LV=(R1)        allocate storage for matrix
         USING  DYNA,R11           make storage addressable
         LR     R11,R1             set addressability
         LA     R6,1               i=1
       DO WHILE=(C,R6,LE,N)        do i=1 to n
         LA     R7,1                 j=1
       DO WHILE=(C,R7,LE,N)          do j=1 to n
       IF CR,R6,EQ,R7 THEN             if i=j then
         LA     R2,1                     k=1
       ELSE     ,                      else
         LA     R2,0                     k=0
       ENDIF    ,                      endif
         LR     R1,R6                  i
         BCTR   R1,0                   -1
         MH     R1,N+2                 *n
         AR     R1,R7                  (i-1)*n+j
         BCTR   R1,0                   -1
         SLA    R1,2                   *4
         ST     R2,A(R1)               a(i,j)=k
         LA     R7,1(R7)               j++
       ENDDO    ,                    enddo j
         LA     R6,1(R6)             i++
       ENDDO    ,                  enddo i
         LA     R6,1               i=1
       DO WHILE=(C,R6,LE,N)        do i=1 to n
         LA     R10,PG               pgi=0
         LA     R7,1                 j=1
       DO WHILE=(C,R7,LE,N)          do j=1 to n
         LR     R1,R6                  i
         BCTR   R1,0                   -1
         MH     R1,N+2                 *n
         AR     R1,R7                  (i-1)*n+j
         BCTR   R1,0                   -1
         SLA    R1,2                   *4
         L      R2,A(R1)               a(i,j)
         XDECO  R2,XDEC                edit
         MVC    0(1,R10),XDEC+11       output
         LA     R10,1(R10)             pgi+=1
         LA     R7,1(R7)               j++
       ENDDO    ,                    enddo j
         XPRNT  PG,L'PG              print
         LA     R6,1(R6)             i++
       ENDDO    ,                  enddo i
         LA     R1,A               address to free
         LA     R2,LL              amount of storage to free
         FREEMAIN A=(R1),LV=(R2)   free allocated storage
         DROP   R11                drop register
         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
NN       EQU    10                 parameter n  (90=>32K)
N        DC     A(NN)              n
LL       DS     F                  n*n*4
PG       DC     CL(NN)' '          buffer
XDEC     DS     CL12               temp
DYNA     DSECT
A        DS     F                  a(n,n)
         YREGS
         END    INDENMAT