This is the Fortran 77 implementation of the anagram program. The problem and the solution is described in the main anagram article. Do read that article first.
Don’t write new programs in Fortran 77. No-one else does. But by all means, do write new programs in later versions of Fortran, especially if you are into high-performance computing, and area where Fortran shines.
This implementation is meant to follow the Fortran 77 standard. Since I do not have a true Fortran 77 compiler, I have used GNU gfortran with -std=legacy. But legacy is not Fortran 77. It does not accept ELSE IF, which is in the Fortran 77 standard, but it does accept other things that are not in the standard. To help me keep to the straight and narrow, I have used my old F77 textbook and some Fortran 77 manuals.
- DEC: PDP-11 FORTRAN-77 Language Reference Manual (July 1983)
- SGI: FORTRAN 77 Language Reference Manual (1990)
- IBM: VS FORTRAN Version 2, Language and Library Reference, Release 6 (Nov 1993)
The code should be compatible with all versions of Fortran up to but not including Fortran 2018. Fortran 2018 deletes (yes, that is the word they use) COMMON blocks from the language, making Fortran 2018 incompatible with Fortran 77.
I have taken some liberty with the standard. Neither of the following is in the standard, but implemented by many compilers:
- The exclamation mark (!) as a comment character.
- The INCLUDE statement.
There is no built-in sorting in Fortran. Sorting in this program is implemented using heapsort. In a language like Fortran 77, that does not provide recursion, heapsort is much easier to implement tham recursive algorithms like quicksort. Another advantage of heapsort is that the execution time is always n log n, while quicksort can be n squared for some input.
Commented source code
Shared constants
integer SHORTEST, LONGEST, TEXT_SIZE, ACC_SIZE, ACC_MINIMUM, A, Z
parameter (SHORTEST = 3 ) ! At least this many characters in an anagram
parameter (LONGEST = 10 ) ! At most - " -
parameter (TEXT_SIZE = 500*512 ) ! Maximum size of the letter string
parameter (ACC_SIZE = 50 ) ! Max # of accepted entries.
parameter (ACC_MINIMUM = 3 ) ! Fewer than this does not count
parameter (A = ichar('A')) ! Character code for 'A'
parameter (Z = ichar('Z')) ! Character code for 'Z'
Shared variables
text holds the uppercased text containing only letters. unified holds the array of unified strings. unified(n) is the unified version of the string of length len starting at text(n) words holds indices into unified. These indices are also indices into text. unified holds the indices for accepted candidates with the same unified value, and naccepted counts them. naccepted is reset to zero every time a new unified value is found. comparisons counts the number of calls to compare_words.
All shared variables are put in a single named COMMON block. Fortran 77 has no other way of sharing variables, except by passing them as parameters, which quickly becomes tedious.
character*(TEXT_SIZE) text
character*(LONGEST) unified(1:TEXT_SIZE-SHORTEST+1 )
integer words (1:TEXT_SIZE-SHORTEST+1+1)
integer len
integer nwords
integer accepted(1:ACC_SIZE)
integer naccepted
integer comparisons
common /globals/words,unified,text,len,nwords,naccepted,accepted,
* comparisons
read_text(): Read the input file
Reads at most 1 million (effectively an infinite number of) lines from the standard input file. Discard all characters that are not letters. Convert lowercase letters to uppercase. Return the number of characters read.
integer function read_text()
include "anagram-f77-common.i"
character*(80) line
integer put, i, n, ch
character*(256) map
C-- Assumes fixed format, 72 chars per line
data map/'--------------------------------------------------------
*--------ABCDEFGHIJKLMNOPQRSTUVWXYZ------ABCDEFGHIJKLMNOPQRSTUVWXYZ
*------------------------------------------------------------------
*------------------------------------------------------------------
*--'/
put = 1
do i = 1, 1000000, 1
read (*,100,end=999) line
100 format(A80)
do n = 1, 80, 1
ch = ichar(line(n:n))
if (map(ch:ch) .ne. '-') then
if (put > TEXT_SIZE) stop 'Input text too large'
text(put:put) = map(ch:ch)
put = put+1
endif
enddo
enddo
999 read_text = put-1
end
get_unified()
Compute the unified version of the string of len characters starting at text(pos) To avoid sorting, count the number of times each letter occurs. The statement lcount = 0 sets all elements to zero.
function get_unified(pos)
include "anagram-f77-common.i"
character*(LONGEST) get_unified
integer pos
integer lcount(A:Z), n, put, tmp
!!! Count each letter
lcount = 0
do n = pos, pos+len-1
tmp = ichar(text(n:n))
lcount(tmp) = lcount(tmp) + 1
enddo
!!! Build key from letter counts
put = 1
get_unified = ''
do n = A, Z
do tmp = 1, lcount(n)
get_unified(put:put) = char(n)
put = put + 1
enddo
enddo
end
compare_words()
First compare the unified versions of the strings. If they are equal, then compare their positions in the text.
integer function compare_words(i1, i2)
include "anagram-f77-common.i"
integer i1, i2
integer pos1, pos2
pos1 = words(i1)
pos2 = words(i2)
comparisons = comparisons + 1
compare_words = pos1 - pos2
if (unified(pos1) .gt. unified(pos2)) then
compare_words = +1
else
if (unified(pos1) .lt. unified(pos2)) then
compare_words = -1
endif
endif
end
function add_to_heap()
The subroutine is called with the size of the heap before insertion as its first parameter, and a “pointer” (in the form of an index into the array unified as it second argument. The new value is placed at the new bootom of the heap and then bubbled up. Unnecessary word swap are avoided by not actually moving the new word until its final position is known.
subroutine add_to_heap(size, value)
include "anagram-f77-common.i"
integer size, value
integer here, compare_words, cmp
words(size+1) = value
here = size
100 if (here .gt. 1) then ! while (here > 1)
cmp = compare_words(size+1, here/2)
if (cmp .gt. 0) then
words(here) = words(here/2)
here = here / 2
goto 100
endif
endif
words(here) = words(size+1)
end
subroutine heap_sort()
The heap is already a heap, so this is the second phase of a heap sort. Save the value at the top of the heap in a safe place, w In thought, but not in deed, Move the last element to the top of the heap. Then, still in thought, let it trickle down until its rightful place has been found. Values bubble up to leave space for the element. Then, in statement 199, move, in deed, the last element to its rightful place. Finally, in the next statement, move the element that was at the top to the head of the sorted list.
Repeat until the heap has size 1.
subroutine heap_sort()
include "anagram-f77-common.i"
integer c12, empty, child, i, j, w, compare_words
integer hsize
do i = nwords, 2, -1
w = words(1)
hsize = i - 1
empty = 1
do j = 1, 10000000
if (2*empty .gt. hsize) goto 199
c12 = compare_words(i, 2*empty )
if (2*empty .eq. hsize) then ! A single (left) child
if (c12 .lt. 0) words(empty) = words(2*empty)
goto 199 ! F77 does not have the EXIT statement
else
if (c12 .gt. 0) then
if (compare_words(i, 2*empty+1) .gt. 0) goto 199 ! Two children, both lesser
endif
child = 2*empty
if (compare_words(child, child+1) .lt. 0) child = child+1 ! Right child is greater
words(empty) = words(child)
empty = child
endif
enddo
199 words(empty) = words(i)
words(i) = w
enddo
end
subroutine add_candidate()
Add the candidate pointed to by the integer ptr (an index), but only if it does not overlap any existing candidates, and only if it is not a duplicate.
The candidate is an index into text and at the same time an index into unified. Candidates with the same unified value are added in increasing index order, so the overlap test need only look at the most recently accepted candidate.
subroutine add_candidate(ptr)
include "anagram-f77-common.i"
integer ptr,i, p2
if (naccepted .gt. 0) then
if (ptr .le. accepted(naccepted)+(len-1)) then
return
endif
endif
do i = 1, naccepted
p2 = accepted(i)
if (text(ptr:ptr+len-1) .eq. text(p2:p2+len-1)) then
return
endif
enddo
naccepted = naccepted + 1
accepted(naccepted) = ptr
end
subroutine print_result()
subroutine print_result()
include "anagram-f77-common.i"
integer i, ptr
write(*,100, advance='no') naccepted
100 format(I3, ': ')
do i = 1, naccepted
ptr = accepted(i)
write(*,110, advance='no') ptr-1, text(ptr:ptr+len-1)
110 format(I5, ': ', A)
enddo
write(*,*)
end
subroutine find_all(text_len)
Find all anagrams of length len, already set by the main program.text_len is the number of characters in text.For each possible word, compute the unified value and add it to the heap words, then sort the heap. The words in words are now sorted by, and therefore grouped by, their unified value, and words with equal unified value are sorted by their index into text. For each word, call add_candidate. If the current word is the last in a suite of words with the same unifoed value 1) print the result if the number af accepted words reaches the threshold MINIMUM, and 2) clear the accepted list by setting naccepted to zero.
Note the use of a sentinel to simplify the testing for “last in a suite”.
subroutine find_all(text_len)
include "anagram-f77-common.i"
integer i
integer text_len
character*(LONGEST) get_unified
nwords = text_len-len+1
do i=1, nwords
! call get_unified(i, unified (i))
unified(i) = get_unified(i)
call add_to_heap(i, i)
enddo
call heap_sort()
unified(nwords+1) = 'ZZZZZZZZZZ'
words(nwords+1) = nwords + 1
do i=1, nwords
call add_candidate(words(i))
if (unified(words(i)) .ne. unified(words(i+1))) then
if (naccepted .ge. ACC_MINIMUM) then
call print_result()
endif
naccepted = 0
endif
enddo
end
program main
Read the input text into text, then call find_all for all lengths len in the range from to to inclusive.
F77 does not have routines for accessing the command line, so the range is set by a DATA statement.
program main
include "anagram-f77-common.i"
integer text_len
integer read_text
integer from, to
data from,to/14,7/
comparisons = 0
if (to .lt. from ) stop '*** "from" > "to"'
if (to .gt. LONGEST ) stop '*** "to" is too large'
if (from .lt. SHORTEST) stop '*** "from" is too small'
text_len = read_text()
do len = from, to
if (len .gt. from) write(*,*)
write(*,100) 'len = ', len
100 format(A, I0)
call find_all(text_len)
enddo
write(*, 110) text_len, comparisons
110 format("string length = ", I5, ", comparisons = ", I5)
end
Full source code
Parameters and COMMON block (anagram-f77-common.i)
!!!---* -*- mode: fortran -*-
!------------------------------------------------------------------
!!!--- Compile-time constants
integer SHORTEST, LONGEST, TEXT_SIZE, ACC_SIZE, ACC_MINIMUM, A, Z
parameter (SHORTEST = 3 ) ! At least this many characters in an anagram
parameter (LONGEST = 10 ) ! At most - " -
parameter (TEXT_SIZE = 500*512 ) ! Maximum size of the letter string
parameter (ACC_SIZE = 50 ) ! Max # of accepted entries.
parameter (ACC_MINIMUM = 3 ) ! Fewer than this does not count
parameter (A = ichar('A')) ! Character code for 'A'
parameter (Z = ichar('Z')) ! Character code for 'Z'
!!!----------------------------------------------------------------
!!!--- Global variables
character*(TEXT_SIZE) text
character*(LONGEST) unified(1:TEXT_SIZE-SHORTEST+1 )
integer words (1:TEXT_SIZE-SHORTEST+1+1)
integer len
integer nwords
integer accepted(1:ACC_SIZE)
integer naccepted
integer comparisons
common /globals/words,unified,text,len,nwords,naccepted,accepted,
* comparisons
The program (anagram-f77.f)
!!!----------------------------------------------------------- read_text
integer function read_text()
include "anagram-f77-common.i"
character*(80) line
integer put, i, n, ch
character*(256) map
C-- Assumes fixed format, 72 chars per line
data map/'--------------------------------------------------------
*--------ABCDEFGHIJKLMNOPQRSTUVWXYZ------ABCDEFGHIJKLMNOPQRSTUVWXYZ
*------------------------------------------------------------------
*------------------------------------------------------------------
*--'/
put = 1
do i = 1, 1000000, 1
read (*,100,end=999) line
100 format(A80)
do n = 1, 80, 1
ch = ichar(line(n:n))
if (map(ch:ch) .ne. '-') then
if (put > TEXT_SIZE) stop 'Input text too large'
text(put:put) = map(ch:ch)
put = put+1
endif
enddo
enddo
999 read_text = put-1
end
!!!--------------------------------------------------------- get_unified
function get_unified(pos)
include "anagram-f77-common.i"
character*(LONGEST) get_unified
integer pos
integer lcount(A:Z), n, put, tmp
!!! Count each letter
lcount = 0
do n = pos, pos+len-1
tmp = ichar(text(n:n))
lcount(tmp) = lcount(tmp) + 1
enddo
!!! Build key from letter counts
put = 1
get_unified = ''
do n = A, Z
do tmp = 1, lcount(n)
get_unified(put:put) = char(n)
put = put + 1
enddo
enddo
end
!!!------------------------------------------------------- compare_words
integer function compare_words(i1, i2)
include "anagram-f77-common.i"
integer i1, i2
integer pos1, pos2
pos1 = words(i1)
pos2 = words(i2)
comparisons = comparisons + 1
compare_words = pos1 - pos2
if (unified(pos1) .gt. unified(pos2)) then
compare_words = +1
else
if (unified(pos1) .lt. unified(pos2)) then
compare_words = -1
endif
endif
end
!!!--------------------------------------------------------- add_to_heap
subroutine add_to_heap(size, value)
include "anagram-f77-common.i"
integer size, value
integer here, compare_words, cmp
words(size+1) = value
here = size
100 if (here .gt. 1) then ! while (here > 1)
cmp = compare_words(size+1, here/2)
if (cmp .gt. 0) then
words(here) = words(here/2)
here = here / 2
goto 100
endif
endif
words(here) = words(size+1)
end
!!!----------------------------------------------------------- heap_sort
subroutine heap_sort()
include "anagram-f77-common.i"
integer c12, empty, child, i, j, w, compare_words
integer hsize
do i = nwords, 2, -1
w = words(1)
hsize = i - 1
empty = 1
do j = 1, 10000000
if (2*empty .gt. hsize) goto 199
c12 = compare_words(i, 2*empty )
if (2*empty .eq. hsize) then ! A single (left) child
if (c12 .lt. 0) words(empty) = words(2*empty)
goto 199 ! F77 does not have the EXIT statement
else
if (c12 .gt. 0) then
if (compare_words(i, 2*empty+1) .gt. 0) goto 199 ! Two children, both lesser
endif
child = 2*empty
if (compare_words(child, child+1) .lt. 0) child = child+1 ! Right child is greater
words(empty) = words(child)
empty = child
endif
enddo
199 words(empty) = words(i)
words(i) = w
enddo
end
!!!------------------------------------------------------- add_candidate
subroutine add_candidate(ptr)
include "anagram-f77-common.i"
integer ptr,i, p2
if (naccepted .gt. 0) then
if (ptr .le. accepted(naccepted)+(len-1)) then
return
endif
endif
do i = 1, naccepted
p2 = accepted(i)
if (text(ptr:ptr+len-1) .eq. text(p2:p2+len-1)) then
return
endif
enddo
naccepted = naccepted + 1
accepted(naccepted) = ptr
end
!!!-------------------------------------------------------- print_result
subroutine print_result()
include "anagram-f77-common.i"
integer i, ptr
write(*,100, advance='no') naccepted
100 format(I3, ': ')
do i = 1, naccepted
ptr = accepted(i)
write(*,110, advance='no') ptr-1, text(ptr:ptr+len-1)
110 format(I5, ': ', A)
enddo
write(*,*)
end
!!!------------------------------------------------------------ find_all
subroutine find_all(text_len)
include "anagram-f77-common.i"
integer i
integer text_len
character*(LONGEST) get_unified
nwords = text_len-len+1
do i=1, nwords
! call get_unified(i, unified (i))
unified(i) = get_unified(i)
call add_to_heap(i, i)
enddo
call heap_sort()
unified(nwords+1) = 'ZZZZZZZZZZ'
words(nwords+1) = nwords + 1
do i=1, nwords
call add_candidate(words(i))
if (unified(words(i)) .ne. unified(words(i+1))) then
if (naccepted .ge. ACC_MINIMUM) then
call print_result()
endif
naccepted = 0
endif
enddo
end
!!!----------------------------------------------------------------main
program main
include "anagram-f77-common.i"
integer text_len
integer read_text
integer from, to
data from,to/14,7/
comparisons = 0
if (to .lt. from ) stop '*** "from" > "to"'
if (to .gt. LONGEST ) stop '*** "to" is too large'
if (from .lt. SHORTEST) stop '*** "from" is too small'
text_len = read_text()
do len = from, to
if (len .gt. from) write(*,*)
write(*,100) 'len = ', len
100 format(A, I0)
call find_all(text_len)
enddo
write(*, 110) text_len, comparisons
110 format("string length = ", I5, ", comparisons = ", I5)
end
You can reach me by email at “lars dash 7 dot sdu dot se” or by telephone +46 705 189090