！应用数组时上下界一定要清楚！

  program test_ubound_lbound
    !
    !测试使用FORTRAN90内部函数UBOUND和LBOUND函数
    !求数组下标下界和下标上界的示例程序(功能)
    !
    implicit none
  
    integer,dimension(-10:10,100:200,4) ::dim3ar
    
    integer ub(3),ub1,ub2,ub3,lb(3),lb1,lb2,lb3

    !下标上界
    ub1=UBOUND(dim3ar,1);ub2=UBOUND(dim3ar,dim=2);ub3=UBOUND(dim3ar,3)
    ub=UBOUND(dim3ar)

    !下标下界
    lb1=lBOUND(dim3ar,1);lb2=lBOUND(dim3ar,dim=2);lb3=lBOUND(dim3ar,3)
    lb=lBOUND(dim3ar)

    print *, '函数UBOUND(dim3ar,    1)求数组dim3ar第1维的下标上界是：',ub1
    print *, '函数UBOUND(dim3ar,dim=2)求数组dim3ar第2维的下标上界是：',ub2
    print *, '函数UBOUND(dim3ar,    3)求数组dim3ar第3维的下标上界是：',ub3
    print *, '函数UBOUND(dim3ar )求数组dim3ar所有维的下标上界依次是：',ub
    print *, '函数lBOUND(dim3ar,    1)求数组dim3ar第1维的下标下界是：',lb1
    print *, '函数lBOUND(dim3ar,dim=2)求数组dim3ar第2维的下标下界是：',lb2
    print *, '函数lBOUND(dim3ar,    3)求数组dim3ar第3维的下标下界是：',lb3
    print *, '函数lBOUND(dim3ar )求数组dim3ar所有维的下标下界依次是：',lb

    stop 'test ok!'

  end program test_ubound_lbound

石间野草

 

program test_ubound_lbound
     !
     !测试使用FORTRAN90内部函数UBOUND和LBOUND函数
     !求数组下标下界和下标上界的示例程序(功能)
     !
     implicit none
  
     integer,dimension(-10:10,100:200,4) ::dim3ar
    
     integer ub(3),ub1,ub2,ub3,lb(3),lb1,lb2,lb3
     !下标上界
     ub1=UBOUND(dim3ar,1);ub2=UBOUND(dim3ar,dim=2);ub3=UBOUND(dim3ar,3)
     ub=UBOUND(dim3ar)
     !下标下界
     lb1=lBOUND(dim3ar,1);lb2=lBOUND(dim3ar,dim=2);lb3=lBOUND(dim3ar,3)
     lb=lBOUND(dim3ar)
     print *, '函数UBOUND(dim3ar,    1)求数组dim3ar第1维的下标上界是：',ub1
     print *, '函数UBOUND(dim3ar,dim=2)求数组dim3ar第2维的下标上界是：',ub2
     print *, '函数UBOUND(dim3ar,    3)求数组dim3ar第3维的下标上界是：',ub3
     print *, '函数UBOUND(dim3ar )求数组dim3ar所有维的下标上界依次是：',ub
     print *, '函数lBOUND(dim3ar,    1)求数组dim3ar第1维的下标下界是：',lb1
     print *, '函数lBOUND(dim3ar,dim=2)求数组dim3ar第2维的下标下界是：',lb2
     print *, '函数lBOUND(dim3ar,    3)求数组dim3ar第3维的下标下界是：',lb3
     print *, '函数lBOUND(dim3ar )求数组dim3ar所有维的下标下界依次是：',lb
     stop 'test ok!'
  end program test_ubound_lbound

石间野草

 

program test_function_ieer
  !测试一个函数的返回值
  implicit none
  integer ::ieer=0
  real(8) ::a,b,c
  real(8) ::s1,func1
  integer ::func2
  real(8) ::resul2
  integer ::s2
  a=1.0d0
  b=0.333d0
  c=2.0d0
  s1=func1(a,b,c,ieer)
  print *,s1,ieer
  s2=func2(a,b,c,resul2)
  print *,s2,resul2
end program test_function_ieer
function func1(a,b,c,ierr)
  implicit none
  real(8),intent(in) ::a,b,c
  real(8) ::func1
  integer,intent(out) ::ierr
  
  if(dabs(b-c)<=0.1d-4) then
    func1=0.0d0
    ierr=1
  else
    func1=a/(b-c)
  endif
end function func1
function func2(a,b,c,resul)
  implicit none
  real(8),intent(in) ::a,b,c
  integer ::func2
  real(8),intent(out) ::resul
  func2=0    
  if(dabs(b-c)<=0.1d-4) then
    func2=1
    resul=0.0
  else
    resul=a/(b-c)
  endif
end function func2

石间野草

 

fortran程序本身是与计算机系统无关

石间野草

 

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

石间野草