c c c c
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
      call input(t1,t2,t3,t4,t5,names,nst,nstmx)
c
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 
      inquire (file=fname,exist=fexist)
c 
      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 
      open (11,file='grades.in',status='old',err=600)
c 
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
      if(nst.gt.nstmx) then
         print *, 'Insufficient Space to Process this Class'
         print *, 'Set nstmax = ', nst,' in the PARAMETER statement'
         stop
         endif
c
      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 
      data grdbnds/95,90.,87.,84.,80.,73.,60.,50./
      data letgrd/'A ','A-','B+','B ','B-','C+','C ','D ','F '/
c 
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 
c c c