Polymorphism in type bound procedures

Question

is there a way to use the same function as a type bound procedure for say two or more types? E.g. imagine the following situation:

module definitions
implicit none

type type1
   integer i
   contains
   procedure,pass :: init1
end type

type type2
   integer i
   contains
   procedure,pass :: init2
end type

contains

subroutine init1(x)
   class(type1),intent(inout) :: x
   x%i=3
end subroutine

subroutine init2(x)
   class(type2),intent(inout) :: x
   x%i=3
end subroutine

end module

program test
use definitions

type(type1) ::a
type(type2) ::b

print*, a%i
print*, b%i
call a%init1
print*, a%i
print*, b%i
call b%init2
print*, a%i
print*, b%i

end program

As you see, I used the same subroutine, but I feel forced to define it twice. So I'm asking for something like

class(type1 .or. type2), intent(inout) :: x

or comparable. I already tried class(*) but this is of course not working since the compiler then doesn't know what to do with the x%i which might not be defined, even not in combination with a select type block. I want to mention that the real program is more complex, so it's not easily possible the merge the similar parts of the type definitions and then extend then to define the two types. Thanks in advance!

Answer 1

It is not possible directly. But why do you not create a base type which is then extended?

module definitions
implicit none

type base
   integer i
contains
   procedure,pass :: init
end type


type, extends(base) :: type1
end type

type, extends(base) ::  type2
end type

contains

subroutine init(x)
   class(base),intent(inout) :: x
   x%i=3
end subroutine

end module

program test
use definitions

type(type1) ::a
type(type2) ::b

print*, a%i
print*, b%i
call a%init
print*, a%i
print*, b%i
call b%init
print*, a%i
print*, b%i

end program

Edit (PM): This solves the problem which I actually had in mind:

module definitions
implicit none

type base
integer :: i
contains
   procedure,pass :: init
end type

type, extends(base) :: type1
integer:: j
end type

type, extends(base) ::  type2
integer:: k
end type

contains

subroutine init(x)
   class(base),intent(inout) :: x
   integer :: m
   select type (x)
   type is (type1)
   m=x%j
   type is (type2)
   m=x%k
   end select
   x%i=3*m
end subroutine

end module

program test
use definitions

type(type1) ::a
type(type2) ::b

a%j=2
b%k=4
print*, a%i
print*, b%i
call a%init
print*, a%i
print*, b%i
call b%init
print*, a%i
print*, b%i

end program
                                                                                                                                                   1,5           Top