home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgLangD.iso / Fortran.51 / DISK6 / MTRX_WD.FO$ / MTRX_WD.bin
Text File  |  1991-03-25  |  2KB  |  98 lines
  1.       INCLUDE 'FLIB.FI'
  2.  
  3.       PROGRAM MTRX
  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.  
  98.