Подпрограммы, предназначенные для решения задач из общей объектной области, общие константы и переменные удобно объединить в модуль.
ПРИМЕР:
Объединить в модуль подпрограммы
· произведения двух матриц,
· представления матрицы в виде произведения нижней и верхней треугольной,
· вычисления обратной матрицы и
· определителя матрицы.
MODULE MATRIX
! Раздел объявления данных модуля
! Константа М будет доступна в любой программе, к которой подключен модуль
INTEGER, PARAMETER :: M=8
! Константа L будет доступна только в модуле
INTEGER, PRIVATE, PARAMETER :: L=24
CONTAINS ! Раздел объявления модульных подпрограмм
! Подпрограмма MULTIPLY перемножает две квадратные матрицы:
! матрицу А и матрицу B,
! результат матрица С.
SUBROUTINE MULTIPLY(N,A,B,C)
INTEGER I,J,K
REAL(8) A(N,N), B(N,N), C(N,N)
C=0
DO I=1, N
DO J=1, N
DO K=1,N
C(I,J)=C(I,J)+A(I,K)*B(K,J)
END DO
END DO
END DO
END SUBROUTINE ! END MULTIPLY
! Процедура представления матрицы A в виде нижней (B)
! и верхней (D) треугольных матриц
SUBROUTINE TRIANGULAR(N,A,B,D)
INTEGER I, J, K
REAL (8) P,G, A(N,N), B(N,N), D(N,N)
D=0.0
B=0.0
DO I=1,N
D(I,I)=1.0
END DO
DO I= 1, N
DO K=1, N
IF (K<=I) THEN
P=0.0
DO J=1, K-1
P=P+B(I,J)*D(J,K)
END DO
B(I,K)=A(I,K)-P;
ELSE
G=0.0
DO J=1, I-1
G=G+B(I,J)*D(J,K)
END DO
D(I,K)=(A(I,K)-G)/B(I,I)
END IF
END DO
END DO
END SUBROUTINE !TRIANGULAR
! Процедура обращения матрицы A, результат – матрица R обратная к A
SUBROUTINE REVERSE(N,A,R)
INTEGER I,J,K
REAL(8) P, B(N,N),D(N,N),Y(N,N),R(N,N),A(N,N),S(N),T(N)
CALL TRIANGULAR(N,A,B,D)
DO K=1, N
DO I=1,N
T(I)=0.0
IF (I==K)T(I)=1.0
END DO
DO I=1,N
P=0.0
DO J=1, I-1
P=P+B(I,J)*S(J)
END DO
S(I)=(T(I)-P)/B(I,I)
END DO
DO I=1, N
Y(I,K)=S(I)
END DO
END DO
DO K=1, N
DO I=1, N
T(I)=Y(I,K)
END DO
DO I=N, 1 ,-1
P=0.0
DO J=I+1, N
P=P+D(I,J)*S(J);
END DO
S(I)=(T(I)-P)/D(I,I);
END DO
DO I=1,N
R(I,K)=S(I)
END DO
END DO;
END SUBROUTINE ! REVERSE
! Процедура вычисления определителя матрицы A
FUNCTION DETERM(N,A)
REAL (8) B(N,N),D(N,N),A(N,N),P,Q
INTEGER (4) I
CALL TRIANGULAR(N,A,B,D)
P=1.0
Q=1.0
DO I=1,N
P=P*B(I,I)
Q=Q*D(I,I)
END DO
DETERM=P*Q
END FUNCTION !DETERMINANT
SUBROUTINE WRITE_L(LP)
PRINT ('(A5,I4)'), 'L= ',L
LP=L
RETURN
END SUBROUTINE ! WRITE_L
END MODULE !MATRIX
PROGRAM REV_MATR
USE MATRIX
REAL(8), ALLOCATABLE, DIMENSION(:,:) ::A,R
REAL(8) D
INTEGER I, J, K, N
OPEN(25,FILE='REVERS_A.TXT')
READ(25,*) N
ALLOCATE(A(N,N))
ALLOCATE(R(N,N))
READ(25,*) ((A(I,J),J=1,N),I=1,N)
CALL REVERSE(N,A,R)
CALL WRITE_L(LP)
WRITE(25,'(/4(A5,I4))') ' N= ',N,' M= ',M, 'L= ',L,' LP= ',LP WRITE(25,'(/)')
WRITE(25,*) ' MATRIX A'
WRITE(25,'(/(<N>F8.4))')((A(I,J),J=1,N),I=1,N)
WRITE(25,'(/)')
WRITE(25,*) ' REVERSE A'
WRITE(25,'(/(<N>F8.4))')((R(I,J),J=1,N),I=1,N)
D=DETERM(N,A)
WRITE(25,'(/A5,F5.2)') ' DET= ',D
DEALLOCATE(A)
DEALLOCATE(R)
CLOSE(25)
END