Как использовать указатель на процедуру Фортрана, чтобы взять имя функции? - PullRequest
Новая
       19

Как использовать указатель на процедуру Фортрана, чтобы взять имя функции?

0 голосов
/ 24 февраля 2019

Я пытаюсь использовать процедуру указателя, чтобы выбрать нужную мне функцию при определенных условиях (в данном случае в цикле do).Разместите часть своего кода, в которой я покажу вам, что я собираюсь сделать.

!Основная программа 

program MKRBF

  use kernel
  use srbf

  implicit none

  !real*8 :: SelKer
  integer :: i,j,k
  integer, parameter :: n = 3
  integer, parameter :: nKer = 2
  real*8, dimension(2,2) :: ParBound, auxpar
  real*8, dimension(2) :: Bound
  real*8, dimension(n) :: Var, func
  real*8, dimension(n,nKer) :: coe
  real*8, dimension(n,n) :: mat

  !external SelKer
  pointer :: fp
  procedure(SelKer), pointer :: fp => null()

  Bound(1) = 0
  Bound(2) = 5

  ParBound(1,1) = 1 
  ParBound(1,2) = 5
  ParBound(2,1) = 1 
  ParBound(2,2) = 5

  auxpar(1,1) = 0 
  auxpar(1,2) = 0
  auxpar(2,1) = 1 
  auxpar(2,2) = 1

  var(:) = (/ 0., 2.5, 5. /)

  do i = 1, n
      func(i) = cos(3*Var(i)) * exp(-.25*Var(i));
  end do

  do i = 1, nKer
      fp => SelKer
      call weigth(n,Var,n,Var,1,func,fp(i),2.0D0,auxpar,coe,mat)
  end do
end program MKRBF

!Модуль testKernel.f90 

module kernel
  implicit none
  contains

  ! POLYNOMIAL 
  function poly(x, ts, ndim, a, param1, param2)
    integer, intent (in) :: ndim
    real*8, dimension(ndim), intent(in) :: x
    real*8, dimension(ndim), intent(in) :: ts
    real*8, intent(in) :: a, param1, param2
    real*8 :: r
    real*8 :: poly 

    r = sqrt(sum((x(1:ndim) - ts(1:ndim))**2.))

    poly = r**a

  end function poly

  ! GAUSSIAN
  function gauss(x, ts, ndim, a, gamma, param2)
     integer, intent (in) :: ndim 
     real*8, dimension(ndim), intent(in) :: x
     real*8, dimension(ndim), intent(in) :: ts
     real*8, intent(in) :: a, param2, gamma
     real*8 :: r
     real*8 :: gauss

     r = sqrt(sum((x(1:ndim) - ts(1:ndim))**2.))

    gauss = exp(-(gamma*r)**a)

 end function gauss

 function SelKer(indx) 
   integer, intent(in) :: indx
   real*8 :: SelKer

   select case (indx)
   case (1)
     SelKer => poly
   case (2)
     SelKer => gauss
   end select
 end function SelKer

end module kernel

!Модуль testSRBF.f90 

module srbf
 implicit none
 contains  

 subroutine weigth(nx, x, nts, ts, ndim, s, kernel, StocPar, param, coe, mat)
   integer :: i,j,k,l,m,n
   integer :: info
   integer :: nx, nts, ndim
   integer, dimension(nts) :: ipiv 
   real*8, dimension(nts) :: w
   real*8, dimension(nts) :: s
   real*8, dimension(2) :: param
   real*8, dimension(nx,ndim) :: x
   real*8, dimension(nts,ndim) :: ts
   real*8, dimension(nx,nts) :: phi, mat
   real*8, dimension(nts) :: coe
   real*8 :: stocPar

   interface
    real*8 function kernel(x1, x2, n3, stov, p1, p2)
      integer, intent (in) :: n3
      real*8, dimension(n3), intent(in) :: x1
      real*8, dimension(n3), intent(in) :: x2
      real*8, intent(in) :: stov, p1, p2
    end function kernel
   end interface

   do i = 1, nx
     do j = 1, nts
         phi(i,j) = kernel(x(i,1:ndim), ts(j,1:ndim), ndim, stocPar, param(1), param(2))
     end do
   end do

   w = s       
   mat = phi   
   call DGESV(nts,1,mat,nts,ipiv,w,nts,info) 
   coe = w
 end subroutine weigth 
end module srbf

Это дает ошибку компиляции 

testKer_mod.f90:41:20: SelKer => poly
Error: Function 'poly' requires an argument list at (1)

и то же самое для другой функции.

1 Ответ

0 голосов
/ 24 февраля 2019

Рассмотрим функцию SelKer: 

function SelKer(indx) 
  integer, intent(in) :: indx
  real*8 :: SelKer

  select case (indx)
  case (1)
    SelKer => poly
  case (2)
    SelKer => gauss
  end select
end function SelKer

Здесь poly и gauss предназначены для определенных нами модульных процедур.

Результат функции SelKer объявлено скалярным значением без указателя real*8.Это не указатель процедуры.Чтобы объявить результат функции как указатель процедуры с интерфейсом poly (учитывая, что poly и gauss имеют одинаковые характеристики): 

procedure(poly), pointer :: SelKer

При этом измените операторы назначения указателя в select case конструкция теперь действительна: результат функции указывает на соответствующую функцию.

Тем не менее, есть другие части, которые необходимо рассмотреть в теле вопроса.Посмотрите теперь на 

pointer :: fp
procedure(SelKer), pointer :: fp => null()

вместе с 

fp => SelKer
call weigth(n,Var,n,Var,1,func,fp(i),2.0D0,auxpar,coe,mat)

В первом блоке есть проблема: вы не можете дважды указать атрибут указателя для fp.Удалите строку pointer :: fp.

Использование fp для указания всегда на SelKer также является избыточным: вы также можете просто написать 

call weigth(n,Var,n,Var,1,func,Selker(i),2.0D0,auxpar,coe,mat)

и не иметь fp какуказатель процедуры.Более полезное использование fp в качестве указателя на процедуру будет 

procedure(poly), pointer :: fp=>null
...
do i = 1, nKer
  fp => SelKer(i)
  call weigth(n,Var,n,Var,1,func,fp,2.0D0,auxpar,coe,mat)
end do
...