Как разделить один файл Fortran на отдельные подпрограммы и функциональные файлы

Question

Еще одна неделя, еще один глупый вопрос от кого-то, кто пытается не ударить sh головой об стол. У меня есть файл Fortran90, который делает то, что я хочу, без ошибок и корректный вывод. Теперь мне нужно разделить эту вещь, которая работает на составляющие, то есть два файла подпрограмм, два файла функций и программу драйвера. Как мне сделать это, не ломая его, потому что он сломан ... Основная проблема - передача массивов ... Я думаю. Рабочий код одного файла:

      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                      

Answer 1

Вот как решена моя головоломка, сначала я разделил все это, создал модуль для параметров точности и отредактировал каждый файл, чтобы учесть тот факт, что массивы должны были быть переданы: Precision MODULE:

  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

Подпрограммы:

            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