Fortran Wiki
swap (Rev #2, changes)

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_swap

Unlimited 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_swap

Unlimited 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_swap

A 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