[Shootout-list] f95 count-words program mk 3
Simon Geard
simon@whiteowl.co.uk
Sat, 26 Mar 2005 12:38:45 +0000
This is a multi-part message in MIME format.
--------------010500000007030605000105
Content-Type: text/plain; charset=ISO-8859-1; format=flowed
Content-Transfer-Encoding: 7bit
My post of last night seems not to have appeared on the list so I'm
reposting with some minor updates that make the code clean and readable.
Attached is the tidied version of the count-words program I submitted
the other day. I've moved the string handling code into a string module
to make the main code cleaner. For the intel compiler the correct
compilation line is
ifort string.f90 count-words.f90 -O3 -static-libcxa -o count-words
but this might not be true of g95 which I think you're linking to as well.
I have tested this against the c++ version and the output is identical
so I'm not sure why the current version is showing an error. My command
line is
./count-words < datafile
If there is still an error perhaps you could mail me the command line
you're using and the result you're getting so that I can diagnose the
fault.
Thanks,
Simon
--------------010500000007030605000105
Content-Type: text/plain;
name="count-words.f90"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline;
filename="count-words.f90"
! The Great Computer Language Shootout
! http://shootout.alioth.debian.org/
!
! contributed by Simon Geard, 25/03/2005
!
! ifort string.f90 count-words.f90 -O3 -static-libcxa -o count-words
!
! $Id: count-words.f90,v 1.4 2005/03/26 12:25:46 simon Exp $ ; $Name: $
!
program countWords
use string
implicit none
type(str) :: line
integer :: nlines = 0 ! Line counter
integer :: nwords = 0 ! Word counter
integer :: nchars = 0 ! Char counter
logical :: finished
! Read and count
readFile: do
call getLine(line, finished)
if (finished) exit readFile
nlines = nlines + 1
nwords = nwords + numWords(line)
nchars = nchars + numChars(line)
end do readFile
nchars = nchars + nlines ! Have to add the number lines
write(*,'(2(i0,a),i0)') nlines, ' ', nwords, ' ', nchars
stop
end program countWords
--------------010500000007030605000105
Content-Type: text/plain;
name="string.f90"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline;
filename="string.f90"
! The Great Computer Language Shootout
! http://shootout.alioth.debian.org/
!
! contributed by Simon Geard, 25/03/2005
!
! A string module to do some basic string manipulaions. Much smaller
! that the iso_varying_string module so hopefully people will be able
! to see what's going on more easily.
!
! $Id: string.f90,v 1.6 2005/03/26 12:33:32 simon Exp $ ; $Name: $
!
module string
integer, parameter, private :: rsize = 64
type str
private
! A string type that is dynamically allocatable
character(len=rsize), dimension(:), allocatable :: s
integer :: nblocks ! The number of blocks of size rsize required for the string
integer :: nchars ! The number of chars
end type str
interface assignment(=)
module procedure assign_str_str
end interface
contains
subroutine assign_str_str(to, from)
type(str), intent(out) :: to
type(str), intent(in) :: from
allocate(to%s(from%nblocks))
to%s = from%s
to%nblocks = from%nblocks
to%nchars = from%nchars
end subroutine assign_str_str
integer function numWords(rline)
! Count the number of words
type(str), intent(in), target :: rline
integer, parameter :: tab = 9
integer, parameter :: space = 32
integer :: i, j, ng
logical :: ingap, started
character(len=rsize), pointer :: line
integer, pointer :: bline
ingap = .false.
ng = 0
started = .false.
! Search in the 1st block
bline => rline%nblocks
if (bline == 0) then
numWords = 0
return
end if
line => rline%s(1)
do i=1,len(line)
if (.not. started) then
started = (line(i:i) /= ' ')
elseif ( .not. ingap .and. (line(i:i) .eq. ' ' .or. line(i:i) .eq. achar(tab))) then
ng = ng + 1
ingap = .true.
elseif (ingap .and. ischar(line(i:i))) then
ingap = .false.
end if
end do
if (bline == 1) then
if (ingap) ng = ng - 1
numWords = ng + 1
return
end if
! Do the next n-2 blocks
do j=2,bline-1
line => rline%s(j)
do i=1,len(line)
if (.not. started) then
started = (line(i:i) /= ' ')
elseif (.not. ingap .and. (line(i:i) .eq. ' ' .or. line(i:i) .eq. achar(tab))) then
ng = ng + 1
ingap = .true.
elseif (ingap .and. ischar(line(i:i))) then
ingap = .false.
end if
end do
end do
! Do the last block
line =>rline%s(bline)
do i=1,len(trim(line))
if (.not. started) then
started = (line(i:i) /= ' ')
elseif (.not. ingap .and. (line(i:i) .eq. ' ' .or. line(i:i) .eq. achar(tab))) then
ng = ng + 1
ingap = .true.
else if (ingap .and. ischar(line(i:i))) then
ingap = .false.
end if
end do
numWords = ng + 1
contains
pure logical function ischar(c)
character, intent(in) :: c
ischar = (iachar(c) > 32 .and. iachar(c) < 127)
end function ischar
end function numWords
! Return the number of chars in the string
pure integer function numChars(line)
type(str), intent(in) :: line
numChars = line%nchars
end function numChars
! Diagnostic print procedure (not used)
subroutine print(line)
type(str), intent(in) :: line
integer :: i
write(*,'(i0,a)',advance='no') line%nblocks,' '
do i=1,line%nblocks-1
write(*,'(a)',advance='no') line%s(i)
end do
write(*,'(a)',advance='yes') line%s(line%nblocks)
end subroutine print
! Get a line from stdin as a str
subroutine getLine(rline, finished)
type(str), intent(out) :: rline ! a str object containing the whole line
logical, intent(out) :: finished ! .true. when there is no more input
integer :: nread
type(str) :: work
character(len=rsize) :: str_blk
allocate(rline%s(4096/rsize)) ! Allocate 4096 chars for the line (max allowed)
rline%nblocks = 0
rline%nchars = 0
readLine: do
rline%nblocks = rline%nblocks+1
read(5,fmt='(a)',end=100,eor=10,size=nread,advance='no') str_blk
if (rline%nblocks > size(rline%s)) then
call enlargeLine
end if
rline%s(rline%nblocks) = str_blk(1:nread)
rline%nchars = rline%nchars + nread
end do readLine
10 continue
if (rline%nblocks > size(rline%s)) then
call enlargeLine
end if
rline%nchars = rline%nchars + nread
if (nread == 0) then
rline%nblocks = rline%nblocks - 1
else
rline%s(rline%nblocks) = str_blk(1:nread)
end if
finished = .false.
return
100 continue
finished = .true.
return
contains
subroutine enlargeLine
! Allocate more memory for a line if requested
allocate(work%s(size(rline%s)))
work = rline
deallocate(rline%s)
allocate(rline%s(2*size(work%s)))
rline = work
deallocate(work%s)
end subroutine enlargeLine
end subroutine getLine
end module string
--------------010500000007030605000105--