250 lines
5.5 KiB
Fortran
250 lines
5.5 KiB
Fortran
! Hex words
|
|
! tested with Intel ifx (IFX) 2025.2.1 20250806 on Kubuntu 25.10
|
|
! GNU gfortran (Ubuntu 15.2.0-4ubuntu4) 15.2.0 on Kubuntu 25.10
|
|
! but not VSI Fortran x86-64 V8.7-001 because that compiler does not accept
|
|
! allocatable character variables
|
|
!
|
|
|
|
module modType
|
|
|
|
implicit none
|
|
public t_hexw
|
|
type :: t_hexw
|
|
integer :: decroot
|
|
integer :: value
|
|
character (len=:), allocatable :: word
|
|
integer :: len
|
|
end type
|
|
|
|
end module modType
|
|
|
|
|
|
program Hexwords
|
|
use modType
|
|
|
|
implicit none
|
|
|
|
integer :: capacity, used
|
|
|
|
integer, parameter :: longestWord=25 ! no word in unixdict.txt is longer.
|
|
character(len=longestWord) :: word
|
|
character(len=longestWord),parameter :: filename = 'unixdict.txt'
|
|
|
|
integer :: l, io_stat ! Length of read word, and status of read operation
|
|
integer :: ival, decroot
|
|
integer :: ii, jj
|
|
|
|
type (t_hexw), allocatable :: resultWords(:), tmp(:)
|
|
|
|
interface ! for the compare functions used to call quicksort
|
|
function compValue (l,r) result (yn)
|
|
use modType
|
|
type (t_hexw),intent(in) :: l, r
|
|
logical :: yn
|
|
end function compValue
|
|
function compRoot (l,r) result (yn)
|
|
use modType
|
|
type (t_hexw),intent(in) :: l, r
|
|
logical :: yn
|
|
end function compRoot
|
|
end interface
|
|
|
|
capacity = 32
|
|
used=0
|
|
|
|
allocate (resultWords(capacity))
|
|
|
|
open(unit=10, file=filename, status='old', action='read', iostat=io_stat)
|
|
if (io_stat .ne. 0) then
|
|
print *, "Error opening file ", filename
|
|
stop
|
|
end if
|
|
do
|
|
read(10, '(a)', iostat=io_stat) word
|
|
if (io_stat .lt. 0) exit ! EOF, normal end of input
|
|
if (io_stat .gt. 0) then ! read error, unexpected failure
|
|
print *, "Read error"
|
|
exit
|
|
end if
|
|
|
|
l = len_trim (word)
|
|
if (l .lt. 4) cycle ! only consider words with 4 letters or more
|
|
|
|
if (is_hexword (word(1:l), l)) then
|
|
ival = base10(word(1:l))
|
|
decroot = decimalRoot (ival)
|
|
used = used + 1
|
|
if (used .gt. capacity) then
|
|
call move_alloc(resultWords, tmp)
|
|
allocate (resultWords (2*capacity))
|
|
resultWords (:capacity) = tmp(:capacity)
|
|
capacity = 2*capacity
|
|
endif
|
|
resultWords (used)%decroot = decroot
|
|
resultWords (used)%value = ival
|
|
resultWords (used)%word = word(:l)
|
|
resultWords (used)%len = l
|
|
endif
|
|
|
|
end do
|
|
|
|
! Sort according to increasing root and print all entries
|
|
call quicksort (resultWords, 1, used, compRoot)
|
|
write (*,'("Digital root Word Decimal value")')
|
|
do jj=1,used
|
|
write (*,'(6x,i1,7x, A5, 3x, i10)') resultWords(jj)%decroot, resultWords(jj)%word(1:resultWords(jj)%len), resultWords(jj)%value
|
|
enddo
|
|
write (*,'(/,"Total count:", i2)') used
|
|
|
|
write (*,'(/,"Digital root Word Decimal value")')
|
|
|
|
! sort according decreasing value, then select and print only words with at least 4 distinct characters,
|
|
call quicksort (resultWords, 1, used, compValue)
|
|
ii = 0
|
|
do jj=1,used
|
|
if (DistinctLetters (resultWords (jj)%word, resultWords (jj)%len) .ge.4) then
|
|
ii = ii + 1 ! Abuse ii to count output lines here.
|
|
write (*,'(6x,i1,7x, A5, 3x, i10)') resultWords(jj)%decroot, resultWords(jj)%word(1:resultWords(jj)%len), resultWords(jj)%value
|
|
endif
|
|
enddo
|
|
write (*,'(/,"Total count:", i2)') ii
|
|
|
|
|
|
|
|
close(10)
|
|
|
|
contains
|
|
|
|
|
|
recursive subroutine quicksort (a, low, high, comparefunc)
|
|
use modType
|
|
implicit none
|
|
|
|
type (t_hexw), intent(inout), dimension(:) :: a
|
|
type (t_hexw) :: temp
|
|
integer , intent(in) :: low, high
|
|
|
|
integer :: pivot, i, j, mid, pivot_index
|
|
|
|
interface
|
|
function comparefunc (l,r) result (yn)
|
|
use modType
|
|
type (t_hexw),intent(in) :: l, r
|
|
logical :: yn
|
|
end function comparefunc
|
|
end interface
|
|
|
|
if (low .lt. high) then
|
|
mid=low+(high-low)/2
|
|
pivot = a(mid)%value
|
|
|
|
! Move pivot to the end
|
|
temp = a(mid)
|
|
a(mid) = a(high)
|
|
a(high) = temp
|
|
i = low-1
|
|
|
|
do j=low,high-1
|
|
if (comparefunc (a(j), a(high))) then
|
|
i = i + 1
|
|
temp=a(i)
|
|
a(i) = a(j)
|
|
a(j)=temp
|
|
endif
|
|
enddo
|
|
temp=a(i+1)
|
|
a(i+1) = a(high)
|
|
a(high)=temp
|
|
pivot_index = i+1
|
|
call quicksort (a,low,pivot_index-1, comparefunc)
|
|
call quicksort (a,pivot_index+1, high, comparefunc)
|
|
endif
|
|
|
|
|
|
end subroutine quicksort
|
|
|
|
|
|
|
|
function DistinctLetters (w, l) result (n)
|
|
integer, intent(in) :: l
|
|
character (len=l), intent(in) :: w
|
|
|
|
integer :: ii, jj
|
|
integer :: n
|
|
integer ::seen
|
|
|
|
n = 0
|
|
|
|
do ii=1,l
|
|
seen = 0
|
|
do jj=1, ii-1 ! But it does not if already seen atleast once
|
|
if (w(ii:ii) .eq. w(jj:jj)) then
|
|
seen = 1
|
|
exit
|
|
endif
|
|
enddo
|
|
if (seen .eq. 0) n=n+1
|
|
end do
|
|
end function DistinctLetters
|
|
|
|
function is_hexword (t, l) result (YN)
|
|
character (len=*), intent(in) :: t
|
|
integer , intent(in) :: l
|
|
logical :: YN
|
|
|
|
integer :: ii
|
|
do ii=1,l
|
|
if (index('abcdefABCDEF',t(ii:ii)) .eq. 0) then
|
|
YN = .false.
|
|
return
|
|
endif
|
|
enddo
|
|
|
|
YN = .true.
|
|
end function is_hexword
|
|
|
|
function base10 (t) result (intnum)
|
|
character (len=*), intent(in) :: t
|
|
integer :: intnum
|
|
|
|
|
|
read (t,'(Z5)') intnum
|
|
end function base10
|
|
|
|
|
|
recursive function decimalRoot (n) result (r)
|
|
integer, intent(in) :: n
|
|
integer :: r
|
|
|
|
integer:: wn
|
|
|
|
wn = N
|
|
r=0
|
|
do while (wn .ne. 0)
|
|
r = r + mod(wn,10)
|
|
wn = wn / 10
|
|
enddo
|
|
! go recursive if digit sum r is >= 10
|
|
if (r .ge. 10) r = decimalRoot (r)
|
|
end function decimalRoot
|
|
|
|
|
|
end program Hexwords
|
|
|
|
function compvalue (l,r) result (yn)
|
|
use modType
|
|
implicit none
|
|
type (t_hexw),intent(in) :: l,r
|
|
logical :: YN
|
|
|
|
yn = l%value .ge. r%value
|
|
end function compvalue
|
|
|
|
function compRoot (l,r) result (yn)
|
|
use modType
|
|
implicit none
|
|
type (t_hexw),intent(in) :: l,r
|
|
logical :: YN
|
|
|
|
yn = l%decroot .le. r%decroot
|
|
end function compRoot
|