Works with: Fortran version 77 and later
C     WARNING: This program is not valid ANSI FORTRAN 77 code. It uses
C     one nonstandard character on the line labelled 5001. Many F77
C     compilers should be okay with it, but it is *not* standard.
      PROGRAM FORLOOP
        INTEGER I, J

        DO 20 I = 1, 5
          DO 10 J = 1, I
C           Print the asterisk.
            WRITE (*,5001) '*'
   10     CONTINUE
C         Print a newline.
          WRITE (*,5000) ''
   20   CONTINUE

        STOP

 5000   FORMAT (A)
C       Standard FORTRAN 77 is completely incapable of completing a
C       WRITE statement without printing a newline. If you wanted to
C       write this program in valid F77, you would have to come up with
C       a creative way of printing varying numbers of asterisks in a
C       single write statement.
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 (A, $)
C5001   FORMAT (A, ADVANCE='NO')
      END

Works with: Fortran version 90 and later
DO i = 1, 5
  DO j = 1, i
    WRITE(*, "(A)", ADVANCE="NO") "*"
  END DO
  WRITE(*,*)
END DO

Works with: Fortran version 95 and later
integer :: i
integer, dimension(10) :: v

forall (i=1:size(v)) v(i) = i

      DO 1 I = 1,5
    1 WRITE (6,*) ("*", J = 1,I)
      END

      DO 1 I = 1,5
    1 WRITE (6,2) (666, J = 1,I)
    2 FORMAT(5I1)
      END

demonstrate the use of nested "for" loops to print a specific pattern. The number of iterations of the inner loop is controlled by the outer loop. The program also utilizes a loop structure in Fortran 95 that can be used when the result is independent of the real order of execution of the loop. It uses an old-style DO label style of DO-loop and an "implied" DO-loop to generate the output list. The output item is a text literal, and if a value cannot fit into its output field, the field is filled with asterisks.


Works with: Fortran version 90 and later
module lcgs
  implicit none

  integer, parameter :: i64 = selected_int_kind(18)
  integer, parameter :: a1 = 1103515245, a2 = 214013
  integer, parameter :: c1 = 12345, c2 = 2531011
  integer, parameter :: div = 65536
  integer(i64), parameter :: m = 2147483648_i64  ! need to go to 64 bits because
                                                 ! of the use of signed integers
contains

function bsdrand(seed)
  integer :: bsdrand
  integer, optional, intent(in) :: seed
  integer(i64) :: x = 0

  if(present(seed)) x = seed
  x = mod(a1 * x + c1, m)
  bsdrand = x
end function

function msrand(seed)
  integer :: msrand
  integer, optional, intent(in) :: seed
  integer(i64) :: x = 0

  if(present(seed)) x = seed
  x = mod(a2 * x + c2, m)
  msrand = x / div
end function
end module

program lcgtest
  use lcgs
  implicit none
  integer :: i

  write(*, "(a)") "      BSD            MS"
  do i = 1, 10
    write(*, "(2i12)") bsdrand(), msrand()
  end do
end program

      BSD            MS
       12345          38
  1406932606        7719
   654583775       21238
  1449466924        2437
   229283573        8855
  1109335178       11797
  1051550459        8365
  1293799192       32285
   794471793       10450
   551188310       30612

implement two historic random number generators: the rand() function from BSD libc and the rand() function from the Microsoft C Runtime (MSCVRT.DLL). These generators use the linear congruential generator formula with specific constants. The sequence of random numbers generated should be the same as the original functions when starting from the same seed. The BSD formula generates numbers in the range 0 to 2147483647, while the Microsoft formula generates numbers in the range 0 to 32767.


elemental subroutine addAfter(nodeBefore,value)
   type (node), intent(inout) :: nodeBefore
   real, intent(in)           :: value
   type (node), pointer       :: newNode

   allocate(newNode)
   newNode%data = value
   newNode%next => nodeBefore%next
   nodeBefore%next => newNode
end subroutine addAfter

define a method to insert an element into a singly-linked list after a specified element. The method is then used to insert element C into a list comprised of elements A and B, after element A.


Works with: Fortran version 90 and laterprogram EthiopicMult
  implicit none

  print *, ethiopic(17, 34, .true.)

contains

  subroutine halve(v)
    integer, intent(inout) :: v
    v = int(v / 2)
  end subroutine halve

  subroutine doublit(v)
    integer, intent(inout) :: v
    v = v * 2
  end subroutine doublit

  function iseven(x)
    logical :: iseven
    integer, intent(in) :: x
    iseven = mod(x, 2) == 0
  end function iseven

  function ethiopic(multiplier, multiplicand, tutorialized) result(r)
    integer :: r
    integer, intent(in) :: multiplier, multiplicand
    logical, intent(in), optional :: tutorialized

    integer :: plier, plicand
    logical :: tutor

    plier = multiplier
    plicand = multiplicand

    if ( .not. present(tutorialized) ) then
       tutor = .false.
    else
       tutor = tutorialized
    endif

    r = 0

    if ( tutor ) write(*, '(A, I0, A, I0)') "ethiopian multiplication of ", plier, " by ", plicand

    do while(plier >= 1)
       if ( iseven(plier) ) then
          if (tutor) write(*, '(I4, " ", I6, A)') plier, plicand, " struck"
       else
          if (tutor) write(*, '(I4, " ", I6, A)') plier, plicand, " kept"
          r = r + plicand
       endif
       call halve(plier)
       call doublit(plicand)
    end do

  end function ethiopic

end program EthiopicMult

The code defines three functions for halving an integer, doubling an integer, and checking if an integer is even. These functions are used to implement Ethiopian multiplication, a method of multiplying integers using addition, doubling, and halving. The multiplication process involves creating a table, discarding rows with even numbers in the left column, and summing the remaining values in the right column.


program solve_24
  use helpers
  implicit none
  real                 :: vector(4), reals(4), p, q, r, s
  integer              :: numbers(4), n, i, j, k, a, b, c, d
  character, parameter :: ops(4) = (/ '+', '-', '*', '/' /)
  logical              :: last
  real,parameter       :: eps = epsilon(1.0)

  do n=1,12
    call random_number(vector)
    reals   = 9 * vector + 1
    numbers = int(reals)
    call Insertion_Sort(numbers)

    permutations: do
      a = numbers(1); b = numbers(2); c = numbers(3); d = numbers(4)
      reals = real(numbers)
      p = reals(1);   q = reals(2);   r = reals(3);   s = reals(4)
      ! combinations of operators:
      do i=1,4
        do j=1,4
          do k=1,4
            if      ( abs(op(op(op(p,i,q),j,r),k,s)-24.0) < eps ) then
              write (*,*) numbers, ' : ', '((',a,ops(i),b,')',ops(j),c,')',ops(k),d
              exit permutations
            else if ( abs(op(op(p,i,op(q,j,r)),k,s)-24.0) < eps ) then
              write (*,*) numbers, ' : ', '(',a,ops(i),'(',b,ops(j),c,'))',ops(k),d
              exit permutations
            else if ( abs(op(p,i,op(op(q,j,r),k,s))-24.0) < eps ) then
              write (*,*) numbers, ' : ', a,ops(i),'((',b,ops(j),c,')',ops(k),d,')'
              exit permutations
            else if ( abs(op(p,i,op(q,j,op(r,k,s)))-24.0) < eps ) then
              write (*,*) numbers, ' : ', a,ops(i),'(',b,ops(j),'(',c,ops(k),d,'))'
              exit permutations
            else if ( abs(op(op(p,i,q),j,op(r,k,s))-24.0) < eps ) then
              write (*,*) numbers, ' : ', '(',a,ops(i),b,')',ops(j),'(',c,ops(k),d,')'
              exit permutations
            end if
          end do
        end do
      end do
      call nextpermutation(numbers,last)
      if ( last ) then
        write (*,*) numbers, ' : no solution.'
        exit permutations
      end if
    end do permutations

  end do

contains

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

end program solve_24

module helpers

contains

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

  subroutine nextpermutation(perm,last)
    integer, intent(inout) :: perm(:)
    logical, intent(out)   :: last
    integer :: k,l
    k = largest1()
    last = k == 0
    if ( .not. last ) then
      l = largest2(k)
      call swap(l,k)
      call reverse(k)
    end if
  contains
    pure integer function largest1()
      integer :: k, max
      max = 0
      do k=1,size(perm)-1
        if ( perm(k) < perm(k+1) ) then
          max = k
        end if
      end do
      largest1 = max
    end function largest1

    pure integer function largest2(k)
      integer, intent(in) :: k
      integer             :: l, max
      max = k+1
      do l=k+2,size(perm)
        if ( perm(k) < perm(l) ) then
          max = l
        end if
      end do
      largest2 = max
    end function largest2

    subroutine swap(l,k)
      integer, intent(in) :: k,l
      integer             :: temp
      temp    = perm(k)
      perm(k) = perm(l)
      perm(l) = temp
    end subroutine swap

    subroutine reverse(k)
      integer, intent(in) :: k
      integer             :: i
      do i=1,(size(perm)-k)/2
        call swap(k+i,size(perm)+1-i)
      end do
    end subroutine reverse

  end subroutine nextpermutation

end module helpers

The code accepts four digits, either from user input or randomly generated, and calculates arithmetic expressions following the 24 game rules. It also displays examples of the solutions it generates.


Fortran 90[edit]

nfactorial = PRODUCT((/(i, i=1,n)/))

INTEGER RECURSIVE FUNCTION RECURSIVE_FACTORIAL(X) RESULT(ANS)
    INTEGER, INTENT(IN) :: X

    IF (X <= 1) THEN
        ANS = 1
    ELSE
        ANS = X * RECURSIVE_FACTORIAL(X-1)
    END IF

END FUNCTION RECURSIVE_FACTORIAL
FORTRAN 77[edit]
      INTEGER FUNCTION MFACT(N)
      INTEGER N,I,FACT
      FACT=1
      IF (N.EQ.0) GOTO 20
      DO 10 I=1,N
        FACT=FACT*I
10    CONTINUE
20    CONTINUE
      MFACT = FACT
      RETURN
      END

implement a function that calculates the factorial of a given number, either iteratively or recursively. The function optionally handles negative input errors. The factorial of 0 is defined as 1, and the factorial of a positive integer n is the product of the sequence from n to 1.


Works with: Fortran version 90 and later
module bac
  implicit none

contains

  subroutine Gennum(n)
    integer, intent(out) :: n(4)
    integer :: i, j
    real :: r

    call random_number(r)
    n(1) = int(r * 9.0) + 1
    i = 2

outer: do while (i <= 4)
         call random_number(r)
         n(i) = int(r * 9.0) + 1
inner:   do j = i-1 , 1, -1
           if (n(j) == n(i)) cycle outer
         end do inner
         i = i + 1
       end do outer

  end subroutine Gennum

  subroutine Score(n, guess, b, c)
    character(*), intent(in) :: guess
    integer, intent(in) :: n(0:3)
    integer, intent(out) :: b, c
    integer :: digit, i, j, ind

    b = 0; c = 0
    do i = 1, 4
      read(guess(i:i), "(i1)") digit
      if (digit == n(i-1)) then
        b = b + 1
      else
        do j = i, i+2
          ind = mod(j, 4)
          if (digit == n(ind)) then
            c = c + 1
            exit
          end if
        end do
      end if
    end do

 end subroutine Score

end module bac

program Bulls_and_Cows
   use bac
   implicit none

   integer :: n(4)
   integer :: bulls=0, cows=0, tries=0
   character(4) :: guess

   call random_seed
   call Gennum(n)

   write(*,*) "I have selected a number made up of 4 digits (1-9) without repetitions."
   write(*,*) "You attempt to guess this number."
   write(*,*) "Every digit in your guess that is in the correct position scores 1 Bull"
   write(*,*) "Every digit in your guess that is in an incorrect position scores 1 Cow"
   write(*,*)

   do while (bulls /= 4)
     write(*,*) "Enter a 4 digit number"
     read*, guess
     if (verify(guess, "123456789") /= 0) then
       write(*,*) "That is an invalid entry. Please try again."
       cycle
     end if
     tries = tries + 1
     call Score (n, guess, bulls, cows)
     write(*, "(a, i1, a, i1, a)") "You scored ", bulls, " bulls and ", cows, " cows"
     write(*,*)
   end do

   write(*,"(a,i0,a)") "Congratulations! You correctly guessed the correct number in ", tries, " attempts"

end program Bulls_and_Cows

generate a unique four-digit number, accept and validate user guesses, calculate and print scores based on matching digits and their positions, and end the program when the user guess matches the generated number.


Works with: Fortran version 90 and later
PROGRAM Random

  INTEGER, PARAMETER :: n = 1000
  INTEGER :: i
  REAL :: array(n), pi, temp, mean = 1.0, sd = 0.5

  pi = 4.0*ATAN(1.0)
  CALL RANDOM_NUMBER(array) ! Uniform distribution

! Now convert to normal distribution
  DO i = 1, n-1, 2
    temp = sd * SQRT(-2.0*LOG(array(i))) * COS(2*pi*array(i+1)) + mean
    array(i+1) = sd * SQRT(-2.0*LOG(array(i))) * SIN(2*pi*array(i+1)) + mean
    array(i) = temp
  END DO

! Check mean and standard deviation
  mean = SUM(array)/n
  sd = SQRT(SUM((array - mean)**2)/n)

  WRITE(*, "(A,F8.6)") "Mean = ", mean
  WRITE(*, "(A,F8.6)") "Standard Deviation = ", sd

END PROGRAM Random

generate a collection of 1000 normally distributed pseudo-random numbers with a mean of 1.0 and a standard deviation of 0.5.


program test_dot_product

  write (*, '(i0)') dot_product ([1, 3, -5], [4, -2, -1])

end program test_dot_product

implement a function to compute the dot product of two vectors of any length. The vectors must be of the same length. The function multiplies corresponding terms from each vector and sums the products to produce the result. The function can handle various precisions of integer, floating-point and complex arrays, and even logical types.


Works with: Fortran version 90 and later

program BasicInputLoop

  implicit none

  integer, parameter        :: in = 50, &
                               linelen = 1000
  integer                   :: ecode
  character(len=linelen)    :: l

  open(in, file="afile.txt", action="read", status="old", iostat=ecode)
  if ( ecode == 0 ) then
     do
        read(in, fmt="(A)", iostat=ecode) l
        if ( ecode /= 0 ) exit
        write(*,*) trim(l)
     end do
     close(in)
  end if

end program BasicInputLoop

read from a text stream either word-by-word or line-by-line until there's no more data, with a parameter limiting the maximum line length.


In ISO Fortran 90 or later, use the SYSTEM_CLOCK intrinsic subroutine:integer :: start, stop, rate
real :: result

! optional 1st integer argument (COUNT) is current raw system clock counter value (not UNIX epoch millis!!)
! optional 2nd integer argument (COUNT_RATE) is clock cycles per second
! optional 3rd integer argument (COUNT_MAX) is maximum clock counter value
call system_clock( start, rate )

result = do_timed_work()

call system_clock( stop )

print *, "elapsed time: ", real(stop - start) / real(rate)
In ISO Fortran 95 or later, use the CPU_TIME intrinsic subroutine:real :: start, stop
real :: result

! System clock value interpreted as floating point seconds
call cpu_time( start )

result = do_timed_work()

call cpu_time( stop )

print *, "elapsed time: ", stop - start

the system time in a specified unit. This can be used for debugging, network information, random number seeds, or program performance. The time is retrieved either by a system command or a built-in language function. It is related to the task of date formatting and retrieving system time.


Works with: Fortran version 90 and later
MODULE SEDOL_CHECK
  IMPLICIT NONE
  CONTAINS

  FUNCTION Checkdigit(c)
    CHARACTER :: Checkdigit
    CHARACTER(6), INTENT(IN) :: c
    CHARACTER(36) :: alpha = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    INTEGER, DIMENSION(6) :: weights = (/ 1, 3, 1, 7, 3, 9 /), temp
    INTEGER :: i, n

    DO i = 1, 6
      temp(i) = INDEX(alpha, c(i:i)) - 1
    END DO
    temp = temp * weights
    n = MOD(10 - (MOD(SUM(temp), 10)), 10)
    Checkdigit = ACHAR(n + 48)
  END FUNCTION Checkdigit

END MODULE SEDOL_CHECK

PROGRAM SEDOLTEST
  USE SEDOL_CHECK
  IMPLICIT NONE

  CHARACTER(31) :: valid = "0123456789BCDFGHJKLMNPQRSTVWXYZ"
  CHARACTER(6) :: codes(10) = (/ "710889", "B0YBKJ", "406566", "B0YBLH", "228276" ,  &
                                 "B0YBKL", "557910", "B0YBKR", "585284", "B0YBKT" /)
  CHARACTER(7) :: sedol
  INTEGER :: i, invalid

  DO i = 1, 10
    invalid = VERIFY(codes(i), valid)
    IF (invalid == 0) THEN
      sedol = codes(i)
      sedol(7:7) = Checkdigit(codes(i))
    ELSE
      sedol = "INVALID"
    END IF
    WRITE(*, "(2A9)") codes(i), sedol
  END DO

END PROGRAM SEDOLTEST

  710889  7108899
  B0YBKJ  B0YBKJ7
  406566  4065663
  B0YBLH  B0YBLH2
  228276  2282765
  B0YBKL  B0YBKL9
  557910  5579107
  B0YBKR  B0YBKR5
  585284  5852842
  B0YBKT  B0YBKT7

The code takes a list of 6-digit SEDOLs as input, calculates the checksum digit for each SEDOL, and appends it to the end. It also validates the input to ensure it is correctly formed according to the SEDOL string rules.


!-*- mode: compilation; default-directory: "/tmp/" -*-
!Compilation started at Fri Jun  6 15:40:18
!
!a=./f && make -k $a && echo 0 25 | $a && echo 250 265 | $a && echo 1000 1025 | $a
!gfortran -std=f2008 -Wall -fopenmp -ffree-form -fall-intrinsics -fimplicit-none -g f.f08 -o f
!                  0'th                  1'st                  2'nd
!                  3'rd                  4'th                  5'th
!                  6'th                  7'th                  8'th
!                  9'th                 10'th                 11'th
!                 12'th                 13'th                 14'th
!                 15'th                 16'th                 17'th
!                 18'th                 19'th                 20'th
!                 21'st                 22'nd                 23'rd
!                 24'th                 25'th
!                                      250'th                251'st
!                252'nd                253'rd                254'th
!                255'th                256'th                257'th
!                258'th                259'th                260'th
!                261'st                262'nd                263'rd
!                264'th                265'th
!                                     1000th                1001st
!               1002nd                1003rd                1004th
!               1005th                1006th                1007th
!               1008th                1009th                1010th
!               1011th                1012th                1013th
!               1014th                1015th                1016th
!               1017th                1018th                1019th
!               1020th                1021st                1022nd
!               1023rd                1024th                1025th
!
!Compilation finished at Fri Jun  6 15:40:18

program nth
  implicit none
  logical :: need
  integer :: here, there, n, i, iostat
  read(5,*,iostat=iostat) here, there
  if (iostat .ne. 0) then
     write(6,*)'such bad input never before seen.'
     write(6,*)'I AYE EYE QUIT!'
     call exit(1)
  end if
  need = .false.
  n = abs(there - here) + 1
  i = 0
  do while (0 /= mod(3+mod(here-i, 3), 3))
     write(6,'(a22)',advance='no') ''
     i = i+1
  end do
  do i = here, there, sign(1, there-here)
     write(6,'(a22)',advance='no') ordinate(i)
     if (2 /= mod(i,3)) then
        need = .true.
     else
        write(6,'(a)')''
        need = .false.
     end if
  end do
  if (need) write(6,'(a)')''

contains

  character(len=22) function ordinate(n)
    character(len=19) :: a
    character(len=20), parameter :: &
         &a09 =   "thstndrdthththththth",&
         &ateen = "thththththththththth"
    integer :: ones, tens, ones_index
    integer, intent(in) :: n
    write(a,'(i19)') n
    ones = mod(n,10)
    tens = mod(n,100)
    ones_index = ones*2+1
    if (n < 1000) then
       if ((10 .le. tens) .and. (tens .lt. 20)) then
          ordinate = a // "'" // ateen(ones_index:ones_index+1)
          !            ^^^^^^  remove these characters to remove the important '
       else
          ordinate = a // "'" // a09(ones_index:ones_index+1)
          !            ^^^^^^  remove these characters to remove the important '
       end if
    else
       if ((10 .le. tens) .and. (tens .lt. 20)) then
          ordinate = a // ateen(ones_index:ones_index+1)
       else
          ordinate = a // a09(ones_index:ones_index+1)
       end if
    end if
  end function ordinate

end program nth

The code is a function that takes a non-negative integer as input and returns a string representation of the number with its ordinal suffix, such as 1'st, 2'nd, 3'rd, 11'th, 111'th, 1001'st, 1012'th. It demonstrates its functionality with the integer ranges of 0..25, 250..265, 1000..1025.


elemental subroutine strip(string,set)
  character(len=*), intent(inout) :: string
  character(len=*), intent(in)    :: set
  integer                         :: old, new, stride
  old = 1; new = 1
  do
    stride = scan( string( old : ), set )
    if ( stride > 0 ) then
      string( new : new+stride-2 ) = string( old : old+stride-2 )
      old = old+stride
      new = new+stride-1
    else
      string( new : ) = string( old : )
      return
    end if
  end do
end subroutine strip
Note: Since strip is an elemental subroutine, it can be called with arrays of strings as well.

"Function to remove specific characters from a given string"


Early inability[edit]

Initial difficulty[edit]
With Fortran IV came the ability to use arrays of integers and the A1 format code in READ and WRITE statements for them. With sixteen-bit integers, one might use A2 and so forth, but the numerical values of the integers would not be convenient especially if the sign bit was involved. This would be even more difficult with floating-point variables. Still, the desire for good headings and annotations and flexible layout flogged one onwards. Following the Pascal "Hello world!" example, one might proceed somewhat as follows:      INTEGER*4 I,TEXT(66)
      DATA TEXT(1),TEXT(2),TEXT(3)/"Wo","rl","d!"/

      WRITE (6,1) (TEXT(I), I = 1,3)
    1 FORMAT ("Hello ",66A2)

      DO 2 I = 1,3
    2   TEXT(I + 3) = TEXT(I)
      TEXT(1) = "He"
      TEXT(2) = "ll"
      TEXT(3) = "o "

      WRITE (6,3) (TEXT(I), I = 1,6)
    3 FORMAT (66A2)
      END

Having made space, the next statements merely assign some bit patterns to elements of TEXT, and then the result is revealed, again using known constants instead of the associated variables of the more general approach. The result from the two WRITE statements is of course Hello world!
Hello world!
Character facility[edit]
With F77 came the CHARACTER type...       CHARACTER*66 TEXT
      TEXT = "World!"
      TEXT = "Hello "//TEXT
      WRITE (6,*) TEXT
      END

Modern[edit]

The code creates a string variable and assigns it a text value. It then prepends this string variable with another string literal. The code also demonstrates idiomatic ways to prepend a string without referring to the variable twice in one expression. The content of the variable is then displayed. The code also includes handling of text manipulation in Fortran, including the use of arrays, integer constants, and format codes. It also discusses the issues of re-entrancy and the use of a temporary working area for character copying. The code also demonstrates how to shift the content of a string variable to make room for prepending text.


program guess_the_number
 implicit none

 integer                          :: guess
 real                             :: r
 integer                          :: i, clock, count, n
 integer,dimension(:),allocatable :: seed

 real,parameter :: rmax = 10

!initialize random number generator:
 call random_seed(size=n)
 allocate(seed(n))
 call system_clock(count)
 seed = count
 call random_seed(put=seed)
 deallocate(seed)

!pick a random number between 1 and rmax:
 call random_number(r)          !r between 0.0 and 1.0
 i = int((rmax-1.0)*r + 1.0)    !i between 1 and rmax

!get user guess:
 write(*,'(A)') 'I''m thinking of a number between 1 and 10.'
 do   !loop until guess is correct
	write(*,'(A)',advance='NO') 'Enter Guess: '
	read(*,'(I5)') guess
	if (guess==i) exit
	write(*,*) 'Sorry, try again.'
 end do

 write(*,*) 'You''ve guessed my number!'

end program guess_the_number

"Implement a number guessing game where the computer selects a number between 1 and 10. The player is repeatedly prompted to guess the number until the correct number is guessed, upon which a 'Well guessed!' message is displayed and the program terminates. A conditional loop is used to facilitate repeated guessing."


Works with: Fortran version 90 and later
  character(26) :: alpha
  integer :: i

  do i = 1, 26
    alpha(i:i) = achar(iachar('a') + i - 1)
  end do

generate a sequence of all lower case ASCII characters from a to z. This is done in a reliable coding style suitable for large programs, using strong typing if available. The code avoids manual enumeration of characters to prevent bugs. It also demonstrates how to access a similar sequence from the standard library if it exists.


!-*- mode: compilation; default-directory: "/tmp/" -*-
!Compilation started at Sun May 19 23:14:14
!
!a=./F && make $a && $a < unixdict.txt
!f95 -Wall -ffree-form F.F -o F
!101
!110010
!10001100101000
!
!Compilation finished at Sun May 19 23:14:14
!
!
!   tobin=: -.&' '@":@#:
!   tobin 5
!101
!   tobin 50
!110010
!   tobin 9000
!10001100101000

program bits
  implicit none
  integer, dimension(3) :: a
  integer :: i
  data a/5,50,9000/
  do i = 1, 3
    call s(a(i))
  enddo

contains

  subroutine s(a)
    integer, intent(in) :: a
    integer :: i
    if (a .eq. 0) then
      write(6,'(a)')'0'
      return
    endif
    do i = 31, 0, -1
      if (btest(a, i)) exit
    enddo
    do while (0 .lt. i)
      if (btest(a, i)) then
        write(6,'(a)',advance='no')'1'
      else
        write(6,'(a)',advance='no')'0'
      endif
      i = i-1
    enddo
    if (btest(a, i)) then
      write(6,'(a)')'1'
    else
      write(6,'(a)')'0'
    endif
  end subroutine s

end program bits

generate a sequence of binary digits for a given non-negative integer. The output is a string of binary digits with no leading zeros, whitespace, radix or sign markers. The function uses either built-in radix functions or a user-defined function to achieve this. After each binary representation, a newline is added. Example inputs and outputs include 5 to '101', 50 to '110010', and 9000 to '10001100101000'.


program readconfig
  implicit none
  integer, parameter    :: strlen = 100
  logical               :: needspeeling = .false., seedsremoved =.false.
  character(len=strlen) :: favouritefruit = "", fullname = "", fst, snd
  character(len=strlen), allocatable :: otherfamily(:), tmp(:)
  character(len=1000)   :: line
  integer               :: lun, stat,  j, j0, j1, ii = 1, z
  integer, parameter    :: state_begin=1, state_in_fst=2, state_in_sep=3

  open(newunit=lun, file="config.ini", status="old")

  do
    read(lun, "(a)", iostat=stat) line
    if (stat<0) exit
    if ((line(1:1) == "#") .or. &
        (line(1:1) == ";") .or. &
        (len_trim(line)==0)) then
      cycle
    end if
    z = state_begin
    do j = 1, len_trim(line)
      if (z == state_begin) then
        if (line(j:j)/=" ") then
          j0 = j
          z = state_in_fst
        end if
      elseif (z == state_in_fst) then
        if (index("= ",line(j:j))>0) then
          fst = lower(line(j0:j-1))
          z = state_in_sep
        end if
      elseif (z == state_in_sep) then
        if (index(" =",line(j:j)) == 0) then
          snd = line(j:)
          exit
        end if
      else
         stop "not possible to be here"
      end if
    end do
    if (z == state_in_fst) then
      fst = lower(line(j0:))
    elseif (z == state_begin) then
      cycle
    end if

    if (fst=="fullname") then
      read(snd,"(a)") fullname
    elseif (fst=="favouritefruit") then
      read(snd,"(a)") favouritefruit
    elseif (fst=="seedsremoved") then
      seedsremoved = .true.
    elseif (fst=="needspeeling") then
      needspeeling = .true.
    elseif (fst=="otherfamily") then
      j = 1; ii = 1
      do while (len_trim(snd(j:)) >0)
        j1  = index(snd(j:),",")
        if (j1==0) then
          j1 = len_trim(snd)
        else
          j1 = j + j1 - 2
        end if
        do
          if (j>len_trim(snd)) exit
          if (snd(j:j) /= " ") exit
          j = j +1
        end do
        allocate(tmp(ii))
        tmp(1:ii-1) = otherfamily
        call move_alloc(tmp, otherfamily)
        read(snd(j:j1),"(a)"), otherfamily(ii)
        j = j1 + 2
        ii = ii + 1
      end do
    else
      print *, "unknown option '"//trim(fst)//"'"; stop
    end if
  end do
  close(lun)

  print "(a,a)","fullname = ",       trim(fullname)
  print "(a,a)","favouritefruit = ", trim(favouritefruit)
  print "(a,l)","needspeeling = ",   needspeeling
  print "(a,l)","seedsremoved = ",   seedsremoved
  print "(a,*(a,:,', '))", "otherfamily = ", &
         (trim(otherfamily(j)), j=1,size(otherfamily))

contains

pure function lower (str) result (string)
    implicit none
    character(*), intent(In) :: str
    character(len(str))      :: string
    Integer :: ic, i

    character(26), parameter :: cap = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
    character(26), parameter :: low = 'abcdefghijklmnopqrstuvwxyz'

    string = str
    do i = 1, len_trim(str)
        ic = index(cap, str(i:i))
        if (ic > 0) string(i:i) = low(ic:ic)
    end do
end function

end program

read a configuration file and set variables based on the contents. It ignores lines starting with a hash or semicolon and blank lines. It sets variables 'fullname', 'favouritefruit', 'needspeeling', and 'seedsremoved' based on the file entries. It also stores multiple parameters from the 'otherfamily' entry into an array.


program example
implicit none
real :: d

d = haversine(36.12,-86.67,33.94,-118.40) ! BNA to LAX
print '(A,F9.4,A)', 'distance: ',d,' km' ! distance: 2887.2600 km

contains

      function to_radian(degree) result(rad)
          ! degrees to radians
          real,intent(in) :: degree
          real, parameter :: deg_to_rad = atan(1.0)/45 ! exploit intrinsic atan to generate pi/180 runtime constant
          real :: rad

          rad = degree*deg_to_rad
      end function to_radian

      function haversine(deglat1,deglon1,deglat2,deglon2) result (dist)
          ! great circle distance -- adapted from Matlab
          real,intent(in) :: deglat1,deglon1,deglat2,deglon2
          real :: a,c,dist,dlat,dlon,lat1,lat2
          real,parameter :: radius = 6372.8

          dlat = to_radian(deglat2-deglat1)
          dlon = to_radian(deglon2-deglon1)
          lat1 = to_radian(deglat1)
          lat2 = to_radian(deglat2)
          a = (sin(dlat/2))**2 + cos(lat1)*cos(lat2)*(sin(dlon/2))**2
          c = 2*asin(sqrt(a))
          dist = radius*c
      end function haversine

end program example

Implement a function to calculate the great-circle distance between two points on a sphere using the Haversine formula. The function takes the coordinates of Nashville International Airport (BNA) and Los Angeles International Airport (LAX) as input and returns the distance between them. The calculation uses the recommended earth radius of 6372.8 km or 6371 km, depending on the level of precision required.


program luhn
  implicit none
  integer              :: nargs
  character(len=20)    :: arg
  integer              :: alen, i, dr
  integer, allocatable :: number(:)
  integer, parameter   :: drmap(0:9) = [0, 2, 4, 6, 8, 1, 3, 5, 7, 9]

  ! Get number
  nargs = command_argument_count()
  if (nargs /= 1) then
     stop
  end if
  call get_command_argument(1, arg, alen)
  allocate(number(alen))
  do i=1, alen
     number(alen-i+1) = iachar(arg(i:i)) - iachar('0')
  end do

  ! Calculate number
  dr = 0
  do i=1, alen
     dr = dr + merge(drmap(number(i)), number(i), mod(i,2) == 0)
  end do

  if (mod(dr,10) == 0) then
     write(*,'(a,i0)') arg(1:alen)//' is valid'
  else
     write(*,'(a,i0)') arg(1:alen)//' is not valid'
  end if
end program luhn

! Results:
! 49927398716 is valid
! 49927398717 is not valid
! 1234567812345678 is not valid
! 1234567812345670 is valid

The code validates credit card numbers using the Luhn test. It reverses the input number, calculates the sum of odd and even positioned digits (with even digits being doubled and if the result is greater than nine, the digits of the result are summed). If the total sum ends in zero, the number is deemed valid. The code tests this functionality on four given numbers.


program josephus
   implicit none
   integer :: n, i, k, p
   integer, allocatable :: next(:)
   read *, n, k
   allocate(next(0:n - 1))
   do i = 0, n - 2
      next(i) = i + 1
   end do
   next(n - 1) = 0
   p = 0
   do while(next(p) /= p)
      do i = 1, k - 2
         p = next(p)
      end do
      print *, "Kill", next(p)
      next(p) = next(next(p))
      p = next(p)
   end do
   print *, "Alive", p
   deallocate(next)
end program

The code implements the Josephus problem, where given 'n' prisoners and 'k' as the step count, it determines the final survivor. It also provides a way to calculate the position of any prisoner in the killing sequence. The prisoners can be numbered either from 0 to n-1 or 1 to n. The code follows a naive approach where prisoners are put in a linked buffer and iteratively killed until only one remains. The complexity of the operation is O(kn) to find the complete killing sequence and O(m) to find the m-th prisoner to die.


Works with: Fortran version 90 and later
program test_repeat

  write (*, '(a)') repeat ('ha', 5)

end program test_repeat

hahahahaha

Code summarization: The code repeats a given string or character a specified number of times. For example, it can turn "ha" repeated 5 times into "hahahahaha" or "*" repeated 5 times into "*****".


 INTEGER A, B
 PRINT *, 'Type in two integer numbers separated by white space',
+         ' and press ENTER'
 READ *, A, B
 PRINT *, '   A + B = ', (A + B)
 PRINT *, '   A - B = ', (A - B)
 PRINT *, '   A * B = ', (A * B)
 PRINT *, '   A / B = ', (A / B)
 PRINT *, 'MOD(A,B) = ', MOD(A,B)
 PRINT *
 PRINT *, 'Even though you did not ask, ',
+         'exponentiation is an intrinsic op in Fortran, so...'
 PRINT *, '  A ** B = ', (A ** B)
 END

take two integers as input from the user and calculate their sum, difference, product, integer quotient, remainder, and exponentiation. The code also indicates the rounding method for the quotient and the sign of the remainder. It does not include error handling. Additionally, it includes an example of the integer `divmod` operator. The code is written in ANSI FORTRAN 77 or later.


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

  n = countsubstring("the three truths", "th")
  write(*,*) n
  n = countsubstring("ababababab", "abab")
  write(*,*) n
  n = countsubstring("abaabba*bbaba*bbab", "a*b")
  write(*,*) n

contains

function countsubstring(s1, s2) result(c)
  character(*), intent(in) :: s1, s2
  integer :: c, p, posn

  c = 0
  if(len(s2) == 0) return
  p = 1
  do
    posn = index(s1(p:), s2)
    if(posn == 0) return
    c = c + 1
    p = p + posn + len(s2) - 1
  end do
end function
end program

The code defines a function to count the number of non-overlapping occurrences of a given substring within a larger string. The function takes two arguments: the main string and the substring to search for. It returns an integer representing the count of non-overlapping occurrences. The function prioritizes the highest number of non-overlapping matches, typically matching from left-to-right or right-to-left.


Works with: Fortran version 90 and later
PROGRAM TOWER

  CALL Move(4, 1, 2, 3)

CONTAINS

  RECURSIVE SUBROUTINE Move(ndisks, from, to, via)
    INTEGER, INTENT (IN) :: ndisks, from, to, via

    IF (ndisks == 1) THEN
       WRITE(*, "(A,I1,A,I1)") "Move disk from pole ", from, " to pole ", to
    ELSE
       CALL Move(ndisks-1, from, via, to)
       CALL Move(1, from, to, via)
       CALL Move(ndisks-1, via, to, from)
    END IF
  END SUBROUTINE Move

END PROGRAM TOWER

PROGRAM TOWER2

  CALL Move(4, 1, 2, 3)

CONTAINS

  RECURSIVE SUBROUTINE Move(ndisks, from, via, to)
    INTEGER, INTENT (IN) :: ndisks, from, via, to

    IF (ndisks > 1) THEN
       CALL Move(ndisks-1, from, to, via)
       WRITE(*, "(A,I1,A,I1,A,I1)") "Move disk ", ndisks, "  from pole ", from, " to pole ", to
       Call Move(ndisks-1,via,from,to)
    ELSE
       WRITE(*, "(A,I1,A,I1,A,I1)") "Move disk ", ndisks, "  from pole ", from, " to pole ", to
    END IF
  END SUBROUTINE Move

END PROGRAM TOWER2

Implement a recursive solution to solve the Towers of Hanoi problem.


Direct Method[edit]
Works with: Fortran version 90 and later
program test_choose

  implicit none

  write (*, '(i0)') choose (5, 3)

contains

  function factorial (n) result (res)

    implicit none
    integer, intent (in) :: n
    integer :: res
    integer :: i

    res = product ((/(i, i = 1, n)/))

  end function factorial

  function choose (n, k) result (res)

    implicit none
    integer, intent (in) :: n
    integer, intent (in) :: k
    integer :: res

    res = factorial (n) / (factorial (k) * factorial (n - k))

  end function choose

end program test_choose

The code calculates any binomial coefficient using the given formula. It is specifically designed to output the binomial coefficient of 5 choose 3, which equals 10. The code also handles tasks related to combinations and permutations, both with and without replacement. It uses a method that delays overflow by potentially extending the primes array.


Works with: Fortran version 90 and later
MODULE sort

CONTAINS

SUBROUTINE Shell_Sort(a)

  IMPLICIT NONE
  INTEGER :: i, j, increment
  REAL :: temp
  REAL, INTENT(in out) :: a(:)

  increment = SIZE(a) / 2
  DO WHILE (increment > 0)
      DO i = increment+1, SIZE(a)
         j = i
         temp = a(i)
         DO WHILE (j >= increment+1 .AND. a(j-increment) > temp)
            a(j) = a(j-increment)
            j = j - increment
         END DO
         a(j) = temp
      END DO
      IF (increment == 2) THEN
   	  increment = 1
      ELSE
         increment = increment * 5 / 11
      END IF
  END DO

END SUBROUTINE Shell_Sort

END MODULE sort

PROGRAM Shellsort

USE sort

  IMPLICIT NONE
  REAL :: array(1000)

  CALL RANDOM_SEED
  CALL RANDOM_NUMBER(array)

  WRITE (*,*) "Unsorted array"
  WRITE (*,*) array
  WRITE (*,*)
  CALL Shell_Sort(array)
  WRITE (*,*) "Sorted array"
  WRITE (*,*) array

END PROGRAM Shellsort

implement the Shell sort algorithm to sort an array of elements. This algorithm, invented by Donald Shell, uses a diminishing increment sort and interleaved insertion sorts based on an increment sequence. The increment size reduces after each pass until it reaches 1, turning the sort into a basic insertion sort. The data is almost sorted at this point, providing the best case for insertion sort. The increment sequence can vary but should always end in 1. Sequences with a geometric increment ratio of about 2.2 have been found to work well.


type scimage
   integer, dimension(:,:), pointer :: channel
   integer :: width, height
end type scimage

interface alloc_img
   module procedure alloc_img_rgb, alloc_img_sc
end interface

interface free_img
   module procedure free_img_rgb, free_img_sc
end interface

interface assignment(=)
   module procedure rgbtosc, sctorgb
end interface

subroutine alloc_img_sc(img, w, h)
  type(scimage) :: img
  integer, intent(in) :: w, h

  allocate(img%channel(w, h))
  img%width = w
  img%height = h
end subroutine alloc_img_sc

subroutine free_img_sc(img)
  type(scimage) :: img

  if ( associated(img%channel) ) deallocate(img%channel)
end subroutine free_img_sc

subroutine rgbtosc(sc, colored)
  type(rgbimage), intent(in) :: colored
  type(scimage), intent(inout) :: sc

  if ( ( .not. valid_image(sc) ) .and. valid_image(colored) ) then
     call alloc_img(sc, colored%width, colored%height)
  end if

  if ( valid_image(sc) .and. valid_image(colored) ) then
     sc%channel = floor(0.2126*colored%red + 0.7152*colored%green + &
                        0.0722*colored%blue)
  end if

end subroutine rgbtosc

subroutine sctorgb(colored, sc)
  type(scimage), intent(in) :: sc
  type(rgbimage), intent(inout) :: colored

  if ( ( .not. valid_image(colored) ) .and. valid_image(sc) ) then
     call alloc_img_rgb(colored, sc%width, sc%height)
  end if

  if ( valid_image(sc) .and. valid_image(colored) ) then
     colored%red = sc%channel
     colored%green = sc%channel
     colored%blue = sc%channel
  end if

end subroutine sctorgb

type(scimage) :: gray
type(rgbimage) :: animage
  ! ... here we "load" or create animage
  ! while gray must be created or initialized to null
  ! or errors can arise...
  call init_img(gray)
  gray = animage
  animage = gray
  call output_ppm(an_unit, animage)

extend the data storage type to support grayscale images, convert a color image to a grayscale image and vice versa. It uses the CIE recommended formula for luminance calculation, ensuring no rounding errors cause run-time problems or distorted results. The codes also rename certain subroutines appending the _rgb suffix for proper overloading, and define new interfaces and subroutines related to the task. An example usage is provided for converting an rgb image to grayscale and back.


Works with: Fortran version 90 and later
INTEGER :: i = 0
DO
  i = i + 1
  WRITE(*, *) i
  IF (MOD(i, 6) == 0) EXIT
END DO

Works with: Fortran version 77 and later
      PROGRAM DOWHILE
C Initialize modulus and value.
        INTEGER MODLUS, IVALUE
        PARAMETER (MODLUS = 6)
        IVALUE = 0

C FORTRAN 77 has no do-while structure -- not semantically. It is not
C difficult to simulate it using GOTO, however:
   10   CONTINUE
          IVALUE = IVALUE + 1
          WRITE (*,*) IVALUE
        IF (.NOT. (MOD(IVALUE, MODLUS) .EQ. 0)) GOTO 10

        STOP
      END

Works with: Fortran version IV and later
      IVALUE = 0
   10 CONTINUE
        IVALUE=IVALUE+1
        WRITE(6,301) IVALUE
  301   FORMAT(I5)
      IF(MOD(IVALUE,6).NE.0) GOTO 10
      END

Works with: Fortran version I and later
      IVALUE = 0
   10 IVALUE=IVALUE+1
      WRITE 301,IVALUE
  301 FORMAT(I5)
      IF(IVALUE-IVALUE/6*6) 10,20,10
   20 STOP
      END

The code initializes a value to 0, then enters a do-while loop where it increments the value by 1 and prints it, continuing as long as the value modulo 6 is not 0. The loop is guaranteed to execute at least once.


Byte Length[edit]

Character Length[edit]

The code determines the character and byte length of a string, accurately handling encodings like UTF-8. It correctly counts Unicode code points as individual characters, not user-visible graphemes. It also handles Non-BMP code points correctly, providing actual character counts in code points, not in code unit counts. It can also provide string length in graphemes if the language supports it. In Fortran 77, it uses CHARACTER type variables and associated syntax to store character data and uses intrinsic functions like LEN(text) to report the number of characters in the variable. It does not support fancy Unicode schemes.


!-----------------------------------------------------------------------
! Test Linux urandom in Fortran
!-----------------------------------------------------------------------
program    urandom_test
  use iso_c_binding, only : c_long
  implicit none

  character(len=*), parameter :: RANDOM_PATH = "/dev/urandom"
  integer :: funit, ios
  integer(c_long) :: buf

  open(newunit=funit, file=RANDOM_PATH, access="stream", form="UNFORMATTED", &
       iostat=ios, status="old", action="read")
  if ( ios /= 0 ) stop "Error opening file: "//RANDOM_PATH

  read(funit) buf

  close(funit)

  write(*,'(A,I64)') "Integer:     ", buf
  write(*,'(A,B64)') "Binary:      ", buf
  write(*,'(A,Z64)') "Hexadecimal: ", buf

end program urandom_test

demonstrate how to generate a random 32-bit number using the /dev/urandom device in a Unix-based system.


program substring

  character(len=5) :: string
  string = "Hello"

  write (*,*) string
  write (*,*) string(2:)
  write (*,*) string( :len(string)-1)
  write (*,*) string(2:len(string)-1)

end program substring

The code demonstrates how to remove the first, last, and both the first and last characters from a string. It works with any valid Unicode code point in UTF-8 or UTF-16, referencing logical characters, not code units. It doesn't necessarily support all Unicode characters for other encodings like 8-bit ASCII or EUC-JP.


Works with: Fortran version 90 and later

program sudoku

  implicit none
  integer, dimension (9, 9) :: grid
  integer, dimension (9, 9) :: grid_solved
  grid = reshape ((/               &
    & 0, 0, 3, 0, 2, 0, 6, 0, 0,   &
    & 9, 0, 0, 3, 0, 5, 0, 0, 1,   &
    & 0, 0, 1, 8, 0, 6, 4, 0, 0,   &
    & 0, 0, 8, 1, 0, 2, 9, 0, 0,   &
    & 7, 0, 0, 0, 0, 0, 0, 0, 8,   &
    & 0, 0, 6, 7, 0, 8, 2, 0, 0,   &
    & 0, 0, 2, 6, 0, 9, 5, 0, 0,   &
    & 8, 0, 0, 2, 0, 3, 0, 0, 9,   &
    & 0, 0, 5, 0, 1, 0, 3, 0, 0/), &
    & shape = (/9, 9/),            &
    & order = (/2, 1/))
  call pretty_print (grid)
  call solve (1, 1)
  write (*, *)
  call pretty_print (grid_solved)

contains

  recursive subroutine solve (i, j)
    implicit none
    integer, intent (in) :: i
    integer, intent (in) :: j
    integer :: n
    integer :: n_tmp
    if (i > 9) then
      grid_solved = grid
    else
      do n = 1, 9
        if (is_safe (i, j, n)) then
          n_tmp = grid (i, j)
          grid (i, j) = n
          if (j == 9) then
            call solve (i + 1, 1)
          else
            call solve (i, j + 1)
          end if
          grid (i, j) = n_tmp
        end if
      end do
    end if
  end subroutine solve

  function is_safe (i, j, n) result (res)
    implicit none
    integer, intent (in) :: i
    integer, intent (in) :: j
    integer, intent (in) :: n
    logical :: res
    integer :: i_min
    integer :: j_min
    if (grid (i, j) == n) then
      res = .true.
      return
    end if
    if (grid (i, j) /= 0) then
      res = .false.
      return
    end if
    if (any (grid (i, :) == n)) then
      res = .false.
      return
    end if
    if (any (grid (:, j) == n)) then
      res = .false.
      return
    end if
    i_min = 1 + 3 * ((i - 1) / 3)
    j_min = 1 + 3 * ((j - 1) / 3)
    if (any (grid (i_min : i_min + 2, j_min : j_min + 2) == n)) then
      res = .false.
      return
    end if
    res = .true.
  end function is_safe

  subroutine pretty_print (grid)
    implicit none
    integer, dimension (9, 9), intent (in) :: grid
    integer :: i
    integer :: j
    character (*), parameter :: bar = '+-----+-----+-----+'
    character (*), parameter :: fmt = '(3 ("|", i0, 1x, i0, 1x, i0), "|")'
    write (*, '(a)') bar
    do j = 0, 6, 3
      do i = j + 1, j + 3
        write (*, fmt) grid (i, :)
      end do
      write (*, '(a)') bar
    end do
  end subroutine pretty_print

end program sudoku

implement a Sudoku solver that fills a given 9x9 grid using a brute force method. The function 'solve' recursively checks for valid entries based on the rules defined in the 'is_safe' function. If 'solve' is called beyond the end of the Sudoku, it means all entered values are valid and the result is displayed.


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

  integer, parameter :: reps = 1000000
  integer :: i, n
  integer, dimension(10) :: a, bins = 0, initial = (/ (n, n=1,10) /)

  do i = 1, reps
    a = initial
 	call Shuffle(a)
    where (a == initial) bins = bins + 1  ! skew tester
  end do
  write(*, "(10(i8))") bins
! prints  100382  100007   99783  100231  100507   99921   99941  100270  100290  100442

contains

subroutine Shuffle(a)
  integer, intent(inout) :: a(:)
  integer :: i, randpos, temp
  real :: r

  do i = size(a), 2, -1
    call random_number(r)
    randpos = int(r * i) + 1
    temp = a(randpos)
    a(randpos) = a(i)
    a(i) = temp
  end do

end subroutine Shuffle

end program Knuth_Shuffle

implement the Knuth shuffle (also known as the Fisher-Yates shuffle) algorithm. This algorithm randomly shuffles the elements of an array in-place. The shuffling process involves iterating from the last index of the array down to 1, and for each index, swapping the element at that index with an element at a random index within the range of 0 to the current index. If in-place modification of the array is not possible in the used programming language, the algorithm can be adjusted to return a new shuffled array. The algorithm can also be modified to iterate from left to right if needed.


The code takes a year as input and calculates the dates of the last Fridays of each month for that year. It starts by determining the day of the week for the last day of January, then adjusts the date backwards to the preceding Friday. This process is repeated for each month. The dates are output in a YYYY-MM-DD format.


program bye
  write (*,'(a)',advance='no') 'Goodbye, World!'
end program bye

      WRITE (6,1) "Goodbye, World!"
    1 FORMAT (A,$)
      END

The code displays the string "Goodbye, World!" without a trailing newline. It uses the Fortran 'advance' facility and format instructions to prevent automatic newline insertion after outputting the string. This is useful for writing prompts to the screen where the response input appears on the same line. The code uses a carriage control character to manage line advancement, rather than the typical sequence of outputting text followed by a carriage control.


Works with: Fortan 90 and later
program Caesar_Cipher
  implicit none

  integer, parameter :: key = 3
  character(43) :: message = "The five boxing wizards jump quickly"

  write(*, "(2a)") "Original message  = ", message
  call encrypt(message)
  write(*, "(2a)") "Encrypted message = ", message
  call decrypt(message)
  write(*, "(2a)") "Decrypted message = ", message

contains

subroutine encrypt(text)
  character(*), intent(inout) :: text
  integer :: i

  do i = 1, len(text)
    select case(text(i:i))
      case ('A':'Z')
        text(i:i) = achar(modulo(iachar(text(i:i)) - 65 + key, 26) + 65)
      case ('a':'z')
        text(i:i) = achar(modulo(iachar(text(i:i)) - 97 + key, 26) + 97)
    end select
  end do
end subroutine

subroutine decrypt(text)
  character(*), intent(inout) :: text
  integer :: i

  do i = 1, len(text)
    select case(text(i:i))
      case ('A':'Z')
        text(i:i) = achar(modulo(iachar(text(i:i)) - 65 - key, 26) + 65)
      case ('a':'z')
        text(i:i) = achar(modulo(iachar(text(i:i)) - 97 - key, 26) + 97)
    end select
  end do
end subroutine

end program Caesar_Cipher

implement both encoding and decoding functions of a Caesar cipher. The cipher rotates the alphabet letters based on a key ranging from 1 to 25, replacing each letter with the corresponding next letter in the alphabet. The codes also handle cases of wrapping from Z to A. The codes illustrate that Caesar cipher provides minimal security as it is vulnerable to frequency analysis and brute force attacks. The codes also demonstrate that Caesar cipher is identical to Vigenère cipher with a key length of 1 and to Rot-13 with a key of 13.


    integer function lcm(a,b)
    integer:: a,b
        lcm = a*b / gcd(a,b)
    end function lcm

    integer function gcd(a,b)
    integer :: a,b,t
        do while (b/=0)
            t = b
            b = mod(a,b)
            a = t
        end do
        gcd = abs(a)
    end function gcd

The code calculates the least common multiple (LCM) of two given integers m and n. The LCM is the smallest positive integer that is a multiple of both m and n. If either m or n is zero, the LCM is zero. The code uses the formula lcm(m, n) = |m x n| / gcd(m, n) to calculate the LCM, where gcd is the greatest common divisor. The code can also find the LCM by merging the prime decompositions of both m and n. The solution is implemented as two functions or as a subroutine.


There is no checking that only valid characters are presented, nor that eight-character codes only are offered, though the compiler might complain if the function were to be invoked with a text literal of the wrong size. In the absence of such checks, there need be no added complications to support a scheme for reporting such errors.       CHARACTER*1 FUNCTION CUSIPCHECK(TEXT)	!Determines the check sum character.
Committee on Uniform Security Identification Purposes, of the American (i.e. USA) Bankers' Association.
       CHARACTER*8 TEXT		!Specifically, an eight-symbol code.
       CHARACTER*(*) VALID	!These only are valid.
       PARAMETER (VALID = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ*@#")
       INTEGER I,V,S		!Assistants.
        S = 0		!Start the checksum.
        DO I = 1,LEN(TEXT)	!Step through the text.
          V = INDEX(VALID,TEXT(I:I)) - 1	!Since counting starts with one.
          IF (MOD(I,2).EQ.0) V = V*2		!V = V*(2 - MOD(I,2))?
          S = S + V/10 + MOD(V,10)		!Specified calculation.
        END DO			!On to the next character.
        I = MOD(10 - MOD(S,10),10) + 1	!Again, counting starts with one.
        CUSIPCHECK = VALID(I:I)	!Thanks to the MOD 10, surely a digit.
      END FUNCTION CUSIPCHECK	!No checking for invalid input...

      PROGRAM POKE	!Just to try it out.
      INTEGER I,N	!Assistants.
      PARAMETER (N = 6)		!A whole lot of blather
      CHARACTER*9 CUSIP(N)	!Just to have an array of test codes.
      DATA CUSIP/		!Here they are, as specified.
     1  "037833100",
     2  "17275R102",
     3  "38259P508",
     4  "594918104",
     5  "68389X106",
     6  "68389X105"/
      CHARACTER*1 CUSIPCHECK	!Needed as no use of the MODULE protocol.

      DO I = 1,N	!"More than two? Use a DO..."
        WRITE (6,*) CUSIP(I),CUSIPCHECK(CUSIP(I)(1:8)).EQ.CUSIP(I)(9:9)
      END DO

      END

037833100 T
17275R102 T
38259P508 T
594918104 T
68389X106 F
68389X105 T

The code validates the last digit (check digit) of a CUSIP code, a nine-character alphanumeric code identifying North American financial securities. It uses a sequence of valid characters and a function to find the position of each character in the code. The function returns a character code to be compared with the check character of the CUSIP code. The output is standard and free-format, starting with a space. The code also handles potential issues with ASCII and EBCDIC encodements.


Works with: Fortran version 90 and < 2018
   integer :: i
   character(len=1) :: c(20)
   equivalence (c, i)

   WRITE(*,*) bit_size(1)  ! number of bits in the default integer type
                           ! which may (or may not!) equal the word size
   i = 1

   IF (ichar(c(1)) == 0) THEN
      WRITE(*,*) "Big Endian"
   ELSE
     WRITE(*,*) "Little Endian"
   END IF

Works with: Fortran version  77 and later
      PROGRAM endianness
      IMPLICIT NONE
      INTEGER(KIND=4)  :: i = 1

      !ISHFT(INTEGER, SHIFT) : Left shift if SHIFT > 0
      !ISHFT(INTEGER, SHIFT) : Right shift if SHIFT < 0
      IF (ISHFT(i,1) .EQ. 0) THEN
        WRITE(*,FMT='(A)') 'Architechture is Big Endian'
      ELSE
        WRITE(*,FMT='(A)') 'Architecture is Little Endian'
      END IF

      RETURN

      STOP
      END PROGRAM endianness

"Outputs the word size and endianness of the host machine."


program main

 implicit none

 integer :: i
 character(len=5),dimension(5),parameter :: colors = ['Red  ','Green','Blue ','Black','White']

 !using a do loop:
 do i=1,size(colors)
   write(*,'(A)') colors(i)
 end do

 !this will also print each element:
 write(*,'(A)') colors

end program main

Iterates through each element in a collection in order and prints it, using a "for each" loop or another loop if "for each" is not available in the language.


Works with: Fortran version 90 and later
PROGRAM Example

  CHARACTER(23) :: str = "Hello,How,Are,You,Today"
  CHARACTER(5) :: word(5)
  INTEGER :: pos1 = 1, pos2, n = 0, i

  DO
    pos2 = INDEX(str(pos1:), ",")
    IF (pos2 == 0) THEN
       n = n + 1
       word(n) = str(pos1:)
       EXIT
    END IF
    n = n + 1
    word(n) = str(pos1:pos1+pos2-2)
    pos1 = pos2+pos1
 END DO

 DO i = 1, n
   WRITE(*,"(2A)", ADVANCE="NO") TRIM(word(i)), "."
 END DO

END PROGRAM Example

"Tokenizes a string by commas into an array, and displays the words to the user separated by a period, including a trailing period."


Works with: Fortran version 95 and later
Recursive Euclid algorithm[edit]
recursive function gcd_rec(u, v) result(gcd)
    integer             :: gcd
    integer, intent(in) :: u, v

    if (mod(u, v) /= 0) then
        gcd = gcd_rec(v, mod(u, v))
    else
        gcd = v
    end if
end function gcd_rec

Iterative Euclid algorithm[edit]
subroutine gcd_iter(value, u, v)
  integer, intent(out) :: value
  integer, intent(inout) :: u, v
  integer :: t

  do while( v /= 0 )
     t = u
     u = v
     v = mod(t, v)
  enddo
  value = abs(u)
end subroutine gcd_iter

function gcd(v, t)
  integer :: gcd
  integer, intent(in) :: v, t
  integer :: c, b, a

  b = t
  a = v
  do
     c = mod(a, b)
     if ( c == 0) exit
     a = b
     b = c
  end do
  gcd = b ! abs(b)
end function gcd

Iterative binary algorithm[edit]
subroutine gcd_bin(value, u, v)
  integer, intent(out) :: value
  integer, intent(inout) :: u, v
  integer :: k, t

  u = abs(u)
  v = abs(v)
  if( u < v ) then
     t = u
     u = v
     v = t
  endif
  if( v == 0 ) then
     value = u
     return
  endif
  k = 1
  do while( (mod(u, 2) == 0).and.(mod(v, 2) == 0) )
     u = u / 2
     v = v / 2
     k = k * 2
  enddo
  if( (mod(u, 2) == 0) ) then
     t = u
  else
     t = -v
  endif
  do while( t /= 0 )
     do while( (mod(t, 2) == 0) )
        t = t / 2
     enddo
     if( t > 0 ) then
        u = t
     else
        v = -t
     endif
     t = u - v
  enddo
  value = u * k
end subroutine gcd_bin

Notes on performance[edit]

Iterative binary algorithm in Fortran 2008[edit]
Works with: Fortran version 2008
Works with: Fortran version 2018
Translation of: ATS

! Stein’s algorithm implemented in Fortran 2008.
! Translated from my implementation for ATS/Postiats.

elemental function gcd (u, v) result (d)
  implicit none
  integer, intent(in) :: u, v
  integer :: d

  integer :: x, y

  ! gcd(x,y) = gcd(u,v), but x and y are non-negative and x <= y.
  x = min (abs (u), abs (v))
  y = max (abs (u), abs (v))

  if (x == 0) then
     d = y
  else
     d = gcd_pos_pos (x, y)
  end if

contains

  elemental function gcd_pos_pos (u, v) result (d)
    integer, intent(in) :: u, v
    integer :: d

    integer :: n
    integer :: x, y
    integer :: p, q

    ! n = the number of common factors of two in u and v.
    n = trailz (ior (u, v))

    ! Remove the common twos from u and v, giving x and y.
    x = ishft (u, -n)
    y = ishft (v, -n)

    ! Make both numbers odd. One of the numbers already was odd.
    ! There is no effect on the value of their gcd.
    x = ishft (x, -trailz (x))
    y = ishft (y, -trailz (y))

    do while (x /= y)
       ! If x > y then swap x and y, renaming them p
       ! and q. Thus p <= q, and gcd(p,q) = gcd(x,y).
       p = min (x, y)
       q = max (x, y)

       x = p                    ! x remains odd.
       q = q - p
       y = ishft (q, -trailz (q)) ! Make y odd again.
    end do

    ! Put the common twos back in.
    d = ishft (x, n)
  end function gcd_pos_pos

end function gcd

program test_gcd
  implicit none

  interface
     elemental function gcd (u, v) result (d)
       integer, intent(in) :: u, v
       integer :: d
     end function gcd
  end interface

  write (*, '("gcd (0, 0) = ", I0)') gcd (0, 0)
  write (*, '("gcd (0, 10) = ", I0)') gcd (0, 10)
  write (*, '("gcd (-6, -9) = ", I0)') gcd (-6, -9)
  write (*, '("gcd (64 * 5, -16 * 3) = ", I0)') gcd (64 * 5, -16 * 3)
  write (*, '("gcd (40902, 24140) = ", I0)') gcd (40902, 24140)
  write (*, '("gcd (-40902, 24140) = ", I0)') gcd (-40902, 24140)
  write (*, '("gcd (40902, -24140) = ", I0)') gcd (40902, -24140)
  write (*, '("gcd (-40902, -24140) = ", I0)') gcd (-40902, -24140)
  write (*, '("gcd (24140, 40902) = ", I0)') gcd (24140, 40902)

end program test_gcd

implement functions to find the greatest common divisor (GCD), also known as the greatest common factor (GCF) or greatest common measure, of two integers. Two versions of the function are provided, one iterative (gcd_iter) and one binary (gcd_bin), with performance times provided for comparison. The code also includes new intrinsic functions for integer operations introduced in Fortran 2008.


FUNCTION is_numeric(string)
  IMPLICIT NONE
  CHARACTER(len=*), INTENT(IN) :: string
  LOGICAL :: is_numeric
  REAL :: x
  INTEGER :: e
  READ(string,*,IOSTAT=e) x
  is_numeric = e == 0
END FUNCTION is_numeric

"Output: Function to check if a given string can be interpreted as a numeric value, including floating point and negative numbers, in the language's syntax."


module SutherlandHodgmanUtil
  ! functions and type needed for Sutherland-Hodgman algorithm

  ! -------------------------------------------------------- !
  type polygon
    !type for polygons
    ! when you define a polygon, the first and the last vertices have to be the same
    integer :: n
    double precision, dimension(:,:), allocatable :: vertex
  end type polygon

  contains

  ! -------------------------------------------------------- !
  subroutine sutherlandHodgman( ref, clip, outputPolygon )
    ! Sutherland Hodgman algorithm for 2d polygons

    ! -- parameters of the subroutine --
    type(polygon) :: ref, clip, outputPolygon

    ! -- variables used is the subroutine
    type(polygon) :: workPolygon               ! polygon clipped step by step
    double precision, dimension(2) :: y1,y2    ! vertices of edge to clip workPolygon
    integer :: i

    ! allocate workPolygon with the maximal possible size
    !   the sum of the size of polygon ref and clip
    allocate(workPolygon%vertex( ref%n+clip%n , 2 ))

    !  initialise the work polygon with clip
    workPolygon%n = clip%n
    workPolygon%vertex(1:workPolygon%n,:) = clip%vertex(1:workPolygon%n,:)

    do i=1,ref%n-1 ! for each edge i of the polygon ref
      y1(:) = ref%vertex(i,:)   !  vertex 1 of edge i
      y2(:) = ref%vertex(i+1,:) !  vertex 2 of edge i

      ! clip the work polygon by edge i
      call edgeClipping( workPolygon, y1, y2, outputPolygon)
      ! workPolygon <= outputPolygon
      workPolygon%n = outputPolygon%n
      workPolygon%vertex(1:workPolygon%n,:) = outputPolygon%vertex(1:workPolygon%n,:)

    end do
    deallocate(workPolygon%vertex)
  end subroutine sutherlandHodgman

  ! -------------------------------------------------------- !
  subroutine edgeClipping( poly, y1, y2, outputPoly )
    ! make the clipping  of the polygon by the line (x1x2)

    type(polygon) :: poly, outputPoly
    double precision, dimension(2) :: y1, y2, x1, x2, intersecPoint
    integer ::  i, c

    c = 0 ! counter for the output polygon

    do i=1,poly%n-1 ! for each edge i of poly
      x1(:) = poly%vertex(i,:)   ! vertex 1 of edge i
      x2(:) = poly%vertex(i+1,:) ! vertex 2 of edge i

      if ( inside(x1, y1, y2) ) then ! if vertex 1 in inside clipping region
        if ( inside(x2, y1, y2) ) then ! if vertex 2 in inside clipping region
          ! add the vertex 2 to the output polygon
          c = c+1
          outputPoly%vertex(c,:) = x2(:)

        else ! vertex i+1 is outside
          intersecPoint = intersection(x1, x2, y1,y2)
          c = c+1
          outputPoly%vertex(c,:) = intersecPoint(:)
        end if
      else ! vertex i is outside
        if ( inside(x2, y1, y2) ) then
          intersecPoint = intersection(x1, x2, y1,y2)
          c = c+1
          outputPoly%vertex(c,:) = intersecPoint(:)

          c = c+1
          outputPoly%vertex(c,:) = x2(:)
        end if
      end if
    end do

    if (c .gt. 0) then
      ! if the last vertice is not equal to the first one
      if ( (outputPoly%vertex(1,1) .ne. outputPoly%vertex(c,1)) .or. &
           (outputPoly%vertex(1,2) .ne. outputPoly%vertex(c,2)))  then
        c=c+1
        outputPoly%vertex(c,:) = outputPoly%vertex(1,:)
      end if
    end if
    ! set the size of the outputPolygon
    outputPoly%n = c
  end subroutine edgeClipping

  ! -------------------------------------------------------- !
  function intersection( x1, x2, y1, y2)
    ! computes the intersection between segment [x1x2]
    ! and line the line (y1y2)

    ! -- parameters of the function --
    double precision, dimension(2) :: x1, x2, &  ! points of the segment
                                      y1, y2     ! points of the line

    double precision, dimension(2) :: intersection, vx, vy, x1y1
    double precision :: a

    vx(:) = x2(:) - x1(:)
    vy(:) = y2(:) - y1(:)

    ! if the vectors are colinear
    if ( crossProduct(vx,vy) .eq. 0.d0) then
      x1y1(:) = y1(:) - x1(:)
      ! if the the segment [x1x2] is included in the line (y1y2)
      if ( crossProduct(x1y1,vx) .eq. 0.d0) then
        ! the intersection is the last point of the segment
        intersection(:) = x2(:)
      end if
    else ! the vectors are not colinear
      ! we want to find the inersection between [x1x2]
      ! and (y1,y2).
      ! mathematically, we want to find a in [0;1] such
      ! that :
      !     x1 + a vx = y1 + b vy
      ! <=> a vx = x1y1 + b vy
      ! <=> a vx^vy = x1y1^vy      , ^ is cross product
      ! <=> a = x1y1^vy / vx^vy

      x1y1(:) = y1(:) - x1(:)
      ! we compute a
      a = crossProduct(x1y1,vy)/crossProduct(vx,vy)
      ! if a is not in [0;1]
      if ( (a .gt. 1.d0) .or. (a .lt. 0)) then
        ! no intersection
      else
        intersection(:) = x1(:) + a*vx(:)
      end if
    end if

  end function intersection

  ! -------------------------------------------------------- !
  function inside( p, y1, y2)
    ! function that tells is the point p is at left of the line (y1y2)

    double precision, dimension(2) :: p, y1, y2, v1, v2
    logical :: inside
    v1(:) = y2(:) -  y1(:)
    v2(:) = p(:)  -  y1(:)
    if ( crossProduct(v1,v2) .ge. 0.d0) then
      inside = .true.
    else
      inside = .false.
    end if

   contains
  end function inside

  ! -------------------------------------------------------- !
  function dotProduct( v1, v2)
    ! compute the dot product of vectors v1 and v2
    double precision, dimension(2) :: v1
    double precision, dimension(2) :: v2
    double precision :: dotProduct
    dotProduct = v1(1)*v2(1) + v1(2)*v2(2)
  end function dotProduct

  ! -------------------------------------------------------- !
  function crossProduct( v1, v2)
    ! compute the crossproduct of vectors v1 and v2
    double precision, dimension(2) :: v1
    double precision, dimension(2) :: v2
    double precision :: crossProduct
    crossProduct = v1(1)*v2(2) - v1(2)*v2(1)
  end function crossProduct

end module SutherlandHodgmanUtil

program main

  ! load the module for S-H algorithm
  use SutherlandHodgmanUtil, only : polygon, &
                                    sutherlandHodgman, &
                                    edgeClipping

  type(polygon) :: p1, p2, res
  integer :: c, n
  double precision, dimension(2) :: y1, y2

  ! when you define a polygon, the first and the last vertices have to be the same

  ! first polygon
  p1%n = 10
  allocate(p1%vertex(p1%n,2))
  p1%vertex(1,1)=50.d0
  p1%vertex(1,2)=150.d0

  p1%vertex(2,1)=200.d0
  p1%vertex(2,2)=50.d0

  p1%vertex(3,1)= 350.d0
  p1%vertex(3,2)= 150.d0

  p1%vertex(4,1)= 350.d0
  p1%vertex(4,2)= 300.d0

  p1%vertex(5,1)= 250.d0
  p1%vertex(5,2)= 300.d0

  p1%vertex(6,1)= 200.d0
  p1%vertex(6,2)= 250.d0

  p1%vertex(7,1)= 150.d0
  p1%vertex(7,2)= 350.d0

  p1%vertex(8,1)= 100.d0
  p1%vertex(8,2)= 250.d0

  p1%vertex(9,1)= 100.d0
  p1%vertex(9,2)= 200.d0

  p1%vertex(10,1)=  50.d0
  p1%vertex(10,2)= 150.d0

  y1 = (/ 100.d0, 300.d0 /)
  y2 = (/ 300.d0, 300.d0 /)

  ! second polygon
  p2%n = 5
  allocate(p2%vertex(p2%n,2))

  p2%vertex(1,1)= 100.d0
  p2%vertex(1,2)= 100.d0

  p2%vertex(2,1)= 300.d0
  p2%vertex(2,2)= 100.d0

  p2%vertex(3,1)= 300.d0
  p2%vertex(3,2)= 300.d0

  p2%vertex(4,1)= 100.d0
  p2%vertex(4,2)= 300.d0

  p2%vertex(5,1)= 100.d0
  p2%vertex(5,2)= 100.d0

  allocate(res%vertex(p1%n+p2%n,2))
  call sutherlandHodgman( p2, p1, res)
  write(*,*) "Suterland-Hodgman"
  do c=1, res%n
    write(*,*) res%vertex(c,1), res%vertex(c,2)
  end do
  deallocate(res%vertex)

end program main

  Suterland-Hodgman
  300.00000000000000        300.00000000000000
  250.00000000000000        300.00000000000000
  200.00000000000000        250.00000000000000
  175.00000000000000        300.00000000000000
  125.00000000000000        300.00000000000000
  100.00000000000000        250.00000000000000
  100.00000000000000        200.00000000000000
  100.00000000000000        200.00000000000000
  100.00000000000000        116.66666666666667
  125.00000000000000        100.00000000000000
  275.00000000000000        100.00000000000000
  300.00000000000000        116.66666666666666
  300.00000000000000        300.00000000000000

implement the Sutherland-Hodgman polygon clipping algorithm. The algorithm takes a subject polygon and a clip polygon as inputs, and outputs the intersecting polygon. The subject polygon is defined by a sequence of points and the clip polygon is a rectangle defined by another sequence of points. The program also includes an extra feature to display all three polygons on a graphical surface, each in a different color, and fills the resulting polygon. The polygons are of fortran type with an allocatable array "vertex" containing the vertices and an integer n indicating the size of the polygon. The first and last vertices of any polygon are identical. The vertex array of the resulting polygon is allocated with its maximum size in the main function.


PROGRAM Trig

  REAL pi, dtor, rtod, radians, degrees

  pi = 4.0 * ATAN(1.0)
  dtor = pi / 180.0
  rtod = 180.0 / pi
  radians = pi / 4.0
  degrees = 45.0

  WRITE(*,*) SIN(radians), SIN(degrees*dtor)
  WRITE(*,*) COS(radians), COS(degrees*dtor)
  WRITE(*,*) TAN(radians), TAN(degrees*dtor)
  WRITE(*,*) ASIN(SIN(radians)), ASIN(SIN(degrees*dtor))*rtod
  WRITE(*,*) ACOS(COS(radians)), ACOS(COS(degrees*dtor))*rtod
  WRITE(*,*) ATAN(TAN(radians)), ATAN(TAN(degrees*dtor))*rtod

END PROGRAM Trig

demonstrate the usage of trigonometric functions such as sine, cosine, tangent, and their inverses in a given programming language. The functions are applied to the same angle in both radians and degrees. The code also includes a conversion process for degrees to radians as trigonometric functions expect arguments in radians. The code also handles scenarios where the language does not have built-in trigonometric functions, by implementing these functions based on known approximations or identities. The output also highlights the accuracy issues in calculations with radians due to the representation of pi and conversion factors.


Works with: gfortran

program signal_handling
  use, intrinsic :: iso_fortran_env, only: atomic_logical_kind
  implicit none

  interface
    integer(C_INT) function usleep(microseconds) bind(c)
      use, intrinsic :: iso_c_binding, only: C_INT, C_INT32_T
      integer(C_INT32_T), value :: microseconds
    end function usleep
  end interface

  integer, parameter :: half_second = 500000
  integer, parameter :: sigint = 2
  integer, parameter :: sigquit = 3

  logical(atomic_logical_kind) :: interrupt_received[*]
  integer :: half_seconds
  logical :: interrupt_received_ref

  interrupt_received = .false.
  half_seconds = 0

  ! "Install" the same signal handler for both SIGINT and SIGQUIT.
  call signal(sigint, signal_handler)
  call signal(sigquit, signal_handler)

  ! Indefinite loop (until one of the two signals are received).
  do
    if (usleep(half_second) == -1) &
      print *, "Call to usleep interrupted."

    call atomic_ref(interrupt_received_ref, interrupt_received)
    if (interrupt_received_ref) then
      print "(A,I0,A)", "Program ran for ", half_seconds / 2, " second(s)."
      stop
    end if

    half_seconds = half_seconds + 1
    print "(I0)", half_seconds
  end do

contains

  subroutine signal_handler(sig_num)
    use, intrinsic :: iso_c_binding, only: C_INT
    integer(C_INT), value, intent(in) :: sig_num
    ! Must be declared with attribute `value` to force pass-by-value semantics
    ! (what C uses by default).

    select case (sig_num)
      case (sigint)
        print *, "Received SIGINT."
      case (sigquit)
        print *, "Received SIGQUIT."
    end select

    call atomic_define(interrupt_received, .true.)
  end subroutine signal_handler

end program signal_handling

The code outputs an integer every half second. It handles the SIGINT or SIGQUIT signal, usually triggered by the user pressing ctrl-C or ctrl-\, respectively. On receiving this signal, the code stops outputting integers, displays the total runtime in seconds, and then terminates. The code utilizes atomic operations enabled by the -fcoarray=single compilation flag.


Works with: Fortran version 90 and later

CHARACTER(10) :: intstr = "12345", realstr = "1234.5"
INTEGER :: i
REAL :: r

READ(intstr, "(I10)") i        ! Read numeric string into integer i
i = i + 1                      ! increment i
WRITE(intstr, "(I10)") i       ! Write i back to string

READ(realstr, "(F10.1)") r
r = r + 1.0
WRITE(realstr, "(F10.1)") r

"Code increments both integer and real numerical strings using 'internal' files."


Works with: Fortran version 90 and later
program Median_Test

  real            :: a(7) = (/ 4.1, 5.6, 7.2, 1.7, 9.3, 4.4, 3.2 /), &
                     b(6) = (/ 4.1, 7.2, 1.7, 9.3, 4.4, 3.2 /)

  print *, median(a)
  print *, median(b)

contains

  function median(a, found)
    real, dimension(:), intent(in) :: a
      ! the optional found argument can be used to check
      ! if the function returned a valid value; we need this
      ! just if we suspect our "vector" can be "empty"
    logical, optional, intent(out) :: found
    real :: median

    integer :: l
    real, dimension(size(a,1)) :: ac

    if ( size(a,1) < 1 ) then
       if ( present(found) ) found = .false.
    else
       ac = a
       ! this is not an intrinsic: peek a sort algo from
       ! Category:Sorting, fixing it to work with real if
       ! it uses integer instead.
       call sort(ac)

       l = size(a,1)
       if ( mod(l, 2) == 0 ) then
          median = (ac(l/2+1) + ac(l/2))/2.0
       else
          median = ac(l/2+1)
       end if

       if ( present(found) ) found = .true.
    end if

  end function median

end program Median_Test

If one refers to Quickselect_algorithm#Fortran which offers function FINDELEMENT(K,A,N) that returns the value of A(K) when the array of N elements has been rearranged if necessary so that A(K) is the K'th in order, then, supposing that a version is devised using the appropriate type for array A,       K = N/2
      MEDIAN = FINDELEMENT(K + 1,A,N)
      IF (MOD(N,2).EQ.0) MEDIAN = (FINDELEMENT(K,A,N) + MEDIAN)/2

"Calculates the median value of a vector of floating-point numbers, handling even number of elements by returning the average of the two middle values. The median is found using the selection algorithm. The function may re-arrange the elements of the array but not fully sort them."


program fizzbuzz_if
   integer :: i

   do i = 1, 100
      if     (mod(i,15) == 0) then; print *, 'FizzBuzz'
      else if (mod(i,3) == 0) then; print *, 'Fizz'
      else if (mod(i,5) == 0) then; print *, 'Buzz'
      else;                         print *, i
      end if
   end do
end program fizzbuzz_if

program FizzBuzz
implicit none
integer :: i = 1

do i = 1, 100
    if (Mod(i,3) == 0)write(*,"(A)",advance='no')  "Fizz"
    if (Mod(i,5) == 0)write(*,"(A)",advance='no') "Buzz"
    if (Mod(i,3) /= 0 .and. Mod(i,5) /=0 )write(*,"(I3)",advance='no') i
    print *, ""
end do
end program FizzBuzz

program fizzbuzz_select
    integer :: i

    do i = 1, 100
       select case (mod(i,15))
          case 0;        print *, 'FizzBuzz'
          case 3,6,9,12; print *, 'Fizz'
          case 5,10;     print *, 'Buzz'
          case default;  print *, i
       end select
    end do
 end program fizzbuzz_select

The code prints integers from 1 to 100, replacing multiples of three with 'Fizz', multiples of five with 'Buzz', and multiples of both three and five with 'FizzBuzz'. It uses structured IF-THEN-ELSE statements in ANSI FORTRAN 77 or later, and SELECT-CASE statement in ISO Fortran 90 or later. The code prints "Fizz" and "Buzz" together if the number is divisible by both 3 and 5, delaying the line break until after the If statements.


Works with: Fortran version 90 and later
program mandelbrot

  implicit none
  integer  , parameter :: rk       = selected_real_kind (9, 99)
  integer  , parameter :: i_max    =  800
  integer  , parameter :: j_max    =  600
  integer  , parameter :: n_max    =  100
  real (rk), parameter :: x_centre = -0.5_rk
  real (rk), parameter :: y_centre =  0.0_rk
  real (rk), parameter :: width    =  4.0_rk
  real (rk), parameter :: height   =  3.0_rk
  real (rk), parameter :: dx_di    =   width / i_max
  real (rk), parameter :: dy_dj    = -height / j_max
  real (rk), parameter :: x_offset = x_centre - 0.5_rk * (i_max + 1) * dx_di
  real (rk), parameter :: y_offset = y_centre - 0.5_rk * (j_max + 1) * dy_dj
  integer, dimension (i_max, j_max) :: image
  integer   :: i
  integer   :: j
  integer   :: n
  real (rk) :: x
  real (rk) :: y
  real (rk) :: x_0
  real (rk) :: y_0
  real (rk) :: x_sqr
  real (rk) :: y_sqr

  do j = 1, j_max
    y_0 = y_offset + dy_dj * j
    do i = 1, i_max
      x_0 = x_offset + dx_di * i
      x = 0.0_rk
      y = 0.0_rk
      n = 0
      do
        x_sqr = x ** 2
        y_sqr = y ** 2
        if (x_sqr + y_sqr > 4.0_rk) then
          image (i, j) = 255
          exit
        end if
        if (n == n_max) then
          image (i, j) = 0
          exit
        end if
        y = y_0 + 2.0_rk * x * y
        x = x_0 + x_sqr - y_sqr
        n = n + 1
      end do
    end do
  end do
  open  (10, file = 'out.pgm')
  write (10, '(a/ i0, 1x, i0/ i0)') 'P2', i_max, j_max, 255
  write (10, '(i0)') image
  close (10)

end program mandelbrot
bs

generate and draw the Mandelbrot set using various available algorithms and functions.


integer, dimension(10) :: a = (/ (i, i=1, 10) /)
integer :: sresult, presult

sresult = sum(a)
presult = product(a)

Computes the sum and product of an array of integers using SUM and PRODUCT intrinsics in ISO Fortran 90 and later.


program leap
 implicit none

 write(*,*) leap_year([1900, 1996, 1997, 2000])

 contains

	pure elemental function leap_year(y) result(is_leap)
	implicit none
	logical :: is_leap
	integer,intent(in) :: y

	is_leap = (mod(y,4)==0 .and. .not. mod(y,100)==0) .or. (mod(y,400)==0)

	end function leap_year

end program leap

"Determines if a specified year is a leap year in the Gregorian calendar."


Note that the syntax enables two classes of labels: the old-style numerical label in columns one to five, and the special label-like prefix of a DO-loop that is not in columns one to five. And yes, a line can have both.       INTEGER P,S,F	!Department codes for Police, Sanitation, and Fire. Values 1 to 7 only.
    1  PP:DO P = 2,7,2	!The police demand an even number. They're special and use violence.
    2   SS:DO S = 1,7		!The sanitation department accepts any value.
    3        IF (P.EQ.S) CYCLE SS	!But it must differ from the others.
    4        F = 12 - (P + S)		!The fire department accepts any number, but the sum must be twelve.
    5        IF (F.LE.0 .OR. F.GT.7) CYCLE SS	!Ensure that the only option is within range.
    6        IF ((F - S)*(F - P)) 7,8,7		!And F is to differ from S and from P
    7        WRITE (6,"(3I2)") P,S,F		!If we get here, we have a possible set.
    8      END DO SS		!Next S
    9    END DO PP	!Next P.
      END	!Well, that was straightforward.

 2 3 7
 2 4 6
 2 6 4
 2 7 3
 4 1 7
 4 2 6
 4 3 5
 4 5 3
 4 6 2
 4 7 1
 6 1 5
 6 2 4
 6 4 2
 6 5 1

generate all possible unique combinations of numbers between 1 and 7 for three city departments (police, sanitation, fire) that add up to 12. The police department number is always an even number. The combinations are generated without using a GO TO statement, instead using a DO-loop and CYCLE statement. The program also considers the evaluation of compound boolean expressions.


"Implements a string copy operation, distinguishing between copying the string content and creating an additional reference to the existing string. Handles Fortran's fixed length character strings, padding or truncating as necessary."


Works with: Fortran version 95 and later
module MutualRec
  implicit none
contains
  pure recursive function m(n) result(r)
    integer :: r
    integer, intent(in) :: n
    if ( n == 0 ) then
       r = 0
       return
    end if
    r = n - f(m(n-1))
  end function m

  pure recursive function f(n) result(r)
    integer :: r
    integer, intent(in) :: n
    if ( n == 0 ) then
       r = 1
       return
    end if
    r = n - m(f(n-1))
  end function f

end module

program testmutrec
  use MutualRec
  implicit none

  integer :: i
  integer, dimension(20) :: a = (/ (i, i=0,19) /), b = (/ (i, i=0,19) /)
  integer, dimension(20) :: ra, rb

  forall(i=1:20)
     ra(i) = m(a(i))
     rb(i) = f(b(i))
  end forall

  write(*,'(20I3)') rb
  write(*,'(20I3)') ra

end program testmutrec

implement two mutually recursive functions to compute the Hofstadter Female and Male sequences. The functions are defined such that F(0) = 1, M(0) = 0, F(n) = n - M(F(n-1)) for n > 0, and M(n) = n - F(M(n-1)) for n > 0. The functions are designed to be used within the same module or program block. If they are in different modules, the interface of the other function needs to be loaded. The functions are marked as pure for use in a forall statement.


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

  integer :: i
  integer :: a(10) = (/ (i, i = 1, 10) /)
  real :: r

  call random_seed
  call random_number(r)
  write(*,*) a(int(r*size(a)) + 1)
end program

demonstrate how to select a random element from a list.


recursive function binarySearch_R (a, value) result (bsresult)
    real, intent(in) :: a(:), value
    integer          :: bsresult, mid

    mid = size(a)/2 + 1
    if (size(a) == 0) then
        bsresult = 0        ! not found
    else if (a(mid) > value) then
        bsresult= binarySearch_R(a(:mid-1), value)
    else if (a(mid) < value) then
        bsresult = binarySearch_R(a(mid+1:), value)
        if (bsresult /= 0) then
            bsresult = mid + bsresult
        end if
    else
        bsresult = mid      ! SUCCESS!!
    end if
end function binarySearch_R

function binarySearch_I (a, value)
    integer                  :: binarySearch_I
    real, intent(in), target :: a(:)
    real, intent(in)         :: value
    real, pointer            :: p(:)
    integer                  :: mid, offset

    p => a
    binarySearch_I = 0
    offset = 0
    do while (size(p) > 0)
        mid = size(p)/2 + 1
        if (p(mid) > value) then
            p => p(:mid-1)
        else if (p(mid) < value) then
            offset = offset + mid
            p => p(mid+1:)
        else
            binarySearch_I = offset + mid    ! SUCCESS!!
            return
        end if
    end do
end function binarySearch_I

Iterative, exclusive bounds, three-way test.[edit]

      INTEGER FUNCTION FINDI(X,A,N)	!Binary chopper. Find i such that X = A(i)
Careful: it is surprisingly difficult to make this neat, due to vexations when N = 0 or 1.
       REAL X,A(*)		!Where is X in array A(1:N)?
       INTEGER N		!The count.
       INTEGER L,R,P		!Fingers.
        L = 0			!Establish outer bounds, to search A(L+1:R-1).
        R = N + 1		!L = first - 1; R = last + 1.
    1   P = (R - L)/2		!Probe point. Beware INTEGER overflow with (L + R)/2.
        IF (P.LE.0) GO TO 5	!Aha! Nowhere!! The span is empty.
        P = P + L		!Convert an offset from L to an array index.
        IF (X - A(P)) 3,4,2	!Compare to the probe point.
    2   L = P			!A(P) < X. Shift the left bound up: X follows A(P).
        GO TO 1			!Another chop.
    3   R = P			!X < A(P). Shift the right bound down: X precedes A(P).
        GO TO 1			!Try again.
    4   FINDI = P		!A(P) = X. So, X is found, here!
       RETURN			!Done.
Curse it!
    5   FINDI = -L		!X is not found. Insert it at L + 1, i.e. at A(1 - FINDI).
      END FUNCTION FINDI	!A's values need not be all different, merely in order.

Statistics[edit]

An alternative version[edit]
      INTEGER FUNCTION FINDI(X,A,N)	!Binary chopper. Find i such that X = A(i)
Careful: it is surprisingly difficult to make this neat, due to vexations when N = 0 or 1.
       REAL X,A(*)		!Where is X in array A(1:N)?
       INTEGER N		!The count.
       INTEGER L,R,P		!Fingers.
        L = 0			!Establish outer bounds, to search A(L+1:R-1).
        R = N + 1		!L = first - 1; R = last + 1.
        GO TO 1			!Hop to it.
    2   L = P			!A(P) < X. Shift the left bound up: X follows A(P).
    1   P = (R - L)/2		!Probe point. Beware INTEGER overflow with (L + R)/2.
        IF (P.LE.0) GO TO 5	!Aha! Nowhere!! The span is empty.
        P = P + L		!Convert an offset from L to an array index.
        IF (X - A(P)) 3,4,2	!Compare to the probe point.
    3   R = P			!X < A(P). Shift the right bound down: X precedes A(P).
        GO TO 1			!Try again.
    4   FINDI = P		!A(P) = X. So, X is found, here!
       RETURN			!Done.
Curse it!
    5   FINDI = -L		!X is not found. Insert it at L + 1, i.e. at A(1 - FINDI).
      END FUNCTION FINDI	!A's values need not be all different, merely in order.

 if expression > 0 then optionP
  else if expression < 0 then optionN
   else optionZ;

 if X > 0 then print "Positive"
  else if X > 0 then print "Still positive";

The code implements a binary search algorithm that divides a range of values into halves to find an unknown value. It includes both recursive and iterative versions of the algorithm. The code also handles multiple values equal to the given value and indicates whether the element was found or not. It provides pseudocode for traditional binary search, leftmost insertion point, and rightmost insertion point. The code also ensures no overflow bugs occur when calculating the mean of two integers. It is designed to work with a sorted integer array, returning the index of the found number or a "not found" message.


Works with: Fortran version 2003 and later
program command_line_arguments

  implicit none
  integer, parameter :: len_max = 256
  integer :: i , nargs
  character (len_max) :: arg

  nargs = command_argument_count()
  !nargs = iargc()
  do i = 0, nargs
    call get_command_argument (i, arg)
    !call getarg (i, arg)
    write (*, '(a)') trim (arg)
  end do

end program command_line_arguments

> ./a.out -c "alpha beta" -h "gamma"
./a.out
-c
alpha beta
-h
gamma

"Retrieves and prints the list of command-line arguments provided to the program. The program also includes intelligent parsing of these arguments. It utilizes Fortran 2003 intrinsic routines command_argument_count and get_command_argument for this purpose."