The snippets are under the CC-BY-SA license.

Creative Commons Attribution-ShareAlike 3.0

Logo

Programming-Idioms.org

< Cheatsheets
  • The snippets are under the CC-BY-SA license.
  • Please consider keeping a bookmark
  • (instead of printing)
Fortran
1
Print Hello World
Print a literal string on standard output 
print *, 'Hello, world!'
2
Print Hello 10 times
Loop to execute some code a constant number of times 
program main
  implicit none
  integer :: i
  do i=1,10
    write (*,'(A)') "Hello"
  end do
end program main
3
Create a procedure
Like a function which doesn't return any value, thus has only side effects (e.g. Print to standard output) 
module foo
  implicit none
contains
  subroutine bar
    print *,"Hello"
  end subroutine bar
end module foo
4
Create a function
Create a function which returns the square of an integer 
module foo
  implicit none
contains
  function square(i) result(res)
    integer, intent(in) :: i
    integer :: res
    res = i * i
  end function square
end module foo
5
Create a 2D Point data structure
Declare a container type for two floating-point numbers x and y 
type point
  real :: x
  real :: y
end type point
Alternative implementation:
module x
  type point
  real :: x, y
  end type point
end module x
6
Iterate over list values
Do something with each item x of the list (or array) items, regardless indexes. 
elemental subroutine foo(x)
  real, intent(in) :: x
end subroutine foo

call foo(x)
7
Iterate over list indexes and values
Print each index i with its value x from an array-like collection items 
do i=1, size(items)
  print *,i, items(i)
end do
9
Create a Binary Tree data structure
The structure must be recursive because left child and right child are binary trees too. A node has access to children nodes, but not to its parent. 
type binary_tree
    integer :: value
    type(binary_tree), allocatable :: left
    type(binary_tree), allocatable :: right
end type binary_tree
10
Shuffle a list
Generate a random permutation of the elements of list x 
module M_shuffle
contains
function scramble( number_of_values ) result(array)
   integer,intent(in)    :: number_of_values
   integer,allocatable   :: array(:)
   array=[(i,i=1,number_of_values)]
   n=1; m=number_of_values
   do k=1,2
    do i=1,m
     call random_number(u)
     j = n + FLOOR((m+1-n)*u)
     itemp=array(j); array(j)=array(i); array(i)=itemp
    enddo
   enddo
end function scramble
end module M_shuffle
 :
use M_shuffle, only : scramble
newlist=list(scramble(size(list))
11
Pick a random element from a list
The list x must be non-empty. 

call random_number (a)
x(lbound(x) + int(a*ubound(x))
12
Check if list contains a value
Check if the list contains the value x.
list is an iterable finite container. 
if (findloc (list, x, 1) != 0) then
Alternative implementation:
if (any(x == list)) ...
14
Pick uniformly a random floating point number in [a..b)
Pick a random number greater than or equals to a, strictly inferior to b. Precondition : a < b. 
call random_number(c)
d = a + (b-a) * c
15
Pick uniformly a random integer in [a..b]
Pick a random integer greater than or equals to a, inferior or equals to b. Precondition : a < b. 
real :: c
integer :: res

call random_number(c)
res = int((b-a+1)*c)
16
Depth-first traversal of a binary tree
Call a function f on every node of binary tree bt, in depth-first infix order 
module x
  type tree
     type (tree), pointer :: left, right
   contains
     procedure, pass:: trav
  end type tree
contains
  recursive subroutine trav (t, f)
    class (tree), intent(inout) :: t
    interface
       subroutine f(t)
         import
         class (tree), intent(inout) :: t
       end subroutine f
    end interface
    if (associated (t%left)) call trav (t%left, f)
    call f(t)
    if (associated (t%right)) call trav (t%right, f)
  end subroutine trav
end module x
17
Create a Tree data structure
The structure must be recursive. A node may have zero or more children. A node has access to its children nodes, but not to its parent. 
type node_t
  integer:: value
  type(node_t), pointer :: next_sibling;
  type(node_t), pointer :: first_child;
end type node_t
18
Depth-first traversal of a tree
Call a function f on every node of a tree, in depth-first prefix order 
  recursive subroutine depth_first (node, f)
    type (tr), pointer :: node
    interface
       subroutine f(node)
         import
         type(tr), pointer :: node
       end subroutine f
    end interface
    if (associated(node%left)) call depth_first (node, f)
    if (associated(node%right)) call depth_first (node, f)
    call f(node)
  end subroutine depth_first
19
Reverse a list
Reverse the order of the elements of the list x.
This may reverse "in-place" and destroy the original ordering. 
  a = a(ubound(a,dim=1)::-1)
20
Return two values
Implement a function search which looks for item x in a 2D matrix m.
Return indices i, j of the matching cell.
Think of the most idiomatic way in the language to return the two values at the same time. 
function search(m,x)
  integer, dimension(:,:), intent(in) :: m
  integer, intent(in) :: x
  integer, dimension(2) :: search
  search = findloc(x,m)
end function search
21
Swap values
Swap the values of the variables a and b
 
tmp = a
a = b
b = tmp
Alternative implementation:
subroutine swap(a, b)
  integer, intent(inout) :: a, b
  integer :: temp
  temp = a
  a = b
  b = temp
end subroutine swap
22
Convert string to integer
Extract the integer value i from its string representation s (in radix 10) 
read (unit=s,fmt=*) i
23
Convert real number to string with 2 decimal places
Given a real number x, create its string representation s with 2 decimal digits following the dot. 
  write (unit=s,fmt="(F20.2)") x
24
Assign to string the japanese word ネコ
Declare a new string s and initialize it with the literal value "ネコ" (which means "cat" in japanese) 
  use, intrinsic :: iso_fortran_env
  implicit none
  integer, parameter :: u = selected_char_kind('ISO_10646')

  character(kind=u,len=2) :: cat
  cat = u_"ネコ"
25
Send a value to another thread
Share the string value "Alan" with an existing running process which will then display "Hello, Alan" 
str[1] = "Alan"
sync all
if (this_image() == 1) then
  print *,"Hello, ", str
end if
26
Create a 2-dimensional array
Declare and initialize a matrix x having m rows and n columns, containing real numbers. 
  real, dimension(m,n) :: x
27
Create a 3-dimensional array
Declare and initialize a 3D array x, having dimensions boundaries m, n, p, and containing real numbers. 
  real, dimension(:,:,:), allocatable :: x

  allocate (x(m,n,p))
29
Remove item from list, by its index
Remove i-th item from list items.
This will alter the original list or return a new list, depending on which is more idiomatic.
Note that in most languages, the smallest valid value for i is 0. 
integer, allocatable, dimension(:) :: items
items = [items(:i-1), items(i+1:)]
30
Parallelize execution of 1000 independent tasks
Launch the concurrent execution of procedure f with parameter i from 1 to 1000.
Tasks are independent and f(i) doesn't return any value.
Tasks need not run all at the same time, so you may use a pool. 
  integer :: tasks, n, t, i
  tasks = 1000
  n = num_images()
  t = this_image()
  do i = t, tasks, n
     call f(i)
  end do
  sync all
31
Recursive factorial (simple)
Create the recursive function f which returns the factorial of the non-negative integer i, calculated from f(i-1) 
module x
  implicit none
contains
  recursive function f (i) result (res)
    integer, intent(in) :: i
    integer :: res
    if (i <= 0) then
       res = 1
    else
       res = f(i-1) * i
    end if
  end function f
end module x
32
Integer exponentiation by squaring
Create function exp which calculates (fast) the value x power n.
x and n are non-negative integers. 
function exp(x,n) result(I)
I=x**n
end function exp
33
Atomically read and update variable
Assign to the variable x the new value f(x), making sure that no other thread may modify x between the read and the write. 
x = f(x)
Alternative implementation:
integer, dimension[*] :: x

critical
  x = f(x)
end critical
38
Extract a substring
Find substring t consisting in characters i (included) to j (excluded) of string s.
Character indices start at 0 unless specified otherwise.
Make sure that multibyte characters are properly handled. 
character(len=:), allocatable :: t

  t = s(i:j-1)
39
Check if string contains a word
Set the boolean ok to true if the string word is contained in string s as a substring, or to false otherwise. 
ok = index(string, word) /= 0
41
Reverse a string
Create the string t containing the same characters as the string s, in reverse order.
The original string s must remain unaltered. Each character must be handled correctly regardless its number of bytes in memory. 
  character(len=:), allocatable :: t
  integer :: i, n

  allocate (t, mold=s)
  n = len(s)
  do i = 0, n - 1
     t(n-i : n-i) = s(i+1 : i+1)
  end do
42
Continue outer loop
Print each item v of list a which is not contained in list b.
For this, write an outer loop to iterate on a and an inner loop to iterate on b. 
  outer: do i=1,size(a)
     do j=1,size(b)
        if (a(i) == b(j)) cycle outer
     end do
     print *,a(i)
  end do outer
43
Break outer loop
Look for a negative value v in 2D integer matrix m. Print it and stop searching. 
  outer: do j=1, size(m,2)
     do i=1, size(m,1)
        v = m(i,j)
        if (v < 0) then
           print *,v
           exit outer
        end if
     end do
  end do outer
44
Insert element in list
Insert the element x at position i in the list s. Further elements must be shifted to the right. 
integer, dimension(:), allocatable :: s

s = [s(1:i-1), x, s(i:)]
45
Pause execution for 5 seconds
Sleep for 5 seconds in current thread, before proceeding with the next instructions. 
module M_time
contains
subroutine system_sleep(wait)
use,intrinsic :: iso_c_binding, only: c_int
integer,intent(in) :: wait
integer(kind=c_int):: waited
interface
 function c_usleep(msecs) bind (C,name="usleep")
  import
  integer(c_int) :: c_usleep
  integer(c_int),intent(in),VALUE :: msecs
 end function c_usleep
end interface
 if(wait.gt.0)then
  waited=c_usleep(int(wait,kind=c_int))
 endif
end subroutine system_sleep
end module M_time
program x
use M_time
call system_sleep(5000000)
end
46
Extract beginning of string (prefix)
Create the string t consisting of the 5 first characters of the string s.
Make sure that multibyte characters are properly handled. 
 character(len=5) :: t
 t = s(1:5)
47
Extract string suffix
Create string t consisting in the 5 last characters of string s.
Make sure that multibyte characters are properly handled. 
character(len=5) :: t
t = s(len(s)-4:)
48
Multi-line string literal
Assign to variable s a string literal consisting in several lines of text, including newlines. 
  s = "Hello &
      &World"
50
Make an infinite loop
Write a loop that has no end clause. 
do
end do
53
Join a list of strings
Concatenate elements of string list x joined by the separator ", " to create a single string y. 
  write (unit=y,fmt='(*(A,:,", "))') x
54
Compute sum of integers
Calculate the sum s of the integer list or array x. 
   s = sum(x)
55
Convert integer to string
Create the string representation s (in radix 10) of the integer value i. 
  write (unit=s,fmt=*) i
56
Launch 1000 parallel tasks and wait for completion
Fork-join : launch the concurrent execution of procedure f with parameter i from 1 to 1000.
Tasks are independent and f(i) doesn't return any value.
Tasks need not run all at the same time, so you may use a pool.
Wait for the completion of the 1000 tasks and then print "Finished". 
  integer :: tasks, n, t, i
  tasks = 1000
  n = num_images()
  t = this_image()
  do i = t, tasks, n
     call f(i)
  end do
  sync all
  print *,"Finished"
57
Filter list
Create the list y containing the items from the list x that satisfy the predicate p. Respect the original ordering. Don't modify x in-place. 
y = pack(x,mask=p(x))
58
Extract file content to a string
Create the string lines from the content of the file with filename f. 
program p
   character(len=:),allocatable :: s
   open(unit=10,file='myfile',access='stream')
   inquire(10,size=i)
   allocate(character(len=i) :: s)
   read(10)(s(j:j),j=1,i)
   write(*,*)s
end program p
59
Write to standard error stream
Print the message "x is negative" to standard error (stderr), with integer x value substitution (e.g. "-2 is negative"). 
program write_to_stderr
   use iso_fortran_env, only : stderr=>ERROR_UNIT   
   implicit none
   integer :: x=-2
   write(stderr,'(i0," is negative")') x
end program write_to_stderr
60
Read command line argument
Assign to x the string value of the first command line parameter, after the program name. 
  character(len=:), allocatable :: x
  integer :: n
  call get_command_argument (1, length=n)
  allocate (character(n):: x)
  call get_command_argument (1, x)
61
Get current date
Assign to the variable d the current date/time value, in the most standard type. 
integer, dimension(8) :: d

call date_and_time (values=d)
62
Find substring position
Set i to the first position of string y inside string x, if exists.

Specify if i should be regarded as a character index or as a byte index.

Explain the behavior when y is not contained in x. 
I=index(x,y)
63
Replace fragment of a string
Assign to x2 the value of string x with all occurrences of y replaced by z.
Assume occurrences of y are not overlapping. 
  character(len=:), allocatable :: x
  character(len=:), allocatable :: x2
  character(len=:), allocatable :: y,z
  integer :: j, k
  k=1
  do
     j = index(x(k:),y)
     if (j==0) then
        x2 = x2 // x(k:)
        exit
     end if
     if (j>1) then
        x2 = x2 // x(k:j+k-2)
     end if
     x2 = x2 // z
     k = k + j + len(y) - 1
  end do
65
Format decimal number
From the real value x in [0,1], create its percentage string representation s with one digit after decimal point. E.g. 0.15625 -> "15.6%" 
write (*,'(F5.1,"%")') x*100.
67
Binomial coefficient "n choose k"
Calculate binom(n, k) = n! / (k! * (n-k)!). Use an integer type able to handle huge numbers. 
integer, parameter :: i8 = selected_int_kind(18)
integer, parameter :: dp = selected_real_kind(15)
n = 100
k = 5
print *,nint(exp(log_gamma(n+1.0_dp)-log_gamma(n-k+1.0_dp)-log_gamma(k+1.0_dp)),kind=i8)
69
Seed random generator
Use seed s to initialize a random generator.

If s is constant, the generator output will be the same each time the program runs. If s is based on the current value of the system clock, the generator output will be different each time. 
  call random_seed(size = n)
  allocate(seed(n))
  ! ...
  call random_seed(put=seed)
70
Use clock as random generator seed
Get the current datetime and provide it as a seed to a random generator. The generator sequence will be different at each run. 
  call random_seed (size=k)
  allocate (seed(k))
  call date_and_time (values=val)
  seed = [(173*i**2+4567,i=1,k)]
  m = min(8,k)
  seed(1:m) = seed(1:m) + val(m:1:-1)
  call random_seed (put=seed)
71
Echo program implementation
Basic implementation of the Echo program: Print all arguments except the program name, separated by space, followed by newline.
The idiom demonstrates how to skip the first argument if necessary, concatenate arguments as strings, append newline and print it to stdout. 
program x
  implicit none
  character (len=:), allocatable :: a
  integer :: n, i, l
  n = command_argument_count()
  a = ''
  do i=1,n
     call get_command_argument(i, a, l)
     if (l > len(a)) then
        deallocate (a)
        allocate (character(len=l) :: a)
        call get_command_argument(i, a)
     end if
     write (unit=*,fmt='(A)', advance="no") a
     if (i < n) then
        write (unit=*,fmt='(" ")', advance="no")
     else
        write (unit=*,fmt='()')
     end if
  end do
end
74
Compute GCD
Compute the greatest common divisor x of big integers a and b. Use an integer type able to handle huge numbers. 
function gcd(m,n) result(answer)
implicit none
integer(kind=int64),intent(in)  :: m, n
integer(kind=int64)             :: answer,irest,ifirst
   ifirst=iabs(m)
   answer=iabs(n)
   if(answer.eq.0)then
      answer=ifirst
   else
      do
         irest = mod(ifirst,answer)
         if(irest == 0)  exit
         ifirst = answer
         answer = irest
      enddo
      answer= iabs(answer)
   endif
end function gcd
76
Binary digits from an integer
Create the string s of integer x written in base 2.

E.g. 13 -> "1101" 
write (unit=s,fmt='(B0)') x
Alternative implementation:
write (unit=s,fmt='(B32)') x
77
Complex number
Declare a complex x and initialize it with value (3i - 2). Then multiply it by i. 
  complex :: x
  x = (-2,3)
  x = x * (0,1)
78
"do while" loop
Execute a block once, then execute it again as long as boolean condition c is true. 
do
  call do_something
  if (.not. c) exit
end do
79
Convert integer to floating point number
Declare the floating point number y and initialize it with the value of the integer x . 
real :: y
y = x
80
Truncate floating point number to integer
Declare integer y and initialize it with the value of floating point number x . Ignore non-integer digits of x .
Make sure to truncate towards zero: a negative x must yield the closest greater integer (not lesser). 
integer :: y
real  :: x
y=x
81
Round floating point number to integer
Declare the integer y and initialize it with the rounded value of the floating point number x .
Ties (when the fractional part of x is exactly .5) must be rounded up (to positive infinity). 
integer :: y

y = nint(x)
82
Count substring occurrences
Find how many times string s contains substring t.
Specify if overlapping occurrences are counted. 
  lt = len(t) - 1
  k = 1
  num = 0
  do
     print *,s(k:)
     i = index(s(k:),t)
     if (i==0) exit
     num = num + 1
     k = k + i + lt
  end do
  print *,num
84
Count bits set in integer binary representation
Count number c of 1s in the integer i in base 2.

E.g. i=6 → c=2 
c = popcnt(i)
85
Check if integer addition will overflow
Write boolean function addingWillOverflow which takes two integers x, y and return true if (x+y) overflows.

An overflow may be above the max positive value, or below the min negative value. 
  logical function adding_will_overflow (x,y) result(res)
    integer, intent(in) :: x, y
    res = (x > 0 .and. y > huge(x) - x) .or. (x < 0 .and. y < huge(x) - x)
  end function adding_will_overflow
86
Check if integer multiplication will overflow
Write the boolean function multiplyWillOverflow which takes two integers x, y and returns true if (x*y) overflows.

An overflow may reach above the max positive value, or below the min negative value. 
logical function multiply_will_overflow (x, y) result(res)
    integer, intent(in) :: x, y
    integer, parameter :: ik = selected_int_kind (int(digits(y)*log10(2.)*2))

    res = int(x,kind=ik) * int(y,kind=ik) > huge(x)
end function multiply_will_overflow
87
Stop program
Exit immediately.
If some extra cleanup work is executed by the program runtime (not by the OS itself), describe it. 
stop
88
Allocate 1M bytes
Create a new bytes buffer buf of size 1,000,000. 
  integer(kind=c_int8_t), dimension(:), allocatable :: a

  allocate (a(10**6))
89
Handle invalid argument
You've detected that the integer value of argument x passed to the current function is invalid. Write the idiomatic way to abort the function execution and signal the problem. 
  if (x > largest_value) error stop "Illegal value in function."
90
Read-only outside
Expose a read-only integer x to the outside world while being writable inside a structure or a class Foo. 
module x
  implicit none
  type foo
     integer, private :: x
   contains
     procedure :: readx
  end type foo
contains
  integer function readx(f)
    class(foo) :: f
    readx = f%x
  end function readx
end module x
93
Pass a runnable procedure as parameter
Implement the procedure control which receives one parameter f, and runs f. 
module x
  implicit none
contains
  subroutine control(f)
    interface
       subroutine f()
       end subroutine f
    end interface
    call f
  end subroutine control
end module x
95
Get file size
Assign to variable x the length (number of bytes) of the local file at path. 
program xx
implicit none
character(len=256) :: message
character(len=4096) :: filename
integer :: ios,x
logical :: foundit
filename='myfile'
inquire(file=filename,exist=foundit,size=x,iostat=ios,iomsg=message)
if(.not.foundit)then
   write(*,*)'file ',trim(filename),' not found'
elseif(ios.ne.0)then
   write(*,*)trim(message)
else
   write(*,*)'size =',x,'bytes'
endif
end program xx
96
Check string prefix
Set the boolean b to true if string s starts with prefix prefix, false otherwise. 
  logical :: b
  b = index (string, prefix) == 1
97
Check string suffix
Set boolean b to true if string s ends with string suffix, false otherwise. 
  b = (s(len(s)-len(suffix)+1:) == suffix)
99
Format date YYYY-MM-DD
Assign to the string x the value of the fields (year, month, day) of the date d, in format YYYY-MM-DD. 
program p
integer, dimension(8) :: d
character(len=10) :: x
call date_and_time (values=d)
write(x,'(i4.4,"-",i2.2,"-",i2.2)')d(1),d(2),d(3)
print *,'DATE=',x
end program p
105
Current executable name
1 
program p
implicit none
character(len=:),allocatable :: s
integer                      :: stat,l,i,j,k
 call get_command_argument (0,length=l)
 allocate(character(len=l) :: s)
 call get_command_argument (0,s,status=stat)
 if (stat == 0) then
  i=index(s,'/',back=.true.)
  j=index(s,'\',back=.true.)
  k=max(i,j)
  if(k.ne.0)s=s(k+1:)
  print *, "The program's name is " // trim (s)
 endif
end program p
106
Get program working directory
Assign to string dir the path of the working directory.
(This is not necessarily the folder containing the executable itself) 
  interface
     function c_getcwd (buf, size) bind(C,name="getcwd") result(r)
       import
       type(c_ptr) :: r
       character(kind=c_char), dimension(*), intent(out) :: buf
       integer(kind=c_size_t), value :: size
     end function c_getcwd
  end interface

    if (c_associated(c_getcwd (buf, size(buf,kind=c_size_t)))) then
       n = findloc(buf,achar(0),1)
       allocate (character(len=n-1) :: dir)
       dir(1:n-1) = transfer(buf(1:n-1),dir(1:n-1))
    end if
108
Determine if variable name is defined
Print the value of variable x, but only if x has been declared in this program.
This makes sense in some languages, not all of them. (Null values are not the point, rather the very existence of the variable.) 
implicit none

print *,x
109
Number of bytes of a type
Set n to the number of bytes of a variable t (of type T). 
n = c_sizeof(i)
110
Check if string is blank
Set the boolean blank to true if the string s is empty, or null, or contains only whitespace ; false otherwise. 
blank = s == ''
111
Launch other program
From current process, run program x with command-line parameters "a", "b". 
program p
   integer :: i

   call execute_command_line("x a b", exitstat=i)
   print *, "Exit status of x was ", i

   call execute_command_line("x a b", wait=.false.)
   print *, "running x in the background"
end program p
116
Remove occurrences of word from string
Remove all occurrences of string w from string s1, and store the result in s2. 
  character(len=:), allocatable :: s1
  character (len=:), allocatable :: s2

  character(len=:), allocatable :: w
  integer :: i, j, k, tc

  allocate (s2, mold=s1)
  i = 1
  j = 1
  do
     k = index (s1(i:), w)
     if (k == 0) then
        s2(j:j+len(s1)-i) = s1(i:)
        s2 = s2(:j+len(s1)-i)
        exit
     else
        tc = k - 1
        if (tc > 0) s2(j:j+tc-1) = s1(i:i+tc-1)
        i = i + tc + len(w)
        j = j + tc
     end if
  end do
117
Get list size
Set n to the number of elements of the list x. 
n = size(x)
120
Read integer from stdin
Read an integer value from the standard input into the variable n 
   integer :: n
   read (*,*) n
122
Declare an enumeration
Create an enumerated type Suit with 4 possible values SPADES, HEARTS, DIAMONDS, CLUBS. 
enum, bind(c)
  enumerator :: spades, hearts, diamonds, clubs
end enum
123
Assert condition
Verify that predicate isConsistent returns true, otherwise report assertion violation.
Explain if the assertion is executed even in production environment or not. 
if (.not. isconsistent) stop "Inconsistent state"
124
Binary search for a value in sorted array
Write the function binarySearch which returns the index of an element having the value x in the sorted array a, or -1 if no such element exists. 
   integer function binarysearch(a,x) result(l)
      integer,intent(in)::a(:)
      integer,intent(in)::x
      integer::r,mid
      l=1
      r=size(a)
      do while(l<=r)
         mid=l+(r-l)/2;
         if(a(mid)==x)then
            l=mid
            return
         end if
         if(a(mid)<x)then
            l=mid+1;
         else 
            r=mid-1;
         end if
      end do
      l=-1
   end function binarysearch
125
Measure function call duration
measure the duration t, in nanoseconds, of a call to the function foo. Print this duration. 
integer, parameter :: i8 = selected_int_kind(15)
integer (kind=i8) :: count, count_rate, count_2
x = 1.2
call system_clock (count, count_rate)
call foo
call system_clock (count_2)
if (count_rate == 10**9) then
  print *,"The call to foo used ", (count_2-count), "Nanoseconds"
else
  print *,"The call to foo used ", (count_2-count)/real(count_rate)*1e9, "Nanoseconds"
end if
126
Multiple return values
Write a function foo that returns a string and a boolean value. 
subroutine foo(c, b)
  character(len=:), allocatable, intent(out) :: c
  logical, intent(out) :: b
  c = 'string'
  b = .false.
end subroutine foo
127
Source code inclusion
Import the source code for the function foo body from a file "foobody.txt". 
function foo()
include "foobody.txt"
end function foo
131
Successive conditions
Execute f1 if condition c1 is true, or else f2 if condition c2 is true, or else f3 if condition c3 is true.
Don't evaluate a condition when a previous condition was true. 
if (c1) then
  call f1
else if (c2) then
  call f2
else if (c3) then
  call f3
end if
132
Measure duration of procedure execution
Run the procedure f, and return the duration of the execution of f. 
integer, parameter :: i8 = selected_int_kind(15)
integer(kind=i8) :: start, finish, rate

call system_clock (count_rate=rate)
call system_clock (count=start)
call f()
call system_clock (count=finish)
print *,(finish-start)/real(rate)
133
Case-insensitive string contains
Set boolean ok to true if string word is contained in string s as a substring, even if the case doesn't match, or to false otherwise. 
 function u_i(string, substr)
  character (len=*), intent(in) :: string, substr
  integer :: i,j, c1, c2, u_i
  u_i = 0
  out: do i=1,len(string)-len(substr)+1
   c1 = iachar(string(i:i))
   if (c1 >= iachar('a') .and. c1 <= iachar('z')) c1 = c1 - 32
   do j=0,len(substr)-2
     c2 = iachar(substr(j+1:j+1))
     if (c2 >= iachar('a') .and. c1 <= iachar('z')) c2 = c2 - 32
     if (c1 /= c2) cycle out
   end do
   u_i = i
   return
 end do out
end function u_i

ok = u_i(string, word) /= 0
134
Create a new list
Declare and initialize a new list items, containing 3 elements a, b, c. 
integer, dimension(3) :: items
items = [a,b,c]
135
Remove item from list, by its value
Remove at most 1 item from list items, having the value x.
This will alter the original list or return a new list, depending on which is more idiomatic.
If there are several occurrences of x in items, remove only one of them. If x is absent, keep items unchanged. 
integer, dimension(:), allocatable :: items

i = findloc(items, x)
if (i /= 0) items = [items(1:i-1), items(i+1:)]
136
Remove all occurrences of a value from a list
Remove all occurrences of the value x from list items.
This will alter the original list or return a new list, depending on which is more idiomatic. 
items = pack (items,items != x)
137
Check if string contains only digits
Set the boolean b to true if the string s contains only characters in the range '0'..'9', false otherwise. 
b = .true.
do i=1, len(s)
  if (s(i:i) < '0' .or. s(i:i) > '9') then
    b = .false.
    exit
  end if
end do
138
Create temp file
Create a new temporary file on the filesystem. 
open (newunit=u,status="scratch")
141
Iterate in sequence over two lists
Iterate in sequence over the elements of the list items1 then items2. For each iteration print the element. 
print *,items1,items2
142
Hexadecimal digits of an integer
Assign to string s the hexadecimal representation (base 16) of integer x.

E.g. 999 -> "3e7" 
write (*,'(Z8.8)') x
143
Iterate alternatively over two lists
Iterate alternatively over the elements of the lists items1 and items2. For each iteration, print the element.

Explain what happens if items1 and items2 have different size. 
do i=1, min(size(items1), size(items2))
  print *,items1(i), items2(i)
end do
144
Check if file exists
Set boolean b to true if file at path fp exists on filesystem; false otherwise.

Beware that you should not do this and then in the next instruction assume the result is still valid, this is a race condition on any multitasking OS. 
inquire (file=fp,exist=b)
145
Print log line with datetime
Print message msg, prepended by current date and time.

Explain what behavior is idiomatic: to stdout or stderr, and what the date format is. 
integer :: value(8)
msg = "asdf"
call date_and_time (values=value)
write (unit=*,fmt='(I4,"-",I2.2,"-",I2.2," ",I2.2,":",I2.2,".",I4.4,": ",A)') value(1:3), value(5:7), msg
146
Convert string to floating point number
Extract floating point value f from its string representation s 
read(s,'(g0)')f
Alternative implementation:
read (unit=s,fmt=*) f
147
Remove all non-ASCII characters
Create string t from string s, keeping only ASCII characters 
n = 0
do i=1,len(s)
   if (iachar(s(i:i)) <= 127) n = n + 1
end do
allocate (character(len=n) :: t)
j = 0
do i=1,len(s)
   if (iachar(s(i:i)) <= 127) then
      j = j + 1
      t(j:j) = s(i:i)
   end if
end do
148
Read list of integers from stdin
Read a list of integer numbers from the standard input, until EOF. 
integer :: I,j,k ,l(3)
read(*,*) I, j, k, l
150
Remove trailing slash
Remove the last character from the string p, if this character is a forward slash / 
program x
character(len=:),allocatable :: string
integer :: ii
string='my string/'
ii=len(string)
string=trim(merge(string(:ii-1)//' ',string,string(ii:ii).eq.'/'))
write(*,*)string
end program x
152
Turn a character into a string
Create string s containing only the character c. 
character(len=:),allocatable :: s
character(len=1) :: c
s=c
153
Concatenate string with integer
Create the string t as the concatenation of the string s and the integer i. 
write (unit=t,fmt='(A,I0)') s, i
154
Halfway between two hex color codes
Find color c, the average between colors c1, c2.

c, c1, c2 are strings of hex color codes: 7 chars, beginning with a number sign # .
Assume linear computations, ignore gamma corrections. 
character (len=7) :: c, c1, c2
integer, dimension(3) :: v, v1, v2

read (unit=c1,fmt='(X,3Z2)') v1
read (unit=c2,fmt='(X,3Z2)') v2
v = (v1 + v2)/2
write (unit=c,fmt='("#",3Z2)') v
155
Delete file
Delete from filesystem the file having path filepath. 
open (10,file=filepath,status="old", iostat=ierr)
if (ierr == 0) close (10,status="delete")
156
Format integer with zero-padding
Assign to the string s the value of the integer i in 3 decimal digits. Pad with zeros if i < 100. Keep all digits if i ≥ 1000. 
write (unit=s,fmt='(I0.3)') i
157
Declare constant string
Initialize a constant planet with string value "Earth". 
  character(len=*), parameter :: planet = "Earth"
Alternative implementation:
character(*), parameter :: planet = "Earth"
158
Random sublist
Create a new list y from randomly picking exactly k elements from list x.

It is assumed that x has at least k elements.
Each element must have same probability to be picked.
Each element from x must be picked at most once.
Explain if the original ordering is preserved or not. 
allocate (sample(k))
do i=1,k
   sample(i) = x(i)
end do
do i=k+1,n
  call random_number(a)
  j = 1 + int(i*a)
  if (j .le. k) sample(j) = x(i)
end do
159
Trie
Define a Trie data structure, where entries have an associated value.
(Not all nodes are entries) 
  type trie_p
     type(trie), pointer :: p => NULL()
  end type trie_p
  type trie
     class(*), allocatable :: value
     type(trie_p), dimension(:), allocatable :: nodes
  end type trie
160
Detect if 32-bit or 64-bit architecture
Execute f32() if platform is 32-bit, or f64() if platform is 64-bit.
This can be either a compile-time condition (depending on target) or a runtime detection. 
program main
  use iso_c_binding
  implicit none
  type(c_ptr) :: x
  logical, parameter :: is_64 = c_sizeof(x) == 8
  if (is_64) then
     call f64
  else
     call f32
  end if
end program main
161
Multiply all the elements of a list
Multiply all the elements of the list elements by a constant c 
elements = elements * c
162
Execute procedures depending on options
execute bat if b is a program option and fox if f is a program option. 
  do i=1, command_argument_count ()
     call get_command_argument (i, length=length)
     if (length > len(opt)) then
        deallocate (opt)
        allocate (character(length) :: opt)
     end if
     call get_command_argument (i, opt)
     if (opt(1:1) /= '-') exit
     do j=2, length
        select case (opt(j:j))
        case ('b')
           print *,"bat"
        case ('f')
           print *,"fox"
        end select
     end do
  end do
163
Print list elements by group of 2
Print all the list elements, two by two, assuming list length is even. 
write (*,'(2I8,:," ")') list
165
Last element of list
Assign to the variable x the last element of the list items. 
x = items(ubound(items,1))
166
Concatenate two lists
Create the list ab containing all the elements of the list a, followed by all the elements of the list b. 
real, dimension(:), allocatable :: ab

ab = [a, b]
167
Trim prefix
Create the string t consisting of the string s with its prefix p removed (if s starts with p). 
  if (index(s,p) == 1) then
     t = s(len(p)+1:)
  else
     t = s
  end if
168
Trim suffix
Create string t consisting of string s with its suffix w removed (if s ends with w). 
  i = index(s,w,back=.true.) - 1
  if (i == len(s) - len(w) ) then
     allocate (t, source=s(:i))
  else
     allocate (t, source=s)
  end if
169
String length
Assign to the integer n the number of characters of the string s.
Make sure that multibyte characters are properly handled.
n can be different from the number of bytes of s. 
n = len(s)
171
Add an element at the end of a list
Append the element x to the list s. 
real, allocatable, dimension(:) :: s

s = [s, x]
175
Bytes to hex string
From the array a of n bytes, build the equivalent hex string s of 2n digits.
Each byte (256 possible values) is encoded as two hexadecimal characters (16 possible values per digit). 
  character(len=:), allocatable :: s
  allocate (character(len=2*size(a)) :: s)
  write(unit=s,fmt='(*(Z2.2))') a
176
Hex string to byte array
From hex string s of 2n digits, build the equivalent array a of n bytes.
Each pair of hexadecimal characters (16 possible values per digit) is decoded into one byte (256 possible values). 
  integer(kind=c_int8_t), dimension(:), allocatable :: a

  allocate (a(len(s)/2))
  read(unit=s,fmt='(*(Z2))') a
178
Check if point is inside rectangle
Set boolean b to true if if the point with coordinates (x,y) is inside the rectangle with coordinates (x1,y1,x2,y2) , or to false otherwise.
Describe if the edges are considered to be inside the rectangle. 
logical :: b
b = (x1 < x) .and. (x < x2) .and. (y1 < y) .and. (y < y2)
179
Get center of a rectangle
Return the center c of the rectangle with coördinates(x1,y1,x2,y2) 
real :: center(2)
center = [(x1 + x2)/2, (y1 + y2)/2]
182
Quine program
Output the source of the current program. A quine is a computer program that takes no input and produces a copy of its own source code as its only output.

Reading the source file from disk is cheating. 
! See original attribution URL
186
Exit program cleanly
Exit a program cleanly indicating no error to OS 
  STOP
188
Matrix multiplication
Perform matrix multiplication of a real matrix a with nx rows and ny columns, a real matrix b with ny rows and nz columns and assign the value to a real matrix c with nx rows and nz columns. 
c = matmul (a,b)
189
Filter and transform list
Produce a new list y containing the result of the function T applied to all elements e of the list x that match the predicate P. 
y = pack (t(x), mask=p(x))
190
Call an external C function
Declare an external C function with the prototype

void foo(double *a, int n);

and call it, passing an array (or a list) of size 10 to a and 10 to n.

Use only standard features of your language. 
module x
  use iso_c_binding
  interface
     subroutine foo (a, n) bind(c)
       import
       real(kind=c_double), dimension(*) :: a
       integer (kind=c_int), value :: n
     end subroutine foo
  end interface
contains
  subroutine call_foo
    real(kind=c_double) :: a(10)
    call foo(a,10)
  end subroutine call_foo
end module x
191
Check if any value in a list is larger than a limit
Given a one-dimensional array a, check if any value is larger than x, and execute the procedure f if that is the case 
if (any(a > x)) call f
192
Declare a real variable with at least 20 digits
Declare a real variable a with at least 20 digits; if the type does not exist, issue an error at compile time. 
  integer, parameter :: qp = selected_real_kind(20)
  real(kind=qp) :: a
193
Transpose a two-dimensional matrix
Declare two two-dimensional arrays a and b of dimension n*m and m*n, respectively. Assign to b the transpose of a (i.e. the value with index interchange). 
real :: a(n,m), b(m,n)

b = transpose(a)
194
Circular shift of a two-dimensional array
Given an array a, set b to an array which has the values of a along its second dimension shifted by n. Elements shifted out should come back at the other end. 
b = cshift(a,n,dim=2)
195
Pass a two-dimensional array
Pass an array a of real numbers to the procedure (resp. function) foo. Output the size of the array, and the sum of all its elements when each element is multiplied with the array indices i and j (assuming they start from one). 
subroutine foo(a)
  implicit none
  real, dimension(:,:) :: a
  real :: s
  integer :: i,j
  print *,size(a,1), size(a,2)
  s = 0
  do j=1,size(a,2)
    do i=1,size(a,1)
      s = s + a(i,j) * i * j
    end do
  end do
  print *,s
end subroutine foo
!
  call foo(a)
196
Pass a sub-array
Given an integer array a of size n, pass the first, third, fifth and seventh, ... up to the m th element to a routine foo which sets all these elements to 42. 
! Caller:
  integer, dimension(n) :: a
  call foo(a(1:m:2))

! Callee:

  subroutine foo(a)
    integer, dimension(:), intent(inout) :: a
    a = 42
  end subroutine foo
198
Abort program execution with error condition
Abort program execution with error condition x (where x is an integer value) 
STOP 1
200
Return hypotenuse
Compute the hypotenuse h of the triangle where the sides adjacent to the square angle have lengths x and y. 
h = hypot(x,y)
201
Euclidean norm
Calculate n, the Euclidean norm of data (an array or list of floating point values). 
n = norm2( data )
202
Sum of squares
Calculate the sum of squares s of data, an array of floating point values. 
s = sum( data**2 )
203
Calculate mean and standard deviation
Calculate the mean m and the standard deviation s of the list of floating point values data. 
real, allocatable :: data(:)
real :: m, s
...
m = sum( data ) / size( data )
s = sqrt( sum( data**2 ) / size( data ) - m**2 )
204
Return fraction and exponent of a real number
Given a real number a, print the fractional part and the exponent of the internal representation of that number. For 3.14, this should print (approximately)

0.785 2
 
a = 3.14
print *,fraction(a), exponent(a)
205
Get an environment variable
Read an environment variable with the name "FOO" and assign it to the string variable foo. If it does not exist or if the system does not support environment variables, assign a value of "none". 
  call get_environment_variable ("FOO", length=n, status=st)
  if (st /= 0) then
    foo = "none"
  else
    allocate (character(len=n) :: foo)
    call get_environment_variable ("FOO", value=foo)
  end if
206
Switch statement with strings
Execute different procedures foo, bar, baz and barfl if the string str contains the name of the respective procedure. Do it in a way natural to the language. 
  select case (str)
  case ("foo")
     call foo
  case ("bar")
     call bar
  case ("baz")
     call baz
  case ("barfl")
     call barfl
  end select
207
Allocate a list that is automatically deallocated
Allocate a list a containing n elements (n assumed to be too large for a stack) that is automatically deallocated when the program exits the scope it is declared in. 
  integer, dimension(:), allocatable :: a
  allocate (a(n))
208
Formula with arrays
Given the arrays a,b,c,d of equal length and the scalar e, calculate a = e*(a+b*c+cos(d)).
Store the results in a. 
a = e*(a+b*c+cos(d))
209
Type with automatic deep deallocation
Declare a type t which contains a string s and an integer array n with variable size, and allocate a variable v of type t. Allocate v.s and v.n and set them to the values "Hello, world!" for s and [1,4,9,16,25], respectively. Deallocate v, automatically deallocating v.s and v.n (no memory leaks). 
  type t
    character(len=:), allocatable :: c
    integer, dimension(:), allocatable :: n
  end type t
  type(t), allocatable :: v

  allocate (v)
  v%s = 'Hello, world!'
  v%n = [1,4,9,16,25]

  deallocate (v)
210
Compiler version and options
Assign, at runtime, the compiler version and the options the program was compiled with to variables version and options, respectively, and print them. For interpreted languages, substitute the version of the interpreter.

Example output:

GCC version 10.0.0 20190914 (experimental)
-mtune=generic -march=x86-64
 
  character(len=:), allocatable :: version, options
  version = compiler_version()
  options = compiler_options()
  print *,version
  print *,options
214
Pad string on the right
Append extra character c at the end of string s to make sure its length is at least m.
The length is the number of characters, not the number of bytes. 
CHARACTER(N) ::  FOO
215
Pad string on the left
Prepend extra character c at the beginning of string s to make sure its length is at least m.
The length is the number of characters, not the number of bytes. 
repeat(x,max(n-len(s),0)) // s
216
Pad a string on both sides
Add the extra character c at the beginning and ending of string s to make sure its length is at least m.
After the padding the original content of s should be at the center of the result.
The length is the number of characters, not the number of bytes.

E.g. with s="abcd", m=10 and c="X" the result should be "XXXabcdXXX". 
  i = (m-len(s))/2
  j = (m - len(s)) - (m-len(s))/2
  s = repeat(c,i) // s // repeat(c,j)
222
Find the first index of an element in list
Set i to the first index in list items at which the element x can be found, or -1 if items does not contain x. 
i = findloc(items, x)
if (i == 0) i = -1
223
for else loop
Loop through list items checking a condition. Do something else if no matches are found.

A typical use case is looping through a series of containers looking for one that matches a condition. If found, an item is inserted; otherwise, a new container is created.

These are mostly used as an inner nested loop, and in a location where refactoring inner logic into a separate function reduces clarity. 
  found = .false.
  do i=1,size(items)
    if (items(i) == "asdf") then
      found = .true.
      exit
    end if
  end do
  if (.not. found) call do_something
224
Add element to the beginning of the list
Insert the element x at the beginning of the list items. 
items = [x, items]
225
Declare and use an optional argument
Declare an optional integer argument x to procedure f, printing out "Present" and its value if it is present, "Not present" otherwise 
subroutine f(x)
  integer, optional :: x
  if (present(x)) then
    print *,"Present", x
  else
    print *,"Not present"
  end if
end subroutine f
226
Delete last element from list
Remove the last element from the list items. 
items = items(1:size(items)-1)
227
Copy a list
Create the new list y containing the same elements as the list x.

Subsequent modifications of y must not affect x (except for the contents referenced by the elements themselves if they contain pointers). 
type (foo), allocatable, dimension(:) :: y
y = x
228
Copy a file
Copy the file at path src to dst. 
character, dimension(n_buff) :: buffer
open (newunit=u_r,file="src", action="read", form="unformatted", &
       access="stream")
open(newunit=u_w,file="dst", action="write", form="unformatted",&
     access="stream") 
inquire(unit=u_r,size=sz)
do while (sz > 0)
   n_chunk = min(sz, n_buff)
   read (unit=u_r) buffer(1:n_chunk)
   write (unit=u_w) buffer(1:n_chunk)
   sz = sz - n_chunk
end do
237
Xor integers
Assign to c the result of (a xor b) 
c = ieor(a,b)
238
Xor byte arrays
Write in a new byte array c the xor result of byte arrays a and b.

a and b have the same size. 
integer(kind=int8), dimension(:) :: a, b, c
! Assign values to a and b
c = ieor(a,b)
243
Print list
Print the contents of the list or array a on the standard output. 
write (*,*) a
247
Filter list in-place
Remove all the elements from list x that don't satisfy the predicate p, without allocating a new list.
Keep all the elements that do satisfy p.

For languages that don't have mutable lists, refer to idiom #57 instead. 
x = pack(x,.not.p())
248
Construct a 64-bit floating-point value
Construct the "double precision" (64-bit) floating point number d from the mantissa m, the exponent e and the sign flag s (true means the sign is negative). 
  if (s) then
    d = -m * radix(d)**e
  else
    d =  m * radix(d)**e
  end if
249
Declare and assign multiple variables
Define variables a, b and c in a concise way.
Explain if they need to have the same type. 
integer :: a, b, c
251
Parse binary digits
Extract integer value i from its binary string representation s (in radix 2)
E.g. "1101" -> 13 
character (len=:), allocatable :: s
integer :: i  
s = '1101'
read (s,'(B4)') i
252
Conditional assignment
Assign to the variable x the string value "a" if calling the function condition returns true, or the value "b" otherwise. 
if (condition())
  x = a
else
  x = b
end if
254
Replace value in list
Replace all exact occurrences of "foo" with "bar" in the string list x 
  where (x == "foo")
     x = "bar"
  endwhere
256
Count backwards
Print the numbers 5, 4, ..., 0 (included), one line per number. 
do i=5,0,-1
  print *,i
end do
257
Traverse list backwards
Print each index i and value x from the list items, from the last down to the first. 
do i=size(items),1,-1
  print *,i,items(i)
end do
258
Convert list of strings to list of integers
Convert the string values from list a into a list of integers b. 
  allocate (b(size(a)))
  read (unit=a,fmt=*) b
260
Create an empty list of strings
Declare a new list items of string elements, containing zero elements 
character(len=:), allocatable, dimension(:) :: items
allocate (items(0),source="")
261
Format time hours-minutes-seconds
Assign to the string x the value of fields (hours, minutes, seconds) of the date d, in format HH:MM:SS. 
integer, dimension(8) :: d
character (len=8) :: x
call date_and_time (values=d)
write (unit=x,fmt='(I2.2,":",I2.2,":",I2.2)') d(5), d(6), d(7)
262
Count trailing zero bits
Assign to t the number of trailing 0 bits in the binary representation of the integer n.

E.g. for n=112, n is 1110000 in base 2 ⇒ t=4 
t = trailz(n)
263
Integer logarithm in base 2
Write two functions log2d and log2u, which calculate the binary logarithm of their argument n rounded down and up, respectively. n is assumed to be positive. Print the result of these functions for numbers from 1 to 12. 
program main
  implicit none
  integer :: i
  do i=1,12
     print *,i,log2d(i),log2u(i)
  end do
contains
  integer function log2d (n)
    integer, intent(in) :: n
    log2d = bit_size(n) - 1 - leadz(n)
  end function log2d

  integer function log2u (n)
    integer, intent(in) :: n
    log2u = bit_size(n) - leadz(n-1)
  end function log2u
end program main
264
Automated passing of array bounds
Pass a two-dimensional integer array a to a procedure foo and print the size of the array in each dimension. Do not pass the bounds manually. Call the procedure with a two-dimensional array. 
module x
contains
  subroutine foo(a)
    integer, dimension(:,:) :: a
    print *,size(a,1), size(a,2)
  end subroutine foo
end module x

program main
  use x
  integer, dimension(5,10) :: a
  call foo(a)
end program main
265
Even parity bit
Calculate the parity p of the integer variable i : 0 if it contains an even number of bits set, 1 if it contains an odd number of bits set. 
print *,poppar(i)
266
Repeated string
Assign to the string s the value of the string v repeated n times, and write it out.

E.g. v="abc", n=5 ⇒ s="abcabcabcabcabc" 
character(len=:), allocatable :: s,v
integer :: n
s = repeat(v,20)
write (*,'(A)') s
267
Pass string to argument that can be of any type
Declare an argument x to a procedure foo that can be of any type. If the type of the argument is a string, print it, otherwise print "Nothing."

Test by passing "Hello, world!" and 42 to the procedure. 
program main
  call foo("Hello, world!")
  call foo(42)
contains
  subroutine foo(x)
    class(*), intent(in) :: x
    select type(x)
    type is (character(len=*))
       write (*,'(A)') x
    class default
       write (*,'(A)') "Nothing."
    end select
  end subroutine foo
end program main
268
User-defined operator
Define a type vector containing three floating point numbers x, y, and z. Write a user-defined operator x that calculates the cross product of two vectors a and b. 
module vect
  private
  type, public:: vector
     real :: x,y,z
  end type vector
  public:: operator(.x.)
  interface operator(.x.)
     procedure vector_cross
  end interface operator(.x.)
contains
  function vector_cross(a,b) result(c)
    type(vector), intent(in) :: a,b
    type(vector) :: c
    c%x = a%y*b%z - a%z*b%y
    c%y = a%z*b%x - a%x*b%z
    c%z = a%x*b%y - a%y*b%x
  end function vector_cross
end module vect
270
Test for quiet or signaling NaN
Given a floating point number r1 classify it as follows:
If it is a signaling NaN, print "This is a signaling NaN."
If it is a quiet NaN, print "This s a quiet NaN."
If it is not a NaN, print "This is a number."
 
  character (len=:), allocatable :: msg
  if (ieee_support_nan(r1)) then
     if (ieee_class(r1) == ieee_quiet_nan) then
        msg = "This s a quiet NaN."
     else if (ieee_class(r1) == ieee_signaling_nan) then
        msg = "This is a signaling NaN."
     else
        msg = "This is a number."
     end if
  else
     msg = "NaNs are not supported."
  end if
  write (*,'(A)') msg
271
Test for type extension
If a variable x passed to procedure tst is of type foo, print "Same type." If it is of a type that extends foo, print "Extends type." If it is neither, print "Not related." 
  subroutine tst (x)
    class (*), intent(in) :: x
    type (foo) :: y
    if (same_type_as (x,y)) then
       write (*,'(A)') "Same type."
    else if (extends_type_of (x,y)) then
       write (*,'(A)') "Extends type."
    else
       write (*,'(A)') "Not related."
    end if
  end subroutine tst
272
Play FizzBuzz
Fizz buzz is a children's counting game, and a trivial programming task used to affirm that a programmer knows the basics of a language: loops, conditions and I/O.

The typical fizz buzz game is to count from 1 to 100, saying each number in turn. When the number is divisible by 3, instead say "Fizz". When the number is divisible by 5, instead say "Buzz". When the number is divisible by both 3 and 5, say "FizzBuzz" 
  integer :: i
  logical :: fizz, buzz
  do i=1,100
     fizz = mod(i,3) == 0
     buzz = mod(i,5) == 0
     if (fizz) write (*,'(A)',advance="no") 'Fizz'
     if (buzz) write (*,'(A)',advance="no") 'Buzz'
     if (.not. fizz .and. .not. buzz) write (*,'(I0)',advance="no") i
     write (*,'(A)',advance="no") ', '
  end do
  write (*,'()')
end program
275
Binary digits to byte array
From the string s consisting of 8n binary digit characters ('0' or '1'), build the equivalent array a of n bytes.
Each chunk of 8 binary digits (2 possible values per digit) is decoded into one byte (256 possible values). 
  subroutine to_s (s, a)
    use iso_fortran_env, only: int8
    character (len=*), intent(in) :: s
    integer (kind=int8), allocatable, intent(out), dimension(:) :: a
    allocate (a(len(s)/8))
    read (unit=s,fmt='(*(B8.8))') a
  end subroutine to_s
277
Remove an element from a set
Remove the element e from the set x.

Explains what happens if e was already absent from x. 
integer,allocatable::x(:)
integer::e=6
x=[2,4,6,8,10]
!remove 6
x=pack(x,x/=e)
280
Filter map
Remove all the elements from the map m that don't satisfy the predicate p.
Keep all the elements that do satisfy p.

Explain if the filtering happens in-place, i.e. if m is reused or if a new map is created. 
  real, dimension(:), allocatable :: a
  a = pack(a,p(a))
!
  elemental logical function p(x)
    real, intent(in) :: x
    p = x > 0.7
  end function p
284
Create a zeroed list of integers
Create a new list a (or array, or slice) of size n, where all elements are integers initialized with the value 0. 
integer, dimension(:), allocatable :: a

allocate(a(n),source = 0)
285
Set variable to NaN
Given two floating point variables a and b, set a to a to a quiet NaN and b to a signalling NaN. Use standard features of the language only, without invoking undefined behavior. 
 a = ieee_value (a, IEEE_QUIET_NAN)
 b = ieee_value (b, IEEE_SIGNALING_NAN)
286
Iterate over characters of a string
Print a line "Char i is c" for each character c of the string s, where i is the character index of c in s (not the byte index).

Make sure that multi-byte characters are properly handled, and count for a single character. 
  integer, parameter :: ucs4  = selected_char_kind ('ISO_10646')
  character(kind=ucs4,  len=30) :: s
open (output_unit, encoding='UTF-8')

do i=1,len(s)
  print *,"Char ", i, " is ", s(i:i)
end do
288
Check if set contains a value
Set the boolean b to true if the set x contains the element e, false otherwise. 
b = x(e)
289
Concatenate two strings
Create the string s by concatenating the strings a and b. 
s = a // b
291
Remove sublist
Delete all the elements from index i (included) to index j (excluded) from the list items. 
items = [items(:,i-1), items(j:)]
292
Write "Ni Hao" in Chinese to standard output in UTF-8
Write "Hello World and 你好" to standard output in UTF-8.
 
  integer, parameter :: ucs4  = selected_char_kind ('ISO_10646')
  character(kind=ucs4,  len=30) :: hello_world
  hello_world = ucs4_'Hello World and ' &
                // char (int (z'4F60'), ucs4)     &
                // char (int (z'597D'), ucs4)

  open (output_unit, encoding='UTF-8')
  write (*,*) trim (hello_world)
294
Print a comma-separated list of integers
Given an array a containing the three values 1, 12, 42, print out
"1, 12, 42" with a comma and a space after each integer except the last one.
 
  integer, dimension(:), allocatable :: a
  a = [1,12,42]
  write (*,'(*(I0:", "))') a
296
Replace last occurrence of substring
Assign to x2 the value of string x with the last occurrence of y replaced by z.
If y is not contained in x, then x2 has the same value as x. 
  character(len=:), allocatable :: x, x2, y, z

  k = index(x,y,back=.true.)
  if (k > 0) then
     x2 = x(1:k-1) // z // x(k+len(y):)
  else
     x2 = x
  end if
299
Comment out a single line
Write a line of comments.

This line will not be compiled or executed. 
! This is a comment.
301
Recursive Fibonacci sequence
Compute the Fibonacci sequence of n numbers using recursion.

Note that naive recursion is extremely inefficient for this task. 
  recursive function f (n) result(res)
    integer, value, intent(in) :: n
    integer :: res
    if (n == 0) then
       res = 0
    else if (n <= 2) then
       res = 1
    else
       if (mod(n,2) == 1) then
          res = f((n + 1)/2)**2 + f((n - 1)/2)**2
       else
          res = f(n/2) * (f(n/2-1) + f(n/2 + 1))
       end if
    end if
  end function f
302
String interpolation
Given the integer x = 8, assign to the string s the value "Our sun has 8 planets", where the number 8 was evaluated from x. 
  write (unit=s,fmt='(*(G0))') "Our sun has ",x," planets."
303
Array with non-default lower bound
Declare an array a of integers with six elements, where the first index is 42 and consecutive elements have the indices 43, 44, 45, 46, 47. 
  integer, dimension(42:47) :: a
305
Calculate exponentiation of real numbers
Compute and print a^b, and a^n, where a and b are floating point numbers and n is an integer.
 
  print *,a**b, a**n
309
Clone a 2D array
Create the new 2-dimensional array y containing a copy of the elements of the 2-dimensional array x.

x and y must not share memory. Subsequent modifications of y must not affect x. 
integer, allocatable, dimension(:,:) :: y

y = x
310
Fill array with random bytes
Fill the byte array a with randomly generated bytes. 
  real, dimension(100) :: b
  integer(int8), dimension(100) :: a
  call random_number(b)
  a = b*256 - 128
312
List equality
Set b to true if the lists p and q have the same size and the same elements, false otherwise. 
  if (size(p,1) /= size(q,1)) then
    b = false
  else
    b = all (p == q)
  end if
314
Fill array with value
Set all the elements in the array x to the same value v 
x = v
316
Count occurrences in a list
Determine the number c of elements in the list x that satisfy the predicate p. 
  
c=count(p(x))
321
Access character in string, by index
Assign to c the value of the i-th character of the string s.

Make sure to properly handle multi-byte characters. i is the character index, which may not be equal to the byte index. 
 c = s(i:i)
336
Exponent
Compute x = b ⁿ

b raised to the power of n is equal to the product of n terms b × b × ... × b 
x = b ** n