第 15 楼
module test_pointer
implicit none
contains
subroutine test_pointer_arror_lowertriangular
!FORTRAN90指针毕竟只是一种变量属性,而不是一种真实的数据类型,因此不
!能直接创建指针数组。作为一种替代方式,可以定义包含指针的派生类型,
!然后创建该派生类型的数组,来间接实现指针数组的功能。
!指针数组在下三角矩阵中的应用
implicit none
type row
real(8),dimension(:),pointer ::r !声明具有指针属性的数组
end type row
integer,parameter ::N=4
type(row),dimension(n) ::t !声明派生类型的数组
integer ::i
do i=1,N
allocate(t(i)%r(1:i)) !为每行分配不同存储单元
t(i)%r(1:i)=1 !为下三角矩阵每行赋值
enddo
do i=1,N
print *,t(i)%r(:i) !输出下三角矩阵
enddo
do i=1,N
deallocate(t(i)%r) !释放存储单元
enddo
return !'test_pointer_arror_lowertriangular ok!'
end subroutine test_pointer_arror_lowertriangular
subroutine test_pointer_function_sort
!有时,需要函数返回一个可变大小的数组,可是FORTRAN90不允许函数返回值由
!allocatable属性,但允许有pointer属性。因此,可以用指针数组代替动态数组
!作为函数的返回值。
!对任一大小的整型数组按升序排列
implicit none
external suba !合法
integer ::suba
!external vector1 !数组返回非法
!integer,dimension(:),pointer ::vector1
interface !数组返回须接口(合法)
function vector1 ( a )
implicit none
integer,dimension(:),pointer ::vector1
integer,dimension(:) ::a
end function vector1
end interface
integer ::ja
integer,dimension(10) ::x=(/3,6,9,-1,56,4,6,0,0,8/)
integer,dimension(:),pointer ::p !声明与x同维的指针数组
p=>vector( x )
print *,p
p=>vector1( x )
print *,p
ja=suba (5)
print *,ja
deallocate( p ) !间接释放为函数分配的空间
return !'test_pointer_function_sort ok!'
contains
function vector ( a ) !函数返回值为指针数组
implicit none
integer,dimension(:),pointer ::vector
integer,dimension(:) ::a !延迟形状数组参数
integer ::i,j,T
allocate( vector(size(a)) ) !为函数动态分配空间
vector=a !相同形状的数组间接赋值
do i=1,size(a)-1
do j=i+1,size(a)
if( vector(i) > vector(j) ) then
T=vector(j)
vector(j)=vector(i)
vector(i)=T
endif
enddo
enddo
end function vector
end subroutine test_pointer_function_sort
end module test_pointer
program test_pointer_main
use test_pointer
implicit none
call test_pointer_arror_lowertriangular
print *,'test_pointer_arror_lowertriangular ok'
call test_pointer_function_sort
print *,'test_pointer_function_sort ok'
stop 'test_pointer ok!'
end program test_pointer_main
function vector1 ( a ) !函数返回值为指针数组
implicit none
integer,dimension(:),pointer ::vector1
integer,dimension(:) ::a !延迟形状数组参数
integer ::i,j,T
allocate( vector1(size(a)) ) !为函数动态分配空间
vector1=a !相同形状的数组间接赋值
do i=1,size(a)-1
do j=i+1,size(a)
if( vector1(i) > vector1(j) ) then
T=vector1(j)
vector1(j)=vector1(i)
vector1(i)=T
endif
enddo
enddo
end function vector1
function suba (a)
implicit none
integer ::suba
integer ::a
suba=a
end function suba
石间野草