Funktionen, Unterprogramme und Module

program unterprogramme
  implicit none
  print *, quadrat(7.0)
  print *, fakultaet(10)
  print *, istgerade(4), istgerade(7)

  block
    real :: mittel, abw
    call statistik([2.0, 4.0, 4.0, 4.0, 5.0, 5.0, 7.0, 9.0], mittel, abw)
    print "(a, f6.2, a, f6.2)", "Mittel ", mittel, " Abweichung ", abw
  end block

  block
    integer :: a, b
    a = 3; b = 8
    call tausche(a, b)
    print *, a, b
  end block

contains

  real function quadrat(x)
    real, intent(in) :: x
    quadrat = x * x
  end function quadrat

  recursive function fakultaet(n) result(r)
    integer, intent(in) :: n
    integer(kind=8) :: r
    if (n <= 1) then
      r = 1
    else
      r = n * fakultaet(n - 1)
    end if
  end function fakultaet

  logical function istgerade(n)
    integer, intent(in) :: n
    istgerade = mod(n, 2) == 0
  end function istgerade

  subroutine statistik(v, mittel, abw)
    real, intent(in) :: v(:)
    real, intent(out) :: mittel, abw
    mittel = sum(v) / size(v)
    abw = sqrt(sum((v - mittel)**2) / size(v))
  end subroutine statistik

  subroutine tausche(a, b)
    integer, intent(inout) :: a, b
    integer :: t
    t = a; a = b; b = t
  end subroutine tausche

end program unterprogramme

49.0000000
              3628800
 T F
Mittel   5.00 Abweichung   2.00
           8           3

module geometrie
  implicit none
  private
  public :: pi, kreis_flaeche, kreis_umfang, dreieck_flaeche, form

  real, parameter :: pi = 3.14159265

  type :: form
    character(len=10) :: name
    real :: a = 0.0, b = 0.0
  contains
    procedure :: flaeche => form_flaeche
  end type form

contains

  pure function kreis_flaeche(r) result(f)
    real, intent(in) :: r
    real :: f
    f = pi * r * r
  end function kreis_flaeche

  pure function kreis_umfang(r) result(u)
    real, intent(in) :: r
    real :: u
    u = 2.0 * pi * r
  end function kreis_umfang

  pure function dreieck_flaeche(a, b, c) result(f)
    real, intent(in) :: a, b, c
    real :: f, s
    s = (a + b + c) / 2.0
    f = sqrt(s * (s - a) * (s - b) * (s - c))
  end function dreieck_flaeche

  function form_flaeche(self) result(f)
    class(form), intent(in) :: self
    real :: f
    f = self%a * self%b
  end function form_flaeche

end module geometrie

program main
  use geometrie
  implicit none
  type(form) :: r

  print "(f8.4)", kreis_flaeche(1.0)
  print "(f8.4)", kreis_umfang(2.0)
  print "(f8.4)", dreieck_flaeche(3.0, 4.0, 5.0)
  r = form("Rechteck", 3.0, 4.5)
  print "(a, f6.2)", trim(r%name) // ": ", r%flaeche()
end program main

3.1416
 12.5664
  6.0000
Rechteck:  13.50

module hilfen
  implicit none
contains
  elemental real function cel_zu_fahr(c)
    real, intent(in) :: c
    cel_zu_fahr = c * 9.0 / 5.0 + 32.0
  end function

  function potenz(basis, exp) result(r)
    real, intent(in) :: basis
    integer, intent(in), optional :: exp
    real :: r
    if (present(exp)) then
      r = basis ** exp
    else
      r = basis ** 2
    end if
  end function

  subroutine zaehle(text, anzahl)
    character(len=*), intent(in) :: text
    integer, intent(out) :: anzahl
    anzahl = len_trim(text)
  end subroutine
end module hilfen

program test
  use hilfen
  implicit none
  integer :: n
  print *, cel_zu_fahr([0.0, 37.0, 100.0])        ! wirkt auf das ganze Array
  print *, potenz(3.0), potenz(2.0, 10), potenz(exp=3, basis=2.0)
  call zaehle("Fortran  ", n)
  print *, n
end program test

32.0000000       98.5999985       212.000000
   9.00000000       1024.00000       8.00000000
           7

module ausgabe
  implicit none
  interface zeige
    module procedure zeige_int, zeige_real, zeige_text
  end interface
contains
  subroutine zeige_int(x)
    integer, intent(in) :: x
    print "(a, i0)", "Ganzzahl: ", x
  end subroutine
  subroutine zeige_real(x)
    real, intent(in) :: x
    print "(a, f0.2)", "Kommazahl: ", x
  end subroutine
  subroutine zeige_text(x)
    character(len=*), intent(in) :: x
    print "(2a)", "Text: ", x
  end subroutine
end module ausgabe

program uebung
  use ausgabe
  call zeige(42)
  call zeige(3.14)
  call zeige("Hallo")
end program uebung

Ganzzahl: 42
Kommazahl: 3.14
Text: Hallo