Pointers in pure functions - fortran

In order to traverse a linked list in Fortran, I use a pointer to the current element that is moved to the next one inside a loop. Trying to apply this inside a pure function that operates on said linked list results in an error.
Example:
module list
implicit none
! Node
type n_list
integer :: val
type(n_list),pointer :: next => NULL()
end type
! Linked list
type t_list
type(n_list),pointer :: head
end type
contains
pure function in_list( list, val ) result(res)
implicit none
class(t_list),intent(in) :: list
integer,intent(in) :: val
logical :: res
type(n_list),pointer :: cur
res = .true.
! Traverse the list
cur => list%head
do while ( associated(cur) )
if ( cur%val == val ) return
cur => cur%next
enddo
! Not found
res = .false.
end function
end module
Results in
cur => list%head
1
Error: Bad target in pointer assignment in PURE procedure at (1)
I am aware of the rationale behind the error/warning, and that it is difficult to ensure that the arguments of the function are not changed when using pointers (Fortran 2008, ch. 12.7 "Pure procedures", esp. C1283). In this case, though, list is never changed.
Is it possible to tell the compiler (ifort and gfortran) that intent(in) is not violated?

The relevant part of the constraint you come up against (C12831) is
In a pure subprogram any designator with a base object that is .. a dummy argument with the INTENT (IN) attribute .. shall not be used
..
as the data-target in a pointer-assignment-stmt
The note below that constraint description motivates it
The above constraints are designed to guarantee that a pure procedure is free from side effects
What you want to say is "I guarantee that there are no side effects, we don't need the constraints for that". The constraints are sufficient but not necessary for this guarantee and you can analyse your code well.
However, a conforming processor/compiler must be able to detect breaches of constraints not just the overall goal of the constraints, so you don't just need to say "it's pure really", but also "and I don't need to be told of violations of C1283". That seems like a lot of effort for the compiler vendor to go to for very little benefit.
I guess, then, that the answer is "no": there isn't a way to compile your code. This isn't definitive, as we're really into implementation-specific areas. You asked about gfortran and ifort in particular, so a "use -nocheck c1283" refutes my "answer".
Now, if there is an option you're in the realms of "trust me" (and non-standard Fortran). So, let's go there anyway. It's just that we're going to lie. As usual, interface blocks will be our means.
module list_mod
implicit none
! Node
type n_list
integer :: val
type(n_list),pointer :: next => NULL()
end type
! Linked list
type t_list
type(n_list),pointer :: head
end type
interface
pure logical function in_list(list, val)
import t_list
class(t_list), intent(in) :: list
integer, intent(in) :: val
end function
end interface
end module
! Interface mismatch in the external function
function in_list(list, val) result(res)
use list_mod, only : t_list, n_list
implicit none
class(t_list),intent(in) :: list
integer,intent(in) :: val
logical :: res
type(n_list),pointer :: cur
res = .true.
! Traverse the list
cur => list%head
do while ( associated(cur) )
if ( cur%val == val ) return
cur => cur%next
enddo
! Not found
res = .false.
end function
use list_mod
type(t_list) testlist
type(n_list), pointer :: ptr
integer i
logical :: res(5) = .FALSE.
allocate(testlist%head)
ptr => testlist%head
do i=1,5
allocate(ptr%next)
ptr => ptr%next
ptr%val = i
end do
! in_list is pure, isn't it?
forall(i=1:5:2) res(i)=in_list(testlist,i)
print*, res
end
This is pure nastiness and is limiting: you no longer have a module procedure; you're not standard conforming; the compiler may be clever and check interfaces (even though it needn't). If the compiler hates you as a result you have only yourself to blame.
Finally, it's all rather a lot of effort to get the procedure pure.
1 This is in Fortran 2008 corresponding to the language revision at the time of asking. In Fortran 2018 the corresponding constraint is C1594.

I have found a solution using recursive functions that is at least Standard conforming. It is neither elegant nor fast, and is limited be the stack depth, but it is working. I'll post it as an answer, although I hope some-one has a better solution...
module list
implicit none
! Node
type n_list
integer :: val
type(n_list),pointer :: next => NULL()
end type
! Linked list
type t_list
type(n_list),pointer :: head
end type
contains
pure function in_list( list, val ) result(res)
implicit none
class(t_list),intent(in) :: list
integer,intent(in) :: val
logical :: res
if ( associated(list%head) ) then
res = in_list_node( list%head, val )
else
res = .false.
endif
end function
recursive pure function in_list_node( node, val ) result(res)
implicit none
class(n_list),intent(in) :: node
integer,intent(in) :: val
logical :: res
if ( node%val == val ) then
res = .true.
elseif ( associated(node%next) ) then
! Recurse
res = in_list_node( node%next, val )
else
res = .false.
endif
end function
end module
program test
use list
implicit none
integer,parameter :: MAXELEM = 100000
integer :: i
type(t_list) :: lst
type(n_list),pointer :: cur
! Fill list
lst%head => NULL()
allocate( lst%head )
lst%head%val = 1
cur => lst%head
do i=2,MAXELEM
allocate( cur%next )
cur%next%val = i
cur => cur%next
enddo !i
print *,'is MAXELEM/2 in list? ', in_list( lst, MAXELEM/2 )
print *,'is MAXELEM+1 in list? ', in_list( lst, MAXELEM+1 )
end program

OK, I found a solution using the transfer intrinsic. The main idea is to clone the list struct (without the data, I checked), and use the pointer to the first node (unchanged) as a start value. Yeah, it is a loop-hole, but both ifort and gfortran accept this without warnings.
module list_mod
implicit none
! Node
type n_list
integer :: val
type(n_list),pointer :: next => NULL()
end type
! Linked list
type t_list
type(n_list),pointer :: head
end type
contains
pure function getHead(list) result(res)
implicit none
class(t_list),intent(in) :: list
type(n_list),pointer :: res
type(t_list),pointer :: listPtr
! Create a copy of pointer to the list struct
allocate( listPtr )
listPtr = transfer( list, listPtr )
! Set the pointer
res => listPtr%head
! Free memory
deallocate( listPtr )
end function
pure function in_list( list, val ) result(res)
implicit none
class(t_list),intent(in) :: list
integer,intent(in) :: val
logical :: res
type(n_list),pointer :: cur
res = .true.
! Traverse the list
cur => getHead(list)
do while ( associated(cur) )
if ( cur%val == val ) return
cur => cur%next
enddo
! Not found
res = .false.
end function
end module
program test
use list_mod
implicit none
integer,parameter :: MAXELEM = 10000000
integer :: i
type(t_list) :: list
type(n_list),pointer :: cur
! Fill list
list%head => NULL()
allocate( list%head )
list%head%val = 1
cur => list%head
do i=2,MAXELEM
allocate( cur%next )
cur%next%val = i
cur => cur%next
enddo !i
print *,'is MAXELEM/2 in list? ', in_list( list, MAXELEM/2 )
print *,'is MAXELEM+1 in list? ', in_list( list, MAXELEM+1 )
end program

Related

Errors #6259, #7715, #6355, #6303 in defining Derived Type specific assignment/operator procedures

First of all, Hi to everyone ! Wish you all a good starting week :)
In enhancing (as well as simplifying some syntax) a previously developed Derived Type, I was (and some still) encountering some errors as in the title specification (NOTE: for details about full messages and their cause, please read the comment lines in the code below :) ).
Among them, the ones I was not understand the most (of the why I am getting them) are error #6355: This binary operation is invalid for this data type. for the operator(==), and error #6303: The assignment operation or the binary expression operation is invalid for the data types of the two operands. for the assignment(=).
Here is an example of source code (NOTE: in order to reproduce those errors, comment out the type-bound procedure part, and uncomment out the two interface bodies):
module MPolicyMod
implicit none
private
public :: MPolicy
type, public :: MPolicy_t
real(kind = 8) :: delta_fI_fct_
real(kind = 8) :: delta_fJ_fct_
real(kind = 8) :: interp_I_fct_
real(kind = 8) :: interp_J_fct_
integer :: id_pol_
contains
generic :: assignment(=) => MPolicy_fromPol_sub, MPolicy_fromID_sub
procedure, private, pass :: MPolicy_fromID_sub, MPolicy_fromPol_sub
generic :: operator(==) => MPolicy_isID
procedure, pass, private :: MPolicy_isID
end type MPolicy_t
integer, public, parameter :: MPolicy_NULL = 0
integer, public, parameter :: MPolicy_DEF = 1
integer, public, parameter :: MPolicy_CONST = 2
interface MPolicy_t
module procedure MPolicy_constructor_integer
module procedure MPolicy_constructor_real
module procedure MPolicy_fromID
end interface
! interface assignment(=)
! module procedure MPolicy_fromPol_sub
! module procedure MPolicy_fromID_sub
! end interface assignment(=)
! interface operator(==)
! module procedure MPolicy_isID
! end interface operator(==)
contains
!> Main default constructor.
function MPolicy_constructor_real(dfi, dfj, interpi, interpj, id) result(pol)
real(kind = 8), intent(in) :: dfi, dfj, interpi, interpj
integer, intent(in) :: id
type(MPolicy_t) :: pol
print *, ' Default constructor (as compiler)...'
pol%delta_fI_fct_ = dfi
pol%delta_fJ_fct_ = dfj
pol%interp_I_fct_ = interpi
pol%interp_J_fct_ = interpj
pol%id_pol_ = id
end function MPolicy_constructor_real
function MPolicy_constructor_integer(dfi, dfj, interpi, interpj, id) result(pol)
integer, intent(in) :: dfi, dfj, interpi, interpj, id
type(MPolicy_t) :: pol
print *, ' Default constructor (integer version)...'
pol = MPolicy_t(real(dfi, 8), &
real(dfj, 8), &
real(interpi, 8), &
real(interpj, 8), id)
end function
function MPolicy_fromID(id) result(pol)
integer, intent(in) :: id
type(MPolicy_t) :: pol
print *, ' Constructor from ID...'
select case (id)
case (MPolicy_NULL)
return
case (MPolicy_DEF)
pol = MPolicy_t(2, 2, 2, 2, MPolicy_DEF)
case (MPolicy_CONST)
pol = MPolicy_t(1, 1, 1, 1, MPolicy_CONST)
case default
block
character(len=3) :: fmt
write(fmt, '(i)'), id
stop ' [ERROR] Unknow policy identifier "id"= '//fmt
end block
end select
end function MPolicy_fromID
subroutine MPolicy_fromPol_sub(lhs, rhs)
class(MPolicy_t), intent(in) :: rhs
class(MPolicy_t), intent(out) :: lhs
lhs%delta_fI_fct_ = rhs%delta_fI_fct_
lhs%delta_fJ_fct_ = rhs%delta_fJ_fct_
lhs%interp_I_fct_ = rhs%interp_I_fct_
lhs%interp_J_fct_ = rhs%interp_J_fct_
lhs%id_pol_ = rhs%id_pol_
end subroutine MPolicy_fromPol_sub
subroutine MPolicy_fromID_sub(lhs, rhs)
class(MPolicy_t), intent(out) :: lhs
integer, intent(in) :: rhs
lhs = MPolicy_t(rhs)
end subroutine MPolicy_fromID_sub
function MPolicy(mpol) result(pol)
integer :: mpol
type(MPolicy_t) :: pol
pol = MPolicy_t(mpol)
end function MPolicy
pure function MPolicy_isID(pol, id) result(isID)
class(MPolicy_t), intent(in) :: pol
integer, intent(in) :: id
logical :: isID
isID = pol%id_pol_ == id
end function MPolicy_isID
end module
Example program:
program test
use MPolicyMod
implicit none
! ! NOTE: generates
! ! error #6259: This array or function or substring is invalid in constant expressions. [MPOLICYMOD^MPOLICY_FROMID]
! ! error #7715: Replacing invalid structure constructor by integer 1. [<NULL_STRING>]
! type(MPolicy_t) :: pol = MPolicy_t(MPolicy_NULL)
type(MPolicy_t) :: pol
! =========================================================================
print *, pol
pol = MPolicy_t(MPolicy_NULL)
print *, pol
! ! NOTE: generates (without TYPE-BOUND specification)
! ! error #6355: This binary operation is invalid for this data type.
print *, pol == MPolicy_NULL
pol = MPolicy_t(1, 1, 1, 1, 2)
print *, pol
! ! NOTE: generates (without TYPE-BOUND specification)
! ! error #6303: The assignment operation or the binary expression operation is invalid for the data types of the two operands.
pol = MPolicy_DEF
print *, pol
end program test
Then, after reading through the ISO Fortran Standard 2003 Draft document, at Section 4.5.4 Type-bound procedures, Rule R452 states that we could specify assignment(=) as a generic-spec, in a generic-binding type of proc-binding-stmt. There I realised I was missing the type-bound specifications for those operator/assignment procedures.
Why, then, only the interface body was not enough to make it work?
After this, I also wonder why the initialisation statement type(MPolicy_t) :: pol = MPolicy_t(MPolicy_NULL) generates errors #6259 and #7715.
For that, I still didn't search by my own. But if you come with an asnwer before I might find (hopefully) an explanation, it's always good to have constructive as well as polite discussions with You all.
I now go back to my searching. Have a nice day :)

How to count unique elements in a vector?

I have a very large vector in which I want to add the total number of elements as a condition that repeat numbers do not characterize a new element, for example:
V=[0,5,1,8,9,1,1,]
My desired answer would be:5
But I can't think of a way to do that because with the count function I would have to know all the elements of my vector.
count function not works in this case
FWIW, here's a solution using a tree. No attempt to balance it.
module treemodule
implicit none
private
public numDistinct
type Node
integer value
type(Node), pointer :: left => null(), right => null()
end type node
type, public :: Tree
private
type(Node), pointer :: root => null()
integer :: size = 0
contains
procedure insert
procedure clear
procedure print
procedure getsize
procedure, private :: insertNode
procedure, private :: deleteNode
procedure, private :: printNode
end type Tree
contains
integer function numDistinct( A )
integer, intent(in) :: A(:)
integer i
type(Tree) T
numDistinct = 3
do i = 1, size( A )
call T%insert( A(i) )
end do
numDistinct = T%getsize()
! Comment out the following if you don't need it ...
write( *, "(A)", advance="no" ) "Distinct elements: "; call T%print; write( *, * )
call T%clear
end function numDistinct
integer function getsize( this )
class(Tree) this
getsize = this%size
end function getsize
subroutine insert( this, value )
class(Tree) this
integer, intent(in) :: value
call this%insertNode( this%root, value )
end subroutine insert
subroutine print( this )
class(Tree) this
call this%printNode( this%root )
end subroutine print
subroutine clear( this )
class(Tree) this
call this%deleteNode( this%root )
end subroutine clear
recursive subroutine insertNode( this, ptr, value )
class(Tree) this
type(Node), pointer, intent(inout) :: ptr
integer value
if ( associated( ptr ) ) then
if ( value < ptr%value ) then
call this%insertNode( ptr%left, value )
else if ( value > ptr%value ) then
call this%insertNode( ptr%right, value )
end if
else
allocate( ptr, source=Node(value) )
this%size = this%size + 1
end if
end subroutine insertNode
recursive subroutine deleteNode( this, ptr )
class(Tree) this
type(Node), pointer, intent(inout) :: ptr
if ( associated( ptr ) ) then
call this%deleteNode( ptr%left )
call this%deleteNode( ptr%right )
deallocate( ptr )
this%size = this%size - 1
end if
end subroutine deleteNode
recursive subroutine printNode( this, ptr )
class(Tree) this
type(Node), pointer, intent(in) :: ptr
if ( associated( ptr ) ) then
call this%printNode( ptr%left )
write ( *, "( i0, 1x )", advance="no" ) ptr%value
call this%printNode( ptr%right )
end if
end subroutine printNode
end module treemodule
!=======================================================================
program main
use treemodule
implicit none
integer, allocatable :: A(:)
integer C
A = [ 0, 5, 1, 8, 9, 1, 1 ]
C = numDistinct( A )
write( *, "( 'Number of distinct elements = ', i0 )" ) C
end program main
Distinct elements: 0 1 5 8 9
Number of distinct elements = 5
If you don't care about memory and performances (otherwise there are more efficient codes in the link given by Francescalus):
integer function count_unique(x) result(n)
implicit none
integer, intent(in) :: x(:)
integer, allocatable :: y(:)
y = x(:)
n = 0
do while (size(y) > 0)
n = n+1
y = pack(y,mask=(y(:) /= y(1)) ! drops all elements that are
! equals to the 1st one (included)
end do
end function count_unique

Ambiguous reference to function error when compiling

So I have a fortran .f90 file (part of the Monte-Carlo tool called SWEEP) that basically contains two main modules for the implementation of a variable length list using two types. The two modules are as follows:
Module LIST_DP_T
Implicit None
Public
Type LIST_DP
Integer :: Count = 0
Double Precision, Pointer :: Items(:)
End Type
Interface Assignment(=)
Module Procedure SetP
End Interface
Interface Operator(+)
Module Procedure Add
Module Procedure AddItem
Module Procedure AddItems
End Interface
Contains
! -------------------------------------------------------
Subroutine Destroy(list)
! DESCRIPTION
! Clears memory associated with a list type.
! ARGUMENTS.
Type(LIST_DP), Intent(INOUT) :: list
! VARIABLES.
Integer :: err = 0
! EXECUTABLE CODE.
list%Count = 0
Deallocate(list%Items, STAT=err)
Nullify(list%Items)
End Subroutine
! -------------------------------------------------------
Subroutine SetP(new, old)
! DESCRIPTION
! Assigns the list of one list type to another
! by passing the list pointer.
! ARGUMENTS.
Type(LIST_DP), Intent(INOUT) :: new
Type(LIST_DP), Intent(IN) :: old
! EXECUTABLE CODE.
new%Count = old%Count
new%Items => old%Items
End Subroutine
! -------------------------------------------------------
Subroutine Copy(new, old)
! DESCRIPTION
! Copies the list of one list type to another.
! ARGUMENTS.
Type(LIST_DP), Intent(INOUT) :: new
Type(LIST_DP), Intent(IN) :: old
! EXECUTABLE CODE.
new%Count = old%Count
new%Items = old%Items
End Subroutine
! -------------------------------------------------------
Function Add(list1, list2) Result (sumlist)
! DESCRIPTION
! Adds together two list and
! returns a new list.
! ARGUMENTS.
Type(LIST_DP), Intent(IN) :: list1
Type(LIST_DP), Intent(IN) :: list2
Type(LIST_DP) :: sumlist
! VARIABLES.
Integer :: err = 0
Double Precision :: items(list1%Count+list2%Count)
! EXECUTABLE CODE.
! Save current list.
If (list1%Count > 0) items(1:list1%Count) = list1%Items
If (list2%Count > 0) items(list1%Count+1:) = list2%Items
! Resize list.
Deallocate(sumlist%Items, STAT=err)
sumlist%Count = list1%Count + list2%Count
Allocate(sumlist%Items(sumlist%Count), STAT=err)
! Assign back the list.
sumlist%Items = items
End Function
! -------------------------------------------------------
Function AddItem(list, item) Result (newlist)
! DESCRIPTION
! Adds a number to the end of the list and
! returns a new list.
! ARGUMENTS.
Type(LIST_DP), Intent(IN) :: list
Double Precision, Intent(IN) :: item
Type(LIST_DP) :: newlist
! VARIABLES.
Integer :: err = 0
Double Precision :: items(list%Count+1)
! EXECUTABLE CODE.
! Save current list.
If (list%Count > 0) items(1:list%Count) = list%Items
items(list%Count+1) = item
! Resize list.
Deallocate(newlist%Items, STAT=err)
newlist%Count = list%Count + 1
Allocate(newlist%Items(newlist%Count), STAT=err)
! Assign back the list.
newlist%Items = items
End Function
! -------------------------------------------------------
Function AddItems(list, items) Result (newlist)
! DESCRIPTION
! Adds some numbers to the end of the list and
! returns a new list.
! ARGUMENTS.
Type(LIST_DP), Intent(IN) :: list
Double Precision, Intent(IN) :: items(:)
Type(LIST_DP) :: newlist
! VARIABLES.
Integer :: err = 0
Double Precision :: allitems(list%Count+Size(items))
! EXECUTABLE CODE.
! Save current list.
If (list%Count > 0) allitems(1:list%Count) = list%Items
allitems(list%Count+1:) = items
! Resize list.
Deallocate(newlist%Items, STAT=err)
newlist%Count = list%Count + Size(items)
Allocate(newlist%Items(newlist%Count), STAT=err)
! Assign back the list.
newlist%Items = allitems
End Function
! -------------------------------------------------------
Double Precision Function SumList(list)
! DESCRIPTION
! Returns the sum of the list items.
Type(LIST_DP), Intent(IN) :: list
SumList = Sum(list%Items)
End Function
End Module
and the other module which is for an integer list:
Module LIST_INT_T
Implicit None
Public
Type LIST_INT
Integer :: Count = 0
Integer, Pointer :: Items(:)
End Type
Interface Assignment(=)
Module Procedure SetP
End Interface
Interface Operator(+)
Module Procedure Add
Module Procedure AddItem
Module Procedure AddItems
End Interface
Contains
! -------------------------------------------------------
Subroutine Destroy(list)
! DESCRIPTION
! Clears memory associated with a list type.
! ARGUMENTS.
Type(LIST_INT), Intent(INOUT) :: list
! VARIABLES.
Integer :: err = 0
! EXECUTABLE CODE.
list%Count = 0
Deallocate(list%Items, STAT=err)
Nullify(list%Items)
End Subroutine
! -------------------------------------------------------
Subroutine SetP(new, old)
! DESCRIPTION
! Assigns the list of one list type to another
! by passing the list pointer.
! ARGUMENTS.
Type(LIST_INT), Intent(INOUT) :: new
Type(LIST_INT), Intent(IN) :: old
! EXECUTABLE CODE.
new%Count = old%Count
new%Items => old%Items
End Subroutine
! -------------------------------------------------------
Subroutine Copy(new, old)
! DESCRIPTION
! Copies the list of one list type to another.
! ARGUMENTS.
Type(LIST_INT), Intent(INOUT) :: new
Type(LIST_INT), Intent(IN) :: old
! EXECUTABLE CODE.
new%Count = old%Count
new%Items = old%Items
End Subroutine
! -------------------------------------------------------
Function Add(list1, list2) Result (sumlist)
! DESCRIPTION
! Adds together two list and
! returns a new list.
! ARGUMENTS.
Type(LIST_INT), Intent(IN) :: list1
Type(LIST_INT), Intent(IN) :: list2
Type(LIST_INT) :: sumlist
! VARIABLES.
Integer :: err = 0
Integer :: items(list1%Count+list2%Count)
! EXECUTABLE CODE.
! Save current list.
If (list1%Count > 0) items(1:list1%Count) = list1%Items
If (list2%Count > 0) items(list1%Count+1:) = list2%Items
! Resize list.
Deallocate(sumlist%Items, STAT=err)
sumlist%Count = list1%Count + list2%Count
Allocate(sumlist%Items(sumlist%Count), STAT=err)
! Assign back the list.
sumlist%Items = items
End Function
! -------------------------------------------------------
Function AddItem(list, item) Result (newlist)
! DESCRIPTION
! Adds a number to the end of the list and
! returns a new list.
! ARGUMENTS.
Type(LIST_INT), Intent(IN) :: list
Integer, Intent(IN) :: item
Type(LIST_INT) :: newlist
! VARIABLES.
Integer :: err = 0
Integer :: items(list%Count+1)
! EXECUTABLE CODE.
! Save current list.
If (list%Count > 0) items(1:list%Count) = list%Items
items(list%Count+1) = item
! Resize list.
Deallocate(newlist%Items, STAT=err)
newlist%Count = list%Count + 1
Allocate(newlist%Items(newlist%Count), STAT=err)
! Assign back the list.
newlist%Items = items
End Function
! -------------------------------------------------------
Function AddItems(list, items) Result (newlist)
! DESCRIPTION
! Adds some numbers to the end of the list and
! returns a new list.
! ARGUMENTS.
Type(LIST_INT), Intent(IN) :: list
Integer, Intent(IN) :: items(:)
Type(LIST_INT) :: newlist
! VARIABLES.
Integer :: err = 0
Integer :: allitems(list%Count+Size(items))
! EXECUTABLE CODE.
! Save current list.
If (list%Count > 0) allitems(1:list%Count) = list%Items
allitems(list%Count+1:) = items
! Resize list.
Deallocate(newlist%Items, STAT=err)
newlist%Count = list%Count + Size(items)
Allocate(newlist%Items(newlist%Count), STAT=err)
! Assign back the list.
newlist%Items = allitems
End Function
! -------------------------------------------------------
Integer Function SumList(list)
! DESCRIPTION
! Returns the sum of the list items.
Type(LIST_INT), Intent(IN) :: list
SumList = Sum(list%Items)
End Function
End Module
and a third module to make things easier when using the modules:
Module LIST_T
Use LIST_DP_T
Use LIST_INT_T
Implicit None
Public
End Module
The module LIST_T is then called from in a different module called Profile_Driver_Input located a different .f90 file (profile_driver_input.f90) as follows:
Module Profile_Driver_Input
Use LIST_T
Use Sweep
Implicit None
Public
Integer, Parameter :: UIN = 102
Integer, Parameter :: MAX_POINTS=1000, MAX_VARS=200
Type Settings
! Control parameters.
Logical :: Solve=.True., PostProcess=.True.
! Input files.
Character(LEN=200) :: MechFile="" ! Particle mechanism file name.
Character(LEN=200) :: ChemFile="" ! Chemistry profile file name.
! Time stepping variables.
Type(LIST_DP) :: Times ! Times between PSL outputs (first entry is start time).
Type(LIST_INT) :: Steps ! Steps between output times.
....
The code then continues to declare more variables and subroutines.
Upon compilation, the following error appears at the end of the Profile_Driver_Input module:
Error: Name 'additem' at (1) is an ambiguous reference to 'additem' from module 'list_dp_t'
Error: Name 'setp' at (1) is an ambiguous reference to 'setp' from module 'list_dp_t'
Error: Name 'setp' at (1) is an ambiguous reference to 'setp' from module 'list_dp_t'
Error: Name 'additem' at (1) is an ambiguous reference to 'additem' from module 'list_dp_t'
Error: Name 'setp' at (1) is an ambiguous reference to 'setp' from module 'list_dp_t'
Error: Name 'setp' at (1) is an ambiguous reference to 'setp' from module 'list_dp_t'
Error: Name 'additem' at (1) is an ambiguous reference to 'additem' from module 'list_dp_t'
Error: Name 'setp' at (1) is an ambiguous reference to 'setp' from module 'list_dp_t'
I cannot seem to figure out how to resolve this issue. Any help/advice would be appreciated.
You have multiple symbols that are named the same way. They come from different modules, but it is still a problem. For example, a subroutine named additem exists in both modules you show.
If you do not actually need to call the subroutines themselves and you only want to call the overloaded operators (+) and assignments (=), you can change the default accessibility from public to private inside the module and only leave public what actually needs to be accessible.
If both additem and destroy and other subroutines will need to be accessible from both modules at the same time, you will have to rename them to be unique. For example: additem_list_int and additem_list_dp.

How to choose a desired code for a Subroutine among various options during the start of a run

Let's say I want to perform an operation in my main program (in Fortran). And lets say that operation is finding minimum number in a 1D array. I wish to do so by passing the array into the call subroutine and the subroutine will print the minimum value on the screen. There are different ways or algorithms to find minimum value in an array. Lets say I have 100 different methods: Method1, Method2..... Method100. Now I want to try using each one of these methods separately (I don't want to try all of them at once, but one method in each run). I don't want to create 100 different subroutines and change the code every time to decide which one to call, rather I want to mention in the input file which one I want to choose. So basically, the computer has to read the input file (to know which method to use) and perform the task using the specified method amongst different methods available.
I can write a Subroutine dump all the methods into that subroutine and put an IF condition to choose among various methods. But IF conditions are in efficient particularly on GPUs, I want to know the most efficient way of doing this.
MAIN PROGRAM
INTEGER Method !will be read from input file
Array = [12,5,3,4,1,7,4,3]
call print_Minimum(Array)
END PROGRAM
SUBROUTINE print_Minimum(Array)
IF (METHOD == 1)
<method 1 code>
ELSE IF (METHOD == 2)
<method 2 code>
:
:
:
:
ELSE IF (METHOD == 100)
<method100 code>
END IF
END SUBROUTINE
Thanks in advance.
This is probably best done using a function pointer and/or functions as arguments.
You can set a function pointer to a certain function and do this in your nested ifs and you can pass functions as arguments.
Both methods are implemented in the following example.
module minimum_mod
implicit none
private
public :: get_min_t, naive_min, time_min_function
abstract interface
integer pure function get_min_t(X)
integer, intent(in) :: X(:)
end function
end interface
contains
subroutine time_min_function(f, X)
procedure(get_min_t) :: f
integer, intent(in) :: X(:)
integer :: res
res = f(X)
write(*, *) res
end subroutine
integer pure function naive_min(X)
integer, intent(in) :: X(:)
integer :: i
naive_min = huge(naive_min)
do i = 1, size(X)
naive_min = min(naive_min, X(i))
end do
end function
end module
program time_min_finders
use minimum_mod, only: get_min_t, naive_min, time_min_function
implicit none
integer, parameter :: test_set(5) = [1, 10, 3, 5, 7]
procedure(get_min_t), pointer :: f
f => naive_min
call time_min_function(f, test_set)
end program
PS: Note that you can now do all the timinig logic inside time_min_function.
You can create an array of a derived type that contains a function pointer, effectively an array of function pointers. Then in principle you could initialize the function pointers to point at all of your test functions so that you could refer to each function by its index without having to test with a SELECT CASE of IF block: this is the typical Fortran way. However, either I've got the syntax for initialization wrong or my old version of gfortran just isn't capable, so I had to initialize one at a time. Sigh.
module minfuncs
implicit none
abstract interface
function func(array)
integer, intent(in) :: array(:)
integer func
end function func
end interface
type func_node
procedure(func), NOPASS, pointer :: f
end type func_node
! type(func_node) :: method(5) = [func_node(min_1),func_node(min_2), &
! func_node(min_3),func_node(min_4),func_node(min_5)]
contains
function min_1(array)
integer, intent(in) :: array(:)
integer min_1
integer i
min_1 = array(1)
do i = 2, size(array)
min_1 = min(min_1,array(i))
end do
end function min_1
function min_2(array)
integer, intent(in) :: array(:)
integer min_2
integer i
min_2 = array(1)
do i = 8, size(array), 7
min_2 = min(min_2,array(i-6),array(i-5),array(i-4), &
array(i-3),array(i-2),array(i-1),array(i))
end do
do i = i-6, size(array)
min_2 = min(min_2, array(i))
end do
end function min_2
function min_3(array)
integer, intent(in) :: array(:)
integer min_3
integer i
min_3 = array(1)
do i = 2, size(array)
min_3 = min_3-dim(min_3,array(i))
end do
end function min_3
function min_4(array)
integer, intent(in) :: array(:)
integer min_4
integer ymm(8)
integer i
if(size(array) >= 8) then
ymm = array(1:8)
do i = 16, size(array), 8
ymm = min(ymm,array(i-7:i))
end do
min_4 = minval([ymm,array(i-7:size(array))])
else
min_4 = minval(array)
end if
end function min_4
function min_5(array)
integer, intent(in) :: array(:)
integer min_5
min_5 = minval(array)
end function min_5
end module minfuncs
program test
use minfuncs
implicit none
integer, parameter :: N = 75
integer i
integer :: A(N) = modulo(5*[(i,i=1,N)]**2,163)
! type(func_node) :: method(5) = [func_node(min_1),func_node(min_2), &
! func_node(min_3),func_node(min_4),func_node(min_5)]
type(func_node) method(5)
method(1)%f => min_1
method(2)%f => min_2
method(3)%f => min_3
method(4)%f => min_4
method(5)%f => min_5
do i = 1, size(method)
write(*,*) method(i)%f(A)
end do
end program test
Output:
2
2
2
2
2

How can I do a swap between two elements belonging to the same polymorphic variable?

What is the best method when you need interchange the values in two polymorphic elements? (Using standard fortran 2008).
I'm sending an example (please try don't modify the type variables).
The problems that I have using intel compiler v.19 and gfortran 8.1 in windows are different.
Here a complete example. Look at the subroutine where I have defined the swap procedure. Currently is activate the version that works in GFortran but I have error with intel compiler. If you comment this part and uncomment the lines for ifort, then works for intel and not for gfortran....
Program Check
implicit none
!> Type definitions
Type :: Refl_Type
integer,dimension(:), allocatable :: H
integer :: Mult =0
End Type Refl_Type
Type :: RefList_Type
integer :: Nref
class(refl_Type), dimension(:), allocatable :: Reflections
end Type RefList_Type
Type(RefList_Type) :: List
Type(Refl_Type), dimension(3) :: Refl_Ini
!> Variables
integer :: i
!> Init
Refl_Ini(1)%H=[1, 0, 0]; Refl_Ini(1)%Mult=1
Refl_Ini(2)%H=[0, 2, 0]; Refl_Ini(2)%Mult=2
Refl_Ini(3)%H=[0, 0, 3]; Refl_Ini(3)%Mult=3
List%Nref=3
List%Reflections=Refl_Ini
!> Print Step:1
do i=1, List%Nref
print '(i3,2x,3i4,2x,i3)', i,List%Reflections(i)%H, List%Reflections(i)%Mult
end do
print*,' '
print*,' '
!> Swap
call Swap_Elements_List(List, 1, 3)
!> Print Step:2
do i=1, List%Nref
print '(i3,2x,3i4,2x,i3)', i,List%Reflections(i)%H, List%Reflections(i)%Mult
end do
Contains
Subroutine Swap_Elements_List(List, i, j)
!---- Argument ----!
type (RefList_Type), intent(in out) :: List
integer, intent(in) :: i,j
!---- Local Variables ----!
class(Refl_Type), allocatable :: tmp
!> IFort
!tmp=List%reflections(i)
!List%reflections(i)=List%reflections(j)
!List%reflections(j)=tmp
!> Gfortran
associate(t1 => list%reflections(i), t2 => list%reflections(j), tt => tmp)
tt=t1
t1=t2
t2=tt
end associate
End Subroutine Swap_Elements_List
End Program Check
Any suggestion?
Compiling the original code with gfortran-8.2 gives
test.f90:34:6:
List%reflections(i)=List%reflections(j) !!<---
1
Error: Nonallocatable variable must not be polymorphic in
intrinsic assignment at (1) - check that there is a
matching specific subroutine for '=' operator
I think this is because List % reflections(i) is not separately allocatable (even though List % reflections itself is allocatable as an array of uniform type). This point seems to be discussed in detail, e.g., in this Q/A page, which suggests two alternative approaches: (A) convince the compiler that all elements will be of the same type; or (B) use an (array) container.
If we use the "container" approach, I think we can use move_alloc() to swap two polymorphic objects (without knowing the dynamic type). For example, a bit modified version of the original code may be
program main
implicit none
type :: Refl_t
integer, allocatable :: H(:)
endtype
type, extends(Refl_t) :: ExtRefl_t
real :: foo
endtype
type :: RefList_t
class(Refl_t), allocatable :: refl
endtype
type(RefList_t) :: list( 3 )
call init()
print *, "Before:"
call output()
call swap( 1, 2 )
print *, "After:"
call output()
contains
subroutine swap( i, j )
integer, intent(in) :: i, j
class(Refl_t), allocatable :: tmp
call move_alloc( from= list( i )% refl, to= tmp )
call move_alloc( from= list( j )% refl, to= list( i )% refl )
call move_alloc( from= tmp, to= list( j )% refl )
end
subroutine init()
integer i
do i = 1, 3
allocate( ExtRefl_t :: list( i ) % refl )
select type( x => list( i ) % refl )
type is ( ExtRefl_t )
x % H = [ i, i * 10 ]
x % foo = i * 100
endselect
enddo
end
subroutine output()
integer i
do i = 1, 3
select type( x => list( i ) % refl )
type is ( ExtRefl_t )
print *, "i = ", i, " : H = ", x % H, " foo = ", x % foo
endselect
enddo
end
end program
Result (gfortran-8.2):
Before:
i = 1 : H = 1 10 foo = 100.000000
i = 2 : H = 2 20 foo = 200.000000
i = 3 : H = 3 30 foo = 300.000000
After:
i = 1 : H = 2 20 foo = 200.000000
i = 2 : H = 1 10 foo = 100.000000
i = 3 : H = 3 30 foo = 300.000000
I think we could also use polymorphic assignment for the above swap() routine, for example:
subroutine swap( i, j )
integer, intent(in) :: i, j
class(Refl_t), allocatable :: tmp
tmp = list( i ) % refl
list( i ) % refl = list( j ) % refl
list( j ) % refl = tmp
end
This compiles with gfortran-8.2, but gives a strange result... (a possible compiler bug?). I guess newer compilers like GCC-9 or Intel Fortran may give an expected result.
On the other hand, if we use a polymorphic array, we may need to use select type explicitly for swapping the two elements. (But I hope there is a different approach...) The code may then look like:
program main
implicit none
type :: Refl_t
integer, allocatable :: H(:)
endtype
type, extends(Refl_t) :: ExtRefl_t
real :: foo
endtype
class(Refl_t), allocatable :: refls( : )
allocate( ExtRefl_t :: refls( 3 ) )
call init()
print *, "Before:"
call output()
call swap( 1, 2 )
print *, "After:"
call output()
contains
subroutine swap( i, j )
integer, intent(in) :: i, j
selecttype ( refls )
type is ( ExtRefl_t )
block
type(ExtRefl_t) :: tmp
tmp = refls( i ) !<-- assignment of concrete type
refls( i ) = refls( j )
refls( j ) = tmp
endblock
class default
stop
endselect
end
subroutine init()
integer i
select type( refls )
type is ( ExtRefl_t )
do i = 1, 3
refls( i ) % H = [ i, i * 10 ]
refls( i ) % foo = i * 100
enddo
endselect
end
subroutine output()
integer i
select type( refls )
type is ( ExtRefl_t )
do i = 1, 3
print *, "i = ", i, " : H = ", refls( i ) % H, &
" foo = ", refls( i ) % foo
enddo
endselect
end
end program
(The result is the same as above.)
The answer by roygvib summarizes the problem well. If this assignment is to be performed in user's code where the types are known or are known to be from a small set of possible types, one can just protect the assignment by the select type typeguard.
The real problem happens in a generic code that is written without the knowledge of the user's derived types. Therefore it may have no access to possible user-defined assignments. I suggest a possible solution using a callback procedure. Basically, the user defines an assignment or swap procedure which is then called by the library code.
subroutine sub_that_needs_assignments(array, assign)
class(*) :: array
interface
subroutne assign(out, in)
end subroutine
end interface
call assign(array(i), array(i+1))
!or you can even assign a new elemnt from somewhere else
! possibly protect by same_type_as()
end subroutine
in the user's code
subroutine assign_my_type(out, in)
class(*), ... :: out
class(*), ... :: in
select type (out)
type is (my_type)
select type (in) ! not always necessary
type is (in)
out = in
end select
end select
!add appropriate error checking
end subroutine