In Fortran, you can pass a function/subroutine A as an argument to another function/subroutine B, but can you store A for later retrieval and use?
for example, this is allowed in C
int foo(float, char, char) { /*whatever*/};
int (*pointerToFunction)(float, char, char);
pointerToFunction = foo;
In Fortran you can pass a subroutine as an argument
subroutine foo
! whatever
end subroutine foo
subroutine bar(func)
call func
end subroutine bar
program x
call bar(foo)
end program
but how can you store the address of foo in a similar way to C ?
Starting from so-called "Fortran 2003" (ISO/IEC 1539-2004) procedure pointers is a part of the Fortran language. It's definitely of the major new features of Fortran language.
Usage example from Fortran Wiki.
Stefano, you mentioned strategy design pattern. In Fortran 2003 you can use pure OOP way to implement it (without procedure pointers). Offhand example:
strategies.f90
module strategies
implicit none
private
public :: strategies_transportation_strategy, &
strategies_by_taxi_strategy, &
strategies_by_bus_strategy
type, abstract :: strategies_transportation_strategy
contains
procedure(transportation_strategy_go), deferred :: go
end type strategies_transportation_strategy
type, extends(strategies_transportation_strategy) :: strategies_by_taxi_strategy
contains
procedure :: go => strategies_by_taxi_strategy_go
end type strategies_by_taxi_strategy
type, extends(strategies_transportation_strategy) :: strategies_by_bus_strategy
contains
procedure :: go => strategies_by_bus_strategy_go
end type strategies_by_bus_strategy
abstract interface
subroutine transportation_strategy_go(this)
import strategies_transportation_strategy
class(strategies_transportation_strategy), intent(in) :: this
end subroutine transportation_strategy_go
end interface
contains
subroutine strategies_by_taxi_strategy_go(this)
class(strategies_by_taxi_strategy), intent(in) :: this
print *, "We are using taxi."
end subroutine strategies_by_taxi_strategy_go
subroutine strategies_by_bus_strategy_go(this)
class(strategies_by_bus_strategy), intent(in) :: this
print *, "We are using public transport."
end subroutine strategies_by_bus_strategy_go
end module strategies
vehicles.f90
module vehicles
use strategies
implicit none
private
public :: vehicles_vehicle, &
vehicles_taxi, &
vehicles_bus
type, abstract :: vehicles_vehicle
private
class(strategies_transportation_strategy), allocatable :: transportation_strategy
contains
procedure :: set_transportation_strategy => vehicle_set_transportation_strategy
procedure :: go => vehicle_go
end type vehicles_vehicle
type, extends(vehicles_vehicle) :: vehicles_taxi
contains
procedure :: init => taxi_init
end type vehicles_taxi
type, extends(vehicles_vehicle) :: vehicles_bus
contains
procedure :: init => bus_init
end type vehicles_bus
contains
subroutine vehicle_go(this)
class(vehicles_vehicle), intent(in) :: this
call this%transportation_strategy%go()
end subroutine vehicle_go
subroutine vehicle_set_transportation_strategy(this, new_transportation_strategy)
class(vehicles_vehicle), intent(inout) :: this
class(strategies_transportation_strategy), intent(in) :: new_transportation_strategy
if (allocated(this%transportation_strategy)) then
deallocate (this%transportation_strategy)
end if
allocate (this%transportation_strategy, source=new_transportation_strategy)
end subroutine vehicle_set_transportation_strategy
subroutine taxi_init(this)
class(vehicles_taxi), intent(out) :: this
type(strategies_by_taxi_strategy) :: by_taxi_strategy
call this%set_transportation_strategy(by_taxi_strategy)
end subroutine taxi_init
subroutine bus_init(this)
class(vehicles_bus), intent(out) :: this
type(strategies_by_bus_strategy) :: by_bus_strategy
call this%set_transportation_strategy(by_bus_strategy)
end subroutine bus_init
end module vehicles
main.f90
program main
use vehicles
implicit none
type(vehicles_taxi) :: taxi
type(vehicles_bus) :: bus
call taxi%init()
call bus%init()
call taxi%go()
call bus%go()
end program main
At least works using gfortran 4.6 (20100925).
The following codes demonstrate how to use procedure pointers:
module my_mod
implicit none
contains
subroutine sub1()
write(*,*) 'the first suboutine is being used'
end subroutine sub1
subroutine sub2()
write(*,*) 'the second subroutine is being used'
end subroutine sub2
end module my_mod
program procTest
use my_mod
implicit none
integer :: n
procedure(sub1), pointer:: funPointer => NULL()
write(*,'(A)') "Please enter your option"
read(*,*) n
select case( n )
case( 1 )
funPointer => sub1
case( 2 )
funPointer => sub2
case DEFAULT
funPointer => sub1
end select
call funPointer()
end program procTest
Related
Following a previous question I had (Fortran TYPE inheritance on runtime (declared by user)), I am using a factory method to generate an array of different types. Below is a simplified version of what I'm doing,
module multiarray
use iso_fortran_env, only: real64
implicit none
integer, parameter :: dp = real64
! abstract list type
type, abstract :: list
contains
procedure(in), deferred, pass(self) :: addval ! add a variable
procedure(out), deferred, pass(self) :: getval ! extract variable
end type
abstract interface
subroutine in(self,val)
import :: list
implicit none
class(list), intent(inout) :: self
class(*), intent(in) :: val
end subroutine
subroutine out(self,val)
import :: list
implicit none
class(list), intent(in) :: self
class(*), intent(out) :: val
end subroutine
end interface
! real(dp) element extension
type, extends(list) :: real_num
real(dp) :: var
contains
procedure, pass(self) :: addval => addreal
procedure, pass(self) :: getval => getreal
end type
! similar for character, logical, etc types
...
! wrapper
type wrapper
class(list), ALLOCATABLE :: arg
end type
contains
! real(dp) subroutines
subroutine addreal(self,val)
implicit none
class(real_num), intent(inout) :: self
class(*), intent(in) :: val
select type(val)
type is (real(dp))
self%var = val
end select
end subroutine
subroutine getreal(self,val)
implicit none
class(real_num), intent(in) :: self
class(*), intent(out) :: val
select type(val)
type is (real(dp))
val = self%var
end select
end subroutine
! similar for character, logical, etc types
...
! factory method
function get_list(val) result(pt)
class(*), intent(in) :: val
class(list), allocatable :: pt
select type(val)
type is (real(dp))
allocate(real_num :: pt)
type is (character(*))
...
end select
end function
end module
I use the wrapper type to generate an allocatable array of type list
type(wrapper) :: A(5)
real(dp) :: x
A(1)%arg = get_list(90.d0) ! Set A(1) as type real
call A(1)%arg%addval(90.d0) ! A(1) is a real of value 90
call A(1)%arg%getval(x) ! set x = A(1) to use elsewhere
The variable var is defined as a generic class in the abstract interface, it can be of real, character, logical, etc type. I then use a select type construct to match the addval=>addreal subroutine argument since var is of type class(*) in the abstract interface.
Is there a way to define an interface inside the abstract interface (nested), in a way that I don't need to have the select type in addreal (since I already know it's input needs to be a real type)? Or is there a better way, simpler way, to achieve what I'm trying to do with the variable type array? Thanks!
I think you don't want to have both class(*) inputs and an abstract base class. I think you want to have either one:
a non-polymorphic container class that can contain any (class(*)) element types, for example, a key-value pair in a dictionary;
a polymorphic container class if a limited set of types should later have a shared API.
In your case it seems you want maximum flexibility, I would vote for having a unique container class and making usage of class(*), like in the following example I've just made up:
! FP 2022-07-25
module myList
use iso_fortran_env
implicit none
type, public :: listElement
class(*), allocatable :: x
contains
procedure :: set
procedure :: get_any
procedure :: get_typed
procedure, private :: print
generic :: write(formatted) => print
end type listElement
contains
! Map accepted types
elemental logical function isAccepted(val)
class(*), intent(in) :: val
select type (input=>val)
type is (real(real32)); isAccepted = .true.
type is (character(*)); isAccepted = .true.
class default; isAccepted = .false.
end select
end function isAccepted
! Print value
subroutine print(this, unit, iotype, v_list, iostat, iomsg)
class(listElement), intent(in) :: this
integer, intent(in) :: unit
character(*), intent(in) :: iotype
integer, intent(in) :: v_list(:)
integer, intent(out) :: iostat
character(*), intent(inout) :: iomsg
if (.not.allocated(this%x)) then
write(unit,*,iostat=iostat) 'null'
else
select type (myVar => this%x)
type is (real(real32)); write(unit,*,iostat=iostat) myVar
type is (character(*)); write(unit,*,iostat=iostat) myVar
class default; write(unit,*,iostat=iostat) "ERROR"
end select
endif
end subroutine print
subroutine set(this,val)
class(listElement), intent(inout) :: this
class(*), intent(in) :: val
integer :: ierr
deallocate(this%x,stat=ierr) ! force deallocate
allocate(this%x,source=val)
end subroutine set
! Can be anything, but "val" must be declared "class(*), allocatable"
subroutine get_any(this,val)
class(listElement), intent(in) :: this
class(*), intent(out), allocatable :: val
allocate(val,source=this%x)
end subroutine get_any
subroutine get_typed(this,val)
class(listElement), intent(in) :: this
class(*), intent(out) :: val ! has a type that can't change
if (.not.isAccepted(val)) stop ' trying to return value to a class thats not supported '
if (.not.allocated(this%x)) return ! will return garbage
select type (outVal => val)
type is (real(real32));
select type (thisVal => this%x)
type is (real(real32)); outVal = thisVal
type is (real(real64)); outVal = real(thisVal,real32)
class default; stop 'error trying to convert list element to real32'
end select
type is (character(*));
select type (thisVal => this%x)
type is (character(*)); outVal = trim(thisVal)
class default; stop 'error trying to convert list element to character'
end select
class default
stop 'trying to return value to a class thats not accepted '
end select
end subroutine get_typed
end module myList
program tryList
use myList
implicit none
type(listElement) :: A(5)
integer :: i
character(255) myChar
real(real32) :: r32
real(real64) :: r64
call A(1)%set(123.45)
call A(2)%set("hello world!")
call A(3)%set(123.45d0)
do i=1,3
print *, 'A(',i,')=',A(i)
end do
call A(1)%get_typed(r64); print *, 'r64=',r64
call A(1)%get_typed(r32); print *, 'r32=',r32
call A(2)%get_typed(myChar); print *, 'myChar=',myChar
call A(2)%get_typed(r32) ! stop on error
end program
Notice that:
In general, this should work with any variables (class(*)), but if you want to use the fully polymorphic interface, the input variable must be defined as class(*), allocatable anywhere else, so, not exactly handy.
You want to have some helper routines and/or an enumerator type that help you map/handle all types you want to be contained, this example is just a stub.
I want to pass a procedure pointer between two classes in modern Fortran.
this procedure pointer should
be called from within the second object
access the first ojects' components, without having it as dummy argument.
A clear example is here, imagine doing an object-oriented wrapper of an ODE solver:
module test_funptr
implicit none
public
type, public :: ode_solver
integer :: NEQ = 0
procedure(ode_api), pointer, nopass :: f => null()
contains
procedure :: run
end type ode_solver
type, public :: ode_problem
integer :: NEQ = 10
procedure(ode_api), pointer, nopass :: yprime => null()
contains
procedure :: init
end type ode_problem
abstract interface
subroutine ode_api(NEQ,YDOT)
integer, intent(in) :: NEQ
real(8), intent(inout) :: YDOT(NEQ)
end subroutine ode_api
end interface
contains
! Initialize problem variables
subroutine init(this,NEQ)
class(ode_problem), intent(inout) :: this
integer, intent(in) :: NEQ
! Associate function pointer
this%yprime => problem_api
contains
! nopass ODE solver API
subroutine problem_api(NEQ,YDOT)
integer, intent(in) :: NEQ
real(8), intent(inout) :: YDOT(NEQ)
integer :: i
print *, 'entered problem API with NEQ=',NEQ
forall(i=1:NEQ) YDOT(i) = real(i,8)
end subroutine
end subroutine init
subroutine run(this)
class(ode_solver), intent(inout) :: this
real(8) :: ydot(this%neq)
ydot = 0.0
print *, 'enter solver run with NEQ=',this%NEQ
print *, 'is function associated? ',associated(this%f)
call this%f(this%neq,ydot)
end subroutine run
end module test_funptr
program test
use test_funptr
type(ode_solver) :: solver
type(ode_problem) :: prob
call prob%init(10)
! Associate ode solver
solver%neq = prob%NEQ
solver%f => prob%yprime
call solver%run()
end program test
This program returns with gfortran-10:
enter solver run with NEQ= 10
is function associated? T
Program received signal SIGILL: Illegal instruction.
The procedure seems properly associated, but it can't be called. Am I doing something wrong passing the procedure pointers, or I'm doing something out-of-standard? I'm concerned the contained subroutine may go out of scope, but if so, how can I achieve this behavior?
The tricky part is of course that the function should access data from the other variable instance.
It is illegal to invoke a procedure pointer to an internal procedure, after the host procedure gets out of scope.
The draft of Fortran 2015 N2123 mentions this in NOTE 15.17
NOTE 15.17
An internal procedure cannot be invoked using a procedure
pointer from either Fortran or C after the host instance completes
execution, because the pointer is then undefined. While the host
instance is active, however, if an internal procedure was passed as an
actual argument or is the target of a procedure pointer, it could be
invoked from outside of the host subprogram.
... an example follows
Often, internal procedures are implemented using trampolines. That is, a piece of executable code placed on the stack, that enables accessing the local scope and calls the procedure itself. The pointer is then a pointer to the trampoline. Once the host function gets out of scope, the pointer to the stack is invalid.
As pointed out, internal (contained) procedures are not the way to go, as they cannot be targets to procedure pointers. Hopefully this will be catched by the compilers.
I've figured out an elegant way to accomplish the aim to pass an interfaced procedure between two classes this way:
class 1 needs to call that function: it must contain a pointer to class 2
The nopass function should be inside this class, as an internal procedure (this way, it'll never go out of scope)
This class must contain a (polymorphic) pointer to the instantiated object from class 2
class 2 contains the actual implementation, it should instantiate an abstract type that contains the same interfaced function, but with the derived type as dummy argument
Here I'm providing an implementation that works:
module odes
implicit none
type, abstract, public :: ode_problem
integer :: NEQ
contains
procedure(ode_api), deferred :: fun
end type ode_problem
type, public :: ode_solver
integer :: NEQ
class(ode_problem), pointer :: problem => null()
contains
procedure :: init
procedure :: run
end type ode_solver
abstract interface
subroutine ode_api(this,YDOT)
import ode_problem
class(ode_problem), intent(inout) :: this
real(8), intent(out) :: YDOT(this%NEQ)
end subroutine ode_api
end interface
contains
! Associate problem to ODE solver
subroutine init(this,my_problem)
class(ode_solver), intent(inout) :: this
class(ode_problem), intent(in), target :: my_problem
this%neq = my_problem%NEQ
this%problem => my_problem
end subroutine init
! call the nopass f77 interface function
subroutine run(this)
class(ode_solver), intent(inout) :: this
real(8) :: YDOT(this%NEQ)
integer :: i
if (.not.associated(this%problem)) stop 'solver not associated to a problem'
! This will be in general passed to another function as an argument
call ode_f77_api(this%NEQ,YDOT)
contains
subroutine ode_f77_api(NEQ,YDOT)
integer, intent(in) :: NEQ
real(8), intent(out) :: YDOT(NEQ)
! This is just a nopass interface to this problem's function that can
! access internal storage
call this%problem%fun(YDOT)
end subroutine ode_f77_api
end subroutine run
end module odes
! Provide an actual implementation
module my_ode_problem
use odes
implicit none
type, public, extends(ode_problem) :: exp_kinetics
real(8) :: k = -0.5d0
contains
procedure :: fun => exp_fun
end type exp_kinetics
contains
subroutine exp_fun(this,YDOT)
class(exp_kinetics), intent(inout) :: this
real(8), intent(out) :: YDOT(this%NEQ)
integer :: i
forall(I=1:this%NEQ) YDOT(i) = this%k*real(i,8)
print 1, this%NEQ,(i,YDOT(i),i=1,this%NEQ)
1 format('test fun! N=',i0,': ',*(/,10x,' ydot(',i0,')=',f5.2,:))
end subroutine exp_fun
end module my_ode_problem
program test_fun_nopass
use odes
use my_ode_problem
implicit none
type(exp_kinetics) :: prob
type(ode_solver) :: ode
prob%NEQ = 10
call ode%init(prob)
call ode%run()
stop 'success!'
end program test_fun_nopass
This program returns:
test fun! N=10:
ydot(1)=-0.50
ydot(2)=-1.00
ydot(3)=-1.50
ydot(4)=-2.00
ydot(5)=-2.50
ydot(6)=-3.00
ydot(7)=-3.50
ydot(8)=-4.00
ydot(9)=-4.50
ydot(10)=-5.00
STOP success!
I have a module which defines a Type, with its methods, plus some other Type-unrelated methods as well.
module TypeDef
type, public :: T
...
contains
...
procedure type_proc
end type
...
contains !module
subroutine type_proc( this, ... )
class(T), target :: this
...
call gen_proc( arg_1, arg_n-1, this, arg_n+1 )
...
end subroutine type_proc
...
subroutine gen_proc( arg_1, ..., arg_n-1, tv, arg_n+1 )
! this is a general module routine.
! NOT type related
implicit none
...
class(T), pointer, intent(in) :: tv
...
if ( cond ) tv%member = 0
...
end subroutine gen_proc
end module
At a given point, I call, from a variable type(T), public :: var its member method type_proc(), which at its interior calls a general module procedure gen_proc(). In there, for some conditions, I may need to change some member(s) of the ACTUAL object calling the method's tree (i.e. var). To do so, I pass this as a constant pointer to call gen_proc() to have its address passed at the function call, and access its members.
But, I get the error as described.
Same if I pass it by reference and not as a const pointer.
I cannot see if I do something mistakenly. Here Intel Fortran error #6633: The type of the actual argument differs from the type of the dummy argument there's something similar, but there, the call happens in a different program unit.
EDIT 2:
Ok, this compiled and run as expected..
module test
type, public :: T
real, allocatable :: m1(:)
real, allocatable :: m2(:)
integer :: may_change
contains
procedure :: t_proc
procedure :: all_t
end type
private :: all_t
contains
subroutine t_proc( this, n )
implicit none
class(T), target :: this
integer, intent(in) :: n
call this%all_t( n )
call gen_proc( n, this%m1, this%m2, this )
end subroutine t_proc
subroutine all_t( this, n )
implicit none
class(T) :: this
integer, intent(in) :: n
allocate( this%m1( n ) )
allocate( this%m2( n ) )
end subroutine
subroutine gen_proc( n, m1, m2, Tt )
implicit none
integer, intent(in) :: n
real, intent(in) :: m1(n), m2(n)
class(T), intent(in), pointer :: Tt
if ( .true. ) Tt%may_change = 1
print *, ' may change = ', Tt%may_change
end subroutine gen_proc
end module test
module varmod
use test
type(T), public :: var
end module varmod
program main
use varmod, only: var
implicit none
integer, parameter :: n = 2
var%may_change = 0
call var%t_proc( n )
end program main
So, even more than before, I don't know what could be wrong on the actual code...
I am trying in an object-oriented fashion to have a type that implements all functionalities, except for one function that should be implemented by the user.
Suppose I have two modules with types, an animal and a cat extending animal. Now I'd like to implement a way of passing a custom procedure to any animal. I don't know what is the best way of implementing such a feature. Right now I've succeeded in having all cat objects have a function caller that that will take a subroutine as an argument, but only if the type is explicit, or in other words, if the type is not an animal and at runtime I create a cat:
animal
module animal_module
implicit none
type, abstract :: animal
private
integer, public :: nlegs = -1
contains
procedure :: legs
procedure :: speak
end type animal
interface animal
module procedure init_animal
end interface animal
contains
type(animal) function init_animal(this)
class(animal), intent(inout) :: this
print *, "Animal!"
this%nlegs = -4
end function init_animal
function legs(this) result(n)
class(animal), intent(in) :: this
integer :: n
n = this%nlegs
end function legs
subroutine speak(this, ntimes)
class(animal), intent(in) :: this
integer, intent(in) :: ntimes
integer :: i
do i = 1, ntimes
print *, "generic animal :: speak"
end do
end subroutine speak
end module animal_module
cat
module cat_module
use animal_module, only : animal
implicit none
type, extends(animal) :: cat
private
real :: hidden = 23.
contains
! something like this? maybe a pointer?
procedure :: caller
procedure :: speak
end type cat
interface cat
module procedure init_cat
end interface cat
abstract interface
subroutine sub_interface
end subroutine
end interface
contains
type(cat) function init_cat()
print *, "Cat!"
init_cat%nlegs = 4
end function init_cat
subroutine caller(this, sub)
class(cat), intent(inout) :: this
procedure(sub_interface) :: sub
print *, "caller begin", this%nlegs
call sub()
print *, "caller ended", this%nlegs
end subroutine caller
subroutine speak(this, ntimes)
class(cat), intent(in) :: this
integer, intent(in) :: ntimes
integer :: i
do i = 1, ntimes
print *, "cat :: meow"
end do
end subroutine speak
end module cat_module
main program
subroutine ahoy
print *, "ahoy"
end subroutine ahoy
program oo
use animal_module
use cat_module
use bee_module
implicit none
class(animal), allocatable :: q
procedure(sub_interface) :: ahoy
class(cat), allocatable :: p
! THIS WON'T WORK
allocate(cat :: q)
q = cat()
call q%caller(ahoy)
! no problem with this
allocate(cat :: p)
p = cat()
call p%caller(ahoy)
end program
The error I am getting in calling caller from an animal is
/oo/main.F90(28): error #6460: This is not a field name that is defined in the encompassing structure. [CALLER]
call q%caller(ahoy)
-----------^
As far as I understand, this should normal: as animal has no clue a cat contains caller, it will not work. Am I right?
How can I let users implement a subroutine that will be called by a caller function? The called function should have access to the type, the user-provided function should be able to modify the hidden integer in a cat object.
I want to add text to a scalar object's component no matter what is shape of this additional text.
To try this, I create an elemental procedure that has a elemental input argument but only one intent(inout) argument which is the passed object.
Here is a MWE:
module add_mod
implicit none
type obj_A
character(len=:), allocatable :: Message
contains
procedure, pass(objA) :: add
procedure, pass(objA) :: write
end type
contains
elemental subroutine add( objA, text )
implicit none
class(obj_A), intent(inout) :: objA
character(len=*), intent(in) :: text
objA%Message=objA%Message//text
end subroutine add
impure elemental subroutine write( objA, text )
implicit none
class(obj_A), intent(in) :: objA
character(len=*), intent(in) :: text
print*,'write ', text
end subroutine write
end module
program test
use add_mod
implicit none
type(obj_A) :: testA
call testA%add('toto')
print *, testA%Message
! call testA%add( ['toto','abcc','d,ef'] )
print *, testA%Message
call testA%write( ['toto','abcc','d,ef'] )
end program
If I let commented the line call testA%add( ['toto','abcc','d,ef'] ), it works fine. But if I uncomment, I have an error during the compilation
Error: Actual argument at (1) for INTENT(INOUT) dummy 'objA' of ELEMENTAL subroutine 'add' is a scalar, but another actual argument is an array`
I understand why it is correct with the testA%write call, it is due to the intent(in) of the passed object; in this case the compiler understands that one argument is scalar shape and the other one is array shape.
With the testA%add( ['toto','abcc','d,ef'] ), I also understand that it requires an array shaped obj_A as intent(inout), since the text given for input is a scalar. Thus, it is not the correct way to do it.
Is there a correct way to add text to obj_A%Message no matter what is shape of this text?
When using elemental subroutines, you can provide an array input and an array output [the operations then occur in an element-wise way]. However, you are trying to assign an array input to a scalar output (here: testA).
If you used an array output of size 3, your routine works as expected:
module add_mod
implicit none
type obj_A
character(len=:), allocatable :: Message
contains
procedure, pass(objA) :: add
end type
contains
elemental subroutine add( objA, text )
implicit none
class(obj_A), intent(inout) :: objA
character(len=*),intent(in) :: text
objA%Message=objA%Message//text
end subroutine add
end module
program test
use add_mod
implicit none
type(obj_A) :: testA
type(obj_A) :: testB(3)
call testA%add('toto')
print *, testA%Message
call testB%add( ['toto','abcc','d,ef'] )
print *, testA%Message
print *, testB(1)%Message, testB(2)%Message, testB(3)%Message
end program
Here is a version to add an array of strings to a scalar output. Please note that due this constellation, the subroutine cannot be elemental. However, it can be pure:
module add_mod
implicit none
type obj_A
character(len=:), allocatable :: Message
contains
procedure, pass(objA) :: add
end type
contains
pure subroutine add( objA, text )
implicit none
class(obj_A), intent(inout) :: objA
character(len=*), dimension(:), intent(in) :: text
integer :: i
do i=1,size(text)
objA%Message=objA%Message//text(i)
enddo !i
end subroutine add
end module
program test
use add_mod
implicit none
type(obj_A) :: testA
call testA%add(['toto'])
print *, testA%Message
call testA%add( ['toto','abcc','d,ef'] )
print *, testA%Message
end program
Finally, to support both scalar and array arguments, you need to provide and bind several implementations and then use a generic interface to provide them under the same name:
module add_mod
implicit none
type obj_A
character(len=:), allocatable :: Message
contains
generic :: add => add1, add2
procedure, pass(objA) :: add1
procedure, pass(objA) :: add2
end type
contains
pure subroutine add1( objA, text )
implicit none
class(obj_A), intent(inout) :: objA
character(len=*), dimension(:), intent(in) :: text
integer :: i
do i=1,size(text)
objA%Message=objA%Message//text(i)
enddo
end subroutine add1
pure subroutine add2( objA, text )
implicit none
class(obj_A), intent(inout) :: objA
character(len=*), intent(in) :: text
objA%Message=objA%Message//text
end subroutine add2
end module
program test
use add_mod
implicit none
type(obj_A) :: testA
call testA%add('toto')
print *, testA%Message
call testA%add( ['toto','abcc','d,ef'] )
print *, testA%Message
end program