Instructions:
Examine the program on the following pages and answer these questions about the different tokens and constructs in the program listing. Hand your answers to me (RTH) before, or during class on Monday (Oct 18th).
1. How many subrountines are declared?
2. Where is the end of the do loop that starts on line 15?
3. On what lines are there string constants?
4. On what lines are there relational operators?
5. Where is the end of the if statement that starts on line 187?
6. On what lines are arithmetic operators used?
7. On what lines are there integer constants that used in statements?
8. How many times is the keyword 'call' used.
c===========================================================
c Implements matrix-matrix multiply
c
c c = a b
c
c where a, b and c are n x n (square) real*8 matrices.
c===========================================================
subroutine dmmmult(a,b,c,n)
implicit none
integer n
real*8 a(n,n), b(n,n), c(n,n)
integer i, j, k
do j = 1 , n
do i = 1 , n
c(i,j) = 0.0d0
do k = 1 , n
c(i,j) = c(i,j) + a(i,k) * b(k,j)
end do
end do
end do
return
end
c===========================================================
c Writes a double precision matrix (two dimensional
c array) to file 'fname'. If 'fname' is the
c string '-', the matrix is written to standard input.
c This routine is modelled on 'dvto' previously
c discussed in class: see ~phy329/ex3/dvto.f
c===========================================================
subroutine dmto(fname,a,d1,d2)
c
implicit none
integer indlnb, getu
character*(*) fname
integer d1, d2
real*8 a(d1,d2)
integer ustdout
parameter ( ustdout = 6 )
integer uto, rc
c-----------------------------------------------------------
c Parse fname: either "attach" 'uto' to stdout or
c get a unit number using 'getu', and open the
c file 'fname' for formatted I/O via 'uto'
c-----------------------------------------------------------
if( fname .eq. '-' ) then
uto = ustdout
else
uto = getu()
open(uto,file=fname(1:indlnb(fname)),
& form='formatted',iostat=rc)
if( rc .ne. 0 ) then
write(0,*) 'dmto: Error opening ',
& fname(1:indlnb(fname))
return
end if
end if
c-----------------------------------------------------------
c Write dimensions, then array elements
c-----------------------------------------------------------
write(uto,*,iostat=rc) d1, d2
if( rc .ne. 0 ) then
write(0,*) 'dmto: Error writing dimensions'
go to 500
end if
write(uto,*,iostat=rc) a
if( rc .ne. 0 ) then
write(0,*) 'dmto: Error reading matrix'
end if
c-----------------------------------------------------------
c Exit: Close file and return
c-----------------------------------------------------------
500 continue
close(uto)
return
end
subroutine dmfrom(fname,a,d1,d2,asize)
c
implicit none
integer indlnb, getu
character*(*) fname
integer d1, d2, asize
real*8 a(d1,d2)
integer ustdin
parameter ( ustdin = 5 )
integer ufrom, rc, i, j
c-----------------------------------------------------------
c Parse fname: either "attach" 'ufrom' to stdin or
c get a unit number using 'getu', and open the
c file 'fname' for formatted I/O via 'ufrom'
c-----------------------------------------------------------
if( fname .eq. '-' ) then
ufrom = ustdin
else
ufrom = getu()
open(ufrom,file=fname(1:indlnb(fname)),
& form='formatted',iostat=rc,status='old')
if( rc .ne. 0 ) then
write(0,*) 'dmfrom: Error opening ',
& fname(1:indlnb(fname))
return
end if
end if
c-----------------------------------------------------------
c Read dimensions and abort if there is insufficient
c storage for the entire matrix. Note the 'go to'
c to the 'exit block' since we've opened a file now
c and should close it, even if there's an error.
c Also, we set the dimensions to 0 for all error
c conditions as a way of communicating failure to
c the calling routine.
c-----------------------------------------------------------
read(ufrom,*,iostat=rc) d1, d2
if( rc .ne. 0 ) then
write(0,*) 'dmfrom: Error reading dimensions'
d1 = 0
d2 = 0
go to 500
end if
if( (d1 * d2) .gt. asize ) then
write(0,*) 'dmfrom: Insufficient storage'
d1 = 0
d2 = 0
go to 500
end if
c-----------------------------------------------------------
c Now that dimensions have been determined call
c helper routine to read values
c-----------------------------------------------------------
call dmfrom1(ufrom,a,d1,d2,rc)
if( rc .ne. 0 ) then
write(0,*) 'dmfrom: Error reading matrix'
d1 = 0
d2 = 0
end if
c-----------------------------------------------------------
c Exit: Close file and return
c-----------------------------------------------------------
500 continue
close(ufrom)
return
end
c-----------------------------------------------------------
c Test program for subroutine 'dmfrom', 'dmto' and
c 'dmmmult' (see 'dmroutines.f')
c
c Program expects one argument, the name of a file which
c contains a real*8 square matrix written as descibed
c in the documentation for 'dmfrom' in 'dmroutines.f'
c Use '-' to read from stdin. Program then computes
c square of matrix and outputs result to stdout.
c-----------------------------------------------------------
program tdm
implicit none
integer iargc
character*256 fname
c-----------------------------------------------------------
c Maximum size for input and output arrays (matrices).
c-----------------------------------------------------------
integer maxsize
parameter ( maxsize = 100 000 )
real*8 a(maxsize), asq(maxsize)
integer d1a, d2a
if( iargc() .ne. 1 ) go to 900
call getarg(1,fname)
c-----------------------------------------------------------
c Read matrix ...
c-----------------------------------------------------------
call dmfrom(fname,a,d1a,d2a,maxsize)
if( d1a .gt. 0 .and. d2a .gt. 0 ) then
if( d1a .eq. d2a ) then
c-----------------------------------------------------------
c Compute square ...
c-----------------------------------------------------------
call dmmmult(a,a,asq,d1a,d1a)
c-----------------------------------------------------------
c ... and output.
c-----------------------------------------------------------
call dmto('-',asq,d1a,d1a)
else
write(0,*) 'tdm: Input array not square'
end if
else
write(0,*) 'tdm: dmfrom() failed'
end if
stop
900 continue
write(0,*) 'usage: tdm <file name>'
write(0,*)
write(0,*) ' Use ''tdm -'' to read ',
& 'from standard input'
stop
end