!Implemented by Anant Dixit (October, 2014)
program animated_pendulum
implicit none
double precision, parameter :: pi = 4.0D0*atan(1.0D0), l = 1.0D-1, dt = 1.0D-2, g = 9.8D0
integer :: io
double precision :: s_ang, c_ang, p_ang, n_ang

write(*,*) 'Enter starting angle (in degrees):'
do
  read(*,*,iostat=io) s_ang
  if(io.ne.0 .or. s_ang.lt.-90.0D0 .or. s_ang.gt.90.0D0) then
    write(*,*) 'Please enter an angle between 90 and -90 degrees:'
  else
    exit
  end if
end do
call execute_command_line('cls')

c_ang = s_ang*pi/180.0D0
p_ang = c_ang

call display(c_ang)
do
  call next_time_step(c_ang,p_ang,g,l,dt,n_ang)
  if(abs(c_ang-p_ang).ge.0.05D0) then
    call execute_command_line('cls')
    call display(c_ang)
  end if
end do
end program

subroutine next_time_step(c_ang,p_ang,g,l,dt,n_ang)
double precision :: c_ang, p_ang, g, l, dt, n_ang
n_ang = (-g*sin(c_ang)/l)*2.0D0*dt**2 + 2.0D0*c_ang - p_ang
p_ang = c_ang
c_ang = n_ang
end subroutine

subroutine display(c_ang)
double precision :: c_ang
character (len=*), parameter :: cfmt = '(A1)'
double precision :: rx, ry
integer :: x, y, i, j
rx = 45.0D0*sin(c_ang)
ry = 22.5D0*cos(c_ang)
x = int(rx)+51
y = int(ry)+2
do i = 1,32
  do j = 1,100
    if(i.eq.y .and. j.eq.x) then
      write(*,cfmt,advance='no') 'O'
    else if(i.eq.y .and. (j.eq.(x-1).or.j.eq.(x+1))) then
      write(*,cfmt,advance='no') 'G'
    else if(j.eq.x .and. (i.eq.(y-1).or.i.eq.(y+1))) then
      write(*,cfmt,advance='no') 'G'
    else if(i.eq.y .and. (j.eq.(x-2).or.j.eq.(x+2))) then
      write(*,cfmt,advance='no') '#'
    else if(j.eq.x .and. (i.eq.(y-2).or.i.eq.(y+2))) then
      write(*,cfmt,advance='no') 'G'
    else if((i.eq.(y+1).and.j.eq.(x+1)) .or. (i.eq.(y-1).and.j.eq.(x-1))) then
      write(*,cfmt,advance='no') '#'
    else if((i.eq.(y+1).and.j.eq.(x-1)) .or. (i.eq.(y-1).and.j.eq.(x+1))) then
      write(*,cfmt,advance='no') '#'
    else if(j.eq.50) then
      write(*,cfmt,advance='no') '|'
    else if(i.eq.2) then
      write(*,cfmt,advance='no') '-'
    else
      write(*,cfmt,advance='no') ' '
    end if
  end do
  write(*,*)
end do
end subroutine

                                                 |
-------------------------------------------------|--------------------------------------------------
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |                G
                                                 |               #G#
                                                 |              #GOG#
                                                 |               #G#
                                                 |                G
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |

                                                 |
-------------------------------------------------|--------------------------------------------------
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |                       G
                                                 |                      #G#
                                                 |                     #GOG#
                                                 |                      #G#
                                                 |                       G
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |

                                                 |
-------------------------------------------------|--------------------------------------------------
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |                            G
                                                 |                           #G#
                                                 |                          #GOG#
                                                 |                           #G#
                                                 |                            G
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |

                                                 |
-------------------------------------------------|--------------------------------------------------
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |                                 G
                                                 |                                #G#
                                                 |                               #GOG#
                                                 |                                #G#
                                                 |                                 G
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |

                                                 |
-------------------------------------------------|--------------------------------------------------
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |                                     G
                                                 |                                    #G#
                                                 |                                   #GOG#
                                                 |                                    #G#
                                                 |                                     G
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |

                                                 |
-------------------------------------------------|--------------------------------------------------
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |                                       G
                                                 |                                      #G#
                                                 |                                     #GOG#
                                                 |                                      #G#
                                                 |                                       G
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |

                                                 |
-------------------------------------------------|--------------------------------------------------
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |                                         G
                                                 |                                        #G#
                                                 |                                       #GOG#
                                                 |                                        #G#
                                                 |                                         G
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |

                                                 |
-------------------------------------------------|--------------------------------------------------
                                                 |
                                                 |
                                                 |
                                                 |                                          G
                                                 |                                         #G#
                                                 |                                        #GOG#
                                                 |                                         #G#
                                                 |                                          G
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |
                                                 |

The code simulates and animates a simple gravity pendulum. It uses system commands to clear the screen and allows an initial starting angle between -90 and 90 degrees, checking for incorrect inputs. It also provides a small preview of the pendulum's motion with an example of an initial angle of 80 degrees.


{
  "PhoneBook": [
    {
      "name": "Adam",
      "phone": "0000001"
    },
    {
      "name": "Eve",
      "phone": "0000002"
    },
    {
      "name": "Julia",
      "phone": "6666666"
    }
  ]
}

program json_fortran
   use json_module
   implicit none

   type phonebook_type
      character(len=:),allocatable :: name
      character(len=:),allocatable :: phone
   end type phonebook_type

   type(phonebook_type), dimension(3) :: PhoneBook
   integer :: i
   type(json_value),pointer :: json_phonebook,p,e
   type(json_file) :: json

   PhoneBook(1) % name = 'Adam'
   PhoneBook(2) % name = 'Eve'
   PhoneBook(3) % name = 'Julia'
   PhoneBook(1) % phone = '0000001'
   PhoneBook(2) % phone = '0000002'
   PhoneBook(3) % phone = '6666666'

   call json_initialize()

   !create the root structure:
   call json_create_object(json_phonebook,'')

   !create and populate the phonebook array:
   call json_create_array(p,'PhoneBook')
   do i=1,3
      call json_create_object(e,'')
      call json_add(e,'name',PhoneBook(i)%name)
      call json_add(e,'phone',PhoneBook(i)%phone)
      call json_add(p,e) !add this element to array
      nullify(e) !cleanup for next loop
   end do
   call json_add(json_phonebook,p) !add p to json_phonebook
   nullify(p) !no longer need this

   !write it to a file:
   call json_print(json_phonebook,'phonebook.json')

   ! read directly from a character string
   call json%load_from_string('{ "PhoneBook": [ { "name": "Adam", "phone": "0000001" },&
   { "name": "Eve", "phone": "0000002" }, { "name": "Julia", "phone": "6666666" } ]}')
   ! print it to the console
   call json%print_file()

end program json_fortran

"Loads a JSON string into a data structure, creates a new data structure, serializes it into JSON using objects and arrays, and validates the JSON using json-fortran library and jsonformatter.org. It also includes functionality for creating a JSON example file and reading a JSON string."


program NthRootTest
  implicit none

  print *, nthroot(10, 7131.5**10)
  print *, nthroot(5, 34.0)

contains

  function nthroot(n, A, p)
    real :: nthroot
    integer, intent(in)        :: n
    real, intent(in)           :: A
    real, intent(in), optional :: p

    real :: rp, x(2)

    if ( A < 0 ) then
       stop "A < 0"       ! we handle only real positive numbers
    elseif ( A == 0 ) then
       nthroot = 0
       return
    end if

    if ( present(p) ) then
       rp = p
    else
       rp = 0.001
    end if

    x(1) = A
    x(2) = A/n   ! starting "guessed" value...

    do while ( abs(x(2) - x(1)) > rp )
       x(1) = x(2)
       x(2) = ((n-1.0)*x(2) + A/(x(2) ** (n-1.0)))/real(n)
    end do

    nthroot = x(2)

  end function nthroot

end program NthRootTest

Implement the principal nth root algorithm for a positive real number A.


Works with: gfortran

program HostTest
  character(len=128) :: name
  call hostnm(name)
  print *, name
end program HostTest

program test_hostname
   use, intrinsic  :: iso_c_binding
   implicit none
   interface !to function: int gethostname(char *name, size_t namelen);
      integer(c_int) function gethostname(name, namelen) bind(c)
         use, intrinsic  :: iso_c_binding, only: c_char, c_int, c_size_t
         integer(c_size_t), value, intent(in) :: namelen
         character(len=1,kind=c_char), dimension(namelen),  intent(inout) ::  name
      end function gethostname
   end interface
   integer(c_int) :: status
   integer,parameter :: HOST_NAME_MAX=255
   character(kind=c_char,len=1),dimension(HOST_NAME_MAX) :: cstr_hostname
   integer(c_size_t) :: lenstr
   character(len=:),allocatable :: hostname
   lenstr = HOST_NAME_MAX
   status = gethostname(cstr_hostname, lenstr)
   hostname = c_to_f_string(cstr_hostname)
   write(*,*) hostname, len(hostname)

 contains
   ! convert c_string to f_string
   pure function c_to_f_string(c_string) result(f_string)
      use, intrinsic :: iso_c_binding, only: c_char, c_null_char
      character(kind=c_char,len=1), intent(in) :: c_string(:)
      character(len=:), allocatable :: f_string
      integer i, n
      i = 1
      do
         if (c_string(i) == c_null_char) exit
         i = i + 1
      end do
      n = i - 1  ! exclude c_null_char
      allocate(character(len=n) :: f_string)
      f_string = transfer(c_string(1:n), f_string)
   end function c_to_f_string

end program test_hostname

The code uses the HOSTNM subroutine, a GNU extension, to find the name of the host where the routine is running. It utilizes Fortran 2003 C-interoperability to directly call the posix C function gethostname, a unix system call.


The method relies on producing a sequence of values, rather than calculating L(n) from the start each time a value from the sequence is required.       SUBROUTINE LEONARDO(LAST,L0,L1,AF)	!Show the first LAST values of the sequence.
       INTEGER LAST	!Limit to show.
       INTEGER L0,L1	!Starting values.
       INTEGER AF	!The "Add factor" to deviate from Fibonacci numbers.
       OPTIONAL AF	!Indicate that this parameter may be omitted.
       INTEGER EMBOLISM	!The bloat to employ.
       INTEGER N,LN,LNL1,LNL2	!Assistants to the calculation.
        IF (PRESENT(AF)) THEN	!Perhaps the last parameter has not been given.
          EMBOLISM = AF			!It has. Take its value.
         ELSE			!But if not,
          EMBOLISM = 1			!This is the specified default.
        END IF			!Perhaps there should be some report on this?
        WRITE (6,1) LAST,L0,L1,EMBOLISM	!Announce.
    1   FORMAT ("The first ",I0,	!The I0 format code avoids excessive spacing.
     1   " numbers in the Leonardo sequence defined by L(0) = ",I0,
     2   " and L(1) = ",I0," with L(n) = L(n - 1) + L(n - 2) + ",I0)
        IF (LAST .GE. 1) WRITE (6,2) L0	!In principle, LAST may be small.
        IF (LAST .GE. 2) WRITE (6,2) L1	!!So, suspicion rules.
    2   FORMAT (I0,", ",$)	!Obviously, the $ sez "don't finish the line".
        LNL1 = L0	!Syncopation for the sequence's initial values.
        LN = L1		!Since the parameters ought not be damaged.
        DO N = 3,LAST	!Step away.
          LNL2 = LNL1		!Advance the two state variables one step.
          LNL1 = LN		!Ready to make a step forward.
          LN = LNL1 + LNL2 + EMBOLISM	!Thus.
          WRITE (6,2) LN	!Reveal the value. Overflow is distant...
        END DO		!On to the next step.
        WRITE (6,*)	!Finish the line.
      END SUBROUTINE LEONARDO	!Only speedy for the sequential production of values.

      PROGRAM POKE

      CALL LEONARDO(25,1,1,1)	!The first 25 Leonardo numbers.
      CALL LEONARDO(25,0,1,0)	!Deviates to give the Fibonacci sequence.
      END

The first 25 numbers in the Leonardo sequence defined by L(0) = 1 and L(1) = 1 with L(n) = L(n - 1) + L(n - 2) + 1
1, 1, 3, 5, 9, 15, 25, 41, 67, 109, 177, 287, 465, 753, 1219, 1973, 3193, 5167, 8361, 13529, 21891, 35421, 57313, 92735, 150049,
The first 25 numbers in the Leonardo sequence defined by L(0) = 0 and L(1) = 1 with L(n) = L(n - 1) + L(n - 2) + 0
0, 1, 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, 144, 233, 377, 610, 987, 1597, 2584, 4181, 6765, 10946, 17711, 28657, 46368,

The code calculates and displays the first 25 Leonardo numbers, starting from L(0). It allows the first two Leonardo numbers (L(0) and L(1)) and the add number to be specified, with 1 as the default value for the add number. The code also shows the first 25 Leonardo numbers when 0 and 1 are specified for L(0) and L(1) respectively, and 0 for the add number, which results in the Fibonacci sequence. The code uses 32-bit integers and the F90 facilities for subroutine naming and integer formatting. The code also handles optional parameters.


Clever implementation[edit]

program game_24
  implicit none
  real               :: vector(4), reals(11), result, a, b, c, d
  integer            :: numbers(4), ascii(11), i
  character(len=11)  :: expression
  character          :: syntax(11)
  ! patterns:
  character, parameter :: one(11)   = (/ '(','(','1','x','1',')','x','1',')','x','1' /)
  character, parameter :: two(11)   = (/ '(','1','x','(','1','x','1',')',')','x','1' /)
  character, parameter :: three(11) = (/ '1','x','(','(','1','x','1',')','x','1',')' /)
  character, parameter :: four(11)  = (/ '1','x','(','1','x','(','1','x','1',')',')' /)
  character, parameter :: five(11)  = (/ '(','1','x','1',')','x','(','1','x','1',')' /)

  do
    call random_number(vector)
    numbers = 9 * vector + 1
    write (*,*) 'Digits: ',numbers
    write (*,'(a)',advance='no') 'Your expression: '
    read (*,'(a11)') expression

    forall (i=1:11) syntax(i) = expression(i:i)
    ascii = iachar(syntax)
    where (syntax >= '0' .and. syntax <= '9')
      syntax = '1'  ! number
    elsewhere (syntax == '+' .or. syntax == '-' .or. syntax == '*' .or. syntax == '/')
      syntax = 'x'  ! op
    elsewhere (syntax /= '(' .and. syntax /= ')')
      syntax = '-'  ! error
    end where

    reals = real(ascii-48)
    if ( all(syntax == one) ) then
      a = reals(3); b = reals(5); c = reals(8); d = reals(11)
      call check_numbers(a,b,c,d)
      result = op(op(op(a,4,b),7,c),10,d)
    else if ( all(syntax == two) ) then
      a = reals(2); b = reals(5); c = reals(7); d = reals(11)
      call check_numbers(a,b,c,d)
      result = op(op(a,3,op(b,6,c)),10,d)
    else if ( all(syntax == three) ) then
      a = reals(1); b = reals(5); c = reals(7); d = reals(10)
      call check_numbers(a,b,c,d)
      result = op(a,2,op(op(b,6,c),9,d))
    else if ( all(syntax == four) ) then
      a = reals(1); b = reals(4); c = reals(7); d = reals(9)
      call check_numbers(a,b,c,d)
      result = op(a,2,op(b,5,op(c,8,d)))
    else if ( all(syntax == five) ) then
      a = reals(2); b = reals(4); c = reals(8); d = reals(10)
      call check_numbers(a,b,c,d)
      result = op(op(a,3,b),6,op(c,9,d))
    else
      stop 'Input string: incorrect syntax.'
    end if

    if ( abs(result-24.0) < epsilon(1.0) ) then
      write (*,*) 'You won!'
    else
      write (*,*) 'Your result (',result,') is incorrect!'
    end if

    write (*,'(a)',advance='no') 'Another one? [y/n] '
    read (*,'(a1)') expression
    if ( expression(1:1) == 'n' .or. expression(1:1) == 'N' ) then
      stop
    end if
  end do

contains

  pure real function op(x,c,y)
    integer, intent(in) :: c
    real, intent(in) :: x,y
    select case ( char(ascii(c)) )
      case ('+')
        op = x+y
      case ('-')
        op = x-y
      case ('*')
        op = x*y
      case ('/')
        op = x/y
    end select
  end function op

  subroutine check_numbers(a,b,c,d)
    real, intent(in) :: a,b,c,d
    integer          :: test(4)
    test = (/ nint(a),nint(b),nint(c),nint(d) /)
    call Insertion_Sort(numbers)
    call Insertion_Sort(test)
    if ( any(test /= numbers) ) then
      stop 'You cheat ;-) (Incorrect numbers)'
    end if
  end subroutine check_numbers

  pure subroutine Insertion_Sort(a)
    integer, intent(inout) :: a(:)
    integer                :: temp, i, j
    do i=2,size(a)
      j = i-1
      temp = a(i)
      do while ( j>=1 .and. a(j)>temp )
        a(j+1) = a(j)
        j = j - 1
      end do
      a(j+1) = temp
    end do
  end subroutine Insertion_Sort

end program game_24

As a more general recursive descent parser:[edit]

! implement a recursive descent parser
module evaluate_algebraic_expression

  integer, parameter :: size = 124
  character, parameter :: statement_end = achar(0)
  character(len=size) :: text_to_parse
  integer :: position
  data position/0/,text_to_parse/' '/

contains

  character function get_token()
    ! return the current token
    implicit none
    if (position <= size) then
       get_token = text_to_parse(position:position)
       do while (get_token <= ' ')
          call advance
          if (size < position) exit
          get_token = text_to_parse(position:position)
       end do
    end if
    if (size < position) get_token = statement_end
  end function get_token

  subroutine advance ! consume a token.  Move to the next token.  consume_token would have been a better name.
    position = position + 1
  end subroutine advance

  logical function unfinished()
    unfinished = get_token() /= statement_end
  end function unfinished

  subroutine parse_error()
    write(6,*)'"'//get_token()//'" unexpected in expression at',position
    stop 1
  end subroutine parse_error

  function precedence3() result(a)
    implicit none
    real :: a
    character :: token
    character(len=10), parameter :: digits = '0123456789'
    token = get_token()
    if (verify(token,digits) /= 0) call parse_error()
    a = index(digits, token) - 1
    call advance()
  end function precedence3

  recursive function precedence2() result(a)
    real :: a
    character :: token
    token = get_token()
    if (token /= '(') then
       a = precedence3()
    else
       call advance
       a = precedence0()
       token = get_token()
       if (token /= ')') call parse_error()
       call advance
    end if
  end function precedence2

  recursive function precedence1() result(a)
    implicit none
    real :: a
    real, dimension(2) :: argument
    character(len=2), parameter :: tokens = '*/'
    character :: token
    a = 0
    token = get_token()
    argument(1) = precedence2()
    token = get_token()
    do while (verify(token,tokens) == 0)
       call advance()
       argument(2) = precedence2()
       if (token == '/') argument(2) = 1 / argument(2)
       argument(1) = product(argument)
       token = get_token()
    end do
    a = argument(1)
  end function precedence1

  recursive function precedence0() result(a)
    implicit none
    real :: a
    real, dimension(2) :: argument
    character(len=2), parameter :: tokens = '+-'
    character :: token
    a = 0
    token = get_token()
    argument(1) = precedence1()
    token = get_token()
    do while (verify(token,tokens) == 0)
       call advance()
       argument(2) = precedence1()
       if (token == '-') argument = argument * (/1, -1/)
       argument(1) = sum(argument)
       token = get_token()
    end do
    a = argument(1)
  end function precedence0

  real function statement()
    implicit none
    if (unfinished()) then
       statement = precedence0()
    else                        !empty okay
       statement = 0
    end if
    if (unfinished()) call parse_error()
  end function statement

  real function evaluate(expression)
    implicit none
    character(len=*), intent(in) :: expression
    text_to_parse = expression
    evaluate = statement()
  end function evaluate

end module evaluate_algebraic_expression

program g24
  use evaluate_algebraic_expression
  implicit none
  integer, dimension(4) :: digits
  character(len=78) :: expression
  real :: result
  ! integer :: i
  call random_seed!easily found internet examples exist to seed by /dev/urandom or time
  call deal(digits)
  ! do i=1, 9999 ! produce the data to test digit distribution
  !   call deal(digits)
  !   write(6,*) digits
  ! end do
  write(6,'(a13,4i2,a26)')'Using digits',digits,', and the algebraic dyadic'
  write(6,*)'operators +-*/() enter an expression computing 24.'
  expression = ' '
  read(5,'(a78)') expression
  if (invalid_digits(expression, digits)) then
     write(6,*)'invalid digits'
  else
     result = evaluate(expression)
     if (nint(result) == 24) then
        write(6,*) result, ' close enough'
     else
        write(6,*) result, ' no good'
     end if
  end if

contains

  logical function invalid_digits(e,d) !verify the digits
    implicit none
    character(len=*), intent(in) :: e
    integer, dimension(4), intent(inout) :: d
    integer :: i, j, k, count
    logical :: unfound
    count = 0
    invalid_digits = .false. !validity assumed
    !write(6,*)'expression:',e(1:len_trim(e))
    do i=1, len_trim(e)
       if (verify(e(i:i),'0123456789') == 0) then
          j = index('0123456789',e(i:i))-1
          unfound = .true.
          do k=1, 4
             if (j == d(k)) then
                unfound = .false.
                exit
             end if
          end do
          if (unfound) then
             invalid_digits = .true.
             !return or exit is okay here
          else
             d(k) = -99
             count = count + 1
          end if
       end if
    end do
    invalid_digits = invalid_digits .or. (count /= 4)
  end function invalid_digits

  subroutine deal(digits)
    implicit none
    integer, dimension(4), intent(out) :: digits
    integer :: i
    real :: harvest
    call random_number(harvest)
    do i=1, 4
       digits(i) = int(mod(harvest*9**i, 9.0))   + 1
    end do
    !    NB. computed with executable Iverson notation, www.jsoftware.oom
    !    #B NB. B are the digits from 9999 deals
    ! 39996
    !    ({.,#)/.~/:~B  # show the distribution of digits
    ! 0 4380
    ! 1 4542
    ! 2 4348
    ! 3 4395
    ! 4 4451
    ! 5 4474
    ! 6 4467
    ! 7 4413
    ! 8 4526
    !    NB. this also shows that I forgot to add 1.  Inserting now...
  end subroutine deal
end program g24

$ gfortran -g -O0 -std=f2008 -Wall f.f08 -o f.exe && echo '8*(9/9+2)' | ./f.exe
 Using digits 9 9 8 2, and the algebraic dyadic
 operators +-*/() enter an expression computing 24.
   24.000000      close enough
$
$
$
$ ./f.exe
$  Using digits 9 9 8 2, and the algebraic dyadic
$  operators +-*/() enter an expression computing 24.
$     8 *   ( 9 / 9  +    2   )
$    24.000000      close enough
$
$
$ ./f.exe
 Using digits 9 9 8 2, and the algebraic dyadic
 operators +-*/() enter an expression computing 24.
(((2+8+9+9)))
   28.000000      no good
$
$
$ ./f.exe
 Using digits 9 9 8 2, and the algebraic dyadic
 operators +-*/() enter an expression computing 24.
(((8+9-2+9)))
   24.000000      close enough
$
$ ./f.exe
 Using digits 9 9 8 2, and the algebraic dyadic
 operators +-*/() enter an expression computing 24.
8929
 "9" unexpected in expression at           2
STOP 1
$
$
$ ./f.exe
 Using digits 9 9 8 2, and the algebraic dyadic
 operators +-*/() enter an expression computing 24.
12348
 invalid digits
$
$
$ ./f.exe
 Using digits 9 9 8 2, and the algebraic dyadic
 operators +-*/() enter an expression computing 24.
892
 invalid digits
$
$
$ ./f.exe
 Using digits 9 9 8 2, and the algebraic dyadic
 operators +-*/() enter an expression computing 24.
8921
 invalid digits
$
$
$
$ ./f.exe
 Using digits 9 9 8 2, and the algebraic dyadic
 operators +-*/() enter an expression computing 24.
89291
 invalid digits
$
$
$
$ ./f.exe
 Using digits 9 9 8 2, and the algebraic dyadic
 operators +-*/() enter an expression computing 24.
9+x-2+8+9
 "x" unexpected in expression at           3
STOP 1
$
$
$
$ ./f.exe
 Using digits 9 9 8 2, and the algebraic dyadic
 operators +-*/() enter an expression computing 24.
(9-2)+8+(9
 "^@" unexpected in expression at         125
STOP 1
$
$
$
$ ./f.exe
 Using digits 9 9 8 2, and the algebraic dyadic
 operators +-*/() enter an expression computing 24.
(9-2)+8+(9)
   24.000000      close enough
$
$
$
$ ./f.exe
 Using digits 9 9 8 2, and the algebraic dyadic
 operators +-*/() enter an expression computing 24.
(9-2)+8/(9)
   7.8888888      no good
$

The code generates four random digits from 1 to 9 and prompts the player to form an arithmetic expression using these digits exactly once. The expression should evaluate to 24 using the operators: addition, subtraction, multiplication, and division. The code checks and evaluates the player's input expression, ensuring that the digit order is not necessarily preserved and multiple-digit numbers are not formed from the given digits. The code uses an expression evaluator, which could be an RPN evaluator, and Insertion_sort in Fortran. It also handles operator precedence, spaces, and arbitrary parentheses.


Works with: Fortran version 95 and later
program RLE
  implicit none

  integer, parameter :: bufsize = 100   ! Sets maximum size of coded and decoded strings, adjust as necessary
  character(bufsize) :: teststr = "WWWWWWWWWWWWBWWWWWWWWWWWWBBBWWWWWWWWWWWWWWWWWWWWWWWWBWWWWWWWWWWWWWW"
  character(bufsize) :: codedstr = "", decodedstr = ""

  call Encode(teststr, codedstr)
  write(*,"(a)") trim(codedstr)
  call Decode(codedstr, decodedstr)
  write(*,"(a)") trim(decodedstr)

contains

subroutine Encode(instr, outstr)
  character(*), intent(in)  :: instr
  character(*), intent(out) :: outstr
  character(8) :: tempstr = ""
  character(26) :: validchars = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  integer :: a, b, c, i

  if(verify(trim(instr), validchars) /= 0) then
    outstr = "Invalid input"
    return
  end if
  outstr = ""
  c = 1
  a = iachar(instr(1:1))
  do i = 2, len(trim(instr))
    b = iachar(instr(i:i))
    if(a == b) then
      c = c + 1
    else
      write(tempstr, "(i0)") c
      outstr = trim(outstr) // trim(tempstr) // achar(a)
      a = b
      c = 1
    end if
  end do
  write(tempstr, "(i0)") c
  outstr = trim(outstr) // trim(tempstr) // achar(b)
end subroutine

subroutine Decode(instr, outstr)
  character(*), intent(in)  :: instr
  character(*), intent(out) :: outstr
  character(26) :: validchars = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  integer :: startn, endn, n

  outstr = ""
  startn = 1
  do while(startn < len(trim(instr)))
    endn = scan(instr(startn:), validchars) + startn - 1
    read(instr(startn:endn-1), "(i8)") n
    outstr = trim(outstr) // repeat(instr(endn:endn), n)
    startn = endn + 1
  end do
end subroutine
end program

12W1B12W3B24W1B14W
WWWWWWWWWWWWBWWWWWWWWWWWWBBBWWWWWWWWWWWWWWWWWWWWWWWWBWWWWWWWWWWWWWW

implement a run-length encoding algorithm that compresses a string of uppercase characters by storing the length of consecutive identical characters, and also provide a function to reverse this compression.


program StringConcatenation

integer, parameter          :: maxstringlength = 64
character (maxstringlength) :: s1, s = "hello"

print *,s // " literal"
s1 = trim(s) // " literal"
print *,s1

end program

Initializes two string variables, one with a text value and the other as a concatenation of the first variable and a string literal, then displays their content.


Works with: Fortran version 90 and later
program KNAPSACK_CONTINUOUS
  implicit none

  real, parameter :: maxweight = 15.0
  real :: total_weight = 0, total_value = 0, frac
  integer :: i, j

  type Item
    character(7) :: name
    real :: weight
    real :: value
  end type Item

  type(Item) :: items(9), temp

  items(1) = Item("beef",    3.8, 36.0)
  items(2) = Item("pork",    5.4, 43.0)
  items(3) = Item("ham",     3.6, 90.0)
  items(4) = Item("greaves", 2.4, 45.0)
  items(5) = Item("flitch",  4.0, 30.0)
  items(6) = Item("brawn",   2.5, 56.0)
  items(7) = Item("welt",    3.7, 67.0)
  items(8) = Item("salami",  3.0, 95.0)
  items(9) = Item("sausage", 5.9, 98.0)

  ! sort items in descending order of their value per unit weight
  do i = 2, size(items)
     j = i - 1
     temp = items(i)
     do while (j>=1 .and. items(j)%value / items(j)%weight < temp%value / temp%weight)
       items(j+1) = items(j)
       j = j - 1
     end do
    items(j+1) = temp
  end do

  i = 0
  write(*, "(a4, a13, a6)") "Item", "Weight", "Value"
  do while(i < size(items) .and. total_weight < maxweight)
    i = i + 1
    if(total_weight+items(i)%weight < maxweight) then
      total_weight = total_weight + items(i)%weight
      total_value = total_value + items(i)%value
      write(*, "(a7, 2f8.2)") items(i)
    else
      frac = (maxweight-total_weight) / items(i)%weight
      total_weight = total_weight + items(i)%weight * frac
      total_value = total_value + items(i)%value * frac
      write(*, "(a7, 2f8.2)") items(i)%name, items(i)%weight * frac, items(i)%value * frac
    end if
  end do

  write(*, "(f15.2, f8.2)") total_weight, total_value

end program KNAPSACK_CONTINUOUS

determine the optimal combination of items a thief can steal from a butcher's shop without exceeding a total weight of 15 kg in his knapsack, with the possibility of cutting items proportionally to their original price, in order to maximize the total value.


!***************************************************************************************
	module anagram_routines
!***************************************************************************************
	implicit none

	!the dictionary file:
	integer,parameter :: file_unit = 1000
	character(len=*),parameter :: filename = 'unixdict.txt'

	!maximum number of characters in a word:
	integer,parameter :: max_chars = 50

	!maximum number of characters in the string displaying the anagram lists:
	integer,parameter :: str_len = 256

	type word
	  character(len=max_chars) :: str = repeat(' ',max_chars)    !the word from the dictionary
	  integer                  :: n = 0                          !length of this word
	  integer                  :: n_anagrams = 0	             !number of anagrams found
	  logical                  :: checked = .false.              !if this one has already been checked
	  character(len=str_len)   :: anagrams = repeat(' ',str_len) !the anagram list for this word
	end type word

	!the dictionary structure:
	type(word),dimension(:),allocatable,target :: dict

	contains
!***************************************************************************************

	!******************************************************************************
		function count_lines_in_file(fid) result(n_lines)
	!******************************************************************************
		implicit none

		integer             :: n_lines
		integer,intent(in)  :: fid
		character(len=1)    :: tmp
		integer             :: i
		integer             :: ios

		!the file is assumed to be open already.

		rewind(fid)	  !rewind to beginning of the file

		n_lines = 0
		do !read each line until the end of the file.
			read(fid,'(A1)',iostat=ios) tmp
			if (ios < 0) exit      !End of file
			n_lines = n_lines + 1  !row counter
		end do

		rewind(fid)   !rewind to beginning of the file

	!******************************************************************************
		end function count_lines_in_file
	!******************************************************************************

	!******************************************************************************
		pure elemental function is_anagram(x,y)
	!******************************************************************************
		implicit none
		character(len=*),intent(in) :: x
		character(len=*),intent(in) :: y
		logical :: is_anagram

		character(len=len(x)) :: x_tmp	!a copy of x
		integer :: i,j

		!a character not found in any word:
		character(len=1),parameter :: null = achar(0)

		!x and y are assumed to be the same size.

		x_tmp = x
		do i=1,len_trim(x)
			j = index(x_tmp, y(i:i)) !look for this character in x_tmp
			if (j/=0) then
				x_tmp(j:j) = null  !clear it so it won't be checked again
			else
				is_anagram = .false. !character not found: x,y are not anagrams
				return
			end if
		end do

		!if we got to this point, all the characters
		! were the same, so x,y are anagrams:
		is_anagram = .true.

	!******************************************************************************
		end function is_anagram
	!******************************************************************************

!***************************************************************************************
	end module anagram_routines
!***************************************************************************************

!***************************************************************************************
	program main
!***************************************************************************************
	use anagram_routines
	implicit none

	integer :: n,i,j,n_max
	type(word),pointer :: x,y
	logical :: first_word
	real :: start, finish

	call cpu_time(start)	!..start timer

	!open the dictionary and read in all the words:
	open(unit=file_unit,file=filename)      !open the file
	n = count_lines_in_file(file_unit)      !count lines in the file
	allocate(dict(n))                       !allocate dictionary structure
	do i=1,n                                !
		read(file_unit,'(A)') dict(i)%str   !each line is a word in the dictionary
		dict(i)%n = len_trim(dict(i)%str)   !saving length here to avoid trim's below
	end do
	close(file_unit)                        !close the file

	!search dictionary for anagrams:
	do i=1,n

		x => dict(i)	!pointer to simplify code
		first_word = .true.	!initialize

		do j=i,n

			y => dict(j)	!pointer to simplify code

			!checks to avoid checking words unnecessarily:
			if (x%checked .or. y%checked) cycle     !both must not have been checked already
			if (x%n/=y%n) cycle                     !must be the same size
			if (x%str(1:x%n)==y%str(1:y%n)) cycle   !can't be the same word

			! check to see if x,y are anagrams:
			if (is_anagram(x%str(1:x%n), y%str(1:y%n))) then
				!they are anagrams.
				y%checked = .true. 	!don't check this one again.
				x%n_anagrams = x%n_anagrams + 1
				if (first_word) then
					!this is the first anagram found for this word.
					first_word = .false.
					x%n_anagrams = x%n_anagrams + 1
					x%anagrams = trim(x%anagrams)//x%str(1:x%n)  !add first word to list
				end if
				x%anagrams = trim(x%anagrams)//','//y%str(1:y%n) !add next word to list
			end if

		end do
		x%checked = .true.  !don't check this one again

	end do

	!anagram groups with the most words:
	write(*,*) ''
	n_max = maxval(dict%n_anagrams)
	do i=1,n
		if (dict(i)%n_anagrams==n_max) write(*,'(A)') trim(dict(i)%anagrams)
	end do

	!anagram group containing longest words:
	write(*,*) ''
	n_max = maxval(dict%n, mask=dict%n_anagrams>0)
	do i=1,n
		if (dict(i)%n_anagrams>0 .and. dict(i)%n==n_max) write(*,'(A)') trim(dict(i)%anagrams)
	end do
	write(*,*) ''

	call cpu_time(finish)	!...stop timer
	write(*,'(A,F6.3,A)') '[Runtime = ',finish-start,' sec]'
	write(*,*) ''

!***************************************************************************************
	end program main
!***************************************************************************************

"Output: The code identifies sets of words from the provided URL that are anagrams of each other, specifically focusing on those sets with the most words."


Works with: Fortran version 90 and later
Translation of: Python
program Sierpinski_carpet
  implicit none

  call carpet(4)

contains

function In_carpet(a, b)
  logical :: in_carpet
  integer, intent(in) :: a, b
  integer :: x, y

  x = a ; y = b
  do
    if(x == 0 .or. y == 0) then
      In_carpet = .true.
      return
    else if(mod(x, 3) == 1 .and. mod(y, 3) == 1) then
      In_carpet = .false.
      return
    end if
    x = x / 3
    y = y / 3
  end do
end function

subroutine Carpet(n)
  integer, intent(in) :: n
  integer :: i, j

  do i = 0, 3**n - 1
    do j = 0, 3**n - 1
      if(In_carpet(i, j)) then
        write(*, "(a)", advance="no") "#"
      else
        write(*, "(a)", advance="no") " "
      end if
    end do
    write(*,*)
  end do
end subroutine Carpet
end program Sierpinski_carpet

generate a graphical or ASCII-art representation of a Sierpinski carpet of a given order N. The representation uses whitespace and non-whitespace characters, with the non-whitespace character not strictly required to be '#'. The placement of these characters follows the pattern of a Sierpinski carpet.


! output:
! d-> 00000, t-> 00001, h-> 0001, s-> 0010,
! c-> 00110, x-> 00111, m-> 0100, o-> 0101,
! n-> 011, u-> 10000, l-> 10001, a-> 1001,
! r-> 10100, g-> 101010, p-> 101011,
! e-> 1011, i-> 1100, f-> 1101,  -> 111
!
! 00001|0001|1100|0010|111|1100|0010|111|1001|011|
! 111|1011|00111|1001|0100|101011|10001|1011|111|
! 1101|0101|10100|111|0001|10000|1101|1101|0100|
! 1001|011|111|1011|011|00110|0101|00000|1100|011|101010|
!
module huffman
implicit none
type node
  character (len=1 ), allocatable :: sym(:)
  character (len=10), allocatable :: code(:)
  integer                         :: freq
contains
  procedure                       :: show => show_node
end type

type queue
  type(node), allocatable :: buf(:)
  integer                 :: n = 0
contains
  procedure :: extractmin
  procedure :: append
  procedure :: siftdown
end type

contains

subroutine siftdown(this, a)
  class (queue)           :: this
  integer                 :: a, parent, child
  associate (x => this%buf)
  parent = a
  do while(parent*2 <= this%n)
    child = parent*2
    if (child + 1 <= this%n) then
      if (x(child+1)%freq < x(child)%freq ) then
        child = child +1
      end if
    end if
    if (x(parent)%freq > x(child)%freq) then
      x([child, parent]) = x([parent, child])
      parent = child
    else
      exit
    end if
  end do
  end associate
end subroutine

function extractmin(this) result (res)
  class(queue) :: this
  type(node)   :: res
  res = this%buf(1)
  this%buf(1) = this%buf(this%n)
  this%n = this%n - 1
  call this%siftdown(1)
end function

subroutine append(this, x)
  class(queue), intent(inout) :: this
  type(node)                  :: x
  type(node), allocatable     :: tmp(:)
  integer                     :: i
  this%n = this%n +1
  if (.not.allocated(this%buf)) allocate(this%buf(1))
  if (size(this%buf)<this%n) then
    allocate(tmp(2*size(this%buf)))
    tmp(1:this%n-1) = this%buf
    call move_alloc(tmp, this%buf)
  end if
  this%buf(this%n) = x
  i = this%n
  do
    i = i / 2
    if (i==0) exit
    call this%siftdown(i)
  end do
end subroutine

function join(a, b) result(c)
  type(node)             :: a, b, c
  integer                :: i, n, n1
  n1 = size(a%sym)
  n = n1 + size(b%sym)
  c%freq = a%freq + b%freq
  allocate (c%sym(n), c%code(n))
  do i = 1, n1
    c%sym(i) = a%sym(i)
    c%code(i) = "0" // trim(a%code(i))
  end do
  do i = 1, size(b%sym)
    c%sym(i+n1) = b%sym(i)
    c%code(i+n1) = "1" // trim(b%code(i))
  end do
end function

subroutine show_node(this)
  class(node) :: this
  integer     :: i
  write(*, "(*(g0,'-> ',g0,:,', '))", advance="no") &
   (this%sym(i), trim(this%code(i)), i=1,size(this%sym))
  print *
end subroutine

function create(letter, freq) result (this)
  character :: letter
  integer   :: freq
  type(node) :: this
  allocate(this%sym(1), this%code(1))
  this%sym(1) = letter ; this%code(1) = ""
  this%freq = freq
end function
end module

program main
  use huffman
  character (len=*), parameter   :: txt = &
   "this is an example for huffman encoding"
  integer                        :: i, freq(0:255) = 0
  type(queue)                    :: Q
  type(node)                     :: x
  do i = 1, len(txt)
    freq(ichar(txt(i:i))) = freq(ichar(txt(i:i))) + 1
  end do
  do i = 0, 255
    if (freq(i)>0) then
      call Q%append(create(char(i), freq(i)))
    end if
  end do
  do i = 1, Q%n-1
    call Q%append(join(Q%extractmin(),Q%extractmin()))
  end do
  x = Q%extractmin()
  call x%show()
  do i = 1, len(txt)
    do k = 1, size(x%sym)
      if (x%sym(k)==txt(i:i)) exit
     end do
     write (*, "(a,'|')", advance="no")  trim(x%code(k))
  end do
  print *
end program

The code generates a Huffman encoding for each character in the given string "this is an example for huffman encoding". It first creates a tree of nodes based on the frequency of each character. Then, it traverses the tree from root to leaves, assigning '0' for one branch and '1' for the other at each node. The accumulated zeros and ones at each leaf constitute a Huffman encoding for those characters. The output is a table of Huffman encodings for each character.


Works with: Fortran version 90 and later
DO i = 10, 0, -1
  WRITE(*, *) i
END DO

Works with: Fortran version 77 and later
      PROGRAM DOWNWARDFOR
C Initialize the loop parameters.
        INTEGER I, START, FINISH, STEP
        PARAMETER (START = 10, FINISH = 0, STEP = -1)

C If you were to leave off STEP, it would default to positive one.
        DO 10 I = START, FINISH, STEP
          WRITE (*,*) I
   10   CONTINUE

        STOP
      END

The code performs a countdown from 10 to 0 using a downward for loop.


Works with: Fortran version 95 and later
program vigenere_cipher
  implicit none

  character(80) :: plaintext = "Beware the Jabberwock, my son! The jaws that bite, the claws that catch!", &
                   ciphertext = ""
  character(14) :: key = "VIGENERECIPHER"

  call encrypt(plaintext, ciphertext, key)
  write(*,*) plaintext
  write(*,*) ciphertext
  call decrypt(ciphertext, plaintext, key)
  write(*,*) plaintext

contains

subroutine encrypt(intxt, outtxt, k)
  character(*), intent(in)  :: intxt, k
  character(*), intent(out) :: outtxt
  integer :: chrn
  integer :: cp = 1, kp = 1
  integer :: i

  outtxt = ""
  do i = 1, len(trim(intxt))
    select case(intxt(i:i))
      case ("A":"Z", "a":"z")
        select case(intxt(i:i))
          case("a":"z")
            chrn = iachar(intxt(i:i)) - 32

          case default
            chrn = iachar(intxt(i:i))

        end select

        outtxt(cp:cp) = achar(modulo(chrn + iachar(k(kp:kp)), 26) + 65)
        cp = cp + 1
        kp = kp + 1
        if(kp > len(k)) kp = kp - len(k)

    end select
  end do
end subroutine

subroutine decrypt(intxt, outtxt, k)
  character(*), intent(in)  :: intxt, k
  character(*), intent(out) :: outtxt
  integer :: chrn
  integer :: cp = 1, kp = 1
  integer :: i

  outtxt = ""
  do i = 1, len(trim(intxt))
    chrn = iachar(intxt(i:i))
    outtxt(cp:cp) = achar(modulo(chrn - iachar(k(kp:kp)), 26) + 65)
    cp = cp + 1
    kp = kp + 1
    if(kp > len(k)) kp = kp - len(k)
   end do
end subroutine
end program

Implement both encryption and decryption of a Vigenère cipher. The codes handle keys and text of unequal length, capitalize all characters and discard non-alphabetic ones. If non-alphabetic characters are handled differently, it is noted.


Works with: Fortran version 90 and later
do i = 1,10,2
   print *, i
end do

Works with: Fortran version 77 and later
      PROGRAM STEPFOR
        INTEGER I

C       This will print all even numbers from -10 to +10, inclusive.
        DO 10 I = -10, 10, 2
          WRITE (*,*) I
   10   CONTINUE

        STOP
      END

demonstrate a for-loop with a step-value greater than one.


Fortran does not offer call-by-name in the manner of the Algol language. It passes parameters by reference (i.e. by passing the storage address) and alternatively uses copy-in, copy-out to give the same effect, approximately, as by reference. If a parameter is an arithmetic expression, it will be evaluated and its value stored in a temporary storage area, whose address will be passed to the routine. This evaluation is done once only for each call, thus vitiating the repeated re-evaluation required by Jensen's device every time within the routine that the parameter is accessed. So, this will not work      FUNCTION SUM(I,LO,HI,TERM)
        SUM = 0
        DO I = LO,HI
          SUM = SUM + TERM
        END DO
      END FUNCTION SUM
      WRITE (6,*) SUM(I,1,100,1.0/I)
      END

Fortran does offer a facility to pass a function as a parameter using the EXTERNAL declaration, as follows - SUM is a F90 library function, so a name change to SUMJ:       FUNCTION SUMJ(I,LO,HI,TERM)	!Attempt to follow Jensen's Device...
       INTEGER I	!Being by reference is workable.
       INTEGER LO,HI	!Just as any other parameters.
       EXTERNAL TERM	!Thus, not a variable, but a function.
        SUMJ = 0
        DO I = LO,HI	!The specified span.
          SUMJ = SUMJ + TERM(I)	!Number and type of parameters now apparent.
        END DO		!TERM will be evaluated afresh, each time.
      END FUNCTION SUMJ	!So, almost there.

      FUNCTION THIS(I)	!A function of an integer.
       INTEGER I
        THIS = 1.0/I	!Convert to floating-point.
      END		!Since 1/i will mostly give zero.

      PROGRAM JENSEN	!Aspiration.
      EXTERNAL THIS	!Thus, not a variable, but a function.
      INTEGER I		!But this is a variable, not a function.

      WRITE (6,*) SUMJ(I,1,100,THIS)	!No statement as to the parameters of THIS.
      END

The code demonstrates Jensen's Device, a programming technique that utilizes call by name. It calculates the 100th harmonic number using a sum procedure. The procedure takes four parameters, including a term passed by-name, and iterates from the lower to upper limit, accumulating the sum of the term. The code exploits call by name to ensure that the term and the bound variable of the summation are re-evaluated in the caller's context each time they are required. The result of the calculation is then printed.


The code continually calculates and outputs the next decimal digit of Pi, starting from 3.14159265 and continuing indefinitely until manually stopped by the user. It uses the Fortran Multiple Precision Library for higher precision and initializes all elements of a vector to 2. The output can be written as each digit is calculated, without the need for an array buffer.


Works with: Fortran version 90 and later
PROGRAM EXAMPLE
  IMPLICIT NONE

  INTEGER :: i, j

  DO i = 0, 3
    DO j = 0, 6
       WRITE(*, "(I10)", ADVANCE="NO") Ackermann(i, j)
    END DO
    WRITE(*,*)
  END DO

CONTAINS

  RECURSIVE FUNCTION Ackermann(m, n) RESULT(ack)
    INTEGER :: ack, m, n

    IF (m == 0) THEN
      ack = n + 1
    ELSE IF (n == 0) THEN
      ack = Ackermann(m - 1, 1)
    ELSE
      ack = Ackermann(m - 1, Ackermann(m, n - 1))
    END IF
  END FUNCTION Ackermann

END PROGRAM EXAMPLE

Implement the Ackermann function which is a recursive function that takes two non-negative arguments and returns a value based on the specified conditions. The function should ideally support arbitrary precision due to its rapid growth.


Works with: Fortran version 2008
Works with: Fortran version 95 with extensions
program ComputeGammaInt

  implicit none

  integer :: i

  write(*, "(3A15)") "Simpson", "Lanczos", "Builtin"
  do i=1, 10
     write(*, "(3F15.8)") my_gamma(i/3.0), lacz_gamma(i/3.0), gamma(i/3.0)
  end do

contains

  pure function intfuncgamma(x, y) result(z)
    real :: z
    real, intent(in) :: x, y

    z = x**(y-1.0) * exp(-x)
  end function intfuncgamma

  function my_gamma(a) result(g)
    real :: g
    real, intent(in) :: a

    real, parameter :: small = 1.0e-4
    integer, parameter :: points = 100000

    real :: infty, dx, p, sp(2, points), x
    integer :: i
    logical :: correction

    x = a

    correction = .false.
    ! value with x<1 gives \infty, so we use
    ! \Gamma(x+1) = x\Gamma(x)
    ! to avoid the problem
    if ( x < 1.0 ) then
       correction = .true.
       x = x + 1
    end if

    ! find a "reasonable" infinity...
    ! we compute this integral indeed
    ! \int_0^M dt t^{x-1} e^{-t}
    ! where M is such that M^{x-1} e^{-M} ≤ \epsilon
    infty = 1.0e4
    do while ( intfuncgamma(infty, x) > small )
       infty = infty * 10.0
    end do

    ! using simpson
    dx = infty/real(points)
    sp = 0.0
    forall(i=1:points/2-1) sp(1, 2*i) = intfuncgamma(2.0*(i)*dx, x)
    forall(i=1:points/2) sp(2, 2*i - 1) = intfuncgamma((2.0*(i)-1.0)*dx, x)
    g = (intfuncgamma(0.0, x) + 2.0*sum(sp(1,:)) + 4.0*sum(sp(2,:)) + &
         intfuncgamma(infty, x))*dx/3.0

    if ( correction ) g = g/a

  end function my_gamma

  recursive function lacz_gamma(a) result(g)
    real, intent(in) :: a
    real :: g

    real, parameter :: pi = 3.14159265358979324
    integer, parameter :: cg = 7

    ! these precomputed values are taken by the sample code in Wikipedia,
    ! and the sample itself takes them from the GNU Scientific Library
    real, dimension(0:8), parameter :: p = &
         (/ 0.99999999999980993, 676.5203681218851, -1259.1392167224028, &
         771.32342877765313, -176.61502916214059, 12.507343278686905, &
         -0.13857109526572012, 9.9843695780195716e-6, 1.5056327351493116e-7 /)

    real :: t, w, x
    integer :: i

    x = a

    if ( x < 0.5 ) then
       g = pi / ( sin(pi*x) * lacz_gamma(1.0-x) )
    else
       x = x - 1.0
       t = p(0)
       do i=1, cg+2
          t = t + p(i)/(x+real(i))
       end do
       w = x + real(cg) + 0.5
       g = sqrt(2.0*pi) * w**(x+0.5) * exp(-w) * t
    end if
  end function lacz_gamma

end program ComputeGammaInt

The code implements the Gamma function using two methods: Numerical Integration through the Simpson formula and the Lanczos approximation. It compares the results with the built-in Gamma function if available. The Gamma function is computed in the real field only.


Works with: Fortran version 95 and later

program Nqueens
  implicit none

  integer, parameter :: n = 8  ! size of board
  integer :: file = 1, rank = 1, queens = 0
  integer :: i
  logical :: board(n,n) = .false.

  do while (queens < n)
    board(file, rank) = .true.
    if(is_safe(board, file, rank)) then
      queens = queens + 1
      file = 1
      rank = rank + 1
    else
      board(file, rank) = .false.
      file = file + 1
      do while(file > n)
         rank = rank - 1
         if (rank < 1) then
           write(*, "(a,i0)") "No solution for n = ", n
           stop
         end if
         do i = 1, n
           if (board(i, rank)) then
             file = i
             board(file, rank) = .false.
             queens = queens - 1
             file = i + 1
             exit
           end if
         end do
       end do
    end if
  end do

  call Printboard(board)

contains

function is_safe(board, file, rank)
  logical :: is_safe
  logical, intent(in) :: board(:,:)
  integer, intent(in) :: file, rank
  integer :: i, f, r

  is_safe = .true.
  do i = rank-1, 1, -1
    if(board(file, i)) then
      is_safe = .false.
      return
    end if
  end do

  f = file - 1
  r = rank - 1
  do while(f > 0 .and. r > 0)
    if(board(f, r)) then
      is_safe = .false.
      return
    end if
    f = f - 1
    r = r - 1
  end do

  f = file + 1
  r = rank - 1
  do while(f <= n .and. r > 0)
    if(board(f, r)) then
      is_safe = .false.
      return
    end if
    f = f + 1
    r = r - 1
  end do
end function

subroutine Printboard(board)
  logical, intent(in) :: board(:,:)
  character(n*4+1) :: line
  integer :: f, r

  write(*, "(a, i0)") "n = ", n
  line = repeat("+---", n) // "+"
  do r = 1, n
    write(*, "(a)") line
    do f = 1, n
      write(*, "(a)", advance="no") "|"
      if(board(f, r)) then
        write(*, "(a)", advance="no") " Q "
      else if(mod(f+r, 2) == 0) then
        write(*, "(a)", advance="no") "   "
      else
        write(*, "(a)", advance="no") "###"
      end if
    end do
    write(*, "(a)") "|"
  end do
  write(*, "(a)") line
end subroutine
end program

solve the N-queens problem using a backtracking method, optimized for symmetry of the chess board and parallelized with OpenMP. The algorithm starts backtracking from the third column. The program counts solutions, stores, and prints all solutions for given board sizes. It also demonstrates the use of Fortran's type polymorphism and linked lists. The program can be compiled with GCC, Absoft Pro Fortran, or Intel Fortran.


Works with: Fortran version 90 and later
program Concat_Arrays
  implicit none

  ! Note: in Fortran 90 you must use the old array delimiters (/ , /)
  integer, dimension(3) :: a = [1, 2, 3] ! (/1, 2, 3/)
  integer, dimension(3) :: b = [4, 5, 6] ! (/4, 5, 6/)
  integer, dimension(:), allocatable :: c, d

  allocate(c(size(a)+size(b)))
  c(1 : size(a)) = a
  c(size(a)+1 : size(a)+size(b)) = b
  print*, c

  ! alternative
  d = [a, b] ! (/a, b/)
  print*, d
end program Concat_Arrays

demonstrate how to concatenate two arrays.


Works with: Fortran version 90 and later

program Short_Circuit_Eval
  implicit none

  logical :: x, y
  logical, dimension(2) :: l = (/ .false., .true. /)
  integer :: i, j

  do i = 1, 2
    do j = 1, 2
      write(*, "(a,l1,a,l1,a)") "Calculating x = a(", l(i), ") and b(", l(j), ")"
      ! a AND b
      x = a(l(i))
      if(x) then
        x = b(l(j))
        write(*, "(a,l1)") "x = ", x
      else
        write(*, "(a,l1)") "x = ", x
      end if

      write(*,*)
      write(*, "(a,l1,a,l1,a)") "Calculating y = a(", l(i), ") or b(", l(j), ")"
      ! a OR b
      y = a(l(i))
      if(y) then
        write(*, "(a,l1)") "y = ", y
      else
        y = b(l(j))
        write(*, "(a,l1)") "y = ", y
      end if
      write(*,*)
    end do
  end do

contains

function a(value)
  logical :: a
  logical, intent(in) :: value

  a = value
  write(*, "(a,l1,a)") "Called function a(", value, ")"
end function

function b(value)
  logical :: b
  logical, intent(in) :: value

  b = value
  write(*, "(a,l1,a)") "Called function b(", value, ")"
end function
end program

The code defines two functions, a and b, which return and print the same boolean value. It then calculates the values of two equations, using short-circuit evaluation to ensure that function b is only called when necessary. If the programming language doesn't support short-circuit evaluation, this is achieved using nested if statements.


!-*- mode: compilation; default-directory: "/tmp/" -*-
!Compilation started at Thu Jun  5 01:52:03
!
!make f && for a in '' a bark book treat common squad confuse ; do echo $a | ./f ; done
!gfortran -std=f2008 -Wall -fopenmp -ffree-form -fall-intrinsics -fimplicit-none -g f.f08 -o f
! T
! T  A                    NA
! T  BARK                 BO NA RE XK
! F  BOOK                 OB BO -- --
! T  TREAT                GT RE ER NA TG
! F  COMMON               PC OB ZM -- -- --
! T  SQUAD                FS DQ HU NA QD
! T  CONFUSE              CP BO NA FS HU FS RE
!
!Compilation finished at Thu Jun  5 01:52:03

program abc
  implicit none
  integer, parameter :: nblocks = 20
  character(len=nblocks) :: goal
  integer, dimension(nblocks) :: solution
  character(len=2), dimension(0:nblocks) :: blocks_copy, blocks = &
       &(/'--','BO','XK','DQ','CP','NA','GT','RE','TG','QD','FS','JW','HU','VI','AN','OB','ER','FS','LY','PC','ZM'/)
  logical :: valid
  integer :: i, iostat
  read(5,*,iostat=iostat) goal
  if (iostat .ne. 0) goal = ''
  call ucase(goal)
  solution = 0
  blocks_copy = blocks
  valid = assign_block(goal(1:len_trim(goal)), blocks, solution, 1)
  write(6,*) valid, ' '//goal, (' '//blocks_copy(solution(i)), i=1,len_trim(goal))

contains

  recursive function assign_block(goal, blocks, solution, n) result(valid)
    implicit none
    logical :: valid
    character(len=*), intent(in) :: goal
    character(len=2), dimension(0:), intent(inout) :: blocks
    integer, dimension(:), intent(out) :: solution
    integer, intent(in) :: n
    integer :: i
    character(len=2) :: backing_store
    valid = .true.
    if (len(goal)+1 .eq. n) return
    do i=1, size(blocks)
       if (index(blocks(i),goal(n:n)) .ne. 0) then
          backing_store = blocks(i)
          blocks(i) = ''
          solution(n) = i
          if (assign_block(goal, blocks, solution, n+1)) return
          blocks(i) = backing_store
       end if
    end do
    valid = .false.
    return
  end function assign_block

  subroutine ucase(a)
    implicit none
    character(len=*), intent(inout) :: a
    integer :: i, j
    do i = 1, len_trim(a)
       j = index('abcdefghijklmnopqrstuvwxyz',a(i:i))
       if (j .ne. 0) a(i:i) = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'(j:j)
    end do
  end subroutine ucase

end program abc

But if backtracking might be needed[edit]

      MODULE PLAYPEN	!Messes with a set of alphabet blocks.
       INTEGER MSG		!Output unit number.
       PARAMETER (MSG = 6)	!Standard output.
       INTEGER MS		!I dislike unidentified constants...
       PARAMETER (MS = 2)	!So this is the maximum number of lettered sides.
       INTEGER LETTER(26),SUPPLY(26)	!For counting the alphabet.
       CONTAINS
        SUBROUTINE SWAP(I,J)	!This really should be known to the compiler.
         INTEGER I,J,K		!Which could generate in-place code,
          K = I			!Using registers, maybe.
          I = J			!Or maybe, there are special op-codes.
          J = K			!Rather than this clunkiness.
        END SUBROUTINE SWAP	!And it should be for any type of thingy.

        INTEGER FUNCTION LSTNB(TEXT)  !Sigh. Last Not Blank.
Concocted yet again by R.N.McLean (whom God preserve) December MM.
Code checking reveals that the Compaq compiler generates a copy of the string and then finds the length of that when using the latter-day intrinsic LEN_TRIM. Madness!
Can't   DO WHILE (L.GT.0 .AND. TEXT(L:L).LE.' ')	!Control chars. regarded as spaces.
Curse the morons who think it good that the compiler MIGHT evaluate logical expressions fully.
Crude GO TO rather than a DO-loop, because compilers use a loop counter as well as updating the index variable.
Comparison runs of GNASH showed a saving of ~3% in its mass-data reading through the avoidance of DO in LSTNB alone.
Crappy code for character comparison of varying lengths is avoided by using ICHAR which is for single characters only.
Checking the indexing of CHARACTER variables for bounds evoked astounding stupidities, such as calculating the length of TEXT(L:L) by subtracting L from L!
Comparison runs of GNASH showed a saving of ~25-30% in its mass data scanning for this, involving all its two-dozen or so single-character comparisons, not just in LSTNB.
         CHARACTER*(*),INTENT(IN):: TEXT	!The bumf. If there must be copy-in, at least there need not be copy back.
         INTEGER L		!The length of the bumf.
          L = LEN(TEXT)		!So, what is it?
    1     IF (L.LE.0) GO TO 2	!Are we there yet?
          IF (ICHAR(TEXT(L:L)).GT.ICHAR(" ")) GO TO 2	!Control chars are regarded as spaces also.
          L = L - 1		!Step back one.
          GO TO 1		!And try again.
    2     LSTNB = L		!The last non-blank, possibly zero.
         RETURN			!Unsafe to use LSTNB as a variable.
        END FUNCTION LSTNB	!Compilers can bungle it.

        SUBROUTINE LETTERCOUNT(TEXT)	!Count the occurrences of A-Z.
         CHARACTER*(*) TEXT	!The text to inspect.
         INTEGER I,K		!Assistants.
          DO I = 1,LEN(TEXT)		!Step through the text.
            K = ICHAR(TEXT(I:I)) - ICHAR("A") + 1	!This presumes that A-Z have contiguous codes!
            IF (K.GE.1 .AND. K.LE.26) LETTER(K) = LETTER(K) + 1	!Not so with EBCDIC!!
          END DO			!On to the next letter.
        END SUBROUTINE LETTERCOUNT	!Be careful with LETTER.

        SUBROUTINE UPCASE(TEXT)	!In the absence of an intrinsic...
Converts any lower case letters in TEXT to upper case...
Concocted yet again by R.N.McLean (whom God preserve) December MM.
Converting from a DO loop evades having both an iteration counter to decrement and an index variable to adjust.
         CHARACTER*(*) TEXT	!The stuff to be modified.
c        CHARACTER*26 LOWER,UPPER	!Tables. a-z may not be contiguous codes.
c        PARAMETER (LOWER = "abcdefghijklmnopqrstuvwxyz")
c        PARAMETER (UPPER = "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
CAREFUL!! The below relies on a-z and A-Z being contiguous, as is NOT the case with EBCDIC.
         INTEGER I,L,IT		!Fingers.
          L = LEN(TEXT)		!Get a local value, in case LEN engages in oddities.
          I = L			!Start at the end and work back..
    1     IF (I.LE.0) RETURN 	!Are we there yet? Comparison against zero should not require a subtraction.
c         IT = INDEX(LOWER,TEXT(I:I))	!Well?
c         IF (IT .GT. 0) TEXT(I:I) = UPPER(IT:IT)	!One to convert?
          IT = ICHAR(TEXT(I:I)) - ICHAR("a")		!More symbols precede "a" than "A".
          IF (IT.GE.0 .AND. IT.LE.25) TEXT(I:I) = CHAR(IT + ICHAR("A"))	!In a-z? Convert!
          I = I - 1			!Back one.
          GO TO 1			!Inspect..
        END SUBROUTINE UPCASE	!Easy.

        SUBROUTINE ORDERSIDE(LETTER)	!Puts the letters into order.
         CHARACTER*(*) LETTER	!The letters.
         INTEGER I,N,H		!Assistants.
         CHARACTER*1 T		!A scratchpad.
         LOGICAL CURSE		!A bit.
          N = LEN(LETTER)	!So, how many letters?
          H = N - 1		!Last - First, and not +1.
          IF (H.LE.0) RETURN	!Ha ha.
    1     H = MAX(1,H*10/13)		!The special feature.
          IF (H.EQ.9 .OR. H.EQ.10) H = 11	!A twiddle.
          CURSE = .FALSE.		!So far, so good.
          DO I = N - H,1,-1		!If H = 1, this is a BubbleSort.
            IF (LETTER(I:I).LT.LETTER(I + H:I + H)) THEN	!One compare.
              T = LETTER(I:I)			!One swap.
              LETTER(I:I) = LETTER(I + H:I + H)	!Alas, no SWAP(A,B)
              LETTER(I + H:I + H) = T		!Is recognised by the compiler.
              CURSE = .TRUE.		!If once a tiger is seen...
            END IF			!So much for that comparison.
          END DO			!On to the next.
          IF (CURSE .OR. H.GT.1) GO TO 1!Another pass?
        END SUBROUTINE ORDERSIDE	!Simple enough.
        SUBROUTINE ORDERBLOCKS(N,SOME)	!Puts the collection of blocks into order.
         INTEGER N		!The number of blocks.
         CHARACTER*(*) SOME(:)	!Their lists of letters.
         INTEGER I,H		!Assistants.
         CHARACTER*(LEN(SOME(1))) T	!A scratchpad matching an element of SOME.
         LOGICAL CURSE			!Since there is still no SWAP(SOME(I),SOME(I + H)).
          H = N - 1		!So here comes another CombSort.
          IF (H.LE.0) RETURN	!With standard suspicion.
    1     H = MAX(1,H*10/13)		!This is the outer loop.
          IF (H.EQ.9 .OR. H.EQ.10) H = 11	!This is a fiddle.
          CURSE = .FALSE.		!Start the next pass in hope.
          DO I = N - H,1,-1		!Going backwards, just for fun.
            IF (SOME(I).LT.SOME(I + H)) THEN	!So then?
              T = SOME(I)		!Disorder.
              SOME(I) = SOME(I + H)	!So once again,
              SOME(I + H) = T		!Swap the two miscreants.
              CURSE = .TRUE.		!And remember.
            END IF			!So much for that comparison.
          END DO			!On to the next.
          IF (CURSE .OR. H.GT.1) GO TO 1!Are we there yet?
        END SUBROUTINE ORDERBLOCKS	!Not much code, but ringing the changes is still tedious.

        SUBROUTINE PLAY(N,SOME)	!Mess about with the collection of blocks.
         INTEGER N		!Their number.
         CHARACTER*(*) SOME(:)	!Their letters.
         INTEGER NH,HIT(N)	!A list of blocks.
         INTEGER B,I,J,K,L,M	!Assistants.
         CHARACTER*1 C		!A letter of the moment.
          L = LEN(SOME(1))	!The maximum number of letters to any block.
Cast the collection on to the floor.
          WRITE (MSG,1) N,L,SOME	!Announce the set as it is supplied.
    1     FORMAT (I7," blocks, with at most",I2," letters:",66(1X,A))
Change the "orientation" of some blocks.
          DO B = 1,N		!Step through each block.
            CALL UPCASE(SOME(B))	!Paranoia rules.
            CALL ORDERSIDE(SOME(B))	!Put its letter list into order.
          END DO		!On to the next block.
          WRITE (MSG,2) SOME	!Reveal the orderly array.
    2     FORMAT (6X,"... the letters in reverse order:",66(1X,A))
Collate the collection of blocks.
          CALL ORDERBLOCKS(N,SOME)	!Now order the blocks by their letters.
          WRITE (MSG,3) SOME		!Reveal them in neato order.
    3     FORMAT (7X,"... the blocks in reverse order:",66(1X,A))
Count the appearances of the letters of the alphabet.
          LETTER = 0		!Enough of shuffling blocks around.
          DO B = 1,N		!Now inspect their collective letters.
            CALL LETTERCOUNT(SOME(B))	!A block's worth at a go.
          END DO		!On to the next block.
          SUPPLY = LETTER	!Save the counts of supplied letters.
          WRITE (MSG,4) (CHAR(ICHAR("A") + I - 1),I = 1,26),SUPPLY	!Results.
    4     FORMAT (15X,"Letters of the alphabet:",26A<MS + 1>,/,	!First, a line with A ... Z.
     1     11X,"... number thereof supplied:",26I<MS + 1>)	!Then a line of the associated counts.
Check for blocks with duplicated letters.
          WRITE (MSG,5)		!Announce.
    5     FORMAT (8X,"Blocks with duplicated letters:",$)	!Further output impends.
          M = 0			!No duplication found.
          DO B = 1,N		!So step through each block.
         JJ:DO J = 2,L			!Inspecting successive letters of the block,
              IF (SOME(B)(J:J).LE." ") EXIT JJ	!Provided they've not run out.
              DO K = 1,J - 1			!To see if it has appeared earlier.
                IF (SOME(B)(K:K).LE." ") EXIT JJ!Reverse order means that spaces will be at the end!
                IF (SOME(B)(J:J).EQ.SOME(B)(K:K)) THEN	!Well?
                  M = M + 1		!A match!
                  WRITE (MSG,6) SOME(B)	!Name the block.
    6             FORMAT (1X,A,$)	!With further output still impending,
                  EXIT JJ		!And give up on this block.
                END IF			!One duplicated letter is sufficient for its downfall.
              END DO			!Next letter up.
            END DO JJ			!On to the next letter of the block.
          END DO		!On to the next block.
          CALL HIC(M)		!Show the count and end the line.
Check for duplicate blocks, knowing that the array of blocks is ordered.
          WRITE (MSG,7)		!Announce.
    7     FORMAT (21X,"Duplicated blocks:",$)	!Again, leave the line dangling.
          K = 0			!No duplication found.
          B = 1			!Syncopation.
   70     B = B + 1		!Advance one.
          IF (B.GT.N) GO TO 72	!Are we there yet?
          IF (SOME(B).NE.SOME(B - 1)) GO TO 70	!No match? Search on.
          K = K + 1		!A match is counted.
          WRITE (MSG,6) SOME(B)	!Name it.
   71     B = B + 1		!And speed through continued matching.
          IF (B.GT.N) GO TO 72	!Unless we're of the end.
          IF (SOME(B).EQ.SOME(B - 1)) GO TO 71	!Continued matching?
          GO TO 70		!Mismatch: resume the normal scan.
   72     CALL HIC(K)		!So much for that.
Check for duplicated letters across different blocks.
          IF (ALL(SUPPLY.LE.1)) RETURN	!Unless there are no duplicated letters.
          WRITE (MSG,8)		!Announce.
    8     FORMAT ("Duplicated letters on different blocks:",$)	!More to come.
          K = 0		!Start another count.
          DO I = 1,26		!A well-known span.
            IF (SUPPLY(I).LE.1) CYCLE	!Any duplicated letters?
            C = CHAR(ICHAR("A") + I - 1)!Yes. This is the character.
            NH = 0		!So, how many blocks contribute?
            DO B = 1,N		!Find out.
              IF (INDEX(SOME(B),C).GT.0) THEN	!On this block?
                NH = NH + 1		!Yes.
                HIT(NH) = B		!Keep track of which.
              END IF			!So much for that block.
            END DO		!On to the next.
            IF (ANY(SOME(HIT(2:NH)) .NE. SOME(HIT(1)))) THEN	!All have the same collection of letters?
              K = K + 1			!No!
              WRITE (MSG,9) C		!Name the heterogenously supported letter.
    9         FORMAT (A<MS + 1>,$)	!Use the same spacing even though one character only.
            END IF		!So much for that letter's search.
          END DO		!On to the next letter.
          CALL HIC(K)	!Finish the line with the count report.
         CONTAINS	!This is used often enough.
          SUBROUTINE HIC(N)	!But has very specific context.
           INTEGER N			!The count.
            IF (N.LE.0) WRITE (MSG,*) "None."	!Yes, we have no bananas.
            IF (N.GT.0) WRITE (MSG,*) N		!Either way, end the line.
          END SUBROUTINE HIC	!This service routine is not needed elsewhere.
        END SUBROUTINE PLAY	!Look mummy! All the blockses are neatened!

        LOGICAL FUNCTION CANBLOCK(WORD,N,SOME)	!Can the blocks spell out the word?
Creates a move tree based on the letters of WORD and for each, the blocks available.
         CHARACTER*(*) WORD	!The word to spell out.
         INTEGER N		!The number of blocks.
         CHARACTER*(*) SOME(:)	!The blocks and their letters.
         INTEGER NA,AVAIL(N)	!Say not the struggle naught availeth!
         INTEGER NMOVE(LEN(WORD))	!I need a list of acceptable blocks,
         INTEGER MOVE(LEN(WORD),N)	!One list for each letter of WORD.
         INTEGER I,L,S		!Assistants.
         CHARACTER*1 C		!The letter of the moment.
          CANBLOCK = .FALSE.		!Initial pessimism.
          L = LSTNB(WORD)		!Ignore trailing spaces.
          IF (L.GT.N) RETURN		!Enough blocks?
          LETTER = 0				!To make rabbit stew,
          CALL LETTERCOUNT(WORD(1:L))		!First catch your rabbit.
          IF (ANY(SUPPLY .LT. LETTER)) RETURN	!The larder is lacking.
          NA = N			!Prepare a list.
          FORALL (I = 1:N) AVAIL(I) = I	!That fingers every block.
          I = 0		!Step through the letters of the WORD.
Chug through the letters of the WORD.
    1     I = I + 1	!One letter after the other.
          IF (I.GT.L) GO TO 100	!Yay! We're through!
          C = WORD(I:I)		!The letter of the moment.
          NMOVE(I) = 0		!No moves known at this new level.
          DO S = 1,NA		!So, look for them amongst the available slots.
            IF (INDEX(SOME(AVAIL(S)),C) .GT. 0) THEN	!A hit?
              NMOVE(I) = NMOVE(I) + 1	!Yes! Count up another possible move.
              MOVE(I,NMOVE(I)) = S	!Remember its slot.
            END IF			!So much for that block.
          END DO		!On to the next.
    2     IF (NMOVE(I).GT.0) THEN	!Have we any moves?
            S = MOVE(I,NMOVE(I))	!Yes! Recover the last found.
            NMOVE(I) = NMOVE(I) - 1	!Uncount, as it is about to be used.
            IF (S.NE.NA) CALL SWAP(AVAIL(S),AVAIL(NA))	!This block is no longer available.
            NA = NA - 1			!Shift the boundary back.
            GO TO 1			!Try the next letter!
          END IF		!But if we can't find a move at that level...
          I = I - 1		!Retreat a level.
          IF (I.LE.0) RETURN	!Oh dear!
          S = MOVE(I,NMOVE(I) + 1)	!Undo the move that had been made at this level.
          NA = NA + 1			!And make its block is re-available.
          IF (S.NE.NA) CALL SWAP(AVAIL(S),AVAIL(NA))	!Move it back.
          GO TO 2		!See what moves remain at this level.
Completed!
  100     CANBLOCK = .TRUE.	!That's a relief.
        END FUNCTION CANBLOCK	!Some revisions might have been made.
      END MODULE PLAYPEN	!No sand here.

      USE PLAYPEN	!Just so.
      INTEGER HAVE,TESTS		!Parameters for the specified problem.
      PARAMETER (HAVE = 20, TESTS = 7)	!Number of blocks, number of tests.
      CHARACTER*(MS) BLOCKS(HAVE)	!Have blocks, will juggle.
      DATA BLOCKS/"BO","XK","DQ","CP","NA","GT","RE","TG","QD","FS",	!The specified set
     1            "JW","HU","VI","AN","OB","ER","FS","LY","PC","ZM"/	!Of letter blocks.
      CHARACTER*8 WORD(TESTS)		!Now for the specified test words.
      LOGICAL ANS(TESTS),T,F		!And the given results.
      PARAMETER (T = .TRUE., F = .FALSE.)	!Enable a more compact specification.
      DATA WORD/"A","BARK","BOOK","TREAT","COMMON","SQUAD","CONFUSE"/	!So that these
      DATA  ANS/ T ,    T ,    F ,     T ,      F ,     T ,       T /	!Can be aligned.
      LOGICAL YAY
      INTEGER I

      WRITE (MSG,1)
    1 FORMAT ("Arranges alphabet blocks, attending only to the ",
     1 "letters on the blocks, and ignoring case and orientation.",/)

      CALL PLAY(HAVE,BLOCKS)	!Some fun first.

      WRITE (MSG,'(/"Now to see if some words can be spelled out.")')
      DO I = 1,TESTS
        CALL UPCASE(WORD(I))
        YAY = CANBLOCK(WORD(I),HAVE,BLOCKS)
        WRITE (MSG,*) YAY,ANS(I),YAY.EQ.ANS(I),WORD(I)
      END DO
      END

Arranges alphabet blocks, attending only to the letters on the blocks, and ignoring case and orientation.

     20 blocks, with at most 2 letters: BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM
      ... the letters in reverse order: OB XK QD PC NA TG RE TG QD SF WJ UH VI NA OB RE SF YL PC ZM
       ... the blocks in reverse order: ZM YL XK WJ VI UH TG TG SF SF RE RE QD QD PC PC OB OB NA NA
               Letters of the alphabet:  A  B  C  D  E  F  G  H  I  J  K  L  M  N  O  P  Q  R  S  T  U  V  W  X  Y  Z
           ... number thereof supplied:  2  2  2  2  2  2  2  1  1  1  1  1  1  2  2  2  2  2  2  2  1  1  1  1  1  1
        Blocks with duplicated letters: None.
                     Duplicated blocks: TG SF RE QD PC OB NA           7
Duplicated letters on different blocks: None.

Now to see if some words can be spelled out.
 T T T A
 T T T BARK
 F F T BOOK
 T T T TREAT
 F F T COMMON
 T T T SQUAD
 T T T CONFUSE

The code defines a function that checks if a given word can be spelled using a collection of ABC blocks. Each block contains two letters and can only be used once. The function is case-insensitive. It also includes a mechanism to backtrack if an initial selection of blocks prevents completion of the word due to the unavailability of required letters. The code also contains support routines to inspect the block collection and report whether a word can be spelled with the provided blocks. The output indicates whether the word can be spelled, the expected result, and if the two match.


Intel Fortran on Windows[edit]

module md5_mod
    use kernel32
    use advapi32
    implicit none
    integer, parameter :: MD5LEN = 16
contains
    subroutine md5hash(name, hash, dwStatus, filesize)
        implicit none
        character(*) :: name
        integer, parameter :: BUFLEN = 32768
        integer(HANDLE) :: hFile, hProv, hHash
        integer(DWORD) :: dwStatus, nRead
        integer(BOOL) :: status
        integer(BYTE) :: buffer(BUFLEN)
        integer(BYTE) :: hash(MD5LEN)
        integer(UINT64) :: filesize

        dwStatus = 0
        filesize = 0
        hFile = CreateFile(trim(name) // char(0), GENERIC_READ, FILE_SHARE_READ, NULL, &
                           OPEN_EXISTING, FILE_FLAG_SEQUENTIAL_SCAN, NULL)

        if (hFile == INVALID_HANDLE_VALUE) then
            dwStatus = GetLastError()
            print *, "CreateFile failed."
            return
        end if

        if (CryptAcquireContext(hProv, NULL, NULL, PROV_RSA_FULL, &
                                CRYPT_VERIFYCONTEXT) == FALSE) then
            dwStatus = GetLastError()
            print *, "CryptAcquireContext failed."
            goto 3
        end if

        if (CryptCreateHash(hProv, CALG_MD5, 0_ULONG_PTR, 0_DWORD, hHash) == FALSE) then
            dwStatus = GetLastError()
            print *, "CryptCreateHash failed."
            go to 2
        end if

        do
            status = ReadFile(hFile, loc(buffer), BUFLEN, nRead, NULL)
            if (status == FALSE .or. nRead == 0) exit
            filesize = filesize + nRead
            if (CryptHashData(hHash, buffer, nRead, 0) == FALSE) then
                dwStatus = GetLastError()
                print *, "CryptHashData failed."
                go to 1
            end if
        end do

        if (status == FALSE) then
            dwStatus = GetLastError()
            print *, "ReadFile failed."
            go to 1
        end if

        nRead = MD5LEN
        if (CryptGetHashParam(hHash, HP_HASHVAL, hash, nRead, 0) == FALSE) then
            dwStatus = GetLastError()
            print *, "CryptGetHashParam failed.", status, nRead, dwStatus
        end if

      1 status = CryptDestroyHash(hHash)
      2 status = CryptReleaseContext(hProv, 0)
      3 status = CloseHandle(hFile)
    end subroutine
end module

program md5
    use md5_mod
    implicit none
    integer :: n, m, i, j
    character(:), allocatable :: name
    integer(DWORD) :: dwStatus
    integer(BYTE) :: hash(MD5LEN)
    integer(UINT64) :: filesize

    n = command_argument_count()
    do i = 1, n
        call get_command_argument(i, length=m)
        allocate(character(m) :: name)
        call get_command_argument(i, name)
        call md5hash(name, hash, dwStatus, filesize)
        if (dwStatus == 0) then
            do j = 1, MD5LEN
                write(*, "(Z2.2)", advance="NO") hash(j)
            end do
            write(*, "(' ',A,' (',G0,' bytes)')") name, filesize
        end if
        deallocate(name)
    end do
end program

The code implements the MD5 encoding algorithm to encode a given string. It optionally validates the implementation using test values from IETF RFC (1321) for MD5. It also includes a warning about the known weaknesses of MD5 and suggests stronger alternatives for production-grade cryptography. If the solution is a library solution, it refers to MD5/Implementation for an implementation from scratch. The code uses Windows API functions like CryptAcquireContextA, CryptCreateHash, CryptHashData, and CryptGetHashParam.


Intel Fortran on Windows[edit]

program sendmail
    use ifcom
    use msoutl
    implicit none
    integer(4) :: app, status, msg

    call cominitialize(status)
    call comcreateobject("Outlook.Application", app, status)
    msg = $Application_CreateItem(app, olMailItem, status)
    call $MailItem_SetTo(msg, "somebody@somewhere", status)
    call $MailItem_SetSubject(msg, "Title", status)
    call $MailItem_SetBody(msg, "Hello", status)
    call $MailItem_Send(msg, status)
    call $Application_Quit(app, status)
    call comuninitialize()
end program

The code is a function that sends an email using the Outlook COM server. It accepts parameters for setting From, To, Cc addresses, Subject, and message text, with optional fields for server name and login details. It provides notifications for problems or success. The solution is portable across multiple operating systems. Sensitive data used in examples is obfuscated. The code requires linking with a Fortran module for the Microsoft Outlook Object Library, generated using the Intel Fortran Module Wizard.


Works with: Fortran version 95 and later
program Octal
  implicit none

  integer, parameter :: i64 = selected_int_kind(18)
  integer(i64) :: n = 0

! Will stop when n overflows from
! 9223372036854775807 to -92233720368547758078 (1000000000000000000000 octal)
  do while(n >= 0)
    write(*, "(o0)") n
    n = n + 1
  end do
end program

generate a sequential count in octal, starting from zero and incrementing by one on each line until the program is terminated or the maximum numeric type value is reached.


Works with: Fortran version 90 and later
MODULE Genericswap
  IMPLICIT NONE

  INTERFACE Swap
    MODULE PROCEDURE Swapint, Swapreal, Swapstring
  END INTERFACE

CONTAINS

  SUBROUTINE Swapint(a, b)
    INTEGER, INTENT(IN OUT) :: a, b
    INTEGER :: temp
    temp = a ; a = b ; b = temp
  END SUBROUTINE Swapint

  SUBROUTINE Swapreal(a, b)
    REAL, INTENT(IN OUT) :: a, b
    REAL :: temp
    temp = a ; a = b ; b = temp
  END SUBROUTINE Swapreal

  SUBROUTINE Swapstring(a, b)
    CHARACTER(*), INTENT(IN OUT) :: a, b
    CHARACTER(len(a)) :: temp
    temp = a ; a = b ; b = temp
  END SUBROUTINE Swapstring
END MODULE Genericswap

PROGRAM EXAMPLE
  USE Genericswap
  IMPLICIT NONE
  INTEGER :: i1 = 1, i2 = 2
  REAL :: r1 = 1.0, r2 = 2.0
  CHARACTER(3) :: s1="abc", s2="xyz"

  CALL Swap(i1, i2)
  CALL Swap(r1, r2)
  CALL Swap(s1, s2)

  WRITE(*,*) i1, i2   ! Prints 2 and 1
  WRITE(*,*) r1, r2   ! Prints 2.0 and 1.0
  WRITE(*,*) s1, s2   ! Prints xyz and abc
END PROGRAM EXAMPLE

implement a generic swap function or operator that can interchange the values of two variables or storage places, regardless of their types. The function is designed to work with both statically and dynamically typed languages, with certain limitations based on language semantics and support for parametric polymorphism.


Works with: Fortran version 90 and later
program palindro

  implicit none

  character(len=*), parameter :: p = "ingirumimusnocteetconsumimurigni"

  print *, is_palindro_r(p)
  print *, is_palindro_r("anothertest")
  print *, is_palindro2(p)
  print *, is_palindro2("test")
  print *, is_palindro(p)
  print *, is_palindro("last test")

contains

! non-recursive
function is_palindro(t)
  logical :: is_palindro
  character(len=*), intent(in) :: t

  integer :: i, l

  l = len(t)
  is_palindro = .false.
  do i=1, l/2
     if ( t(i:i) /= t(l-i+1:l-i+1) ) return
  end do
  is_palindro = .true.
end function is_palindro

! non-recursive 2
function is_palindro2(t) result(isp)
  logical :: isp
  character(len=*), intent(in) :: t

  character(len=len(t)) :: s
  integer :: i

  forall(i=1:len(t)) s(len(t)-i+1:len(t)-i+1) = t(i:i)
  isp = ( s == t )
end function is_palindro2

  recursive function is_palindro_r (t) result (isp)

    implicit none
    character (*), intent (in) :: t
    logical :: isp

    isp = len (t) == 0 .or. t (: 1) == t (len (t) :) .and. is_palindro_r (t (2 : len (t) - 1))

  end function is_palindro_r

end program palindro

The code includes a function that checks if a given sequence of characters is a palindrome. It supports Unicode characters and also includes a second function that detects inexact palindromes, ignoring white-space, punctuation, and case sensitivity. The functions are designed both recursively and non-recursively.


Works with: any Fortran compiler
program show_home
implicit none
character(len=32) :: home_val  ! The string value of the variable HOME
integer           :: home_len  ! The actual length of the value
integer           :: stat      ! The status of the value:
                               !  0 = ok
                               !  1 = variable does not exist
                               ! -1 = variable is not long enought to hold the result
call get_environment_variable('HOME', home_val, home_len, stat)
if (stat == 0) then
    write(*,'(a)') 'HOME = '//trim(home_val)
else
    write(*,'(a)') 'No HOME to go to!'
end if
end program show_home

"Demonstrates how to retrieve a process's environment variables such as PATH, HOME, or USER in a Unix system."