Using pointers in procedures

프로시저의 인자가 포인터이면 explicit interface를 갖아야 한다.

explicit interface란

- 외부 프로시저의 경우 프로시저를 사용하는 프로그램에서 interface block을 둔다.

- 프로시저를 모듈에 둔다.

정방행렬에서 대각원소를 뽑는 프로그램

PROGRAM test_diagonal

IMPLICIT NONE

! 서브루틴의 dummy argument로 pointer를 쓴다면 꼭 explicit interface를 가져야 한다.
INTERFACE
SUBROUTINE get_diagonal(ptr_a, ptr_b, error)
INTEGER, DIMENSION(:,:), POINTER :: ptr_a
INTEGER, DIMENSION(:), POINTER :: ptr_b
INTEGER, INTENT(OUT) :: error
END SUBROUTINE get_diagonal
END INTERFACE

INTEGER :: i, j, k
INTEGER :: istat
INTEGER, DIMENSION(:,:), POINTER :: ptr_a
INTEGER, DIMENSION(:), POINTER :: ptr_b
INTEGER :: error

! error 1 happen
CALL get_diagonal(ptr_a, ptr_b, error)
WRITE (*,*) 'No pointers allocated: '
WRITE (*,*) ' Error = ', error

! error 2
ALLOCATE (ptr_a(10,10), STAT = istat)
ALLOCATE (ptr_b(10), STAT = istat)
CALL get_diagonal(ptr_a, ptr_b, error)
WRITE (*,*) 'Both pointers allocated: '
WRITE (*,*) ' Error = ', error

! error 3
DEALLOCATE (ptr_a, STAT = istat)
DEALLOCATE (ptr_b, STAT = istat)
ALLOCATE (ptr_a(-5:5, 10), STAT = istat)
CALL get_diagonal(ptr_a, ptr_b, error)
WRITE (*,*) 'Array on ptr_a not square '
WRITE (*,*) ' Error = ', error

DEALLOCATE (ptr_a, STAT = istat)
ALLOCATE (ptr_a(-2:2, 0:4), STAT = istat)
k = 0
DO j = 0, 4
DO i = -2, 2
k = k + 1
ptr_a(i, j) = k
END DO
END DO

CALL get_diagonal(ptr_a, ptr_b, error)
WRITE (*,*) 'ptr_a allocated & square; ptr_b not allocated: '
WRITE (*,*) ' Error = ', error
WRITE (*,*) 'Square Matrix '
WRITE (*,100) ((ptr_a(i, j), i = -2, 2), j = 0 ,4)
100 FORMAT (1X, 5I5)
WRITE (*,*) 'Diagonal '
WRITE (*,100) ptr_b



END PROGRAM test_diagonal

SUBROUTINE get_diagonal(ptr_a, ptr_b, error)

! error code
! 0 - no error
! 1 - ptr_a not associated on input
! 2 - ptr_b already associated on input
! 3 - array on ptr_a not square
! 4 - unable to allocate memory for ptr_b

IMPLICIT NONE

INTEGER, DIMENSION(:,:), POINTER :: ptr_a ! pointer는 INTENT()를 쓸 수 없다.
INTEGER, DIMENSION(:), POINTER :: ptr_b
INTEGER, INTENT(OUT) :: error

INTEGER :: i
INTEGER :: istat
INTEGER, DIMENSION(2) :: l_bound
INTEGER, DIMENSION(2) :: u_bound
INTEGER, DIMENSION(2) :: extent

IF (.NOT. ASSOCIATED(ptr_a)) THEN
error = 1
ELSE IF (ASSOCIATED(ptr_b)) THEN
error = 2
ELSE
l_bound = LBOUND(ptr_a)
u_bound = UBOUNd(ptr_a)
extent = u_bound - l_bound + 1

IF (extent(1) /= extent(2)) THEN
error = 3
ELSE
ALLOCATE(ptr_b(extent(1)), STAT = istat)
IF ( istat /= 0 ) THEN
error = 4
ELSE
DO i = 1, extent(1)
ptr_b(i) = ptr_a(l_bound(1)+i-1,l_bound(2)+i-1)
END DO
END IF

error = 0

END IF
END IF

END SUBROUTINE get_diagonal

위 소스를 get_diag.f95로 저장

컴파일 및 프로그램 테스트