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_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

category: code