Fortran Wiki
swap
Making a generic routine without built-in template support in Fortran
Fortran does not have explicit facilities for building generic templates (for creating generic routines without duplicating a lot of code).
INCLUDE files, the ISO_C_BINDING interface (to get to move_alloc, memcpy, and other C pointer functionality), source(), transfer(), and unlimited polymorphic entities (ie. “CLASS(*)”) are a poor substitute but can sometimes help.
INCLUDE files can be very useful for reducing duplicate code but have the disadvantage of breaking the code into seperate files. There is no Fortran feature to allow the common code to reside in a single file along with the parameterized code.
Note that CLASS(*) basically allows runtime type-safe but type-agnostic storage, put can sometimes be used to substitute as a compile-time type parameterisation mechanism.
Preprocessors such as m4(), cpp(), … can be very useful. An often overlooked but simple option is to write your code as “here” documents in the sh(1) or bash(1) shell. Combined with adding a make(1) rule for building “.sh” file suffixes this is a very flexible and readily available option.
Generic Interfaces
So you can hide the ugly details from the user with generic interfaces, but this requires a routine for each combination of parameter types. Even for the simple idea of swapping two variables of the same type (A very common operation in sorting algorithms) you can see a lot of duplicate code when building a generic interface:
Module M_swap
! SWAP is a Generic Interface in a module with PRIVATE specific procedures.
! that swaps two variables of like type (real,integer,complex,character,double)
! you must add a new routine for each new type directly supported; although
! multiple calls can be used on the components of a non-intrinsic type.
implicit none
integer,parameter :: cd=kind(0.0d0)
private
public swap
interface swap
module procedure r_swap, i_swap, c_swap, s_swap, d_swap, l_swap, cd_swap
end interface
contains
elemental subroutine d_swap(lhs,rhs)
doubleprecision, intent(inout) :: lhs,rhs
doubleprecision :: temp
temp = lhs; lhs = rhs; rhs = temp
end subroutine d_swap
elemental subroutine r_swap(lhs,rhs)
real, intent(inout) :: lhs,rhs
real :: temp
temp = lhs; lhs = rhs; rhs = temp
end subroutine r_swap
elemental subroutine i_swap(lhs,rhs)
integer, intent(inout) :: lhs,rhs
integer :: temp
temp = lhs; lhs = rhs; rhs = temp
end subroutine i_swap
elemental subroutine l_swap(l,ll)
logical, intent(inout) :: l,ll
logical :: ltemp
ltemp = l; l = ll; ll = ltemp
end subroutine l_swap
elemental subroutine c_swap(lhs,rhs)
complex, intent(inout) :: lhs,rhs
complex :: temp
temp = lhs; lhs = rhs; rhs = temp
end subroutine c_swap
elemental subroutine cd_swap(lhs,rhs)
complex(kind=cd), intent(inout) :: lhs,rhs
complex(kind=cd) :: temp
temp = lhs; lhs = rhs; rhs = temp
end subroutine cd_swap
elemental subroutine s_swap(string1,string2)
character(len=*), intent(inout) :: string1,string2
character( len=max(len(string1),len(string2))) :: string_temp
string_temp = string1; string1 = string2; string2 = string_temp
end subroutine s_swap
end module M_swapUnlimited polymorphic variables
When the operations generally just require moving or changing the storage, functions like TRANSFER() and unlimited polymorphic entities can be useful for reducing duplicate code. This is often the case for sorting, swapping, and various types of lists.
So another example using an unlimited polymorphic entity to construct a generic swap function follows.
It would be nice if TRANSFER or “=” worked with unlimited polymorphic entities ; so you have to add a type into ANYTHING_TO_BYTES() an BYTES_TO_ANYTHING) and this approach precludes making the routine elemental
module m_swap
use, intrinsic :: iso_fortran_env, only : int8,int16,int32,int64,real32,real64,real128
implicit none
private
public :: swap
integer,parameter :: dble=kind(0.0d0)
interface swap
module procedure swap_scalar
end interface
contains
function anything_to_bytes(anything) result(chars)
implicit none
class(*),intent(in) :: anything
character(len=1),allocatable :: chars(:)
select type(anything)
type is (character(len=*)); chars=transfer(anything,chars)
type is (complex); chars=transfer(anything,chars)
type is (complex(kind=dble)); chars=transfer(anything,chars)
type is (integer(kind=int8)); chars=transfer(anything,chars)
type is (integer(kind=int16)); chars=transfer(anything,chars)
type is (integer(kind=int32)); chars=transfer(anything,chars)
type is (integer(kind=int64)); chars=transfer(anything,chars)
type is (real(kind=real32)); chars=transfer(anything,chars)
type is (real(kind=real64)); chars=transfer(anything,chars)
type is (real(kind=real128)); chars=transfer(anything,chars)
class default
stop 'crud. anything_to_bytes(1) does not know about this type'
end select
end function anything_to_bytes
subroutine bytes_to_anything(chars,anything)
character(len=1),allocatable :: chars(:)
class(*) :: anything
select type(anything)
type is (character(len=*)); anything=transfer(chars,anything)
type is (complex); anything=transfer(chars,anything)
type is (complex(kind=dble)); anything=transfer(chars,anything)
type is (integer(kind=int8)); anything=transfer(chars,anything)
type is (integer(kind=int16)); anything=transfer(chars,anything)
type is (integer(kind=int32)); anything=transfer(chars,anything)
type is (integer(kind=int64)); anything=transfer(chars,anything)
type is (real(kind=real32)); anything=transfer(chars,anything)
type is (real(kind=real64)); anything=transfer(chars,anything)
type is (real(kind=real128)); anything=transfer(chars,anything)
class default
stop 'crud. bytes_to_anything(1) does not know about this type'
end select
end subroutine bytes_to_anything
subroutine swap_scalar( lhs, rhs )
class(*) :: rhs
class(*) :: lhs
character(len=1),allocatable :: templ(:)
character(len=1),allocatable :: tempr(:)
tempr=anything_to_bytes(rhs)
templ=anything_to_bytes(lhs)
call bytes_to_anything(templ,rhs)
call bytes_to_anything(tempr,lhs)
end subroutine swap_scalar
end module m_swapUnlimited polymorphic variables and ISO_C_BINDING access to low-level C functionality.
Sometimes using the ISO_C_BINDING interface to use lower-level functions supported in C (and to therefore open up the code to some of risks of working with addresses) combined with polymorphic variables can be useful.
WARNING: This did not work with CHARACTER variables using the compiler I tested with. In theory I think this should work with any type. Corrections are welcome.
module M_swap
private
public swap
contains
subroutine swap(lhs,rhs)
use iso_c_binding
implicit none
class(*),intent(inout) :: lhs, rhs
class(*), allocatable :: temp
type(c_ptr) :: tmp
! Copy N bytes of SRC to DEST, no aliasing or overlapping allowed.
! extern void *memcpy (void *dest, const void *src, size_t n);
interface
subroutine s_memcpy(dest, src, n) bind(C,name='memcpy')
use iso_c_binding
INTEGER(c_intptr_t), value, intent(in) :: dest
INTEGER(c_intptr_t), value, intent(in) :: src
integer(c_size_t), value :: n
end subroutine s_memcpy
end interface
temp=lhs
call s_memcpy(loc(lhs), loc(rhs), storage_size(lhs, kind=c_size_t)/8_c_size_t )
call s_memcpy(loc(rhs), loc(temp), storage_size(rhs, kind=c_size_t)/8_c_size_t )
end subroutine swap
end module M_swapA nod towards preprocessors
The output of this bash shell is a generic interface. This approach is a lot more useful when more complex code sections are indentical but is far more flexible than INCLUDE which does not allow for looping or substition or even cpp(1). cpp(1) has macros and substitution but also does not support functions and looping. More powerful preprocessors like m4(1) do, but bash(1) is more commonly available and have a larger user base.
#!/bin/bash
#############################################################
GENERIC(){
TYPE=$1
cat <<EOF
subroutine swap_${TYPE}(a,b)
$TYPE :: a,b,temp
temp=a
a=b
b=a
end subroutine swap_$TYPE
EOF
}
#############################################################
HEADER(){
# module header
cat <<\EOF
module M_swap
implicit none
private
interface swap
EOF
for MP in $NAMES
do
echo " module procedure swap_$MP"
done
cat <<\EOF
end interface swap
contains
EOF
}
#############################################################
FOOTER(){
cat <<\EOF
end module M_swap
EOF
}
#############################################################
# add types here
NAMES='integer real doubleprecision complex'
HEADER
for NAME in $NAMES
do
GENERIC $NAME
done
FOOTER
exit