Task: Kronecker product








VB: 
dim a(),b(),r()
 
sub kroneckerproduct 
    m=ubound(a,1): n=ubound(a,2)
    p=ubound(b,1): q=ubound(b,2)
    rtn=m*p
    ctn=n*q
    redim r(rtn,ctn) 
    for i=1 to m
        for j=1 to n
            for k=1 to p
                for l=1 to q
                    r(p*(i-1)+k,q*(j-1)+l)=a(i,j)*b(k,l)  
    next: next: next: next
end sub 
 
sub printmatrix(text,m,w)
    wscript.stdout.writeline text
    select case m
        case "a": ni=ubound(a,1): nj=ubound(a,2)
        case "b": ni=ubound(b,1): nj=ubound(b,2)
        case "r": ni=ubound(r,1): nj=ubound(r,2)
    end select
    for i=1 to ni
        for j=1 to nj
            select case m
                case "a": k=a(i,j)
                case "b": k=b(i,j)
                case "r": k=r(i,j)
            end select
            wscript.stdout.write right(space(w)&k,w)
        next
        wscript.stdout.writeline
    next
end sub 
 
sub printall(w)
    printmatrix "matrix a:", "a", w 
    printmatrix "matrix b:", "b", w 
    printmatrix "kronecker product:", "r", w  
end sub 
 
sub main()
    xa=array( 1, 2, _
              3, 4)
    redim a(2,2)
    k=0: for i=1 to ubound(a,1): for j=1 to ubound(a,1)
        a(i,j)=xa(k): k=k+1
    next:next
    xb=array( 0, 5, _ 
              6, 7)
    redim b(2,2)
    k=0: for i=1 to ubound(b,1): for j=1 to ubound(b,1)
        b(i,j)=xb(k): k=k+1
    next:next
    kroneckerproduct
    printall 3
 
    xa=array( 0, 1, 0, _ 
              1, 1, 1, _ 
              0, 1, 0)
    redim a(3,3)
    k=0: for i=1 to ubound(a,1): for j=1 to ubound(a,1)
        a(i,j)=xa(k): k=k+1
    next:next
    xb=array( 1, 1, 1, 1, _ 
              1, 0, 0, 1, _ 
              1, 1, 1, 1) 
    redim b(3,4)
    k=0: for i=1 to ubound(b,1): for j=1 to ubound(b,1)
        b(i,j)=xb(k): k=k+1
    next:next
    kroneckerproduct
    printall 2
end sub 

main



Fortran:       MODULE ARRAYMUSH	
       CONTAINS		
        SUBROUTINE KPRODUCT(A,B,AB)	
Considers the arrays to be addressed as A(row,column), despite any storage order arrangements.        .
Creating array AB to fit here, adjusting the caller's array AB, may not work on some compilers.
         INTEGER A(:,:),B(:,:)		
         INTEGER, ALLOCATABLE:: AB(:,:)	
         INTEGER R,RA,RB,C,CA,CB,I	
          RA = UBOUND(A,DIM = 1)	
          CA = UBOUND(A,DIM = 2)	
          RB = UBOUND(B,DIM = 1)	
          CB = UBOUND(B,DIM = 2)	
          WRITE (6,1) "A",RA,CA,"B",RB,CB,"A.k.B",RA*RB,CA*CB	
    1     FORMAT (3(A," is ",I0,"x",I0,1X))	
          IF (ALLOCATED(AB)) DEALLOCATE(AB)	
          ALLOCATE (AB(RA*RB,CA*CB))		
          R = 0		
          DO I = 1,RA	
            C = 0		
            DO J = 1,CA		
              AB(R + 1:R + RB,C + 1:C + CB) = A(I,J)*B	
              C = C + CB		
            END DO		
            R = R + RB		
          END DO	
        END SUBROUTINE KPRODUCT	

        SUBROUTINE SHOW(F,A)	
         INTEGER F	
         INTEGER A(:,:)	
         INTEGER R	
          DO R = 1,UBOUND(A,DIM = 1)	
            WRITE (F,1) A(R,:)		
    1       FORMAT (666I3)		
          END DO			
        END SUBROUTINE SHOW	
      END MODULE ARRAYMUSH	

      PROGRAM POKE
      USE ARRAYMUSH
      INTEGER A(2,2),B(2,2)		
      INTEGER, ALLOCATABLE:: AB(:,:)	
      INTEGER C(3,3),D(3,4)		
      DATA A/1,3, 2,4/,B/0,6, 5,7/	
      DATA C/0,1,0, 1,1,1, 0,1,0/	
      DATA D/1,1,1, 1,0,1, 1,0,1, 1,1,1/

      WRITE (6,*) "First test..."
      CALL KPRODUCT(A,B,AB)
      CALL SHOW (6,AB)

      WRITE (6,*)
      WRITE (6,*) "Second test..."
      CALL KPRODUCT(C,D,AB)
      CALL SHOW (6,AB)

      END