fortran指针在过程中的使用

以下代码演示的是指针在过程中的使用
功能：使用指针存储矩阵中的对角元素
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