Arrays 如何将单个Fortran文件拆分为单独的子例程和函数文件
又是一个星期，又是一个愚蠢的问题，有人试图不让自己的头撞到桌子上。我有一个Fortran90文件，它可以完成我希望它完成的任务，没有错误，并且输出正确。现在我需要把这个东西分成它的组成部分，即两个子程序文件，两个函数文件和一个驱动程序。我如何在不破坏它的情况下做到这一点，因为它被破坏了…主要问题是传递数组…我认为。 工作单文件代码：Arrays 如何将单个Fortran文件拆分为单独的子例程和函数文件,arrays,function,fortran,subroutine,Arrays,Function,Fortran,Subroutine,又是一个星期，又是一个愚蠢的问题，有人试图不让自己的头撞到桌子上。我有一个Fortran90文件，它可以完成我希望它完成的任务，没有错误，并且输出正确。现在我需要把这个东西分成它的组成部分，即两个子程序文件，两个函数文件和一个驱动程序。我如何在不破坏它的情况下做到这一点，因为它被破坏了…主要问题是传递数组…我认为。 工作单文件代码： program testnew implicit none integer,parameter
program testnew
implicit none
integer,parameter :: p14r300 = SELECTED_REAL_KIND(14,300)
integer,parameter :: k7 = SELECTED_INT_KIND(7)
integer(kind=k7) :: n, ng
real(kind=p14r300), dimension(:), allocatable :: xarr
real(kind=p14r300), dimension(:), allocatable :: xabsc
real(kind=p14r300), dimension(:), allocatable :: weight
real(kind=p14r300) :: tol
do n=2,4
allocate (xarr(n))
allocate (xabsc(n))
allocate (weight(n))
call gauss_leg_int(ng, xabsc, weight)
print *, ng, xabsc, weight
deallocate (xarr)
deallocate (xabsc)
deallocate (weight)
enddo
return
contains
subroutine gauss_leg_int(ng, xabsc, weight)
!==================================================================
! Subroutine that organizes the computations to find the abscissas
! and weights for Gauss-Legendre integration, where ng is the
! number of integration points(integer, input), and xabsc and
! weight are real arrays of length ng (output) that hold the
! abscissas and weights, respectively.
!==================================================================
integer(kind=k7) :: ng, i, iter
real(kind=p14r300) :: x, w
real(kind=p14r300), dimension(:), allocatable :: weight, xabsc
do i=1,n
call leg_root(n, tol, xarr)
xabsc=xarr
ng=n
!do iter=1,n
x=xabsc(i)
print *,x
w=2/((1-x**2)*leg_deriv(n, x)**2)
!enddo
weight(i)=w
enddo
end subroutine gauss_leg_int
subroutine leg_root(n, tol, xarr)
!==================================================================
! Subroutine that finds the set of roots of a Legendre polynomial,
! where n is the degree of the polynomial (input,integer), and tol
! is an absolute tolerance(input,real) for stopping the iteration
! when abs(P_l(x_i))<=tol.
!==================================================================
real(kind=p14r300) :: a, pi, x, y, pl, tol ! Declare real variables
real(kind=p14r300), dimension(:), allocatable :: xarr ! Array
integer(kind=k7) :: i, n, iter ! Declare integer variables
a=1.0 ! Value to use on the next line
pi=4*atan(a) ! Calculate Pi
tol=1.d-14
do i=1,n
x=-cos(pi*(i-0.25)/(n+0.5)) ! Initial x value
do iter=1,20 ! Set maximum number of iterations
y=x-leg_poly(n, x)/leg_deriv(n, x)
pl=leg_poly(n, y)-leg_poly(n, x)
x=y ! Once value of y is correct, make x the same
if (abs(pl)<=tol) exit ! Once tolerance is reached, exit
enddo
!write (*,*) x
xarr(i)=x
!print *,xarr
enddo
!xarr(1,i*4)=x
end subroutine leg_root
function leg_poly(n, x) result(pn)
!==================================================================
! Function for evaluating a given Legendre polynomial using the
! recurrence relation, where n is the degree of the
! polynomial(input, integer), and x is the location(input, real)
! in the interval -1<=x<=1 in which to evaluate the polynomial.
! The function result is the real value of P_n(x).
!==================================================================
real(kind=p14r300) :: pn, x, pln(0:n)
integer(kind=k7) :: l, n
pln(0)=1.0 ! First Legendre polynomial
pln(1)=x ! Second Legendre polynomial
if (n<=1) then ! Set the first two polynomials
pn=pln(n)
else ! Starts the recurrence to generate
do l=1,n-1 ! higher degree polynomials
pln(l+1)=((2.0*l+1.0)*x*pln(l)-l*pln(l-1))/(l+1)
enddo
pn=pln(n)
endif
end function leg_poly
function leg_deriv(n, x) result(pdn)
!=================================================================
! Function for evaluating the derivatives of a given Legendre
! polynomial using the recurrence relation, where n is the degree
! of the polynomial(input, integer), and x is the
! location(input, real) in the interval -1<=x<=1 in which to
! evaluate the derivative. The function result is the real value
! of Pd_n(x).
!=================================================================
real(kind=p14r300) :: pdn, x, pdln(0:n)
integer(kind=k7) :: l, n
pdln(0)=0 ! Derivative of first Legendre polynomial
pdln(1)=1.0 ! Derivative of second Legendre polynomial
if (n<=1) then ! Set the first two Legendre polynomial
pdn=pdln(n) ! derivatives
else ! Starts the recurrence to generate
do l=1,n-1 ! higher degree polynomial derivatives
pdln(l+1)=((2.0*l+1.0)*x*pdln(l)-(l+1)*pdln(l-1))/l
enddo
pdn=pdln(n)
endif
end function leg_deriv
end program
testnew程序
隐式无
整数，参数：：p14r300=所选的实类（14300）
整数，参数：：k7=选定的整数类型（7）
整数（种类=k7）：：n，ng
实数（种类=p14r300），维度（：），可分配：：xarr
实（种类=p14r300），维度（：），可分配：：xabsc
实（种类=p14r300），维度（：），可分配：：权重
真实（种类=p14r300）：：tol
Don=2,4
分配（xarr（n））
分配（xabsc（n））
分配（重量（n））
调用gauss_leg_int（ng、xabsc、weight）
打印*，ng，xabsc，重量
解除分配（xarr）
解除分配（xabsc）
解除分配（重量）
结束循环
返回
包含
子例程gauss_leg_int（ng，xabsc，weight）
!==================================================================
! 组织计算以查找横坐标的子例程
! 和高斯-勒让德积分的权重，其中ng是
! 积分点数（整数、输入）、xabsc和
! 权重是长度ng（输出）的实数数组，用于保存
! 横坐标和权重。
!==================================================================
整数（kind=k7）：ng，i，iter
真实（种类=p14r300）：x，w
实（种类=p14r300），维度（：），可分配：：权重，xabsc
i=1，n吗
调用leg_root（n、tol、xarr）
xabsc=xarr
ng=n
!do iter=1，n
x=xabsc（i）
打印*，x
w=2/（（1-x**2）*支腿（n，x）**2）
!结束循环
重量（i）=w
结束循环
结束子程序gauss\u leg\u int
子例程leg_root（n，tol，xarr）
!==================================================================
! 查找勒让德多项式根集的子例程，
! 其中n是多项式的次数（输入，整数），tol
! 是用于停止迭代的绝对公差（输入，实数）
! 当abs（P_l（x_i））这是如何解决我的难题的时候，首先我将其全部划分，创建一个精度参数模块，并编辑每个文件以处理数组必须传递的事实：
精度模块：
MODULE Precision
!===========================================================
! Module to be used to declare precision parameters for any
! program using it.
!===========================================================
IMPLICIT NONE
INTEGER, PARAMETER :: p14r300=SELECTED_REAL_KIND(14,300)
INTEGER, PARAMETER :: k7=SELECTED_INT_KIND(7)
END MODULE Precision
驱动程序：
program testnew
USE Precision
implicit none
integer(kind=k7) :: n, ng
real(kind=p14r300), allocatable :: xabsc(:)
real(kind=p14r300), allocatable :: weight(:)
do n=2,4 ! Set range based on provided table
! Allocate memory to dynamic arrays
allocate (xabsc(n))
allocate (weight(n))
! Call subroutine to obtain values of interest
call gauss_leg_int(n, xabsc, weight)
! Print values to stdout
print *, n
print *, xabsc
print *, weight
! Deallocate memory
deallocate (xabsc)
deallocate (weight)
enddo
end program testnew
职能：
function leg_poly(n, x) result(pn)
!==================================================================
! Function for evaluating a given Legendre polynomial using the
! recurrence relation, where n is the degree of the
! polynomial(input, integer), and x is the location(input, real)
! in the interval -1<=x<=1 in which to evaluate the polynomial.
! The function result is the real value of P_n(x).
!==================================================================
USE Precision
IMPLICIT NONE
real(kind=p14r300) :: pn, pln(0:n)
real(kind=p14r300), intent(in) :: x
integer(kind=k7), intent(in) :: n
integer(kind=k7) :: l
pln(0)=1.0 ! First Legendre polynomial
pln(1)=x ! Second Legendre polynomial
if (n<=1) then ! Set the first two polynomials
pn=pln(n)
else ! Starts the recurrence to generate
do l=1,n-1 ! higher degree polynomials
pln(l+1)=((2.0*l+1.0)*x*pln(l)-l*pln(l-1))/(l+1)
enddo
pn=pln(n)
endif
end function leg_poly
function leg_deriv(n, x) result(pdn)
!=================================================================
! Function for evaluating the derivatives of a given Legendre
! polynomial using the recurrence relation, where n is the degree
! of the polynomial(input, integer), and x is the
! location(input, real) in the interval -1<=x<=1 in which to
! evaluate the derivative. The function result is the real value
! of Pd_n(x).
!=================================================================
USE Precision
IMPLICIT NONE
REAL(KIND=p14r300) :: pdn, x, pdln(0:n)
INTEGER(KIND=k7), INTENT(IN) :: n
INTEGER(KIND=k7) :: l
pdln(0)=0 ! Derivative of first Legendre polynomial
pdln(1)=1.0 ! Derivative of second Legendre polynomial
if (n<=1) then ! Set the first two Legendre polynomial
pdn=pdln(n) ! derivatives
else ! Starts the recurrence to generate
do l=1,n-1 ! higher degree polynomial derivatives
pdln(l+1)=((2.0*l+1.0)*x*pdln(l)-(l+1)*pdln(l-1))/l
enddo
pdn=pdln(n)
endif
end function leg_deriv
函数支腿_多边形（n，x）结果（pn）
!==================================================================
! 使用
! 递推关系，其中n是
! 多项式（输入，整数），x是位置（输入，实数）
! 在区间-1A模块是您想要的-这是您尝试过的吗？还请注意，您很可能会失去精度，因为实际变量和实际常量的类型不一致。如果您发布了不起作用的代码，并仔细描述了它是如何起作用的（不编译？总是错误的答案？有时错误的答案？），这将非常有用@伊恩·布什：我设法做到了，我用了一个精确参数模块。我很想知道你说的失去精确性是什么意思。我将在几天后在这里发布我的版本…@PetrH No，4已转换为其他真实表达式的类型。这并不重要，因为小整数可以用所有合理的浮点和定点（二进制和十进制）数字格式精确表示。对于像1/21/8这样的数字，以及像3.75这样的组合，情况也是如此。3.75以合理的二进制和十进制格式准确表示。对于这些值，最好使用双精度文字。或者，就像我所做的，只需除以一个整数1，2，4，8…@PetrH数字，这些数字不具有精确的代表性，类似于0.1，0.2，0.3和类似的数字。这些数据只能用十进制格式表示，不能用二进制表示。在前面的评论中，我应该使用十进制，而不是十进制。不完全清楚，您是否将例程放入了一个模块中？只是为了澄清Mark的评论-如果您将函数和子例程放入一个模块中会更好。在现代代码中，应避免使用外部子程序。我正在学习FORTRAN90，在我的作业中，我必须将其全部分解，即模块、主程序、每个子程序和函数必须是它们自己的文件。我宁愿把它们都放在一个文件中，但是，唉，如果教育机构对你有这样的要求，那么每个子例程和函数都必须是它们自己的文件，你可以要求退款，然后去其他地方。除非每个例程都在自己的模块中，否则将每个例程放在自己的文件中比原始实现更糟糕，因为所有例程都在包含的部分与程序在同一源中。或者你误解了指令，应该把所有的例程和参数声明放在同一个模块中
subroutine leg_root(n, xarr)
!==================================================================
! Subroutine that finds the set of roots of a Legendre polynomial,
! where n is the degree of the polynomial (input,integer), and tol
! is an absolute tolerance(input,real) for stopping the iteration
! when abs(P_l(x_i))<=tol.
!==================================================================
USE Precision
IMPLICIT NONE
real(kind=p14r300) :: a, pi, x, y, pl ! Declare real variables
real(kind=p14r300) :: tol
real(kind=p14r300), intent(out) :: xarr(n)
integer(kind=k7) :: i, iter ! Declare integer variables
integer(kind=k7), intent(in) :: n
real(kind=p14r300),EXTERNAL :: leg_poly, leg_deriv
a=1.0 ! Value to use on the next line
pi=4*atan(a) ! Calculate Pi
tol=1.d-14
do i=1,n
x=-cos(pi*(i-0.25)/(n+0.5)) ! Initial x value
do iter=1,20 ! Set maximum number of iterations
y=x-leg_poly(n, x)/leg_deriv(n, x)
pl=leg_poly(n, y)-leg_poly(n, x)
x=y ! Make x the same as the computed y to repeat
! calculation
if (abs(pl)<=tol) exit ! Once tolerance is reached, exit
enddo
xarr(i)=x ! Place x values into array
enddo
end subroutine leg_root
subroutine gauss_leg_int(ng, xabsc, weight)
!==================================================================
! Subroutine that organizes the computations to find the abscissas
! and weights for Gauss-Legendre integration, where ng is the
! number of integration points(integer, input), and xabsc and
! weight are real arrays of length ng (output) that hold the
! abscissas and weights, respectively.
!==================================================================
USE Precision
IMPLICIT NONE
integer(kind=k7) :: i
integer(kind=k7), intent(in) :: ng
real(kind=p14r300) :: x, w
real(kind=p14r300), EXTERNAL :: leg_deriv
real(kind=p14r300) :: xarr(ng)
real(kind=p14r300), intent(out) :: weight(ng)
real(kind=p14r300), intent(out) :: xabsc(ng)
do i=1,ng
call leg_root(ng, xabsc) ! Call subroutine to use xarr
x=xabsc(i) ! Loop over each x value per ng
w=2/((1-x**2)*leg_deriv(ng, x)**2) ! calculate weight
weight(i)=w ! Place weight values into array
enddo
end subroutine gauss_leg_int