Введите связанную процедуру в качестве аргументов

Я хочу передать связанные с типом процедуры (в качестве внешней функции) другой функции следующим образом:

module mod1
   implicit none

   type type1
      real :: a
      contains
      procedure,pass :: f
   end type

contains

   real function f(y,e)
      class(type1), intent(in) :: y
      real,intent(in) :: e
      f=y%a+e
   end function

end module

program test

   use mod1
   type(type1) :: t

   t%a=3e0
   write(*,*) s(t%f)

contains

   real function s(g)
      real,external :: g
      s=g(5e0)+2e0
   end function

end program

gfortran выдает эту ошибку:

       write(*,*) s(t%f)
                       1
Error: Expected argument list at (1)

Но что я могу сделать, так это:

program test

   t%a=3e0
   write(*,*) s(k)

contains

   real function s(g)
      real,external :: g
      s=g(5e0)+2e0
   end function

   real function k(e)
      real,intent(in) :: e
      k=3e0+e
   end function

end program

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

РЕДАКТИРОВАТЬ:

Лучший пример, который (надеюсь) показывает сложность:

module mod2
   implicit none
contains

   real function s(g)
       interface
        real function g(x)
          real, intent(in) :: x
        end function
      end interface

      s=g(5e0)+2e0
   end function
end module

module mod1
   use mod2

   type type1
      real :: a
      contains
      procedure,pass :: f
      procedure,pass :: h
   end type

contains

   real function f(y,e)
      class(type1), intent(in) :: y
      real,intent(in) :: e
      f=y%a+e
   end function

   real function h(y)
      class(type1), intent(inout) :: y
      h=s(y%f)
   end function
end module

program test

use mod1
   type(type1) :: t

   t%a=3e0
   write(*,*) t%h
end program

РЕДАКТИРОВАТЬ II: Хорошо, обертки все еще работают в сочетании с указателем:

module mod2
   implicit none
contains

   real function s(g)
       interface
        real function g(x)
          real, intent(in) :: x
        end function
      end interface

      s=g(5e0)+2e0
   end function
end module 

module mod1 
   use mod2

   type type1
      real :: a
      contains
      procedure,pass :: f
      procedure,pass :: h
   end type

   class(type1),pointer :: help_w

contains

   real function f(y,e)
      class(type1), intent(in) :: y
      real,intent(in) :: e
      f=y%a+e
   end function

   real function h(y)
      class(type1), intent(inout),target :: y
      help_w => y
      h=s(wrap) 
   end function

   function wrap(x)
      real,intent(in) :: x
      wrap=help_w%f(x)
   end function 
end module

program test

use mod1
   type(type1) :: t

   t%a=3e0
   write(*,*) t%h()
end program

Это, конечно, не красивое решение, но, по крайней мере, оно работает.


person PeMa    schedule 02.06.2014    source источник


Ответы (1)


Вы можете написать обертку. Это самая прямая версия. Требуется передача внутренней функции в качестве фиктивного аргумента (F2008), но вы также можете объявить оболочку в модуле, если t может быть там.

Примечание. Я изменил объявление аргумента процедуры в s на что-то более современное — интерфейсный блок.

program test
   use mod1
   type(type1) :: t

   t%a=3e0
   write(*,*) s(wrap)

contains

   real function s(g)
      interface
        real function g(x)
          real, intent(in) :: x
        end function
      end interface

      s=g(5e0)+2e0
   end function

   function wrap(x)
     real, intent(in) :: x
     wrap = t%f(x)
   end function

end program

Причина вашей ошибки хорошо описана в ответах на связанный вопрос, вы не можете передавать процедуры привязки типа так, как вы пытались.

person Vladimir F    schedule 02.06.2014
comment
Да, я вижу, что упростил свой пример. Извини! Я добавлю еще одну версию, в которой я не понимаю, как я могу определить оболочку таким простым способом, поскольку она не объявляется, когда я определяю вызов. Надеюсь, это лучше показывает сложность. - person PeMa; 03.06.2014
comment
Да, с дополнительным указателем это снова работает. Так что большое спасибо. - person PeMa; 03.06.2014