FORTRAN 2003: Into the Future
by Malcolm Cohen


Listing One

module c_signal_module
   use iso_c_binding
   integer(c_int), parameter :: sighup = 1, ...
   interface
      function signal(sig, func) bind(C)
         use iso_c_binding
         type(c_funptr) signal, func
         integer(c_int) sig
         value sig, func
      end function
      function raise(sig) bind(C)
         use iso_c_binding
         integer(c_int) raise, sig
         value sig
      end function
   end interface
end module
program example
   ...
   if (signal(sighup,c_funloc(myhandler))/=c_funloc(myhandler)) then
      stop 'Cannot establish signal handler'
   end if
   ...
   if (raise(sighup)/=0) then
      stop 'Cannot raise signal'
   end if
   ...
end program


Listing Two

subroutine nag_g05faf(a, b, n, x) bind(c)
   use iso_c_binding
   real(c_double), value :: a, b
   integer(c_int), value :: n
   real(c_double) :: x(n)
   integer, parameter :: nagp = kind(0d0)
   interface
      subroutine g05faf(a, b, n, x)
         import nagp
         integer n
         real(nagp) a, b, x(n)
      end subroutine
   call g05faf(a,b,n,x)
end subroutine
 ...
extern void nag_g05faf(double,double,int,double[]);


Listing Three

use iso_c_binding
real, allocatable, target :: x(:)
type(c_ptr),bind(c,name='Data_Array') :: p
 ...
allocate(x(n))
p = c_loc(x)


Listing Four

double precision d
 ...
open(27,file='data.file',access='stream',form='unformatted')
 ...
write(27) d


Listing Five

open(28,file='/dev/tty',access='stream',form='formatted')
write(28,'(a)') 'Hello'//newline()//'World'


Listing Six

character(:), allocatable :: name
 ...
name = ''
! LEN(name) is now 0.
 ...
name = 'John Doe'
! LEN(name) is now 8.
 ...
name = 'John Hancock'
! LEN(name) is now 12.
 ...
name(:) = ''
! LEN(name) remains 12, but contents are now all blank.


Listing Seven

function object_filename(input_filename)
   character(*), intent(in) :: input_filename
   character(:), allocatable :: object_filename
   integer :: base_length
   base_length = index(input_filename,'.',back=.true.) - 1
   if (index(input_filename,'/',back=.true.)>=base_length) &
      base_length = len(input_filename)
   allocate(character(base_length+4) :: object_filename)
   object_filename = input_filename(:base_length)//'.obj'
end function


Listing Eight

subroutine create_date_string(string)
    intrinsic date_and_time,selected_char_kind
    integer,parameter :: ucs4 = selected_char_kind("ISO_10646")
    character,parameter :: nen = char(int(Z'5e74'),ucs4)
    character,parameter :: gatsu = char(int(Z'6708'),ucs4)
    character,parameter :: nichi = char(int(Z'65e5'),ucs4)
    character(len= *, kind= ucs4) string
    integer values(8)
    call date_and_time(values=values)
    write(string,10) values(1),nen,values(2),gatsu,values(3),nichi
10  format(I0,A,I0,A,I0,A)
  end subroutine


Listing Nine

type world_point
   real latitude, longitude
end type
type, extends(world_point) :: radio_beacon_point
   real frequency
end type
Listing Ten
real function distance_between(point_1, point_2)
   class(world_point), intent(in) :: point_1, point_2
   distance_between = ... formula using latitude and longitude ...
end function


Listing Eleven

class(radio_beacon_point), pointer :: rbp_ptr
class(world_point), pointer        :: wp_ptr
 ...
wp_ptr => rbp_ptr     ! Allowed
rbp_ptr => wp_ptr     ! Not allowed


Listing Twelve

select type(point => wp_ptr)
type is (world_point)
   ! Here if the dynamic type is exactly "world_point"
   print *, 'Ordinary world point'
class is (radio_beacon_point)
   ! Here if the dynamic type is in the class "radio_beacon_point"
   ! i.e. including anything extended from it
   print *, 'Radio frequency', point%frequency
class default
   ! Here if nothing else matched
   print *, 'Unrecognized point'
end select


Listing Thirteen

type mytype
   private
   ... ! data components omitted
contains
   procedure :: accumulate
   procedure :: reset => reset_mytype
end type mytype


