Могу ли я имитировать c несколько фиктивных аргументов переданного объекта в Фортране?

Question

Я хотел бы написать процедуру, которая принимает два фиктивных аргумента переданного объекта, таких как

module m
  type, abstract :: Parent
  contains
    procedure(f_Parent), deferred :: f
  end type

  abstract interface
    subroutine f_Parent(foo,bar)
      import Parent
      implicit none
      class(Parent), intent(in) :: foo
      class(Parent), intent(in) :: bar
    end subroutine
  end interface

  type, extends(Parent) :: Child
  contains
    procedure, public :: f => f_Child
  end type
contains
  subroutine f_Child(foo,bar)
    implicit none
    class(Child), intent(in) :: foo
    class(Child), intent(in) :: bar
  end subroutine
end module

, но это не разрешено стандартом Фортрана, так как bar не является переданным объектом фиктивный аргумент, и поэтому должен быть class(Parent), а не class(Child).

Мое текущее решение -

subroutine f_Child(foo,bar)
  implicit none
  class(Child),  intent(in) :: foo
  class(Parent), intent(in) :: bar

  select type(bar); type is(Child) 
  end select
end subroutine

, которое работает, но конструкция select type слишком медленная и доминирует время выполнения моего кода (эта подпрограмма вызывается много раз).

Я пытался использовать один аргумент переданного объекта, который содержит foo и bar, например, в виде массива или указателя, но это также запрещено стандартом.

Есть ли способ имитировать поведение наличия нескольких фиктивных аргументов переданного объекта, которое не влечет за собой стоимость конструкции select type? Или, возможно, более быстрый способ получить аргумент class(Child) из class(Parent)?

Answer 1

Вы можете сделать это, используя одну отправку дважды:

Module m

  Implicit None

  Type, Public, Abstract :: Parent
   Contains
     Procedure( i_Parent_Parent ),              Public , Deferred :: f
     Procedure( i_Child_Parent  ), Pass( bar ), Private, Deferred :: f_c_p
     Procedure( i_set           ),              Public , Deferred :: set
  End Type Parent

  Type, Public, Extends( Parent ) :: Child
     Integer               , Private :: data
   Contains
     Procedure             , Public  :: f     => f_Child_Parent
     Procedure, Pass( bar ), Private :: f_c_p => f_Child_Child
     Procedure             , Public  :: set   => f_Child_set
  End Type Child

  Private

  Abstract Interface
     Subroutine i_Parent_Parent( foo, bar )
       Import :: Parent
       Implicit None
       Class( Parent ), Intent( In ) :: foo
       Class( Parent ), Intent( In ) :: bar
     End Subroutine i_Parent_Parent
     Subroutine i_Child_Parent( foo, bar )
       Import :: Parent, Child
       Implicit None
       Class( Child  ), Intent( In ) :: foo
       Class( Parent ), Intent( In ) :: bar
     End Subroutine i_Child_Parent
     Subroutine i_set( foo, data )
       Import :: Parent
       Class( Parent ), Intent( InOut ) :: foo
       Integer        , Intent( In    ) :: data
     End Subroutine i_set
  End Interface

Contains

  Subroutine f_Child_Parent( foo, bar )
    Implicit None
    Class( Child  ), Intent( In ) :: foo
    Class( Parent ), Intent( In ) :: bar
    Call bar%f_c_p( foo )
  End Subroutine f_Child_Parent

  Subroutine f_Child_Child( foo, bar )
    Implicit None
    Class( Child ), Intent( In ) :: foo
    Class( Child ), Intent( In ) :: bar
    Write( *, * ) 'In child child foo%data = ', foo%data, ' bar%data = ', bar%data
  End Subroutine f_Child_Child

  Subroutine f_Child_set( foo, data )
    Implicit None
    Class( Child ), Intent( InOut ) :: foo
    Integer       , Intent( In    ) :: data
    foo%data = data
  End Subroutine f_Child_set

End Module m

Program driver

  Use m, Only : Parent, Child

  Class( Parent ), Allocatable :: foo, bar

  Allocate( Child :: foo )
  Allocate( Child :: bar )

  Call foo%set( 3 )
  Call bar%set( 4 )

  Call foo%f( bar )

End Program driver
ian@eris:~/work/stack$ gfortran-8 -std=f2008  -fcheck=all -Wall -Wextra dd.f90
ian@eris:~/work/stack$ ./a.out
 In child child foo%data =            3  bar%data =            4
ian@eris:~/work/stack$ 

Будет ли это быстрее, чем select type, будет зависеть от реализации, но я думаю, что это чище.