Works with: Fortran version 2008
Works with: Fortran version 2018

module avl_trees
  !
  ! References:
  !
  !   * Niklaus Wirth, 1976. Algorithms + Data Structures =
  !     Programs. Prentice-Hall, Englewood Cliffs, New Jersey.
  !
  !   * Niklaus Wirth, 2004. Algorithms and Data Structures. Updated
  !     by Fyodor Tkachov, 2014.
  !

  implicit none
  private

  ! The type for an AVL tree.
  public :: avl_tree_t

  ! The type for a pair of pointers to key and data within the tree.
  ! (Be careful with these!)
  public :: avl_pointer_pair_t

  ! Insertion, replacement, modification, etc.
  public :: avl_insert_or_modify

  ! Insert or replace.
  public :: avl_insert

  ! Is the key in the tree?
  public :: avl_contains

  ! Retrieve data from a tree.
  public :: avl_retrieve

  ! Delete data from a tree. This is a generic function.
  public :: avl_delete

  ! Implementations of avl_delete.
  public :: avl_delete_with_found
  public :: avl_delete_without_found

  ! How many nodes are there in the tree?
  public :: avl_size

  ! Return a list of avl_pointer_pair_t for the elements in the
  ! tree. The list will be in order.
  public :: avl_pointer_pairs

  ! Print a representation of the tree to an output unit.
  public :: avl_write

  ! Check the AVL condition (that the heights of the two branches from
  ! a node should differ by zero or one). ERROR STOP if the condition
  ! is not met.
  public :: avl_check

  ! Procedure types.
  public :: avl_less_than_t
  public :: avl_insertion_t
  public :: avl_key_data_writer_t

  type :: avl_node_t
     class(*), allocatable :: key, data
     type(avl_node_t), pointer :: left
     type(avl_node_t), pointer :: right
     integer :: bal             ! bal == -1, 0, 1
  end type avl_node_t

  type :: avl_tree_t
     type(avl_node_t), pointer :: p => null ()
   contains
     final :: avl_tree_t_final
  end type avl_tree_t

  type :: avl_pointer_pair_t
     class(*), pointer :: p_key, p_data
     class(avl_pointer_pair_t), pointer :: next => null ()
   contains
     final :: avl_pointer_pair_t_final
  end type avl_pointer_pair_t

  interface avl_delete
     module procedure avl_delete_with_found
     module procedure avl_delete_without_found
  end interface avl_delete

  interface
     function avl_less_than_t (key1, key2) result (key1_lt_key2)
       !
       ! The ordering predicate (‘<’).
       !
       ! Two keys a,b are considered equivalent if neither a<b nor
       ! b<a.
       !
       class(*), intent(in) :: key1, key2
       logical key1_lt_key2
     end function avl_less_than_t

     subroutine avl_insertion_t (key, data, p_is_new, p)
       !
       ! Insertion or modification of a found node.
       !
       import avl_node_t
       class(*), intent(in) :: key, data
       logical, intent(in) :: p_is_new
       type(avl_node_t), pointer, intent(inout) :: p
     end subroutine avl_insertion_t

     subroutine avl_key_data_writer_t (unit, key, data)
       !
       ! Printing the key and data of a node.
       !
       integer, intent(in) :: unit
       class(*), intent(in) :: key, data
     end subroutine avl_key_data_writer_t
  end interface

contains

  subroutine avl_tree_t_final (tree)
    type(avl_tree_t), intent(inout) :: tree

    type(avl_node_t), pointer :: p

    p => tree%p
    call free_the_nodes (p)

  contains

    recursive subroutine free_the_nodes (p)
      type(avl_node_t), pointer, intent(inout) :: p

      if (associated (p)) then
         call free_the_nodes (p%left)
         call free_the_nodes (p%right)
         deallocate (p)
      end if
    end subroutine free_the_nodes

  end subroutine avl_tree_t_final

  recursive subroutine avl_pointer_pair_t_final (node)
    type(avl_pointer_pair_t), intent(inout) :: node

    if (associated (node%next)) deallocate (node%next)
  end subroutine avl_pointer_pair_t_final

  function avl_contains (less_than, key, tree) result (found)
    procedure(avl_less_than_t) :: less_than
    class(*), intent(in) :: key
    class(avl_tree_t), intent(in) :: tree
    logical :: found

    found = avl_contains_recursion (less_than, key, tree%p)
  end function avl_contains

  recursive function avl_contains_recursion (less_than, key, p) result (found)
    procedure(avl_less_than_t) :: less_than
    class(*), intent(in) :: key
    type(avl_node_t), pointer, intent(in) :: p
    logical :: found

    if (.not. associated (p)) then
       found = .false.
    else if (less_than (key, p%key)) then
       found = avl_contains_recursion (less_than, key, p%left)
    else if (less_than (p%key, key)) then
       found = avl_contains_recursion (less_than, key, p%right)
    else
       found = .true.
    end if
  end function avl_contains_recursion

  subroutine avl_retrieve (less_than, key, tree, found, data)
    procedure(avl_less_than_t) :: less_than
    class(*), intent(in) :: key
    class(avl_tree_t), intent(in) :: tree
    logical, intent(out) :: found
    class(*), allocatable, intent(inout) :: data

    call avl_retrieve_recursion (less_than, key, tree%p, found, data)
  end subroutine avl_retrieve

  recursive subroutine avl_retrieve_recursion (less_than, key, p, found, data)
    procedure(avl_less_than_t) :: less_than
    class(*), intent(in) :: key
    type(avl_node_t), pointer, intent(in) :: p
    logical, intent(out) :: found
    class(*), allocatable, intent(inout) :: data

    if (.not. associated (p)) then
       found = .false.
    else if (less_than (key, p%key)) then
       call avl_retrieve_recursion (less_than, key, p%left, found, data)
    else if (less_than (p%key, key)) then
       call avl_retrieve_recursion (less_than, key, p%right, found, data)
    else
       found = .true.
       data = p%data
    end if
  end subroutine avl_retrieve_recursion

  subroutine avl_insert (less_than, key, data, tree)
    procedure(avl_less_than_t) :: less_than
    class(*), intent(in) :: key, data
    class(avl_tree_t), intent(inout) :: tree

    call avl_insert_or_modify (less_than, insert_or_replace, key, data, tree)
  end subroutine avl_insert

  subroutine insert_or_replace (key, data, p_is_new, p)
    class(*), intent(in) :: key, data
    logical, intent(in) :: p_is_new
    type(avl_node_t), pointer, intent(inout) :: p

    p%data = data
  end subroutine insert_or_replace

  subroutine avl_insert_or_modify (less_than, insertion, key, data, tree)
    procedure(avl_less_than_t) :: less_than
    procedure(avl_insertion_t) :: insertion ! Or modification in place.
    class(*), intent(in) :: key, data
    class(avl_tree_t), intent(inout) :: tree

    logical :: fix_balance

    fix_balance = .false.
    call insertion_search (less_than, insertion, key, data, tree%p, fix_balance)
  end subroutine avl_insert_or_modify

  recursive subroutine insertion_search (less_than, insertion, key, data, p, fix_balance)
    procedure(avl_less_than_t) :: less_than
    procedure(avl_insertion_t) :: insertion
    class(*), intent(in) :: key, data
    type(avl_node_t), pointer, intent(inout) :: p
    logical, intent(inout) :: fix_balance

    type(avl_node_t), pointer :: p1, p2

    if (.not. associated (p)) then
       ! The key was not found. Make a new node.
       allocate (p)
       p%key = key
       p%left => null ()
       p%right => null ()
       p%bal = 0
       call insertion (key, data, .true., p)
       fix_balance = .true.
    else if (less_than (key, p%key)) then
       ! Continue searching.
       call insertion_search (less_than, insertion, key, data, p%left, fix_balance)
       if (fix_balance) then
          ! A new node has been inserted on the left side.
          select case (p%bal)
          case (1)
             p%bal = 0
             fix_balance = .false.
          case (0)
             p%bal = -1
          case (-1)
             ! Rebalance.
             p1 => p%left
             select case (p1%bal)
             case (-1)
                ! A single LL rotation.
                p%left => p1%right
                p1%right => p
                p%bal = 0
                p => p1
                p%bal = 0
                fix_balance = .false.
             case (0, 1)
                ! A double LR rotation.
                p2 => p1%right
                p1%right => p2%left
                p2%left => p1
                p%left => p2%right
                p2%right => p
                p%bal = -(min (p2%bal, 0))
                p1%bal = -(max (p2%bal, 0))
                p => p2
                p%bal = 0
                fix_balance = .false.
             case default
                error stop
             end select
          case default
             error stop
          end select
       end if
    else if (less_than (p%key, key)) then
       call insertion_search (less_than, insertion, key, data, p%right, fix_balance)
       if (fix_balance) then
          ! A new node has been inserted on the right side.
          select case (p%bal)
          case (-1)
             p%bal = 0
             fix_balance = .false.
          case (0)
             p%bal = 1
          case (1)
             ! Rebalance.
             p1 => p%right
             select case (p1%bal)
             case (1)
                ! A single RR rotation.
                p%right => p1%left
                p1%left => p
                p%bal = 0
                p => p1
                p%bal = 0
                fix_balance = .false.
             case (-1, 0)
                ! A double RL rotation.
                p2 => p1%left
                p1%left => p2%right
                p2%right => p1
                p%right => p2%left
                p2%left => p
                p%bal = -(max (p2%bal, 0))
                p1%bal = -(min (p2%bal, 0))
                p => p2
                p%bal = 0
                fix_balance = .false.
             case default
                error stop
             end select
          case default
             error stop
          end select
       end if
    else
       ! The key was found. The pointer p points to an existing node.
       call insertion (key, data, .false., p)
    end if
  end subroutine insertion_search

  subroutine avl_delete_with_found (less_than, key, tree, found)
    procedure(avl_less_than_t) :: less_than
    class(*), intent(in) :: key
    class(avl_tree_t), intent(inout) :: tree
    logical, intent(out) :: found

    logical :: fix_balance

    fix_balance = .false.
    call deletion_search (less_than, key, tree%p, fix_balance, found)
  end subroutine avl_delete_with_found

  subroutine avl_delete_without_found (less_than, key, tree)
    procedure(avl_less_than_t) :: less_than
    class(*), intent(in) :: key
    class(avl_tree_t), intent(inout) :: tree

    logical :: found

    call avl_delete_with_found (less_than, key, tree, found)
  end subroutine avl_delete_without_found

  recursive subroutine deletion_search (less_than, key, p, fix_balance, found)
    procedure(avl_less_than_t) :: less_than
    class(*), intent(in) :: key
    type(avl_node_t), pointer, intent(inout) :: p
    logical, intent(inout) :: fix_balance
    logical, intent(out) :: found

    type(avl_node_t), pointer :: q

    if (.not. associated (p)) then
       ! The key is not in the tree.
       found = .false.
    else if (less_than (key, p%key)) then
       call deletion_search (less_than, key, p%left, fix_balance, found)
       if (fix_balance) call balance_for_shrunken_left (p, fix_balance)
    else if (less_than (p%key, key)) then
       call deletion_search (less_than, key, p%right, fix_balance, found)
       if (fix_balance) call balance_for_shrunken_right (p, fix_balance)
    else
       q => p
       if (.not. associated (q%right)) then
          p => q%left
          fix_balance = .true.
       else if (.not. associated (q%left)) then
          p => q%right
          fix_balance = .true.
       else
          call del (q%left, q, fix_balance)
          if (fix_balance) call balance_for_shrunken_left (p, fix_balance)
       end if
       deallocate (q)
       found = .true.
    end if
  end subroutine deletion_search

  recursive subroutine del (r, q, fix_balance)
    type(avl_node_t), pointer, intent(inout) :: r, q
    logical, intent(inout) :: fix_balance

    if (associated (r%right)) then
       call del (r%right, q, fix_balance)
       if (fix_balance) call balance_for_shrunken_right (r, fix_balance)
    else
       q%key = r%key
       q%data = r%data
       q => r
       r => r%left
       fix_balance = .true.
    end if
  end subroutine del

  subroutine balance_for_shrunken_left (p, fix_balance)
    type(avl_node_t), pointer, intent(inout) :: p
    logical, intent(inout) :: fix_balance

    ! The left side has lost a node.

    type(avl_node_t), pointer :: p1, p2

    if (.not. fix_balance) error stop

    select case (p%bal)
    case (-1)
       p%bal = 0
    case (0)
       p%bal = 1
       fix_balance = .false.
    case (1)
       ! Rebalance.
       p1 => p%right
       select case (p1%bal)
       case (0)
          ! A single RR rotation.
          p%right => p1%left
          p1%left => p
          p%bal = 1
          p1%bal = -1
          p => p1
          fix_balance = .false.
       case (1)
          ! A single RR rotation.
          p%right => p1%left
          p1%left => p
          p%bal = 0
          p1%bal = 0
          p => p1
          fix_balance = .true.
       case (-1)
          ! A double RL rotation.
          p2 => p1%left
          p1%left => p2%right
          p2%right => p1
          p%right => p2%left
          p2%left => p
          p%bal = -(max (p2%bal, 0))
          p1%bal = -(min (p2%bal, 0))
          p => p2
          p2%bal = 0
       case default
          error stop
       end select
    case default
       error stop
    end select
  end subroutine balance_for_shrunken_left

  subroutine balance_for_shrunken_right (p, fix_balance)
    type(avl_node_t), pointer, intent(inout) :: p
    logical, intent(inout) :: fix_balance

    ! The right side has lost a node.

    type(avl_node_t), pointer :: p1, p2

    if (.not. fix_balance) error stop

    select case (p%bal)
    case (1)
       p%bal = 0
    case (0)
       p%bal = -1
       fix_balance = .false.
    case (-1)
       ! Rebalance.
       p1 => p%left
       select case (p1%bal)
       case (0)
          ! A single LL rotation.
          p%left => p1%right
          p1%right => p
          p1%bal = 1
          p%bal = -1
          p => p1
          fix_balance = .false.
       case (-1)
          ! A single LL rotation.
          p%left => p1%right
          p1%right => p
          p1%bal = 0
          p%bal = 0
          p => p1
          fix_balance = .true.
       case (1)
          ! A double LR rotation.
          p2 => p1%right
          p1%right => p2%left
          p2%left => p1
          p%left => p2%right
          p2%right => p
          p%bal = -(min (p2%bal, 0))
          p1%bal = -(max (p2%bal, 0))
          p => p2
          p2%bal = 0
       case default
          error stop
       end select
    case default
       error stop
    end select
  end subroutine balance_for_shrunken_right

  function avl_size (tree) result (size)
    class(avl_tree_t), intent(in) :: tree
    integer :: size

    size = traverse (tree%p)

  contains

    recursive function traverse (p) result (size)
      type(avl_node_t), pointer, intent(in) :: p
      integer :: size

      if (associated (p)) then
         ! The order of traversal is arbitrary.
         size = 1 + traverse (p%left) + traverse (p%right)
      else
         size = 0
      end if
    end function traverse

  end function avl_size

  function avl_pointer_pairs (tree) result (lst)
    class(avl_tree_t), intent(in) :: tree
    type(avl_pointer_pair_t), pointer :: lst

    ! Reverse in-order traversal of the tree, to produce a CONS-list
    ! of pointers to the contents.

    lst => null ()
    if (associated (tree%p)) lst => traverse (tree%p, lst)

  contains

    recursive function traverse (p, lst1) result (lst2)
      type(avl_node_t), pointer, intent(in) :: p
      type(avl_pointer_pair_t), pointer, intent(in) :: lst1
      type(avl_pointer_pair_t), pointer :: lst2

      type(avl_pointer_pair_t), pointer :: new_entry

      lst2 => lst1
      if (associated (p%right)) lst2 => traverse (p%right, lst2)
      allocate (new_entry)
      new_entry%p_key => p%key
      new_entry%p_data => p%data
      new_entry%next => lst2
      lst2 => new_entry
      if (associated (p%left)) lst2 => traverse (p%left, lst2)
    end function traverse

  end function avl_pointer_pairs

  subroutine avl_write (write_key_data, unit, tree)
    procedure(avl_key_data_writer_t) :: write_key_data
    integer, intent(in) :: unit
    class(avl_tree_t), intent(in) :: tree

    character(len = *), parameter :: tab = achar (9)

    type(avl_node_t), pointer :: p

    p => tree%p
    if (.not. associated (p)) then
       continue
    else
       call traverse (p%left, 1, .true.)
       call write_key_data (unit, p%key, p%data)
       write (unit, '(2A, "depth = ", I0, "  bal = ", I0)') tab, tab, 0, p%bal
       call traverse (p%right, 1, .false.)
    end if

  contains

    recursive subroutine traverse (p, depth, left)
      type(avl_node_t), pointer, intent(in) :: p
      integer, value :: depth
      logical, value :: left

      if (.not. associated (p)) then
         continue
      else
         call traverse (p%left, depth + 1, .true.)
         call pad (depth, left)
         call write_key_data (unit, p%key, p%data)
         write (unit, '(2A, "depth = ", I0, "  bal = ", I0)') tab, tab, depth, p%bal
         call traverse (p%right, depth + 1, .false.)
      end if
    end subroutine traverse

    subroutine pad (depth, left)
      integer, value :: depth
      logical, value :: left

      integer :: i

      do i = 1, depth
         write (unit, '(2X)', advance = 'no')
      end do
    end subroutine pad

  end subroutine avl_write

  subroutine avl_check (tree)
    use, intrinsic :: iso_fortran_env, only: error_unit
    class(avl_tree_t), intent(in) :: tree

    type(avl_node_t), pointer :: p
    integer :: height_L, height_R

    p => tree%p
    call get_heights (p, height_L, height_R)
    call check_heights (height_L, height_R)

  contains

    recursive subroutine get_heights (p, height_L, height_R)
      type(avl_node_t), pointer, intent(in) :: p
      integer, intent(out) :: height_L, height_R

      integer :: height_LL, height_LR
      integer :: height_RL, height_RR

      height_L = 0
      height_R = 0
      if (associated (p)) then
         call get_heights (p%left, height_LL, height_LR)
         call check_heights (height_LL, height_LR)
         height_L = height_LL + height_LR
         call get_heights (p%right, height_RL, height_RR)
         call check_heights (height_RL, height_RR)
         height_R = height_RL + height_RR
      end if
    end subroutine get_heights

    subroutine check_heights (height_L, height_R)
      integer, value :: height_L, height_R

      if (2 <= abs (height_L - height_R)) then
         write (error_unit, '("*** AVL condition violated ***")')
         error stop
      end if
    end subroutine check_heights

  end subroutine avl_check

end module avl_trees

program avl_trees_demo
  use, intrinsic :: iso_fortran_env, only: output_unit
  use, non_intrinsic :: avl_trees

  implicit none

  integer, parameter :: keys_count = 20

  type(avl_tree_t) :: tree
  logical :: found
  class(*), allocatable :: retval
  integer :: the_keys(1:keys_count)
  integer :: i, j

  do i = 1, keys_count
     the_keys(i) = i
  end do
  call fisher_yates_shuffle (the_keys, keys_count)

  call avl_check (tree)
  do i = 1, keys_count
     call avl_insert (lt, the_keys(i), real (the_keys(i)), tree)
     call avl_check (tree)
     if (avl_size (tree) /= i) error stop
     do j = 1, keys_count
        if (avl_contains (lt, the_keys(j), tree) .neqv. (j <= i)) error stop
     end do
     do j = 1, keys_count
        call avl_retrieve (lt, the_keys(j), tree, found, retval)
        if (found .neqv. (j <= i)) error stop
        if (found) then
           ! This crazy way to write ‘/=’ is to quell those tiresome
           ! warnings about using ‘==’ or ‘/=’ with floating point
           ! numbers. Floating point numbers can represent integers
           ! *exactly*.
           if (0 < abs (real_cast (retval) - real (the_keys(j)))) error stop
        end if
        if (found) then
           block
             character(len = 1), parameter :: ch = '*'
             !
             ! Try replacing the data with a character and then
             ! restoring the number.
             !
             call avl_insert (lt, the_keys(j), ch, tree)
             call avl_retrieve (lt, the_keys(j), tree, found, retval)
             if (.not. found) error stop
             if (char_cast (retval) /= ch) error stop
             call avl_insert (lt, the_keys(j), real (the_keys(j)), tree)
             call avl_retrieve (lt, the_keys(j), tree, found, retval)
             if (.not. found) error stop
             if (0 < abs (real_cast (retval) - real (the_keys(j)))) error stop
           end block
        end if
     end do
  end do

  write (output_unit, '(70("-"))')
  call avl_write (int_real_writer, output_unit, tree)
  write (output_unit, '(70("-"))')
  call print_contents (output_unit, tree)
  write (output_unit, '(70("-"))')

  call fisher_yates_shuffle (the_keys, keys_count)
  do i = 1, keys_count
     call avl_delete (lt, the_keys(i), tree)
     call avl_check (tree)
     if (avl_size (tree) /= keys_count - i) error stop
     ! Try deleting a second time.
     call avl_delete (lt, the_keys(i), tree)
     call avl_check (tree)
     if (avl_size (tree) /= keys_count - i) error stop
     do j = 1, keys_count
        if (avl_contains (lt, the_keys(j), tree) .neqv. (i < j)) error stop
     end do
     do j = 1, keys_count
        call avl_retrieve (lt, the_keys(j), tree, found, retval)
        if (found .neqv. (i < j)) error stop
        if (found) then
           if (0 < abs (real_cast (retval) - real (the_keys(j)))) error stop
        end if
     end do
  end do

contains

  subroutine fisher_yates_shuffle (keys, n)
    integer, intent(inout) :: keys(*)
    integer, intent(in) :: n

    integer :: i, j
    real :: randnum
    integer :: tmp

    do i = 1, n - 1
       call random_number (randnum)
       j = i + floor (randnum * (n - i + 1))
       tmp = keys(i)
       keys(i) = keys(j)
       keys(j) = tmp
    end do
  end subroutine fisher_yates_shuffle

  function int_cast (u) result (v)
    class(*), intent(in) :: u
    integer :: v

    select type (u)
    type is (integer)
       v = u
    class default
       ! This case is not handled.
       error stop
    end select
  end function int_cast

  function real_cast (u) result (v)
    class(*), intent(in) :: u
    real :: v

    select type (u)
    type is (real)
       v = u
    class default
       ! This case is not handled.
       error stop
    end select
  end function real_cast

  function char_cast (u) result (v)
    class(*), intent(in) :: u
    character(len = 1) :: v

    select type (u)
    type is (character(*))
       v = u
    class default
       ! This case is not handled.
       error stop
    end select
  end function char_cast

  function lt (u, v) result (u_lt_v)
    class(*), intent(in) :: u, v
    logical :: u_lt_v

    select type (u)
    type is (integer)
       select type (v)
       type is (integer)
          u_lt_v = (u < v)
       class default
          ! This case is not handled.
          error stop
       end select
    class default
       ! This case is not handled.
       error stop
    end select
  end function lt

  subroutine int_real_writer (unit, key, data)
    integer, intent(in) :: unit
    class(*), intent(in) :: key, data

    write (unit, '("(", I0, ", ", F0.1, ")")', advance = 'no') &
         & int_cast(key), real_cast(data)
  end subroutine int_real_writer

  subroutine print_contents (unit, tree)
    integer, intent(in) :: unit
    class(avl_tree_t), intent(in) :: tree

    type(avl_pointer_pair_t), pointer :: ppairs, pp

    write (unit, '("tree size = ", I0)') avl_size (tree)
    ppairs => avl_pointer_pairs (tree)
    pp => ppairs
    do while (associated (pp))
       write (unit, '("(", I0, ", ", F0.1, ")")') &
            & int_cast (pp%p_key), real_cast (pp%p_data)
       pp => pp%next
    end do
    if (associated (ppairs)) deallocate (ppairs)
  end subroutine print_contents

end program avl_trees_demo

Implement an AVL tree with operations such as lookup, insertion, and deletion which all take O(log n) time. The tree ensures that the heights of two child subtrees of any node differ by at most one. The implementation also includes checking the AVL condition, printing the tree representation, outputting the full contents as an ordered linked list, and computing the tree size by traversal. The keys and data can be of any type. Duplicate node keys are not allowed. The operations are written using some more general mechanisms.


! Implemented by Anant Dixit (Nov. 2014)
! Transpose elements in find_center to obtain correct results. R.N. McLean (Dec 2017)
program circles
implicit none
double precision :: P1(2), P2(2), R

P1 = (/0.1234d0, 0.9876d0/)
P2 = (/0.8765d0,0.2345d0/)
R = 2.0d0
call print_centers(P1,P2,R)

P1 = (/0.0d0, 2.0d0/)
P2 = (/0.0d0,0.0d0/)
R = 1.0d0
call print_centers(P1,P2,R)

P1 = (/0.1234d0, 0.9876d0/)
P2 = (/0.1234d0, 0.9876d0/)
R = 2.0d0
call print_centers(P1,P2,R)

P1 = (/0.1234d0, 0.9876d0/)
P2 = (/0.8765d0, 0.2345d0/)
R = 0.5d0
call print_centers(P1,P2,R)

P1 = (/0.1234d0, 0.9876d0/)
P2 = (/0.1234d0, 0.9876d0/)
R = 0.0d0
call print_centers(P1,P2,R)
end program circles

subroutine print_centers(P1,P2,R)
implicit none
double precision :: P1(2), P2(2), R, Center(2,2)
integer :: Res
call test_inputs(P1,P2,R,Res)
write(*,*)
write(*,'(A10,F7.4,A1,F7.4)') 'Point1  : ', P1(1), ' ', P1(2)
write(*,'(A10,F7.4,A1,F7.4)') 'Point2  : ', P2(1), ' ', P2(2)
write(*,'(A10,F7.4)') 'Radius  : ', R
if(Res.eq.1) then
  write(*,*) 'Same point because P1=P2 and r=0.'
elseif(Res.eq.2) then
  write(*,*) 'No circles can be drawn because r=0.'
elseif(Res.eq.3) then
  write(*,*) 'Infinite circles because P1=P2 for non-zero radius.'
elseif(Res.eq.4) then
  write(*,*) 'No circles with given r can be drawn because points are far apart.'
elseif(Res.eq.0) then
  call find_center(P1,P2,R,Center)
  if(Center(1,1).eq.Center(2,1) .and. Center(1,2).eq.Center(2,2)) then
    write(*,*) 'Points lie on the diameter. A single circle can be drawn.'
    write(*,'(A10,F7.4,A1,F7.4)') 'Center  : ', Center(1,1), ' ', Center(1,2)
  else
    write(*,*) 'Two distinct circles found.'
    write(*,'(A10,F7.4,A1,F7.4)') 'Center1 : ', Center(1,1), ' ', Center(1,2)
    write(*,'(A10,F7.4,A1,F7.4)') 'Center2 : ', Center(2,1), ' ', Center(2,2)
  end if
elseif(Res.lt.0) then
  write(*,*) 'Incorrect value for r.'
end if
write(*,*)
end subroutine print_centers

subroutine test_inputs(P1,P2,R,Res)
implicit none
double precision :: P1(2), P2(2), R, dist
integer :: Res
if(R.lt.0.0d0) then
  Res = -1
  return
elseif(R.eq.0.0d0 .and. P1(1).eq.P2(1) .and. P1(2).eq.P2(2)) then
  Res = 1
  return
elseif(R.eq.0.0d0) then
  Res = 2
  return
elseif(P1(1).eq.P2(1) .and. P1(2).eq.P2(2)) then
  Res = 3
  return
else
  dist = sqrt( (P1(1)-P2(1))**2 + (P1(2)-P2(2))**2 )
  if(dist.gt.2.0d0*R) then
    Res = 4
    return
  else
    Res = 0
    return
  end if
end if
end subroutine test_inputs

subroutine find_center(P1,P2,R,Center)
implicit none
double precision :: P1(2), P2(2), MP(2), Center(2,2), R, dm, dd
MP = (P1 + P2)/2.0d0
dm = sqrt((P1(1) - P2(1))**2 + (P1(2) - P2(2))**2)
dd = sqrt(R**2 - (dm/2.0d0)**2)
Center(1,1) = MP(1) - dd*(P2(2) - P1(2))/dm
Center(1,2) = MP(2) + dd*(P2(1) - P1(1))/dm

Center(2,1) = MP(1) + dd*(P2(2) - P1(2))/dm
Center(2,2) = MP(2) - dd*(P2(1) - P1(1))/dm
end subroutine find_center

The code defines a function that takes two points and a radius as input and returns two circles that pass through these points. The function handles special cases such as when the radius is zero, the points are coincident, form a diameter, or are too far apart. It also provides output for specific input values. The code also includes a module for handling error messages and uses complex number arithmetic. The output format is free-format, displaying complex numbers in brackets.


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

  real :: r
  integer :: a, b

  do
     call random_number(r)
     a = int(r * 20)
     write(*,*) a
     if (a == 10) exit
     call random_number(r)
     b = int(r * 20)
     write(*,*) b
  end do

end program Example

Works with: Fortran version 77 and later
      PROGRAM LOOPBREAK
        INTEGER I, RNDINT

C       It doesn't matter what number you put here.
        CALL SDRAND(123)

C       Because FORTRAN 77 semantically lacks many loop structures, we
C       have to use GOTO statements to do the same thing.
   10   CONTINUE
C         Print a random number.
          I = RNDINT(0, 19)
          WRITE (*,*) I

C         If the random number is ten, break (i.e. skip to after the end
C         of the "loop").
          IF (I .EQ. 10) GOTO 20

C         Otherwise, print a second random number.
          I = RNDINT(0, 19)
          WRITE (*,*) I

C         This is the end of our "loop," meaning we jump back to the
C         beginning again.
          GOTO 10

   20   CONTINUE

        STOP
      END

C FORTRAN 77 does not come with a random number generator, but it
C is easy enough to type "fortran 77 random number generator" into your
C preferred search engine and to copy and paste what you find. The
C following code is a slightly-modified version of:
C
C     http://www.tat.physik.uni-tuebingen.de/
C         ~kley/lehre/ftn77/tutorial/subprograms.html
      SUBROUTINE SDRAND (IRSEED)
        COMMON  /SEED/ UTSEED, IRFRST
        UTSEED = IRSEED
        IRFRST = 0
        RETURN
      END
      INTEGER FUNCTION RNDINT (IFROM, ITO)
        INTEGER IFROM, ITO
        PARAMETER (MPLIER=16807, MODLUS=2147483647,                     &
     &              MOBYMP=127773, MOMDMP=2836)
        COMMON  /SEED/ UTSEED, IRFRST
        INTEGER HVLUE, LVLUE, TESTV, NEXTN
        SAVE    NEXTN
        IF (IRFRST .EQ. 0) THEN
          NEXTN = UTSEED
          IRFRST = 1
        ENDIF
        HVLUE = NEXTN / MOBYMP
        LVLUE = MOD(NEXTN, MOBYMP)
        TESTV = MPLIER*LVLUE - MOMDMP*HVLUE
        IF (TESTV .GT. 0) THEN
          NEXTN = TESTV
        ELSE
          NEXTN = TESTV + MODLUS
        ENDIF
        IF (NEXTN .GE. 0) THEN
          RNDINT = MOD(MOD(NEXTN, MODLUS), ITO - IFROM + 1) + IFROM
        ELSE
          RNDINT = MOD(MOD(NEXTN, MODLUS), ITO - IFROM + 1) + ITO + 1
        ENDIF
        RETURN
      END

Works with: Fortran version 66 and earlier

      SUBROUTINE RANDU(IX,IY,YFL)
Copied from the IBM1130 Scientific Subroutines Package (1130-CM-02X): Programmer's Manual, page 60.
CAUTION! This routine's 32-bit variant is reviled by Prof. Knuth and many others for good reason!
        IY = IX*899
        IF (IY) 5,6,6
    5   IY = IY + 32767 + 1
    6   YFL = IY
        YFL = YFL/32767.
      END

      FUNCTION IR19(IX)
        CALL RANDU(IX,IY,YFL)
        IX = IY
        I = YFL*20
        IF (I - 20) 12,11,11
   11   I = 19
   12   IR19 = I
      END

      IX = 1
Commence the loop.
   10 I = IR19(IX)
      WRITE (6,11) I
   11 FORMAT (I3)
      IF (I - 10) 12,20,12
   12 I = IR19(IX)
      WRITE (6,11) I
      GO TO 10
Cease.
   20 CONTINUE
      END

 0 13  4 19  1  7  2 12  4  7 14 11  6  4  0  9  5 12 16 19 18  2  0 13  2  7 10

The code generates and prints random numbers between 0 and 19 in a loop. If the first generated number in a loop is 10, the loop stops. If not, a second random number is generated and printed before the loop restarts. If 10 is never the first number generated, the loop continues indefinitely. The random number generation is done using the RANDU generator, in the style of Fortran 66. The code ensures that all numbers have an equal chance of being generated, with special handling for the edge case of 19.


Works with: Fortran version 90 and later
PROGRAM EXAMPLE
  IMPLICIT NONE
  INTEGER :: exponent, factor

  WRITE(*,*) "Enter exponent of Mersenne number"
  READ(*,*) exponent
  factor = Mfactor(exponent)
  IF (factor == 0) THEN
    WRITE(*,*) "No Factor found"
  ELSE
    WRITE(*,"(A,I0,A,I0)") "M", exponent, " has a factor: ", factor
  END IF

CONTAINS

FUNCTION isPrime(number)
!   code omitted - see [[Primality by Trial Division]]
END FUNCTION

FUNCTION  Mfactor(p)
  INTEGER :: Mfactor
  INTEGER, INTENT(IN) :: p
  INTEGER :: i, k,  maxk, msb, n, q

  DO i = 30, 0 , -1
    IF(BTEST(p, i)) THEN
      msb = i
      EXIT
    END IF
  END DO

  maxk = 16384  / p     ! limit for k to prevent overflow of 32 bit signed integer
  DO k = 1, maxk
    q = 2*p*k + 1
    IF (.NOT. isPrime(q)) CYCLE
    IF (MOD(q, 8) /= 1 .AND. MOD(q, 8) /= 7) CYCLE
    n = 1
    DO i = msb, 0, -1
      IF (BTEST(p, i)) THEN
        n = MOD(n*n*2, q)
      ELSE
        n = MOD(n*n, q)
      ENDIF
    END DO
    IF (n == 1) THEN
      Mfactor = q
      RETURN
    END IF
  END DO
  Mfactor = 0
END FUNCTION
END PROGRAM EXAMPLE

implement a method to find a factor of a Mersenne number (in this case, M929). The method uses efficient algorithms to determine if a number divides 2P-1, including a self-implemented modPow operation. It also incorporates properties of Mersenne numbers to refine the process, such as the form of any factor q of 2P-1 and the conditions that q must meet. The method stops when 2kP+1 > sqrt(N). It only works on Mersenne numbers where P is prime.


Works with: Fortran version 90 and later

PROGRAM YULETIDE

IMPLICIT NONE

INTEGER :: day, year

WRITE(*, "(A)", ADVANCE="NO") "25th of December is a Sunday in"
DO year = 2008, 2121
   day = Day_of_week(25, 12, year)
   IF (day == 1) WRITE(*, "(I5)", ADVANCE="NO") year
END DO

CONTAINS

FUNCTION Day_of_week(d, m, y)
   INTEGER :: Day_of_week, j, k, mm, yy
   INTEGER, INTENT(IN) :: d, m, y

   mm=m
   yy=y
   IF(mm.le.2) THEN
      mm=mm+12
      yy=yy-1
   END IF
   j = yy / 100
   k = MOD(yy, 100)
   Day_of_week = MOD(d + ((mm+1)*26)/10 + k + k/4 + j/4 + 5*j, 7)
END FUNCTION Day_of_week

END PROGRAM YULETIDE

"Determines the years between 2008 and 2121 when Christmas falls on a Sunday using standard date handling libraries, and compares the results across different programming languages to identify any discrepancies due to issues like overflow in date/time representation."


Library: LAPACK

program qrtask
    implicit none
    integer, parameter :: n = 4
    real(8) :: durer(n, n) = reshape(dble([ &
        16,  5,  9,  4, &
         3, 10,  6, 15, &
         2, 11,  7, 14, &
        13,  8, 12,  1  &
    ]), [n, n])
    real(8) :: q(n, n), r(n, n), qr(n, n), id(n, n), tau(n)
    integer, parameter :: lwork = 1024
    real(8) :: work(lwork)
    integer :: info, i, j

    q = durer
    call dgeqrf(n, n, q, n, tau, work, lwork, info)

    r = 0d0
    forall (i = 1:n, j = 1:n, j >= i) r(i, j) = q(i, j)

    call dorgqr(n, n, n, q, n, tau, work, lwork, info)

    qr = matmul(q, r)
    id = matmul(q, transpose(q))

    call show(4, durer, "A")
    call show(4, q, "Q")
    call show(4, r, "R")
    call show(4, qr, "Q*R")
    call show(4, id, "Q*Q'")
contains
    subroutine show(n, a, s)
        character(*) :: s
        integer :: n, i
        real(8) :: a(n, n)

        print *, s
        do i = 1, n
            print 1, a(i, :)
          1 format (*(f12.6,:,' '))
        end do
    end subroutine
end program

"Implement QR decomposition using Householder reflections on a given matrix. The code also includes the application of QR decomposition for solving linear least squares problems. The code handles cases where the matrix is not square by removing zero padded bottom rows. The solution is obtained by back substitution."


program remove_dups
  implicit none
  integer :: example(12)         ! The input
  integer :: res(size(example))  ! The output
  integer :: k                   ! The number of unique elements
  integer :: i, j

  example = [1, 2, 3, 2, 2, 4, 5, 5, 4, 6, 6, 5]
  k = 1
  res(1) = example(1)
  outer: do i=2,size(example)
     do j=1,k
        if (res(j) == example(i)) then
           ! Found a match so start looking again
           cycle outer
        end if
     end do
     ! No match found so add it to the output
     k = k + 1
     res(k) = example(i)
  end do outer
  write(*,advance='no',fmt='(a,i0,a)') 'Unique list has ',k,' elements: '
  write(*,*) res(1:k)
end program remove_dups

program remove_dups
    implicit none
    integer :: example(12)         ! The input
    integer :: res(size(example))  ! The output
    integer :: k                   ! The number of unique elements
    integer :: i

    example = [1, 2, 3, 2, 2, 4, 5, 5, 4, 6, 6, 5]
    k = 1
    res(1) = example(1)
    do i=2,size(example)
        ! if the number already exist in res check next
        if (any( res == example(i) )) cycle
        ! No match found so add it to the output
        k = k + 1
        res(k) = example(i)
    end do

    write(*,advance='no',fmt='(a,i0,a)') 'Unique list has ',k,' elements: '
    write(*,*) res(1:k)
end program remove_dups

implement a method to remove duplicate elements from an array in Fortran. This is achieved by comparing all elements in the array. If a duplicate is found, it is discarded. The code also uses the 'ANY' function to check if an input number already exists in the array of unique elements.


Works with: Fortran version 90 and later

If the largest element is in the last slot, the call to QSort(A(marker:),nA-marker+1) goes beyond the end of the array. This can cause exceptions and bad results.
The use of a random number causes non reproducible performance.

MODULE qsort_mod

  IMPLICIT NONE

  TYPE group
     INTEGER :: order    ! original order of unsorted data
     REAL    :: VALUE    ! values to be sorted by
  END TYPE group

CONTAINS

  RECURSIVE SUBROUTINE QSort(a,na)

    ! DUMMY ARGUMENTS
    INTEGER, INTENT(in) :: nA
    TYPE (group), DIMENSION(nA), INTENT(in out) :: A

    ! LOCAL VARIABLES
    INTEGER :: left, right
    REAL :: random
    REAL :: pivot
    TYPE (group) :: temp
    INTEGER :: marker

    IF (nA > 1) THEN

       CALL random_NUMBER(random)
       pivot = A(INT(random*REAL(nA-1))+1)%VALUE   ! Choice a random pivot (not best performance, but avoids worst-case)
       left = 1
       right = nA
       ! Partition loop
       DO
          IF (left >= right) EXIT
          DO
             IF (A(right)%VALUE <= pivot) EXIT
             right = right - 1
          END DO
          DO
             IF (A(left)%VALUE >= pivot) EXIT
             left = left + 1
          END DO
          IF (left < right) THEN
             temp = A(left)
             A(left) = A(right)
             A(right) = temp
          END IF
       END DO

       IF (left == right) THEN
          marker = left + 1
       ELSE
          marker = left
       END IF

       CALL QSort(A(:marker-1),marker-1)
       CALL QSort(A(marker:),nA-marker+1)  WARNING CAN GO BEYOND END OF ARRAY DO NOT USE THIS IMPLEMENTATION

    END IF

  END SUBROUTINE QSort

END MODULE qsort_mod

! Test Qsort Module
PROGRAM qsort_test
  USE qsort_mod
  IMPLICIT NONE

  INTEGER, PARAMETER :: nl = 10, nc = 5, l = nc*nl, ns=33
  TYPE (group), DIMENSION(l) :: A
  INTEGER, DIMENSION(ns) :: seed
  INTEGER :: i
  REAL :: random
  CHARACTER(LEN=80) :: fmt1, fmt2
  ! Using the Fibonacci sequence to initialize seed:
  seed(1) = 1 ; seed(2) = 1
  DO i = 3,ns
     seed(i) = seed(i-1)+seed(i-2)
  END DO
  ! Formats of the outputs
  WRITE(fmt1,'(A,I2,A)') '(', nc, '(I5,2X,F6.2))'
  WRITE(fmt2,'(A,I2,A)') '(3x', nc, '("Ord.  Num.",3x))'
  PRINT *, "Unsorted Values:"
  PRINT fmt2,
  CALL random_SEED(put = seed)
  DO i = 1, l
     CALL random_NUMBER(random)
     A(i)%VALUE = NINT(1000*random)/10.0
     A(i)%order = i
     IF (MOD(i,nc) == 0) WRITE (*,fmt1) A(i-nc+1:i)
  END DO
  PRINT *
  CALL QSort(A,l)
  PRINT *, "Sorted Values:"
  PRINT fmt2,
  DO i = nc, l, nc
     IF (MOD(i,nc) == 0) WRITE (*,fmt1) A(i-nc+1:i)
  END DO
  STOP
END PROGRAM qsort_test

implement the Quicksort algorithm to sort an array or list of elements. The algorithm works by selecting a pivot element from the array and partitioning the other elements into two sub-arrays, according to whether they are less than or greater than the pivot. The sub-arrays are then recursively sorted. The algorithm also includes an optimized version that works in place by swapping elements within the array to avoid memory allocation of more arrays. The pivot selection method is not specified and can vary. The implementation also discusses the comparison of Quicksort with merge sort and its performance. Note: The Fortran implementation of Quicksort is flawed and an alternative is suggested.


Works with: Fortran version 95 and later

PROGRAM DATE

  IMPLICIT NONE

  INTEGER :: dateinfo(8), day
  CHARACTER(9) :: month, dayname

  CALL DATE_AND_TIME(VALUES=dateinfo)
  SELECT CASE(dateinfo(2))
    CASE(1)
      month = "January"
    CASE(2)
      month = "February"
    CASE(3)
      month = "March"
    CASE(4)
      month = "April"
    CASE(5)
      month = "May"
    CASE(6)
      month = "June"
    CASE(7)
      month = "July"
    CASE(8)
      month = "August"
    CASE(9)
      month = "September"
    CASE(10)
      month = "October"
    CASE(11)
      month = "November"
    CASE(12)
     month = "December"
  END SELECT

  day = Day_of_week(dateinfo(3), dateinfo(2), dateinfo(1))

  SELECT CASE(day)
    CASE(0)
      dayname = "Saturday"
    CASE(1)
      dayname = "Sunday"
    CASE(2)
      dayname = "Monday"
    CASE(3)
      dayname = "Tuesday"
    CASE(4)
      dayname = "Wednesday"
    CASE(5)
      dayname = "Thursday"
    CASE(6)
      dayname = "Friday"
  END SELECT

  WRITE(*,"(I0,A,I0,A,I0)") dateinfo(1),"-", dateinfo(2),"-", dateinfo(3)
  WRITE(*,"(4(A),I0,A,I0)") trim(dayname), ", ", trim(month), " ", dateinfo(3), ", ", dateinfo(1)

CONTAINS

  FUNCTION Day_of_week(d, m, y)
    INTEGER :: Day_of_week, j, k
    INTEGER, INTENT(IN) :: d, m, y

    j = y / 100
    k = MOD(y, 100)
    Day_of_week = MOD(d + (m+1)*26/10 + k + k/4 + j/4 + 5*j, 7)
  END FUNCTION Day_of_week

END PROGRAM DATE

display the current date in two formats: "2007-11-23" and "Friday, November 23, 2007". It includes a custom function to determine the day of the week as the DATE_AND_TIME subroutine does not provide this information.


Works with: Fortran version 90 and later
program roman_numerals

  implicit none

  write (*, '(a)') roman (2009)
  write (*, '(a)') roman (1666)
  write (*, '(a)') roman (3888)

contains

function roman (n) result (r)

  implicit none
  integer, intent (in) :: n
  integer, parameter   :: d_max = 13
  integer              :: d
  integer              :: m
  integer              :: m_div
  character (32)       :: r
  integer,        dimension (d_max), parameter :: d_dec = &
    & (/1000, 900, 500, 400, 100, 90, 50, 40, 10, 9, 5, 4, 1/)
  character (32), dimension (d_max), parameter :: d_rom = &
    & (/'M ', 'CM', 'D ', 'CD', 'C ', 'XC', 'L ', 'XL', 'X ', 'IX', 'V ', 'IV', 'I '/)

  r = ''
  m = n
  do d = 1, d_max
    m_div = m / d_dec (d)
    r = trim (r) // repeat (trim (d_rom (d)), m_div)
    m = m - d_dec (d) * m_div
  end do

end function roman

end program roman_numerals

create a function that converts a positive integer into its equivalent Roman numeral representation.


Works with: Fortran version 90 and later

integer a (10)
integer :: a (10)
integer, dimension (10) :: a

integer, dimension (10) :: a
integer, dimension (1 : 10) :: a

integer, dimension (0 : 9) :: a

real, dimension (10) :: a
type (my_type), dimension (10) :: a

integer, dimension (10, 10) :: a
integer, dimension (10, 10, 10) :: a

integer, dimension (:), allocatable :: a
integer, dimension (:, :), allocatable :: a

allocate (a (10))
allocate (a (10, 10))

deallocate (a)

integer, dimension (10) :: a = (/1, 2, 3, 4, 5, 6, 7, 8, 9, 10/)
integer :: i
integer, dimension (10) :: a = (/(i * i, i = 1, 10)/)
integer, dimension (10) :: a = 0
integer :: i
integer, dimension (10, 10) :: a = reshape ((/(i * i, i = 1, 100)/), (/10, 10/))

integer :: i
integer, dimension (10), parameter :: a = (/(i * i, i = 1, 10)/)

a (1) = 1
a (1, 1) = 1

a = (/1, 2, 3, 4, 5, 6, 7, 8, 9, 10/)
a = (/(i * i, i = 1, 10)/)
a = reshape ((/(i * i, i = 1, 100)/), (/10, 10/))
a = 0

a (:) = (/1, 2, 3, 4, 5, 6, 7, 8, 9, 10/)
a (1 : 5) = (/1, 2, 3, 4, 5/)
a (: 5) = (/1, 2, 3, 4, 5/)
a (6 :) = (/1, 2, 3, 4, 5/)
a (1 : 5) = (/(i * i, i = 1, 10)/)
a (1 : 5)= 0
a (1, :)= (/(i * i, i = 1, 10)/)
a (1 : 5, 1)= (/(i * i, i = 1, 5)/)

i = a (1)

a = b (1 : 10)

i = size (a)

i = size (a, 1)

i_min = lbound (a)
i_max = ubound (a)

a = ubound (b)

demonstrate the basic syntax of arrays in the given programming language. It includes the creation of both fixed-length and dynamic arrays, assigning values to them, and retrieving an element. The code also showcases pushing a value into the array. It covers the declaration of arrays with different bases and types, including multidimensional and allocatable arrays. The code also illustrates the process of array allocation, deallocation, initialization, and constant array declaration. It further demonstrates element assignment, array assignment, and array section assignment. The retrieval of an element, array section, size, and bounds of an array, including multidimensional arrays, are also included.


Works with: Fortran version 2003

program FileIO

  integer, parameter :: out = 123, in = 124
  integer :: err
  character :: c

  open(out, file="output.txt", status="new", action="write", access="stream", iostat=err)
  if (err == 0) then
     open(in, file="input.txt", status="old", action="read", access="stream", iostat=err)
     if (err == 0) then
        err = 0
        do while (err == 0)
           read(unit=in, iostat=err) c
           if (err == 0) write(out) c
        end do
        close(in)
     end if
     close(out)
  end if

end program FileIO

demonstrate how to create a file named "output.txt", read the contents from "input.txt" into an intermediate variable, and then write these contents into "output.txt". It uses the "stream" access method as per the Fortran 2003 standard for easy binary data copying.


Works with: Fortran version 90 and later
 program example

   implicit none

   character(9) :: teststring = "alphaBETA"

   call To_upper(teststring)
   write(*,*) teststring
   call To_lower(teststring)
   write(*,*) teststring

 contains

   subroutine To_upper(str)
     character(*), intent(in out) :: str
     integer :: i

     do i = 1, len(str)
       select case(str(i:i))
         case("a":"z")
           str(i:i) = achar(iachar(str(i:i))-32)
       end select
     end do
   end subroutine To_upper

   subroutine To_lower(str)
     character(*), intent(in out) :: str
     integer :: i

     do i = 1, len(str)
       select case(str(i:i))
         case("A":"Z")
           str(i:i) = achar(iachar(str(i:i))+32)
       end select
     end do
   end subroutine To_Lower

 end program example

For converting lower-case text to upper, the following will work both on an ASCII system and an EBCDIC system (or any other encodement), once it is compiled for that system:       SUBROUTINE UPCASE(TEXT)
       CHARACTER*(*) TEXT
       INTEGER I,C
        DO I = 1,LEN(TEXT)
          C = INDEX("abcdefghijklmnopqrstuvwxyz",TEXT(I:I))
          IF (C.GT.0) TEXT(I:I) = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"(C:C)
        END DO
      END

The INDEX function of course returning zero if the character is not found. Converting from upper to lower case is the obvious inverse and it might be worthwhile defining a MODULE with suitable named character constants to avoid repetition - one might hope the compiler will share duplicated constants rather than producing a fresh version every time, but it might not too. The repeated text scanning done by the INDEX function for each character of TEXT will of course be a lot slower. A still-more advanced compiler might be able to take advantage of special translation op-codes, on systems that offer them. If storage space is not at a premium a swifter method would be to create something like CHARACTER*1 XLATUC(0:255) with most entries being equal to their index, except for those corresponding to the lower case letters for which the value is the corresponding upper case letter. Then       DO I = 1,LEN(TEXT)
        TEXT(I:I) = XLATUC(ICHAR(TEXT(I:I)))
      END DO

module uplow
   implicit none
   character(len=26), parameter, private :: low  = "abcdefghijklmnopqrstuvwxyz"
   character(len=26), parameter, private :: high = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
contains

   function to_upper(s) result(t)
      ! returns upper case of s
      implicit none
      character(len=*), intent(in) :: s
      character(len=len(s))        :: t

      character(len=1), save       :: convtable(0:255)
      logical, save                :: first = .true.
      integer                      :: i

      if(first) then
         do i=0,255
            convtable(i) = char(i)
         enddo
         do i=1,len(low)
            convtable(iachar(low(i:i))) = char(iachar(high(i:i)))
         enddo
         first = .false.
      endif

      t = s

      do i=1,len_trim(s)
         t(i:i) = convtable(iachar(s(i:i)))
      enddo

   end function to_upper

   function to_lower(s) result(t)
      ! returns lower case of s
      implicit none
      character(len=*), intent(in) :: s
      character(len=len(s))        :: t

      character(len=1), save :: convtable(0:255)
      logical, save          :: first = .true.
      integer                :: i

      if(first) then
         do i=0,255
            convtable(i) = char(i)
         enddo
         do i = 1,len(low)
            convtable(iachar(high(i:i))) = char(iachar(low(i:i)))
         enddo
         first = .false.
      endif

      t = s

      do i=1,len_trim(s)
         t(i:i) = convtable(iachar(s(i:i)))
      enddo

   end function to_lower

end module uplow

program doit
   use uplow
   character(len=40) :: s

   s = "abcdxyz ZXYDCBA _!@"
   print *,"original: ",'[',s,']'
   print *,"to_upper: ",'[',to_upper(s),']'
   print *,"to_lower: ",'[',to_lower(s),']'

end program doit

The code takes a string 'alphaBETA' and demonstrates conversion to upper-case and lower-case using default encoding or ASCII. It also showcases additional case conversion functions like swapping case, capitalizing the first letter, etc. The code uses functions or subroutines, and handles different character sets like ASCII and EBCDIC. It also manages different data formats in a file. The code is compatible with both ASCII and EBCDIC systems.


The code provides two functions to solve the Closest Pair of Points problem in a two-dimensional plane. The first function uses a brute-force algorithm with a time complexity of O(n^2) to find the closest pair of points among a given set. The second function uses a recursive divide and conquer approach with a time complexity of O(n log n) to achieve the same task. It sorts the points by x and y coordinates and recursively finds the closest pairs in the divided sets. It also checks for closer pairs across the divided sets.


Standard[edit]
The only facility for a collection more organised than a collection of separately-named variables (even if with a system for the names) is the array, which is a collection of items of identical type, indexed by an integer only, definitely not by a text as in say Snobol. Thus  REAL A(36)   !Declares a one-dimensional array A(1), A(2), ... A(36)
  A(1) = 1           !Assigns a value to the first element.
  A(2) = 3*A(1) + 5  !The second element gets 8.

With F90 came a large expansion in the facilities for manipulating arrays. They can now have any lower bound, as in REAL A(-6:+12) and their size can be defined at run time, not just compile time. Further, programmer-defined data aggregates can be defined via the TYPE statement, and arrays of such types can be manipulated. However, type-matching remains rigid: all elements of an array must be of the same type. So,  TYPE(MIXED)           !Name the "type".
  INTEGER COUNTER        !Its content is listed.
  REAL WEIGHT,DEPTH
  CHARACTER*28 MARKNAME
  COMPLEX PATH(6)        !The mixed collection includes an array.
 END TYPE MIXED
 TYPE(MIXED) TEMP,A(6) !Declare some items of that type.

Coarray[edit]

The code creates a collection of values, adds a few items to it, and allows for the manipulation of these values. It uses the concept of collections to represent sets of values, with specific focus on statically-typed languages where values are of a common data type. It also demonstrates the usage of complex formulae and the co-array concept for parallel execution. Additionally, it showcases the flexibility of the CHARACTER type to represent different types as texts.


Works with: Fortran version 90 and later

PROGRAM KNAPSACK

  IMPLICIT NONE

  REAL :: totalWeight, totalVolume
  INTEGER :: maxPanacea, maxIchor, maxGold, maxValue = 0
  INTEGER :: i, j, k
  INTEGER :: n(3)

  TYPE Bounty
    INTEGER :: value
    REAL :: weight
    REAL :: volume
  END TYPE Bounty

  TYPE(Bounty) :: panacea, ichor, gold, sack, current

  panacea = Bounty(3000, 0.3, 0.025)
  ichor   = Bounty(1800, 0.2, 0.015)
  gold    = Bounty(2500, 2.0, 0.002)
  sack    = Bounty(0, 25.0, 0.25)

  maxPanacea = MIN(sack%weight / panacea%weight, sack%volume / panacea%volume)
  maxIchor = MIN(sack%weight / ichor%weight, sack%volume / ichor%volume)
  maxGold = MIN(sack%weight / gold%weight, sack%volume / gold%volume)

  DO i = 0, maxPanacea
     DO j = 0, maxIchor
        Do k = 0, maxGold
           current%value = k * gold%value + j * ichor%value + i * panacea%value
           current%weight = k * gold%weight + j * ichor%weight + i * panacea%weight
           current%volume = k * gold%volume + j * ichor%volume + i * panacea%volume
           IF (current%weight > sack%weight .OR. current%volume > sack%volume) CYCLE
           IF (current%value > maxValue) THEN
              maxValue = current%value
              totalWeight = current%weight
              totalVolume = current%volume
              n(1) = i ; n(2) = j ; n(3) = k
           END IF
        END DO
     END DO
  END DO

  WRITE(*, "(A,I0)") "Maximum value achievable is ", maxValue
  WRITE(*, "(3(A,I0),A)") "This is achieved by carrying ", n(1), " panacea, ", n(2), " ichor and ", n(3), " gold items"
  WRITE(*, "(A,F4.1,A,F5.3)") "The weight to carry is ", totalWeight, " and the volume used is ", totalVolume

END PROGRAM KNAPSACK

Maximum value achievable is 54500
This is achieved by carrying 0 panacea, 15 ichor and 11 gold items
The weight to carry is 25.0 and the volume used is 0.247

"Code calculates the maximum value a traveler can carry in his knapsack from available items in Shangri La, considering the weight and volume constraints. It determines the optimal quantity of each item to take, using a brute force approach. It provides one of the four possible solutions that maximize the value."


Works with: FORTRAN version IV and later
C     Loops N plus one half - Fortran IV (1964)
      INTEGER I
      WRITE(6,301) (I,I=1,10)
  301 FORMAT((I3,','))
      END

Works with: Fortran version 77 and later
C     WARNING: This program is not valid ANSI FORTRAN 77 code. It uses
C     two nonstandard characters on the lines labelled 5001 and 5002.
C     Many F77 compilers should be okay with it, but it is *not*
C     standard.
      PROGRAM LOOPPLUSONEHALF
        INTEGER I, TEN
C       I'm setting a parameter to distinguish from the label 10.
        PARAMETER (TEN = 10)

        DO 10 I = 1, TEN
C         Write the number only.
          WRITE (*,5001) I

C         If we are on the last one, stop here. This will make this test
C         every iteration, which can slow your program down a little. If
C         you want to speed this up at the cost of your own convenience,
C         you could loop only to nine, and handle ten on its own after
C         the loop is finished. If you don't care, power to you.
          IF (I .EQ. TEN) GOTO 10

C         Append a comma to the number.
          WRITE (*,5002) ','
   10   CONTINUE

C       Always finish with a newline. This programmer hates it when a
C       program does not end its output with a newline.
        WRITE (*,5000) ''
        STOP

 5000   FORMAT (A)

C       Standard FORTRAN 77 is completely incapable of completing a
C       WRITE statement without printing a newline. This program would
C       be much more difficult (i.e. impossible) to write in the ANSI
C       standard, without cheating and saying something like:
C
C           WRITE (*,*) '1, 2, 3, 4, 5, 6, 7, 8, 9, 10'
C
C       The dollar sign at the end of the format is a nonstandard
C       character. It tells the compiler not to print a newline. If you
C       are actually using FORTRAN 77, you should figure out what your
C       particular compiler accepts. If you are actually using Fortran
C       90 or later, you should replace this line with the commented
C       line that follows it.
 5001   FORMAT (I3, $)
 5002   FORMAT (A, $)
C5001   FORMAT (T3, ADVANCE='NO')
C5001   FORMAT (A, ADVANCE='NO')
      END

Works with: Fortran version 90 and later
i = 1
do
  write(*, '(I0)', advance='no') i
  if ( i == 10 ) exit
  write(*, '(A)', advance='no') ', '
  i = i + 1
end do
write(*,*)

The code writes a comma-separated list from 1 to 10, using separate output statements for the number and the comma within a loop. The loop executes a partial body in its last iteration.


FORTRAN 77[edit]

      SUBROUTINE TSORT(NL,ND,IDEP,IORD,IPOS,NO)
      IMPLICIT NONE
      INTEGER NL,ND,NO,IDEP(ND,2),IORD(NL),IPOS(NL),I,J,K,IL,IR,IPL,IPR
      DO 10 I=1,NL
      IORD(I)=I
   10 IPOS(I)=I
      K=1
   20 J=K
      K=NL+1
      DO 30 I=1,ND
      IL=IDEP(I,1)
      IR=IDEP(I,2)
      IPL=IPOS(IL)
      IPR=IPOS(IR)
      IF(IL.EQ.IR .OR. IPL.GE.K .OR. IPL.LT.J .OR. IPR.LT.J) GO TO 30
      K=K-1
      IPOS(IORD(K))=IPL
      IPOS(IL)=K
      IORD(IPL)=IORD(K)
      IORD(K)=IL
   30 CONTINUE
      IF(K.GT.J) GO TO 20
      NO=J-1
      END

      PROGRAM EX_TSORT
      IMPLICIT NONE
      INTEGER NL,ND,NC,NO,IDEP,IORD,IPOS,ICODE,I,J,IL,IR
      PARAMETER(NL=15,ND=44,NC=69)
      CHARACTER*(20) LABEL
      DIMENSION IDEP(ND,2),LABEL(NL),IORD(NL),IPOS(NL),ICODE(NC)
      DATA LABEL/'DES_SYSTEM_LIB','DW01','DW02','DW03','DW04','DW05',
     1 'DW06','DW07','DWARE','GTECH','RAMLIB','STD_CELL_LIB','SYNOPSYS',
     2 'STD','IEEE'/
      DATA ICODE/1,14,13,12,1,3,2,11,15,0,2,15,2,9,10,0,3,15,3,9,0,4,14,
     213,9,4,3,2,15,10,0,5,5,15,2,9,10,0,6,6,15,9,0,7,7,15,9,0,8,15,9,0,
     39,15,9,0,10,15,10,0,11,14,15,0,12,15,12,0,0/

C DECODE DEPENDENCIES AND BUILD IDEP ARRAY
      I=0
      J=0
   10 I=I+1
      IL=ICODE(I)
      IF(IL.EQ.0) GO TO 30
   20 I=I+1
      IR=ICODE(I)
      IF(IR.EQ.0) GO TO 10
      J=J+1
      IDEP(J,1)=IL
      IDEP(J,2)=IR
      GO TO 20
   30 CONTINUE

C SORT LIBRARIES ACCORDING TO DEPENDENCIES (TOPOLOGICAL SORT)
      CALL TSORT(NL,ND,IDEP,IORD,IPOS,NO)

      PRINT*,'COMPILE ORDER'
      DO 40 I=1,NO
   40 PRINT*,LABEL(IORD(I))
      PRINT*,'UNORDERED LIBRARIES'
      DO 50 I=NO+1,NL
   50 PRINT*,LABEL(IORD(I))
      END

implement a function to perform a topological sort on VHDL libraries based on their dependencies. The function returns a valid compile order of the libraries, ignoring self-dependencies and flagging un-orderable dependencies. The function uses either Kahn's 1962 topological sort or depth-first search algorithm. It also includes a routine to handle the dependencies and compile order, with potential for optimization. The input data is assumed to be an array of dependencies with library names as single words.


      SUBROUTINE STARTS(A,B)	!Text A starts with text B?
       CHARACTER*(*) A,B
        IF (INDEX(A,B).EQ.1) THEN	!Searches A to find B.
          WRITE (6,*) ">",A,"< starts with >",B,"<"
         ELSE
          WRITE (6,*) ">",A,"< does not start with >",B,"<"
        END IF
      END SUBROUTINE STARTS

      SUBROUTINE HAS(A,B)	!Text B appears somewhere in text A?
       CHARACTER*(*) A,B
       INTEGER L
        L = INDEX(A,B)		!The first position in A where B matches.
        IF (L.LE.0) THEN
          WRITE (6,*) ">",A,"< does not contain >",B,"<"
         ELSE
          WRITE (6,*) ">",A,"< contains a >",B,"<, offset",L
        END IF
      END SUBROUTINE HAS

      SUBROUTINE ENDS(A,B)	!Text A ends with text B.
       CHARACTER*(*) A,B
       INTEGER L
        L = LEN(A) - LEN(B)	!Find the tail end of A that B might match.
        IF (L.LT.0) THEN	!Dare not use an OR, because of full evaluation risks.
          WRITE (6,*) ">",A,"< is too short to end with >",B,"<"	!Might as well have a special message.
        ELSE IF (A(L + 1:L + LEN(B)).NE.B) THEN	!Otherwise, it is safe to look.
          WRITE (6,*) ">",A,"< does not end with >",B,"<"
        ELSE
          WRITE (6,*) ">",A,"< ends with >",B,"<"
        END IF
      END SUBROUTINE ENDS

      CALL STARTS("This","is")
      CALL STARTS("Theory","The")
      CALL HAS("Bananas","an")
      CALL ENDS("Banana","an")
      CALL ENDS("Banana","na")
      CALL ENDS("Brief","Much longer")
      END

 >This< does not start with >is<
 >Theory< starts with >The<
 >Bananas< contains a >an<, offset           2
 >Banana< does not end with >an<
 >Banana< ends with >na<
 >Brief< is too short to end with >Much longer<

!-----------------------------------------------------------------------
!Main program string_matching
!-----------------------------------------------------------------------
program    string_matching
   implicit none
   character(len=*), parameter :: fmt= '(I0)'
   write(*,fmt) starts("this","is")
   write(*,fmt) starts("theory","the")
   write(*,fmt) has("bananas","an")
   write(*,fmt) ends("banana","an")
   write(*,fmt) ends("banana","na")
   write(*,fmt) ends("brief","much longer")

 contains
   !     Determining if the first string starts with second string
   function  starts(string1, string2) result(answer)
      implicit none
      character(len=*), intent(in) :: string1
      character(len=*), intent(in) :: string2
      integer :: answer
      answer = 0
      if(len(string2)>len(string1)) return
      if(string1(1:len(string2))==string2) answer = 1
   end function starts
   !     Determining if the first string contains the second string at any location
   function  has(string1, string2) result(answer)
      implicit none
      character(len=*), intent(in) :: string1
      character(len=*), intent(in) :: string2
      character(len=:),allocatable :: temp
      integer :: answer, add
      character(len=*), parameter :: fmt= '(A6,X,I0)'
      answer = 0
      add = 0
      if(len(string2)>len(string1)) return
      answer = index(string1, string2)
      if(answer==0) return
      !     Print the location of the match for part 2
      write(*,fmt) " at ", answer
      !     Handle multiple occurrences of a string for part 2.
      add = answer
      temp = string1(answer+1:)
      do while(answer>0)
         answer = index(temp, string2)
         add = add + answer
         if(answer>0) write(*,fmt) " at ", add
         !          deallocate(temp)
         temp = string1(add+1:) ! auto reallocation
      enddo
      answer = 1
   end function has
   !     Determining if the first string ends with the second string
   function  ends(string1, string2) result(answer)
      implicit none
      character(len=*), intent(in) :: string1
      character(len=*), intent(in) :: string2
      integer :: answer
      answer = 0
      if(len(string2)>len(string1)) return
      if(string1(len(string1)-len(string2)+1:)==string2) answer = 1
   end function ends
end program string_matching

0
1
   at  2
   at  4
1
0
1
0

The code performs three types of string matching operations: checking if the first string starts with the second string, if the first string contains the second string at any location, and if the first string ends with the second string. It also optionally prints the location of the match and handles multiple occurrences of a string. The code uses the CHARACTER variable and LEN function in Fortran for string-like usage. The INDEX function is used to determine the first index where the target matches. The code also handles potential issues with logical expressions and indexing. The output indicates whether the match is true or false, and displays multiple occurrences if applicable. The code is written in modern Fortran style with intrinsic procedures for string manipulation.


Also standardised in F90 is the $ format code, which specifies that the output line is not to end with the WRITE statement. The problem here is that Fortran does not offer an IF ...FI bracketing construction inside an expression, that would allow something like WRITE(...) FIRST,LAST,IF (UNIQUE) THEN "Distinct values only" ELSE "Repeated values allowed" FI // "."
 so that the correct alternative will be selected. Further, an array (that would hold those two texts) can't be indexed by a LOGICAL variable, and playing with EQUIVALENCE won't help, because the numerical values revealed thereby for .TRUE. and .FALSE. may not be 1 and 0. And anyway, parameters are not allowed to be accessed via EQUIVALENCE to another variable.
So, a two-part output, and to reduce the blather, two IF-statements.       SUBROUTINE FOURSHOW(FIRST,LAST,UNIQUE)	!The "Four Rings" or "Four Squares" puzzle.
Choose values such that A+B = B+C+D = D+E+F = F+G, all being integers in FIRST:LAST...
       INTEGER FIRST,LAST	!The range of allowed values.
       LOGICAL UNIQUE		!Solutions need not have unique values.
       INTEGER A,B,C,D,E,F,G	!Ah, Diophantus of Alexandria.
       INTEGER V(7),S,N		!Assistants.
       EQUIVALENCE (V(1),A),(V(2),B),(V(3),C),		!Yes,
     1             (V(4),D),(V(5),E),(V(6),F),(V(7),G)	!We're all individuals.
        WRITE (6,1) FIRST,LAST	!Announce: first part.
    1   FORMAT (/,"The Four Rings puzzle, over ",I0," to ",I0,".",$)	!$: An addendum follows.
        IF (UNIQUE) WRITE (6,*) "Distinct values only."	!Save on the THEN ... ELSE ... END IF blather.
        IF (.NOT.UNIQUE) WRITE (6,*) "Repeated values allowed."	!Perhaps the compiler will be smarter.

        N = 0	!No solutions have been found.
      BB:DO B = FIRST,LAST	!Start chugging through the possibilities.
        CC:DO C = FIRST,LAST		!Brute force and ignorance.
             IF (UNIQUE .AND. B.EQ.C) CYCLE CC	!The first constraint shows up.
          DD:DO D = FIRST,LAST		!Start by forming B, C, and D.
               IF (UNIQUE .AND. ANY(V(2:3).EQ.D)) CYCLE DD	!Ignoring A just for now.
               S = B + C + D		!This is the common sum.
               A = S - B		!The value of A is not free from BCD.
               IF (A < FIRST .OR. A > LAST) CYCLE DD	!And it may not be within bounds.
               IF (UNIQUE .AND. ANY(V(2:4).EQ.A)) CYCLE DD	!Or, if required so, unique.
            EE:DO E = FIRST,LAST	!Righto, A,B,C,D are valid. Try an E.
                 IF (UNIQUE .AND. ANY(V(1:4).EQ.E)) CYCLE EE	!Precluded already?
                 F = S - (E + D)		!No. So therefore, F is determined.
                 IF (F < FIRST .OR. F > LAST) CYCLE EE	!Acceptable?
                 IF (UNIQUE .AND. ANY(V(1:5).EQ.F)) CYCLE EE	!And, if required, unique?
                 G = S - F			!Yes! So finally, G is determined.
                 IF (G < FIRST .OR. G > LAST) CYCLE EE	!Acceptable?
                 IF (UNIQUE .AND. ANY(V(1:6).EQ.G)) CYCLE EE	!And, if required, unique?
                 N = N + 1			!Yes! Count a solution set!
                 IF (UNIQUE) WRITE (6,"(7I3)") V	!Show its values.
               END DO EE			!Consder another E.
             END DO DD			!Consider another D.
           END DO CC		!Consider another C.
         END DO BB	!Consider another B.
        WRITE (6,2) N	!Announce the count.
    2   FORMAT (I9," found.")	!Numerous, if no need for distinct values.
      END SUBROUTINE FOURSHOW	!That was fun!

      PROGRAM POKE

      CALL FOURSHOW(1,7,.TRUE.)
      CALL FOURSHOW(3,9,.TRUE.)
      CALL FOURSHOW(0,9,.FALSE.)

      END

The Four Rings puzzle, over 1 to 7. Distinct values only.
  7  2  6  1  3  5  4
  7  3  2  5  1  4  6
  6  4  1  5  2  3  7
  6  4  5  1  2  7  3
  4  5  3  1  6  2  7
  5  6  2  3  1  7  4
  4  7  1  3  2  6  5
  3  7  2  1  5  4  6
        8 found.

The Four Rings puzzle, over 3 to 9. Distinct values only.
  9  6  4  5  3  7  8
  9  6  5  4  3  8  7
  8  7  3  5  4  6  9
  7  8  3  4  5  6  9
        4 found.

The Four Rings puzzle, over 0 to 9. Repeated values allowed.
     2860 found.

31:                    IF (UNIQUE .AND. ANY(V(1:6).EQ.G)) CYCLE EE    !And, if required, unique?
00401496   mov         edi,dword ptr [UNIQUE]
00401499   mov         edi,dword ptr [edi]
0040149B   mov         ebx,dword ptr [G (00470380)]
004014A1   mov         eax,0
004014A6   mov         ecx,1
004014AB   mov         dword ptr [ebp-60h],1
004014B2   cmp         dword ptr [ebp-60h],6
004014B6   jg          FOURSHOW+4C4h (004014fc)
004014B8   cmp         ecx,1
004014BB   jl          FOURSHOW+48Ah (004014c2)
004014BD   cmp         ecx,7
004014C0   jle         FOURSHOW+493h (004014cb)
004014C2   xor         esi,esi
004014C4   mov         dword ptr [ebp-6Ch],esi
004014C7   dec         esi
004014C8   bound       esi,qword ptr [ebp-6Ch]
004014CB   imul        esi,ecx,4
004014CE   mov         esi,dword ptr S+4 (00470364)[esi]
004014D4   xor         edx,edx
004014D6   cmp         esi,ebx
004014D8   sete        dl
004014DB   mov         dword ptr [ebp-6Ch],edx
004014DE   mov         edx,eax
004014E0   or          edx,dword ptr [ebp-6Ch]
004014E3   and         edx,1
004014E6   mov         eax,edx
004014E8   neg         eax
004014EA   mov         esi,ecx
004014EC   add         esi,1
004014EF   mov         ecx,esi
004014F1   mov         edx,dword ptr [ebp-60h]
004014F4   add         edx,1
004014F7   mov         dword ptr [ebp-60h],edx
004014FA   jmp         FOURSHOW+47Ah (004014b2)
004014FC   and         edi,eax
004014FE   mov         edx,edi
00401500   and         edx,1
00401503   cmp         edx,0
00401506   jne         FOURSHOW+531h (00401569)
32:                    N = N + 1          !Yes! Count a solution set!
00401508   mov         esi,dword ptr [N (0047035c)]
0040150E   add         esi,1
00401511   mov         dword ptr [N (0047035c)],esi
33:                    IF (UNIQUE) WRITE (6,"(7I3)") V    !Show its values.

The code replaces the variables a, b, c, d, e, f, and g with decimal digits ranging from LOW to HIGH, ensuring that the sum of the variables in each of the four large squares is equal. It displays all unique solutions for ranges 1-7 and 3-9, and the total number of solutions for non-unique variables in the range 0-9. The code uses the ANY function and DO-loops with text labels for multiple tests and array manipulation. The output is not in a specific order due to the variable determination sequence.


!Digital Text implemented as in C version - Anant Dixit (Oct, 2014)
program clock
implicit none
integer :: t(8)
do
  call date_and_time(values=t)
  call sleep(1)
  call system('clear')
  call digital_display(t(5),t(6),t(7))
end do
end program

subroutine digital_display(H,M,S)
!arguments
integer :: H, M, S
!local
character(len=*), parameter :: nfmt='(A8)', cfmt='(A6)'
character(len=88), parameter :: d1 = ' 00000     1     22222   33333      4   5555555  66666  7777777  88888   99999        '
character(len=88), parameter :: d2 = '0     0   11    2     2 3     3    44   5       6     6 7     7 8     8 9     9  ::   '
character(len=88), parameter :: d3 = '0    00  1 1          2       3   4 4   5       6             7 8     8 9     9  ::   '
character(len=88), parameter :: d4 = '0   0 0    1         2        3  4  4   5       6            7  8     8 9     9  ::   '
character(len=88), parameter :: d5 = '0  0  0    1        2      333  4444444 555555  666666      7    88888   999999       '
character(len=88), parameter :: d6 = '0 0   0    1       2          3     4         5 6     6    7    8     8       9  ::   '
character(len=88), parameter :: d7 = '00    0    1      2           3     4         5 6     6   7     8     8       9  ::   '
character(len=88), parameter :: d8 = '0     0    1     2      3     3     4   5     5 6     6  7      8     8 9     9  ::   '
character(len=88), parameter :: d9 = ' 00000  1111111 2222222  33333      4    55555   66666  7        88888   99999        '
integer :: h1, h2, m1, m2, s1, s2
h1 = 1+8*floor(dble(H)/10.D0)
h2 = 1+8*modulo(H,10)
m1 = 1+8*floor(dble(M)/10.D0)
m2 = 1+8*modulo(M,10)
s1 = 1+8*floor(dble(S)/10.D0)
s2 = 1+8*modulo(S,10)

write(*,nfmt,advance='no') d1(h1:h1+8)
write(*,nfmt,advance='no') d1(h2:h2+8)
write(*,cfmt,advance='no') d1(81:88)
write(*,nfmt,advance='no') d1(m1:m1+8)
write(*,nfmt,advance='no') d1(m2:m2+8)
write(*,cfmt,advance='no') d1(81:88)
write(*,nfmt,advance='no') d1(s1:s1+8)
write(*,nfmt) d1(s2:s2+8)

write(*,nfmt,advance='no') d2(h1:h1+8)
write(*,nfmt,advance='no') d2(h2:h2+8)
write(*,cfmt,advance='no') d2(81:88)
write(*,nfmt,advance='no') d2(m1:m1+8)
write(*,nfmt,advance='no') d2(m2:m2+8)
write(*,cfmt,advance='no') d2(81:88)
write(*,nfmt,advance='no') d2(s1:s1+8)
write(*,nfmt) d2(s2:s2+8)

write(*,nfmt,advance='no') d3(h1:h1+8)
write(*,nfmt,advance='no') d3(h2:h2+8)
write(*,cfmt,advance='no') d3(81:88)
write(*,nfmt,advance='no') d3(m1:m1+8)
write(*,nfmt,advance='no') d3(m2:m2+8)
write(*,cfmt,advance='no') d3(81:88)
write(*,nfmt,advance='no') d3(s1:s1+8)
write(*,nfmt) d3(s2:s2+8)

write(*,nfmt,advance='no') d4(h1:h1+8)
write(*,nfmt,advance='no') d4(h2:h2+8)
write(*,cfmt,advance='no') d4(81:88)
write(*,nfmt,advance='no') d4(m1:m1+8)
write(*,nfmt,advance='no') d4(m2:m2+8)
write(*,cfmt,advance='no') d4(81:88)
write(*,nfmt,advance='no') d4(s1:s1+8)
write(*,nfmt) d4(s2:s2+8)

write(*,nfmt,advance='no') d5(h1:h1+8)
write(*,nfmt,advance='no') d5(h2:h2+8)
write(*,cfmt,advance='no') d5(81:88)
write(*,nfmt,advance='no') d5(m1:m1+8)
write(*,nfmt,advance='no') d5(m2:m2+8)
write(*,cfmt,advance='no') d5(81:88)
write(*,nfmt,advance='no') d5(s1:s1+8)
write(*,nfmt) d5(s2:s2+8)

write(*,nfmt,advance='no') d6(h1:h1+8)
write(*,nfmt,advance='no') d6(h2:h2+8)
write(*,cfmt,advance='no') d6(81:88)
write(*,nfmt,advance='no') d6(m1:m1+8)
write(*,nfmt,advance='no') d6(m2:m2+8)
write(*,cfmt,advance='no') d6(81:88)
write(*,nfmt,advance='no') d6(s1:s1+8)
write(*,nfmt) d6(s2:s2+8)

write(*,nfmt,advance='no') d7(h1:h1+8)
write(*,nfmt,advance='no') d7(h2:h2+8)
write(*,cfmt,advance='no') d7(81:88)
write(*,nfmt,advance='no') d7(m1:m1+8)
write(*,nfmt,advance='no') d7(m2:m2+8)
write(*,cfmt,advance='no') d7(81:88)
write(*,nfmt,advance='no') d7(s1:s1+8)
write(*,nfmt) d7(s2:s2+8)

write(*,nfmt,advance='no') d8(h1:h1+8)
write(*,nfmt,advance='no') d8(h2:h2+8)
write(*,cfmt,advance='no') d8(81:88)
write(*,nfmt,advance='no') d8(m1:m1+8)
write(*,nfmt,advance='no') d8(m2:m2+8)
write(*,cfmt,advance='no') d8(81:88)
write(*,nfmt,advance='no') d8(s1:s1+8)
write(*,nfmt) d8(s2:s2+8)

write(*,nfmt,advance='no') d9(h1:h1+8)
write(*,nfmt,advance='no') d9(h2:h2+8)
write(*,cfmt,advance='no') d9(81:88)
write(*,nfmt,advance='no') d9(m1:m1+8)
write(*,nfmt,advance='no') d9(m2:m2+8)
write(*,cfmt,advance='no') d9(81:88)
write(*,nfmt,advance='no') d9(s1:s1+8)
write(*,nfmt) d9(s2:s2+8)

end subroutine

 22222   33333           1     88888           1       1
2     2 3     3  ::     11    8     8  ::     11      11
      2       3  ::    1 1    8     8  ::    1 1     1 1
     2        3  ::      1    8     8  ::      1       1
    2      333           1     88888           1       1
   2          3  ::      1    8     8  ::      1       1
  2           3  ::      1    8     8  ::      1       1
 2      3     3  ::      1    8     8  ::      1       1
2222222  33333        1111111  88888        1111111 1111111

create a graphical or text-based clock that displays time in seconds. The clock updates every second and cycles every minute or 30 seconds. The code ensures the clock is not CPU intensive and matches the system clock time. It uses system commands for screen clearing, sleeping, and time retrieval. The code is simple and concise.


       MODULE DATEGNASH

       TYPE DATEBAG
        INTEGER DAY,MONTH,YEAR
       END TYPE DATEBAG

       CHARACTER*9 MONTHNAME(12),DAYNAME(0:6)
       PARAMETER (MONTHNAME = (/"JANUARY","FEBRUARY","MARCH","APRIL",
     1  "MAY","JUNE","JULY","AUGUST","SEPTEMBER","OCTOBER","NOVEMBER",
     2  "DECEMBER"/))
       PARAMETER (DAYNAME = (/"SUNDAY","MONDAY","TUESDAY","WEDNESDAY",
     1  "THURSDAY","FRIDAY","SATURDAY"/))

       INTEGER*4 JDAYSHIFT
       PARAMETER (JDAYSHIFT = 2415020)
       CONTAINS
       INTEGER FUNCTION LSTNB(TEXT)
        CHARACTER*(*),INTENT(IN):: TEXT
        INTEGER L
         L = LEN(TEXT)
    1    IF (L.LE.0) GO TO 2
         IF (ICHAR(TEXT(L:L)).GT.ICHAR(" ")) GO TO 2
         L = L - 1
         GO TO 1
    2    LSTNB = L
        RETURN
       END FUNCTION LSTNB
      CHARACTER*2 FUNCTION I2FMT(N)
       INTEGER*4 N
        IF (N.LT.0) THEN
          IF (N.LT.-9) THEN
            I2FMT = "-!"
           ELSE
            I2FMT = "-"//CHAR(ICHAR("0") - N)
          END IF
        ELSE IF (N.LT.10) THEN
          I2FMT = " " //CHAR(ICHAR("0") + N)
        ELSE IF (N.LT.100) THEN
          I2FMT = CHAR(N/10      + ICHAR("0"))
     1           //CHAR(MOD(N,10) + ICHAR("0"))
        ELSE
          I2FMT = "+!"
        END IF
      END FUNCTION I2FMT
      CHARACTER*8 FUNCTION I8FMT(N)
       INTEGER*4 N
       CHARACTER*8 HIC
        WRITE (HIC,1) N
    1   FORMAT (I8)
        I8FMT = HIC
      END FUNCTION I8FMT

      SUBROUTINE SAY(OUT,TEXT)
       INTEGER OUT
       CHARACTER*(*) TEXT
        WRITE (6,1) TEXT(1:LSTNB(TEXT))
    1   FORMAT (A)
      END SUBROUTINE SAY

       INTEGER*4 FUNCTION DAYNUM(YY,M,D)
        INTEGER*4 JDAYN
        INTEGER YY,Y,M,MM,D
         Y = YY
         IF (Y.LT.1) Y = Y + 1
         MM = (M - 14)/12
         JDAYN = D - 32075
     A    + 1461*(Y + 4800  + MM)/4
     B    +  367*(M - 2     - MM*12)/12
     C    -    3*((Y + 4900 + MM)/100)/4
         DAYNUM = JDAYN - JDAYSHIFT
       END FUNCTION DAYNUM

       TYPE(DATEBAG) FUNCTION MUNYAD(DAYNUM)
        INTEGER*4 DAYNUM,JDAYN
        INTEGER Y,M,D,L,N
         JDAYN = DAYNUM + JDAYSHIFT
         L = JDAYN + 68569
         N = 4*L/146097
         L = L - (146097*N + 3)/4
         Y = 4000*(L + 1)/1461001
         L = L - 1461*Y/4 + 31
         M = 80*L/2447
         D = L - 2447*M/80
         L = M/11
         M = M + 2 - 12*L
         Y = 100*(N - 49) + Y + L
         IF (Y.LT.1) Y = Y - 1
         MUNYAD%YEAR  = Y
         MUNYAD%MONTH = M
         MUNYAD%DAY   = D
       END FUNCTION MUNYAD

       INTEGER FUNCTION PMOD(N,M)
        INTEGER N,M
         PMOD = MOD(MOD(N,M) + M,M)
       END FUNCTION PMOD

      SUBROUTINE CALENDAR(Y1,Y2,COLUMNS)

       INTEGER Y1,Y2,YEAR
       INTEGER M,M1,M2,MONTH
       INTEGER*4 DN1,DN2,DN,D
       INTEGER W,G
       INTEGER L,LINE
       INTEGER COL,COLUMNS,COLWIDTH
       CHARACTER*200 STRIPE(6),SPECIAL(6),MLINE,DLINE
        W = 3
        G = 1
        COLWIDTH = 7*W + G
      Y:DO YEAR = Y1,Y2
          CALL SAY(MSG,"")
          IF (YEAR.EQ.0) THEN
            CALL SAY(MSG,"THERE IS NO YEAR ZERO.")
            CYCLE Y
          END IF
          MLINE = ""
          L = (COLUMNS*COLWIDTH - G - 8)/2
          IF (YEAR.GT.0) THEN
            MLINE(L:) = I8FMT(YEAR)
           ELSE
            MLINE(L - 1:) = I8FMT(-YEAR)//"BC"
          END IF
          CALL SAY(MSG,MLINE)
          DO MONTH = 1,12,COLUMNS
            M1 = MONTH
            M2 = MIN(12,M1 + COLUMNS - 1)
            MLINE = ""
            DLINE = ""
            STRIPE = ""
            SPECIAL = ""
            L0 = 1
            DO M = M1,M2
              L = (COLWIDTH - G - LSTNB(MONTHNAME(M)))/2 - 1
              MLINE(L0 + L:) = MONTHNAME(M)
              DO D = 0,6
                L = L0 + (3 - W) + D*W
                DLINE(L:L + 2) = DAYNAME(D)(1:W - 1)
              END DO
              DN1 = DAYNUM(YEAR,M,1)
              DN2 = DAYNUM(YEAR,M + 1,0)
              COL = MOD(PMOD(DN1,7) + 7,7)
              LINE = 1
              D = 1
              DO DN = DN1,DN2
                L = L0 + COL*W
                STRIPE(LINE)(L:L + 1) = I2FMT(D)
                D = D + 1
                COL = COL + 1
                IF (COL.GT.6) THEN
                  LINE = LINE + 1
                  COL = 0
                END IF
              END DO
              L0 = L0 + 7*W + G
            END DO
            CALL SAY(MSG,MLINE)
            CALL SAY(MSG,DLINE)
            DO LINE = 1,6
              IF (STRIPE(LINE).NE."") THEN
                CALL SAY(MSG,STRIPE(LINE))
              END IF
            END DO
          END DO
        END DO Y
        CALL SAY(MSG,"")
      END SUBROUTINE CALENDAR
      END MODULE DATEGNASH

      PROGRAM SHOW1968
       USE DATEGNASH
       INTEGER NCOL
        DO NCOL = 1,6
          CALL CALENDAR(1969,1969,NCOL)
        END DO
      END

                                                                1969
      JANUARY              FEBRUARY                MARCH                 APRIL                  MAY                  JUNE
SU MO TU WE TH FR SA  SU MO TU WE TH FR SA  SU MO TU WE TH FR SA  SU MO TU WE TH FR SA  SU MO TU WE TH FR SA  SU MO TU WE TH FR SA
          1  2  3  4                     1                     1         1  2  3  4  5               1  2  3   1  2  3  4  5  6  7
 5  6  7  8  9 10 11   2  3  4  5  6  7  8   2  3  4  5  6  7  8   6  7  8  9 10 11 12   4  5  6  7  8  9 10   8  9 10 11 12 13 14
12 13 14 15 16 17 18   9 10 11 12 13 14 15   9 10 11 12 13 14 15  13 14 15 16 17 18 19  11 12 13 14 15 16 17  15 16 17 18 19 20 21
19 20 21 22 23 24 25  16 17 18 19 20 21 22  16 17 18 19 20 21 22  20 21 22 23 24 25 26  18 19 20 21 22 23 24  22 23 24 25 26 27 28
26 27 28 29 30 31     23 24 25 26 27 28     23 24 25 26 27 28 29  27 28 29 30           25 26 27 28 29 30 31  29 30
                                            30 31
       JULY                 AUGUST               SEPTEMBER              OCTOBER              NOVEMBER              DECEMBER
SU MO TU WE TH FR SA  SU MO TU WE TH FR SA  SU MO TU WE TH FR SA  SU MO TU WE TH FR SA  SU MO TU WE TH FR SA  SU MO TU WE TH FR SA
       1  2  3  4  5                  1  2      1  2  3  4  5  6            1  2  3  4                     1      1  2  3  4  5  6
 6  7  8  9 10 11 12   3  4  5  6  7  8  9   7  8  9 10 11 12 13   5  6  7  8  9 10 11   2  3  4  5  6  7  8   7  8  9 10 11 12 13
13 14 15 16 17 18 19  10 11 12 13 14 15 16  14 15 16 17 18 19 20  12 13 14 15 16 17 18   9 10 11 12 13 14 15  14 15 16 17 18 19 20
20 21 22 23 24 25 26  17 18 19 20 21 22 23  21 22 23 24 25 26 27  19 20 21 22 23 24 25  16 17 18 19 20 21 22  21 22 23 24 25 26 27
27 28 29 30 31        24 25 26 27 28 29 30  28 29 30              26 27 28 29 30 31     23 24 25 26 27 28 29  28 29 30 31
                      31                                                                30

The code provides an algorithm for generating a calendar formatted to fit a page that is 132 characters wide, similar to the output of 1969 era line printers. The entire code is written in uppercase, inspired by the programming practices of the 1960s. It does not include Snoopy generation but instead outputs a placeholder. The code is designed for practicality and ease of reading, especially for those with presbyopia.


Works with: Fortran version 90 and later
Translation of: C efficient method
module triples
  implicit none

  integer :: max_peri, prim, total
  integer :: u(9,3) = reshape((/ 1, -2, 2,  2, -1, 2,  2, -2, 3, &
                                 1,  2, 2,  2,  1, 2,  2,  2, 3, &
                                -1,  2, 2, -2,  1, 2, -2,  2, 3 /), &
                                (/ 9, 3 /))

contains

recursive subroutine new_tri(in)
  integer, intent(in) :: in(:)
  integer :: i
  integer :: t(3), p

  p = sum(in)
  if (p > max_peri) return

  prim = prim + 1
  total = total + max_peri / p
  do i = 1, 3
    t(1) = sum(u(1:3, i) * in)
    t(2) = sum(u(4:6, i) * in)
    t(3) = sum(u(7:9, i) * in)
    call new_tri(t);
  end do
end subroutine new_tri
end module triples

program Pythagorean
  use triples
  implicit none

  integer :: seed(3) = (/ 3, 4, 5 /)

  max_peri = 10
  do
    total = 0
    prim = 0
    call new_tri(seed)
    write(*, "(a, i10, 2(i10, a))") "Up to", max_peri, total, " triples",  prim, " primitives"
    if(max_peri == 100000000) exit
    max_peri = max_peri * 10
  end do
end program Pythagorean

The code calculates the number of Pythagorean triples (a, b, c) where a, b, and c are positive integers, a < b < c, and a^2 + b^2 = c^2, with a perimeter (a + b + c) no larger than 100. It also determines the number of these triples that are primitive, meaning a, b, and c are co-prime. The code is also optimized to handle large values up to a maximum perimeter of 100,000,000.


-*- mode: compilation; default-directory: "/tmp/" -*-
Compilation started at Sat May 18 18:09:46

a=./F && make $a && $a < configuration.file
f95 -Wall -ffree-form F.F -o F
          92          21          17          24          82          19          19          22          67           0           2          27          27          57          55          31           1          61          43          60          20           6           2           0          10           0

Compilation finished at Sat May 18 18:09:46

! count letters from stdin
program LetterFrequency
  implicit none
  character (len=1) :: s
  integer, dimension(26) :: a
  integer :: ios, i, t
  data a/26*0/,i/0/
  open(unit=7, file='/dev/stdin', access='direct', form='formatted', recl=1, status='old', iostat=ios)
  if (ios .ne. 0) then
    write(0,*)'Opening stdin failed'
    stop
  endif
  do i=1, huge(i)
    read(unit=7, rec = i, fmt = '(a)', iostat = ios ) s
    if (ios .ne. 0) then
      !write(0,*)'ios on failure is ',ios
      close(unit=7)
      exit
    endif
    t = ior(iachar(s(1:1)), 32) - iachar('a')
    if ((0 .le. t) .and. (t .le. iachar('z'))) then
      t = t+1
      a(t) = a(t) + 1
    endif
  end do
  write(6, *) a
end program LetterFrequency

The code opens a text file and counts the frequency of each letter occurrence. It can count all characters, including punctuation, or just the letters A to Z, based on the configuration file. The program is compiled and executed on a gnu/linux system. The FORTRAN90 source code reads from stdin and writes the result to stdout, with a potential future enhancement to use block size records.


type node
   real :: data
   type( node ), pointer :: next => null()
end type node
!
!. . . .
!
type( node ) :: head

define a data structure for a singly-linked list element. This element includes a data member for storing a numeric value and a mutable link to the next element.


Works with: Fortran version 90 and later
program Factors
  implicit none
  integer :: i, number

  write(*,*) "Enter a number between 1 and 2147483647"
  read*, number

  do i = 1, int(sqrt(real(number))) - 1
    if (mod(number, i) == 0) write (*,*) i, number/i
  end do

  ! Check to see if number is a square
  i = int(sqrt(real(number)))
  if (i*i == number) then
     write (*,*) i
  else if (mod(number, i) == 0) then
     write (*,*) i, number/i
  end if

end program

compute the factors of a given positive integer, excluding zero and negative numbers. The factors are the positive integers that can divide the input number to yield a positive integer. For prime numbers, the factors are 1 and the number itself.


      SUBROUTINE RAKE(IN,M,X,WAY)	!Casts forth text in fixed-width columns.
Collates column widths so that each column is wide enough for its widest member.
       INTEGER IN		!Fingers the input file.
       INTEGER M		!Maximum record length thereof.
       CHARACTER*1 X		!The delimiter, possibly a comma.
       INTEGER WAY		!Alignment style.
       INTEGER W(M + 1)		!If every character were X in the maximum-length record,
       INTEGER C(0:M + 1)	!Then M + 1 would be the maximum number of fields possible.
       CHARACTER*(M) ACARD	!A scratchpad big enough for the biggest.
       CHARACTER*(28 + 4*M) FORMAT	!Guess. Allow for "Ann," per field.
       INTEGER I		!A stepper.
       INTEGER L,LF		!Text fingers.
       INTEGER NF,MF		!Field counts.
       CHARACTER*6 WAYNESS(-1:+1)	!Some annotation may be helpful.
       PARAMETER (WAYNESS = (/"Left","Centre","Right"/))	!Using normal language.
       INTEGER LINPR	!The mouthpiece.
       COMMON LINPR	!Used all over.
        W = 0		!Maximum field widths so far seen.
        MF = 0		!Maximum number of fields to a record.
        C(0) = 0	!Syncopation for the first field's predecessor.
        WRITE (LINPR,*)	!Some separation.
        WRITE (LINPR,*) "Align ",WAYNESS(MIN(MAX(WAY,-1),+1))	!Explain, cautiously.

Chase through the file assessing the lengths of each field.
   10   READ (IN,11,END = 20) L,ACARD(1:L)	!Grab a record.
   11   FORMAT (Q,A)				!Working only up to its end.
        CALL LIZZIEBORDEN	!Find the chop points.
        W(1:NF) = MAX(W(1:NF),C(1:NF) - C(0:NF - 1) - 1)	!Thereby the lengths between.
        MF = MAX(MF,NF)		!Also want to know the most number of chops.
        GO TO 10		!Get the next record.

Concoct a FORMAT based on the maximum size of each field. Plus one.
   20   REWIND(IN)		!Back to the beginning.
        WRITE (FORMAT,21) W(1:MF) + 1	!Add one to meet the specified at least one space between columns.
   21   FORMAT ("(",<MF>("A",I0,","))	!Generates a sequence of An, items.
        LF = INDEX(FORMAT,", ")		!The last one has a trailing comma.
        IF (LF.LE.0) STOP "Format trouble!"	!Or, maybe not!
        FORMAT(LF:LF) = ")"			!Convert it to the closing bracket.
        WRITE (LINPR,*) "Format",FORMAT(1:LF)	!Present it.

Chug afresh, this time knowing the maximum length of each field.
   30   READ (IN,11,END = 40) L,ACARD(1:L)	!Place just the record's content.
        CALL LIZZIEBORDEN		!Find the chop points.
        SELECT CASE(WAY)	!What is to be done?
         CASE(-1)		!Shove leftwards by appending spaces.
          WRITE (LINPR,FORMAT) (ACARD(C(I - 1) + 1:C(I) - 1)//	!The chopped text.
     1     REPEAT(" ",W(I) - C(I) + C(I - 1) + 1),I = 1,NF)	!Some spaces.
         CASE( 0)		!Centre by appending half as many spaces.
          WRITE (LINPR,FORMAT) (ACARD(C(I - 1) + 1:C(I) - 1)//	!The chopped text.
     1     REPEAT(" ",(W(I) - C(I) + C(I - 1) + 1)/2),I = 1,NF)	!Some spaces.
         CASE(+1)		!Align rightwards is the default style.
          WRITE (LINPR,FORMAT) (ACARD(C(I - 1) + 1:C(I) - 1),I = 1,NF)	!So, just the texts.
         CASE DEFAULT		!This shouldn't happen.
         WRITE (LINPR,*) "Huh? WAY=",WAY	!But if it does,
         STOP "Unanticipated value for WAY!"	!Explain.
        END SELECT		!So much for that record.
        GO TO 30		!Go for another.
Closedown
   40   REWIND(IN)		!Be polite.
       CONTAINS	!This also marks the end of source for RAKE...
        SUBROUTINE LIZZIEBORDEN	!Take an axe to ACARD, chopping at X.
          NF = 0		!No strokes so far.
          DO I = 1,L		!So, step away.
            IF (ICHAR(ACARD(I:I)).EQ.ICHAR(X)) THEN	!Here?
              NF = NF + 1		!Yes!
              C(NF) = I		!The place!
            END IF		!So much for that.
          END DO		!On to the next.
          NF = NF + 1		!And the end of ACARD is also a chop point.
          C(NF) = L + 1		!As if here.
        END SUBROUTINE LIZZIEBORDEN	!She was aquitted.
      END SUBROUTINE RAKE	!So much raking over.

      INTEGER L,M,N	!To be determined the hard way.
      INTEGER LINPR,IN	!I/O unit numbers.
      COMMON LINPR	!Some of general note.
      LINPR = 6		!Standard output via this unit number.
      IN = 10		!Some unit number for the input file.
      OPEN (IN,FILE="Rake.txt",STATUS="OLD",ACTION="READ")	!For formatted input.
      N = 0		!No records read.
      M = 0		!Longest record so far.

    1 READ (IN,2,END = 10) L	!How long is this record?
    2 FORMAT (Q)	!Obviously, Q specifies the length, not a content field.
      N = N + 1		!Anyway, another record has been read.
      M = MAX(M,L)	!And this is the longest so far.
      GO TO 1		!Go back for more.

   10 REWIND (IN)	!We're ready now.
      WRITE (LINPR,*) N,"Recs, longest rec. length is ",M
      CALL RAKE(IN,M,"$",-1)	!Align left.
      CALL RAKE(IN,M,"$", 0)	!Centre.
      CALL RAKE(IN,M,"$",+1)	!Align right.
      END	!That's all.

          6 Recs, longest rec. length is           66

Align Left
Format(A11,A11,A11,A7,A7,A10,A11,A9,A8,A8,A7,A5,A1)
Given      a          text       file   of     many      lines,     where    fields  within  a      line
are        delineated by         a      single 'dollar'  character, write    a       program
that       aligns     each       column of     fields    by         ensuring that    words   in     each
column     are        separated  by     at     least     one        space.
Further,   allow      for        each   word   in        a          column   to      be      either left
justified, right      justified, or     center justified within     its      column.

Align Centre
Format(A11,A11,A11,A7,A7,A10,A11,A9,A8,A8,A7,A5,A1)
   Given        a        text     file    of      many     lines,     where   fields  within    a   line
    are    delineated     by        a   single  'dollar' character,   write     a    program
   that      aligns      each    column   of     fields      by     ensuring   that   words    in   each
  column       are     separated   by     at     least       one     space.
 Further,     allow       for     each   word      in         a      column     to      be   either left
justified,    right   justified,   or   center justified   within      its   column.

Align Right
Format(A11,A11,A11,A7,A7,A10,A11,A9,A8,A8,A7,A5,A1)
     Given          a       text   file     of      many     lines,    where  fields  within      a line
       are delineated         by      a single  'dollar' character,    write       a program
      that     aligns       each column     of    fields         by ensuring    that   words     in each
    column        are  separated     by     at     least        one   space.
  Further,      allow        for   each   word        in          a   column      to      be either left
justified,      right justified,     or center justified     within      its column.

The code reads a text file where fields within a line are delineated by a dollar character. It aligns each column of fields by ensuring that words in each column are separated by at least one space. It also allows for each word in a column to be either left justified, right justified, or center justified within its column. The code handles varying record lengths and field sizes, and computes the minimum space between columns from the text itself. It also determines the maximum record length and maximum widths for each column. Finally, it makes another pass through the file to produce the output with the aligned columns.


Works with: Fortran version 90 and later
program test_rot_13

  implicit none
  integer, parameter :: len_max = 256
  integer, parameter :: unit = 10
  character (len_max) :: file
  character (len_max) :: fmt
  character (len_max) :: line
  integer :: arg
  integer :: arg_max
  integer :: iostat

  write (fmt, '(a, i0, a)') '(a', len_max, ')'
  arg_max = iargc ()
  if (arg_max > 0) then
! Encode all files listed on the command line.
    do arg = 1, arg_max
      call getarg (arg, file)
      open (unit, file = file, iostat = iostat)
      if (iostat /= 0) cycle
      do
        read (unit, fmt = fmt, iostat = iostat) line
        if (iostat /= 0) exit
        write (*, '(a)') trim (rot_13 (line))
      end do
      close (unit)
    end do
  else
! Encode standard input.
    do
      read (*, fmt = fmt, iostat = iostat) line
      if (iostat /= 0) exit
      write (*, '(a)') trim (rot_13 (line))
    end do
  end if

contains

  function rot_13 (input) result (output)

    implicit none
    character (len_max), intent (in) :: input
    character (len_max) :: output
    integer :: i

    output = input
    do i = 1, len_trim (output)
      select case (output (i : i))
      case ('A' : 'M', 'a' : 'm')
        output (i : i) = char (ichar (output (i : i)) + 13)
      case ('N' : 'Z', 'n' : 'z')
        output (i : i) = char (ichar (output (i : i)) - 13)
      end select
    end do

  end function rot_13

end program test_rot_13

> cat foo.txt
foo
> cat bar.txt
bar
> ./rot_13 foo.txt bar.txt
sbb
one
> ./rot_13 < foo.txt
sbb
> cat foo.txt bar.txt | ./rot_13
sbb
one

The code implements a rot-13 function, which is a mono-alphabetic substitution cipher that replaces every letter of the ASCII alphabet with the letter which is "rotated" 13 characters around the 26 letter alphabet. The function works on both upper and lower case letters, preserves case, and passes all non-alphabetic characters in the input stream through without alteration. It can optionally be wrapped in a utility program, acting like a common UNIX utility, performing a line-by-line rot-13 encoding of every line of input contained in each file listed on its command line or acting as a filter on its standard input.


Works with: Fortran version 90 and later

PROGRAM EXAMPLE
  IMPLICIT NONE

  TYPE Pair
    CHARACTER(6) :: name
    CHARACTER(1) :: value
  END TYPE Pair

  TYPE(Pair) :: rcc(10), temp
  INTEGER :: i, j

  rcc(1) = Pair("Black", "0")
  rcc(2) = Pair("Brown", "1")
  rcc(3) = Pair("Red", "2")
  rcc(4) = Pair("Orange", "3")
  rcc(5) = Pair("Yellow", "4")
  rcc(6) = Pair("Green", "5")
  rcc(7) = Pair("Blue", "6")
  rcc(8) = Pair("Violet", "7")
  rcc(9) = Pair("Grey", "8")
  rcc(10) = Pair("White", "9")

  DO i = 2, SIZE(rcc)
     j = i - 1
     temp = rcc(i)
        DO WHILE (j>=1 .AND. LGT(rcc(j)%name, temp%name))
           rcc(j+1) = rcc(j)
           j = j - 1
        END DO
     rcc(j+1) = temp
  END DO

  WRITE (*,"(2A6)") rcc

END PROGRAM EXAMPLE

Black      0
Blue       6
Brown      1
Green      5
Grey       8
Orange     3
Red        2
Violet     7
White      9
Yellow     4

"Sorts an array of composite structures (name-value pairs) by the key 'name' using a custom comparator. In languages without a built-in sort function, an insertion sort method is implemented."