113 lines
4.3 KiB
Fortran
113 lines
4.3 KiB
Fortran
!
|
|
! Abbreviations, automatic
|
|
! tested with Intel ifx (IFX) 2025.2.1 20250806 on Kubuntu 25.10
|
|
! GNU Fortran (Ubuntu 15.2.0-4ubuntu4) 15.2.0 on Kubuntu 25.10
|
|
! VSI Fortran x86-64 V8.6-001 on OpenVMS x86_64 V9.2-3
|
|
! U.B., December 2025
|
|
!==============================================================================
|
|
|
|
program AbbrAuto
|
|
integer, parameter :: longestLine = 210 ! Longest input line
|
|
integer, parameter :: LongestDay = 30 ! Longest length of 1 day name
|
|
character (len=longestLine) :: Line
|
|
character (len=LongestDay) :: Days(7) ! 1 week
|
|
|
|
integer :: l, io_stat
|
|
logical :: OK
|
|
|
|
open (unit=10, file = 'days_of_week.txt', status='old', action='read', iostat=io_stat)
|
|
if (io_stat /= 0) then
|
|
print *, "Error opening file"
|
|
stop
|
|
end if
|
|
|
|
|
|
do ! Read all lines
|
|
read (10, '(A)', iostat=io_stat) Line
|
|
if (io_stat <0) exit ! Normal: EOF on input
|
|
if (io_stat >0) then ! Not Normal: Read error
|
|
print *, "Read error" ! has never been observed during testing.
|
|
exit
|
|
end if
|
|
call separateDays (Line, Days, OK)
|
|
if (OK) then ! 7 week days' name found
|
|
print '(I2, X, A)' , smallestAbreviation (Days), Line (:len_trim(Line))
|
|
else
|
|
print * ! Null string for empty or invalid line
|
|
endif
|
|
|
|
end do ! Read all lines
|
|
|
|
contains
|
|
|
|
|
|
! =========================================================================================
|
|
! Argument argLine contains space-separated list of (expected) 7 names of week days.
|
|
! Separate day names into array argDays, OK is .false. if number of days is not exactly 7.
|
|
! =========================================================================================
|
|
subroutine separateDays (argLine, argDays, OK)
|
|
|
|
character (len=longestLine), intent(in) :: argLine
|
|
character (len=LongestDay) , intent(out) :: argDays(7) ! 1 week
|
|
logical, intent(out) :: OK
|
|
integer :: ip1, ip2, nDays ! 2 Pointers into line, number of day names detected
|
|
integer :: l
|
|
|
|
ip1 = 1
|
|
nDays = 0
|
|
|
|
l = len_trim (argLine)
|
|
do while (ip1 .le. l) ! Loop untill entire line processed.
|
|
do while (ip1 .le. l .and. argLine (ip1:ip1) .eq. ' ') ! Skip space(s)
|
|
ip1 = ip1 + 1
|
|
end do
|
|
if (ip1 .le. l) then ! still inside Line?
|
|
ip2 = ip1
|
|
do while (ip2 .le. l .and. argLine (ip2:ip2) .ne. ' ') ! Find end of current word
|
|
ip2 = ip2 + 1
|
|
end do
|
|
|
|
! Here found space or end of line: Word is complete
|
|
if (ip2 .gt. l) ip2 = l ! End reached
|
|
if (argLine (ip2:ip2) .eq. ' ') ip2 = ip2 - 1 ! Space found
|
|
if (ip2 .gt. ip1) then ! day name has at least 2 letters
|
|
nDays = nDays + 1
|
|
argDays (nDays) = ' '
|
|
argDays (nDays) = argLine (ip1:ip2)
|
|
endif !
|
|
ip1 = ip2 + 1 ! Prepare for next day search: set behind current word
|
|
endif
|
|
end do
|
|
OK = (nDays .eq. 7) ! Result is OK only if number of days is 7
|
|
end subroutine separateDays
|
|
|
|
! =============================================================================
|
|
! Find length of smallest abbreviation of 7 day names so that abbreviated name
|
|
! is still unique.
|
|
! =============================================================================
|
|
function smallestAbreviation (argDays) result (nUniq)
|
|
character (len=LongestDay) , intent(in) :: argDays(7) ! 1 week
|
|
integer :: nUniq
|
|
integer :: ii, jj
|
|
logical :: done
|
|
nUniq = 1
|
|
done = .false.
|
|
do while (.not. done)
|
|
done = .true.
|
|
daysLoop: do ii=1, 6
|
|
do jj=ii+1,7
|
|
if (argDays (ii)(:nUniq) .eq. argDays(jj)(:nUniq)) then
|
|
! nUniq is too small for useful abbreviation of week days' name
|
|
nUniq = nUniq + 1
|
|
done = .false.
|
|
exit daysLoop ! go and try tith next larger nUniq
|
|
end if
|
|
end do
|
|
end do daysLoop
|
|
! here: done is .true. if no two day names are identical in first 'nUuniq' characters
|
|
! otherwise still the abbreviation is still too short
|
|
end do
|
|
end function smallestAbreviation
|
|
|
|
|
|
end program AbbrAuto
|