c <html>
c <head><title></title></head>
c <body>
c <pre>
c
program grades
c
c Program to provide information about a Class Grade distribution
c
c This program starts to look like a serious structured program
c The main program only acts as a broad outline calling various key
c tasks in subprograms. Specific classes of tasks are isolated in
c their own subprograms.
c
implicit none
integer nstmx, nst
parameter (nstmx=30)
real final(nstmx)
real t1(nstmx),t2(nstmx),t3(nstmx),t4(nstmx),t5(nstmx)
character*16 names(nstmx)
character*2 grds(nstmx)
real temp(nstmx)
integer ind(nstmx) , i
c nstmx - maximum class size
c nst - number of students found
c t1 - array of grades for test1
c t2 - array of grades for test2
c t3 - array of grades for test3
c t4 - array of grades for test4
c t5 - array of grades for test5
c names - array containing names of students
c final - final score obtained from a weighted average of tests
c grds - letter grades assigned to each student
c temp - temporary score array used for determining ranking
c ind - array containing index references to students listed from
c highest to lowest class score.
c
c Initialize ind
c
do 10 i=1,nstmx
10 ind(i)=i
c
c Open an output file to record all information
c
open (12,file='grades.out')
c
c Read in test data
c<a name="call"><font color="FF0000">
call input(t1,t2,t3,t4,t5,names,nst,nstmx)
c</font></a>
c
c Calculate the Final avrag score for all students
c
call mean (t1,t2,t3,t4,t5,nst,final)
c
c Generate output of processed information
c
call output(t1,t2,t3,t4,t5,final,nst,names,grds,temp,ind)
c
stop
end
c
c
subroutine input(t1,t2,t3,t4,t5,names,nst,nstmx)
c
c Reads grades from 5 tests and associated student name
c
implicit none
c
c Use of the * in the array dimensioning says that the actual dimension
c is the problem of the calling routine
c
real t1(*),t2(*),t3(*),t4(*),t5(*)
character*(*) names(*)
character*32 fname
character*8 answer
integer nst,nstmx, i
logical fexist
c
c Arguments
c
c Input -
c nstmax - maximum number of students that can be processed
c
c Output -
c nst - number of students found
c t1 - array of grades for test1
c t2 - array of grades for test2
c t3 - array of grades for test3
c t4 - array of grades for test4
c t5 - array of grades for test5
c names - array containing names of students
c
c Begin executable code by opening the I/O units
c
5 write(*,1000)
1000 format ( 'Provide name of file with student information:')
read *, fname
c <a name="inquire"><font color="FF0000">
inquire (file=fname,exist=fexist)
c </font></a>
if (.not.fexist) then
print *, fname,' does not exist'
print *, 'Do you want to quit (yes or no)?'
read *, answer
if (answer(1:1).eq.'y'.or.answer(1:1).eq.'Y') stop
go to 5
endif
c <a name="open"><font color="FF0000">
open (11,file='grades.in',status='old',err=600)
c </font></a>
c c
i=1
20 read (11,*,end=40) t1(i),t2(i),t3(i),t4(i),t5(i),names(i)
i=i+1
go to 20
40 nst=i-1
c<a name="12"><font color="FF0000">
if(nst.gt.nstmx) then
print *, 'Insufficient Space to Process this Class'
print *, 'Set nstmax = ', nst,' in the PARAMETER statement'
stop
endif
c</a></font>
return
c
600 print *,'Problem opening file: ', fname
stop
end
c
c
subroutine mean (t1,t2,t3,t4,t5,nst,final)
implicit none
c
c average the results of 5 tests to produce final scores
c
real t1(*),t2(*),t3(*),t4(*),t5(*), final(*)
real w(5),wa(5),wsum
c
integer nst,i
c
c Set relative weighting factors for exams
c
data w/ 5*1./
c
c Arguments
c
c Input -
c nst - number of students
c nst - number of students found
c t1 - array of grades for test1
c t2 - array of grades for test2
c t3 - array of grades for test3
c t4 - array of grades for test4
c t5 - array of grades for test5
c
c Output -
c final - array containing final averaged score
c
c Other variables:
c w - relative weights of tests
c wsum - sum of relative weights
c wa - absolute weights of tests
c
c Calculate absolute weight factors
c
wsum=0.
do 10 i=1,5
10 wsum = wsum+ w(i)
c
c The next line saves computer time in the following do loop
c
wsum=1./wsum
do 20 i=1,5
20 wa(i)=w(i)*wsum
do 30 i=1,nst
30 final(i)=wa(1)*t1(i)+wa(2)*t2(i)+wa(3)*t3(i)+wa(4)*t4(i)
& +wa(5)*t5(i)
return
end
c
c
subroutine output(t1,t2,t3,t4,t5,final,nst,names,grds,temp,ind)
c
c Output Scoring information
c
implicit none
integer nst
real final(*)
real t1(*),t2(*),t3(*),t4(*),t5(*)
real scmin,scmax,avrag,stdev
character*16 names(*)
character*2 grds(*)
integer igtot(10)
real temp(*)
integer ind(*) , i, j
c
c nst - number of students found
c t1 - array of grades for test1
c t2 - array of grades for test2
c t3 - array of grades for test3
c t4 - array of grades for test4
c t5 - array of grades for test5
c names - array containing names of students
c final - final score obtained from a weighted average of tests
c
c The following three arrays are passed in the argument list simply
c to permit a single point for assigning space in the main program
c we will learn other ways of providing this flexibility later.
c
c grds - letter grades assigned to each student
c temp - temporary score array used for determining ranking
c ind - array containing index references to students listed from
c highest to lowest class score. ind(1) points to the scores
c and name for the one with the highest final score, etc.
c
c Initialize ind
c
do 10 i=1,nst
10 ind(i)=i
c
c Generate statistics on all tests and the final exam
c
write(6,*) 'Test 1'
write(12,*) 'Test 1'
call stats (t1,nst,scmax,scmin,avrag,stdev)
write(6,*) 'Test 2'
write(12,*) 'Test 2'
call stats (t2,nst,scmax,scmin,avrag,stdev)
write(6,*) 'Test 3'
write(12,*) 'Test 3'
call stats (t3,nst,scmax,scmin,avrag,stdev)
write(6,*) 'Test 4'
write(12,*) 'Test 4'
call stats (t4,nst,scmax,scmin,avrag,stdev)
write(6,*) 'Test 5'
write(12,*) 'Test 5'
call stats (t5,nst,scmax,scmin,avrag,stdev)
write(6,*) 'Final Scores'
write(12,*) 'Final Scores'
call stats (final,nst,scmax,scmin,avrag,stdev)
c
c In the above calls note that I never use the values returned for the
c last four arguments. The subroutine was taken from another application
c and I have chosed to leave the calling sequence unaltered to preserve
c future flexibility within this program. If blinding speed were a question
c I would have cleaned this up.
c
c
c Assign and tally grades
c
call grade (final,avrag,nst,igtot,grds)
c
c Establish the final grade ranking
c
do 30 i=1,nst
30 temp(i)=final(i)
call ssort(temp,ind,nst,-2)
write(12,2221)
do 40 i=1,nst
j=ind(i)
write(12,2222) names(j),final(j),grds(j)
40 continue
2221 format(//,'Class Grades',/)
2222 format(1x,a,3x,f5.1,5x,a)
return
end
c
c
subroutine stats (scores,nst,scmax,scmin,avrag,stdev)
c
c Compute Mean, Standard, minimum, and maximum for a set of scores
c
c
implicit none
real scores(*),scmax, scmin,avrag,stdev,sqm
integer nst,i, nused
c
c Arguments
c Input -
c scores - array containing scores for all students
c nst - number of students
c Output -
c scmax - Maximum of all scores
c scmin - minimum of all scores
c avrag - avrag of all scores
c stdev - standard deviation of scores
c
c You can't initialize items in the argument list with a data statement
c
avrag=0.
sqm=0.
scmax=-1.e38
scmin=1.e38
nused=0
c
do 50 i=1,nst
nused=nused+1
scmax=max(scores(i),scmax)
scmin=min(scores(i),scmin)
sqm=sqm+scores(i)**2
avrag=avrag+scores(i)
50 continue
avrag=avrag/nused
stdev=sqrt((sqm-nused*avrag**2)/(nused-1))
write(6,2002) avrag,stdev,scmin,scmax
write(12,2002) avrag,stdev,scmin,scmax
2002 format(5x,'Mean Score=',F5.1,', Standard Deviation =',F5.1,/,
& 2x, 'Minimum Score =',F5.1,', Maximum Score =',F5.1)
return
end
c
c
subroutine grade (x,xm,ntot,itgrds,grds)
implicit none
integer ngrds,ngrdp
c
c Assign a grade to match a score and tally total number of each grade
c
parameter (ngrds=8, ngrdp=ngrds+1)
real x(*),xm
character*2 grds(*)
character letgrd(ngrdp)*2
integer itgrds(*),ntot,i,j
real grdbnds(ngrds)
c <a href="data"><font color="FF0000">
data grdbnds/95,90.,87.,84.,80.,73.,60.,50./
data letgrd/'A ','A-','B+','B ','B-','C+','C ','D ','F '/
c </font></a>
c
c Arguments
c
c Input
c x - array containing scores
c xm - mean value of contents of x
c ntot - total number of scores in x
c
c Output
c itgrds - total number of students receiving each grade
c grds - letter grade corresponding to each element in x
c
c Note: The loops below are brute force. Faster methods exist for
c covering large class sizes. Try rewriting taking advantage of
c presorted x
c
do 60 i=1,ngrdp
60 itgrds(i)=0
do 100 i=1,ntot
do 70 j=1,ngrds
if(x(i).ge.grdbnds(j)) go to 80
70 continue
itgrds(ngrdp)=itgrds(ngrdp)+1
grds(i)=letgrd(ngrdp)
go to 100
80 itgrds(j)=itgrds(j)+1
grds(i)=letgrd(j)
100 continue
c
c Output the distribution of grades
c
call distrb(x,xm,ntot,itgrds,ngrds,grdbnds)
return
end
c
c
subroutine distrb(x,xm,ntot,igtot,ngrds,xlbgrds)
implicit none
c
c Give an ascii plot of grade distributions. Note that there are some
c hidden assumptions in here about maximum number of students with a
c given score.
c
c The following is a doubly dimensioned array more about these
c when we get to linear equations
c
character *1 scr(80,20)
character*80 baseline
real x,xm,xlbgrds
integer i,ii, iscr1, itot,igtot,im,j,ntot, ngrds
dimension x(*),itot(0:100),igtot(*),xlbgrds(*)
c
c Arguments
c
c Input
c x - array containing scores
c xm - mean value of contents of x
c ntot - total number of scores in x
c igtot - total number of each grade
c ngrds - total number of possible grades
c xlbgrds - lowest score permitted for each grade catigory above F
c
c
do 5 i=0,100
5 itot(i)=0
c
c Tally scores
c
do 10 i=1,ntot
ii=int(x(i))
10 itot(ii)=itot(ii)+1
c
c Put count for all less than 21 in itot(21)
c
do 12 i=1,20
12 itot(21)=itot(21)+itot(i)
c
c Load screen display array
c
iscr1=20
do 40 i=1,20
do 40 j=1,80
if(itot(j+20).lt.i) then
scr(j,21-i)=' '
else
iscr1=min0(iscr1,21-i)
scr(j,21-i)='*'
endif
40 continue
iscr1=iscr1-1
c
c Write bar chart
c
write (6,'(80a1)') ((scr(i,j),i=1,80),j=iscr1,20)
write (12,'(80a1)') ((scr(i,j),i=1,80),j=iscr1,20)
c
c The following 3 writes are poor programming practice. I should have
c passed the array letgrd in and automatically generated "baseline" and
c the associated grade labels using character string manipulations an the
c information in letgrd and xlbgrds. To get a feeling for the power of
c character variable manipulations you should rewrite these in a general
c form so that the grading system can be changed without requiring a
c rewrite of the output generation.
c
c Write baseline
c
baseline=
& '---------+---------+---------|---------|---------+--|----'
& //'--|---|--|--|----|----+'
im=nint(xm)-20
baseline(im:im)='^'
write(6,'(a)') baseline
write(12,'(a)') baseline
c
c Write Label Line: This is a poor programming example. I should have
c passed the array letgrd in and automatically generated a format based
c on letgrd and xlbgrds. If you are feeling ambitious, try a general
c form for this write.
c
write(6,2001)
write(12,2001)
2001 format(' F D C C+'
& , ' B- B B+ A- A ')
c
c Write Grade Totals
c
write(6,2003) (igtot(i),i=(ngrds+1),1,-1)
write(12,2003) (igtot(i),i=(ngrds+1),1,-1)
2003 format(' ',i2,' ',i2,' '
& ,i2,' ',i2,' ',i2,' ',i2,' ',i2,' ',i2,' ',i2)
c write(6,2002) xm
c write(12,2002) xm
2002 format(2x,'Mean =',F5.1)
return
end
SUBROUTINE SSORT (X, Y, N, KFLAG)
C***BEGIN PROLOGUE SSORT
C***PURPOSE Sort an array and make the same interchanges in
C an auxiliary array. The array is sorted in
C decreasing order.
C What algorithm is used?
C***TYPE SINGLE PRECISION
C***KEYWORDS SORT, SORTING
C
C Description of Parameters
C X - array of values to be sorted (usually abscissas)
C Y - array to be carried with X (all swaps of X elements are
C matched in Y
C N - number of values in array X to be sorted
C KFLAG - Not used in this implementation
C
C***REVISION HISTORY (YYMMDD)
C 950310 DATE WRITTEN
C John Mahaffy
C***END PROLOGUE SSORT
C .. Scalar Arguments ..
INTEGER KFLAG, N, Y(*)
C .. Array Arguments ..
REAL X(*)
C .. Local Scalars ..
REAL TEMP
INTEGER I, J, JMIN, JMAX, JSWAP, ITEMP
C .. External Subroutines ..
C None
C .. Intrinsic Functions ..
C None
C***FIRST EXECUTABLE STATEMENT SSORT
C
JMAX=N
DO 200 I=1,N-1
JSWAP=I
JMIN=I+1
DO 100 J=JMIN,JMAX
IF(X(J).GT.X(JSWAP)) JSWAP=J
100 CONTINUE
IF(JSWAP.NE.I) THEN
TEMP=X(I)
X(I)=X(JSWAP)
X(JSWAP)=TEMP
ITEMP=Y(I)
Y(I)=Y(JSWAP)
Y(JSWAP)=ITEMP
ENDIF
200 CONTINUE
RETURN
END
c </pre>
c </body>
c </html>
c
Copyright ©2017 - STI - Todos os direitos reservados