home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgLangD.iso / FORTRAN / DISK6 / MTRX_W.FO$ / MTRX_W.bin
Text File  |  1991-03-29  |  3KB  |  117 lines
  1.       INCLUDE 'FLIB.FI'
  2.  
  3.       PROGRAM MTRX_W
  4.  
  5.       INCLUDE 'FLIB.FD'
  6.  
  7.       REAL*8 a[ALLOCATABLE] (:,:), b[ALLOCATABLE] (:,:),
  8.      +       c[ALLOCATABLE] (:,:)
  9.       INTEGER*2 rows, cols, prods, dummy
  10.  
  11. C
  12. C  Set the About Box message
  13. C
  14.       dummy = ABOUTBOXQQ ('Matrix Multiplier\r    Version 1.0'C)
  15. C
  16. C  Get dimensions of matrices
  17. C
  18.       WRITE (*, '(A)'  ) ' This program multiplies two matrices.'
  19.       WRITE (*, '(A \)')
  20.      +      ' Enter dimensions of first matrix (rows, columns): '
  21.       READ  (*, *) rows, prods
  22.  
  23.       WRITE (*, '(A, I2, A)') ' Second matrix has ', prods, ' rows.'
  24.       WRITE (*, '(A \)') ' Enter number of columns: '
  25.       READ (*, *) cols
  26. C
  27. C  Allocate matrices
  28. C
  29.       ALLOCATE (a(rows,  prods))
  30.       ALLOCATE (b(prods, cols ))
  31.       ALLOCATE (c(rows,  cols ))
  32. C
  33. C  Get matrix elements
  34. C
  35.       CALL YIELDQQ
  36.  
  37.       OPEN  (UNIT = 10, FILE = 'USER', TITLE = 'Matrix 1')
  38.       WRITE (10, *) 'Enter first  matrix'
  39.       CALL GetMatrix (rows, prods, a, 10)
  40.       CLOSE (10, STATUS = 'KEEP')
  41.  
  42.       OPEN  (UNIT = 11, FILE = 'USER', TITLE = 'Matrix 2')
  43.       WRITE (11, *) 'Enter second matrix'
  44.       CALL GetMatrix (prods, cols, b, 11)
  45.       CLOSE (11, STATUS = 'KEEP')
  46. C
  47. C  Multiply them
  48. C
  49.       CALL MultMatrices(rows, prods, cols, a, b, c )
  50. C
  51. C  Show results
  52. C
  53.       OPEN  (UNIT = 12, FILE = 'USER', TITLE = 'Product Matrix')
  54.       WRITE (12, *) 'Product matrix: '
  55.       CALL ShowMatrix (rows, cols,  c, 12)
  56.       CLOSE (12, STATUS = 'KEEP')
  57.       END
  58.  
  59. C
  60. C Begin subroutines
  61. C
  62.  
  63. C
  64. C Get a matrix from the user
  65. C
  66.       SUBROUTINE GetMatrix(rows, cols, mtrx [REFERENCE], unitnum)
  67.       INTEGER*2 rows, cols, i, j
  68.       INTEGER unitnum
  69.       REAL*8 mtrx (rows, cols)
  70.  
  71.       DO 1000, i = 1, rows
  72.  
  73.           WRITE (unitnum, '(A \, I2 \, A \, I2 \, A \)')
  74.      +          '       Row ', i, '   (', cols, ' values): '
  75.           READ (unitnum, *) (mtrx(i,j), j = 1, cols)
  76.  1000 CONTINUE
  77.       RETURN
  78.       END
  79.  
  80. C
  81. C Display the matrix
  82. C
  83.       SUBROUTINE ShowMatrix (rows, cols, mtrx, unitnum)
  84.       INTEGER*2 rows, cols, i, j
  85.       INTEGER unitnum
  86.       REAL*8 mtrx (rows,cols)
  87.  
  88.       DO 2000, i = 1, rows
  89.           WRITE (unitnum, '(A\)') '    '
  90.           DO 2100, j = 1, cols
  91.               WRITE (unitnum, '(A \, F6.1\)') '  ', mtrx (i, j)
  92.  2100     CONTINUE
  93.           WRITE (unitnum, *) ' '
  94.  2000 CONTINUE
  95.       RETURN
  96.       END
  97. C
  98. C Multiply the matrices
  99. C
  100.  
  101.       SUBROUTINE MultMatrices( rows, prods, cols, a, b, c [REFERENCE])
  102.  
  103.       INTEGER*2 i, j, k, rows, prods, cols
  104.       REAL*8 a(rows, prods), b(prods, cols), c(rows, cols)
  105.  
  106.       DO 3000, j = 1, cols
  107.           DO 3100, i = 1, rows
  108.               c(i, j) = 0.0
  109.               DO 3200, k = 1, prods
  110.                   c(i, j) = c(i, j) + (a(i, k) * b(k, j))
  111.  3200         CONTINUE
  112.  3100     CONTINUE
  113.  3000 CONTINUE
  114.       RETURN
  115.       END
  116. 
  117.