以下代码演示的是指针在过程中的使用
功能:使用指针存储矩阵中的对角元素
Program test_diagonal
implicit none
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
!.. data dictionary: declare variable types & definitions
integer :: i, j, k, istat
integer, dimension(:,:), pointer :: ptr_a
integer, dimension(:), pointer :: ptr_b
integer :: error !.. error flag
!.. call diagonal with nothing defined to see what happens:
call get_diagonal( ptr_a, ptr_b, error )
write( *,'(1x,a)' ) 'No pointers allocated!'
write( *,'(1x,a,g0)' ) 'error = ',error
!.. allocate both pointers, and call the subroutine
allocate( ptr_a(10,10), stat = istat )
allocate( ptr_b(10), stat = istat )
call get_diagonal( ptr_a, ptr_b, error )
write( *,'(1x,a)' ) 'Both pointers allocated!'
write( *,'(1x,a,g0)' ) 'error = ', error
!.. allocate ptr_a only, but with unequal extents
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( *,'(1x,a)' ) 'Array on ptr_a not square!'
write( *,'(1x,a,g0)' ) 'error = ', error
!.. allocate ptr_a only, initialize, and get results
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( *,'(1x,a)' ) 'ptr_a allocated & square; but ptr_b not allocated!'
write( *,'(1x,a,g0)' ) 'error = ', error
write( *,* ) 'diag = ', ptr_b
deallocate( ptr_a, stat = istat )
deallocate( ptr_b, stat = istat )
end program test_diagonal
Subroutine get_diagonal( ptr_a, ptr_b, error )
implicit none
integer, dimension(:,:), pointer :: ptr_a !.. ptr to square array
integer, dimension(:), pointer :: ptr_b !.. ptr to output array
integer, intent(out) :: error !.. Errors flag
integer :: i, istat
integer, dimension(2) :: l_bound, u_bound, extent
!.. check error conditions
if ( .not.associated( ptr_a ) ) then
error = 1
else if ( associated( ptr_b ) ) then
error = 2
else
!.. check for square array
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
!.. everything is ok so far, allocate ptr_b
allocate( ptr_b(extent(1)), stat = istat )
if ( istat /= 0 ) then
error = 4
else
!.. everything is ok so far, extract diagonal
Do i = 1, extent(1)
ptr_b(i) = ptr_a( l_bound(1) + i-1, l_bound(2) + i-1 )
End do
!.. reset error flag
error = 0
end if
end if
end if
End subroutine get_diagonal
fortran在过程中的使用指针
猜你喜欢
转载自blog.csdn.net/chd_lkl/article/details/83822365
今日推荐
周排行