How can I achieve this objective in fortran 90 ? I have a routine accepting a function
subroutine foo(bar, mysub)
integer, intent(in) :: bar
interface
subroutine mysub(x)
integer :: x
end subroutine
end interface
call mysub(bar)
end subroutine
Now I want the routine to be optional
subroutine foo(bar, mysub)
integer, intent(in) :: bar
interface
subroutine mysub(x)
integer :: x
end subroutine
end interface
optional :: mysub
call mysub(bar)
end subroutine
Now, if mysub were a standard variable var I could do something like
if (present(var)) then
l_var = var
else
l_var = <default value>
endif
but as far as I know, I cannot perform the same for an optional subroutine. In practice this is not possible
subroutine foo(bar, mysub)
integer, intent(in) :: bar
interface
subroutine mysub(x)
integer :: x
end subroutine
end interface
optional :: mysub
if (present(mysub)) then
l_mysub = mysub
else
l_mysub = default
endif
call mysub(bar)
end subroutine
because you cannot declare l_mysub. Is it possible through some trick I am not aware of ? Yes, of course I can do
if (present(mysub)) then
call mysub(bar)
else
call default(bar)
endif
but my case is more complex and I would have to put this check everywhere. Consider that I have three optional subroutines I may pass.
My first thought was to use a procedure pointer, but then I noticed you specified fortran 90, so that's not an option.
How about making a wrapper subroutine for your original foo, which calls it with the given subroutine if it is specified, or else with default? Something like this (untested):
subroutine foo_wrap(bar, mysub)
integer, intent(in) :: bar
interface
subroutine mysub(x)
integer :: x
end subroutine mysub
end interface
optional :: mysub
if (present(mysub)) then
call foo(bar, mysub)
else
call foo(bar, default)
endif
end subroutine foo_wrap
With multiple optional subroutines it might become a little complex, but not impossible, I think.
Related
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
I have a few array variables in a module that are dynamic, and later allocated in one of two subroutines outside of the module. However, in one subroutine I want the array to be 1D, in the other subroutine I want it to be 2D.
In principle I would want something like this in the module, but I don't believe this is possible in the declaration area?:
if (option1) then
real (kind=8), allocatable :: arr1(:)
else
real (kind=8), allocatable :: arr1(:,:)
endif
Is there a way in the allocatable declarations to have the dimension be dynamic?
Edit1: The reason I'm doing this is I'm adding a new subroutine to an existing codebase, but I want to be backwards compatible. arr1 is only used by the two separate subroutines, the main program doesn't use it at all. Here is some more complete code showing the idea:
program myprog
use inputs
call read_inputs
if (option1) then
call do1
else
call do2
endif
contains
subroutine read_inputs
use inputs
use mymod
!!!read from file .logical. option1, integers N1, N2
!allocate arrays
if (option1) then
else
endif
end subroutine read_inputs
subroutine do1
use inputs
use mymod
allocate(arr1(N1))
!do stuff with arr1
end subroutine do1
subroutine do2
use inputs
use mymod
allocate(arr1(N1,N2))
!do stuff with arr1
end subroutine do2
end program
module inputs
logical :: option1
integer :: N1, N2
end module inputs
module mymod
use inputs
!!!!can I do something here to make the rank of arr1 dynamic? I don't think the following will work
if (option1)
real (kind=8), allocatable :: arr1(:)
else
real (kind=8), allocatable :: arr1(:,:)
endif
end module mymod
I may just have two separate variable in mymod, arr1 and arr1_new. I was just hoping to avoid that.
I think the 'olden' ways to do something like this is to pass the first element instead of the whole array and the size of the array separately:
program dyn_array
implicit none
integer :: a(2, 3)
integer :: i
call set1d(a(1,1), size(a))
do i = 1, 3
write(*, '(2I4)') a(:,i)
end do
contains
subroutine set1d(array, s)
implicit none
integer, intent(in) :: s
integer, intent(out) :: array(s)
integer :: i
do i = 1, s
array(i) = 3 * i
end do
end subroutine set1d
end program dyn_array
"Can you pass a 2D array into a subroutine that expects a 1D array and get the right size?"
You can use reshape, but if you code is relying on the compiler to help then a 2D into a 1D is dicey. You could use RESHAPE before and after... Or you can have 2 routines, which we can call set1d and set2d.
Then in the module you can have it choose what one you want to use. You could have integer(s), float(s), complex(s), byte.
You would CALL Array$Set(Array,s)
MODULE Stuff
PUBLIC :: Array$Set
PRIVATE
INTERFACE Array$Set
MODULE PROCEDURE Set1d_Float, Set1D_Double, set2D_Float, Set2D_Double
END INTERFACE Array$Set
CONTAINS
SUBROUTINE Set1D_Float(Array,S)...
!$DIR ATRIBUTES ASUUME_ALIGND:64 :: Array
REAL, DIMENSION(:,:), CONTIGUOUS, INTENT(INOUT) :: Array
REAL, DIMENSION(:,:), INTENT(IN ) :: S
REAL, DIMENSION(2) :: Shapez
...
Shapez = Shape(Array)
DO I = 1, Shapez(1)
DO J = 1, Shapez(2)
...
END SUBROUTINE Set1D_Float
END MODULE Stuff
For your example:
if (option1) then
real (kind=8), allocatable :: arr1(:)
else
real (kind=8), allocatable :: arr1(:,:)
endif
I would suggest this:
!DIR ATTRIBUTES ALIGN:64 :: Arr1
REAL, DIMENSION(:), ALLOCATABLE :: Arr1
...
if (option1) then
ALLOCATE(Arr1(<#>))
else
ALLOCATE(Arr1(<#>*<#2>))
RESHAPE(Arr1, SHAPE=/(#1,#2)) !Check the syntax
endif
CALL Array$Set(Arr1,s) !It'll find the right one...
!... at the bottom ...
IF(ALLOCATED(Arr1)) DEALLOCATE(Arr1)
END PROGRAM
I have a code that looks like
subroutine sub1(f)
interface
function f(x)
(description of f)
end function f
end interface
(do something with f)
end subroutine sub1
subroutine sub2(f)
interface
function f(x)
(description of f)
end function f
end interface
(do something with f)
end subroutine sub2
However, the two subroutines sub1 and sub2 both use identical interfaces for the dummy function f. How do I make these two procedures share the same interface (e.g. using a module)? Do I have to use procedure pointers?
You can define such reusable "function types" as abstract interfaces in modules:
module m
implicit none
abstract interface
function der(x,y) result(yDot)
real, intent(in) :: x, y
real :: yDot
end function
end interface
end module
subroutine integrateEuler(derY,x0,xf,y)
use m
real, intent(in) :: x0, xf
real, intent(inout) :: y
procedure(der) :: derY
! code here
end subroutine
subroutine integrateRKF45(derY,x0,xf,y)
use m
real, intent(in) :: x0, xf
real, intent(inout) :: y
procedure(der) :: derY
! code here
end subroutine
Using function pointers is not necessary, but you can declare them in the same way: procedure(der), pointer :: funPtr => myFun
I want to pass a type bound procedures (as an external function) to another function as follows:
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 produces gives this error :
write(*,*) s(t%f)
1
Error: Expected argument list at (1)
But what I can do is:
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
I think the problem is related to Passing type bound procedures as arguments, but I don't see at the moment how the answers there can help me.
EDIT:
A better example which (hopefully) shows the difficulty:
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
EDIT II:
Ok, the wrappers still work in combination with a pointer:
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
This is certainly not a beautiful solution but at least it works.
You can write a wrapper. This is the most straightforward version. Requires passing internal function as a dummy argument (F2008), but you could declare the wrapper in a module too, if the t can bee there.
Note I changed the declaration of the procedure argument in s to something more modern - the interface block.
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
The reason for your error is well described in the answers to the linked question, you cannot pass type bound procedures the way you tried.
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