FORTRAN Version, Listing




* Start of file BBallF.FOR *********************************************
* ----------------------------------------------------------------------
* PROGRAM: BBallF - Baseball probability
* ----------------------------------------------------------------------
*	BBallF - Baseball probability (if each game is a 50-50 chance).
*	FORTRAN Version 2.03, last revised: 1993-09-27, 0600 hours
*	Copyright (c) 1981-1993 by author: Harry J. Smith,
*	19628 Via Monte Dr., Saratoga CA 95070.  All rights reserved.
* ----------------------------------------------------------------------
*
* Computes the probability that the 1st place team will beat the 2nd
* place team for the division title, assuming each has a 50-50 chance of
* winning any given future game. Uses a bivariate binomial distribution
* as a model.
*
* Developed in Turbo Pascal 5.0, converted to MS FORTRAN
*
* ----------------------------------------------------------------------
$STORAGE:2
	INTERFACE TO SUBROUTINE ReadInt( Mess, Min, Max, Nom, I)
	CHARACTER*(*) Mess
	INTEGER*2 Min, Max, Nom, I
	END
* ----------------------------------------------------------------------
	INTERFACE TO SUBROUTINE ReadReal( Mess, Min, Max, Nom, R)
	CHARACTER*(*) Mess
	DOUBLE PRECISION Min, Max, Nom, R
	END
* ----------------------------------------------------------------------
	CHARACTER Name*70, Version*70, Author*70, Address*70
	CHARACTER TN1*12, TN2*12
	INTEGER*2 GL1, GL2, GE, GA2, MNT1, MNW1, MNT2, MNW2, Debug
	DOUBLE PRECISION GA, P, Q
	INTEGER*1 Ch
	COMMON Name, Version, Author, Address
	COMMON /NUM/ TN1, TN2, GL1, GL2, GE, GA2, MNT1, MNW1, MNT2,
     #  MNW2, GA, P, Q, Ch, Debug
* ----------------------------------------------------------------------
* TN1  : Team's name, 1st place team
* TN2  : Team's name, 2nd place team
* GL1  : Games Left to play, 1st place team
* GL2  : Games Left to play, 2nd place team
* GE   : Games to play each other
* GA   : Games 1st place team is ahead. 0, 0.5, ...
* GA2  : Twice games ahead = 2 * GA, 0, 1, ...
* MNT1 : Magic Number to tie for 1st place team
* MNW1 : Magic Number to win for 1st place team
* MNT2 : Magic Number to tie for 2nd place team
* MNW2 : Magic Number to win for 2nd place team
* P    : Probability that 1st place team beats 2nd place team
* Q    : Probability that 2nd place team beats 1st place team
* Ch   : A keyboard input character
* Debug: .NE. 0 if debug turned on
* ----------------------------------------------------------------------
	Name    =
     #'BBallF - Baseball probability (if each game is a 50-50 chance).'
	Version =
     #'FORTRAN Version 2.03, last revised: 1993-09-27, 0600 hours'
	Author  = 
     #'Copyright (c) 1981-1993 by author: Harry J. Smith,'
	Address = 
     #'19628 Via Monte Dr., Saratoga CA 95070.  All rights reserved.'
* ----------------------------------------------------------------------
* Main program, BBallF
	Debug = 0
100	CALL Init()
	CALL GetCase()
	CALL ExpandCase()
	CALL ComputeProb()
	CALL Init()
	CALL DispCase()
	CALL DispProb()
	WRITE(*, 10) 'Press Enter to continue... (or Ctrl-C to exit)'
	READ(*, 10) Ch
	GOTO 100

10	FORMAT( 1X, A)
	END

* ----------------------------------------------------------------------
* SUBROUTINE: Init - Initialize the program BBallF
* ----------------------------------------------------------------------
	SUBROUTINE Init()
	CHARACTER Name*70, Version*70, Author*70, Address*70
	COMMON Name, Version, Author, Address
* ----------------------------------------------------------------------
	WRITE(*, 10)
	WRITE(*, 11) Name
	WRITE(*, 11) Version
	WRITE(*, 11) Author
	WRITE(*, 11) Address
	WRITE(*, 12)

* Ansi.Sys ESC seq. for YELLOW on BLUE, clrscr
10	FORMAT('  [1;33;44m [2J')
11	FORMAT( 1X, A)
12	FORMAT()
	END

* ----------------------------------------------------------------------
* SUBROUTINE: GetCase - Get data for a case to compute
* ----------------------------------------------------------------------
	SUBROUTINE GetCase()
	CHARACTER TN1*12, TN2*12
	INTEGER*2 GL1, GL2, GE, GA2, MNT1, MNW1, MNT2, MNW2, Debug
	DOUBLE PRECISION GA, P, Q
	INTEGER*1 Ch
	COMMON /NUM/ TN1, TN2, GL1, GL2, GE, GA2, MNT1, MNW1, MNT2,
     #  MNW2, GA, P, Q, Ch, Debug
	INTEGER*2 I
* ----------------------------------------------------------------------
* Giants, Braves 1993
* 1993-09-27, 1 / Q = 4.7175
	TN1 = '(Braves)'
	TN2 = '(Giants)'
	GL1 = 6
	GL2 = 7
	GE = 0
	GA = 1.5  
	CALL ReadInt(
     #'Games Left to play, 1st place team (-2 => Exit, -1 => Test case)'
     #, -2, 162, -1, I)
	IF (I .EQ. -2) STOP ' '
	IF (I .GE. 0) THEN
	  TN1 = '(        )'
	  TN2 = '(        )'
	  GL1 = I
	  CALL ReadInt('Games Left to play, 2nd place team',
     #      0, 162, GL1, GL2)
	  CALL ReadInt('Games to play each other', 0, 24, 0, GE)
100	  CONTINUE
	    CALL ReadReal('Games ahead, 0, 0.5, ...',
     #             0.0D0, 162.0D0, 0.0D0, GA)
	  IF (DINT( GA + GA) .NE. (GA + GA)) GOTO 100
	ENDIF
	END

* ----------------------------------------------------------------------
* SUBROUTINE: ExpandCase - Compute related data
* ----------------------------------------------------------------------
	SUBROUTINE ExpandCase()
	CHARACTER TN1*12, TN2*12
	INTEGER*2 GL1, GL2, GE, GA2, MNT1, MNW1, MNT2, MNW2, Debug
	DOUBLE PRECISION GA, P, Q
	INTEGER*1 Ch
	COMMON /NUM/ TN1, TN2, GL1, GL2, GE, GA2, MNT1, MNW1, MNT2,
     #  MNW2, GA, P, Q, Ch, Debug
	INTEGER*2 I
* ----------------------------------------------------------------------
	GA2 = IDNINT(2 * GA)
	I = GL1 + GL2 - GA2
	IF (MOD(I, 2) .EQ. 1) THEN
	  WRITE(*, 10)
	  WRITE(*, 20)
	  READ(*, 30) Ch
	ENDIF
	MNT1 = I / 2
	MNW1 = MNT1 + 1
	MNT2 = GL1 + GL2 - MNT1 
	MNW2 = MNT2 + 1

10	FORMAT(' Error in data')
20	FORMAT(' Press Enter to continue...'\)
30	FORMAT( 1X, A)
	END

* ----------------------------------------------------------------------
* SUBROUTINE: DispCase - Display Case
* ----------------------------------------------------------------------
	SUBROUTINE DispCase()
	CHARACTER TN1*12, TN2*12
	INTEGER*2 GL1, GL2, GE, GA2, MNT1, MNW1, MNT2, MNW2, Debug
	DOUBLE PRECISION GA, P, Q
	INTEGER*1 Ch
	COMMON /NUM/ TN1, TN2, GL1, GL2, GE, GA2, MNT1, MNW1, MNT2,
     #  MNW2, GA, P, Q, Ch, Debug
* ----------------------------------------------------------------------
	WRITE(*, 10) GL1, TN1
	WRITE(*, 20) GL2, TN2
	WRITE(*, 30) GE
	WRITE(*, 40) GA
	WRITE(*, 50) MNT1
	WRITE(*, 60) MNW1
	WRITE(*, 70) MNT2
	WRITE(*, 80) MNW2
	WRITE(*, 90)

10	FORMAT(' ', I8,
     #  ' = Games Left to play, 1st place team ', A)
20	FORMAT(' ', I8,
     #  ' = Games Left to play, 2nd place team ', A)
30	FORMAT(' ', I8,   ' = Games to play each other')
40	FORMAT(' ', F8.1,
     #  ' = Games 1st place team is ahead.  0, 0.5, ...')
50	FORMAT(' ', I8,   ' = Magic Number to tie for 1st place team')
60	FORMAT(' ', I8,   ' = Magic Number to win for 1st place team')
70	FORMAT(' ', I8,   ' = Magic Number to tie for 2nd place team')
80	FORMAT(' ', I8,   ' = Magic Number to win for 2nd place team')
90	FORMAT()
	END

* ----------------------------------------------------------------------
* SUBROUTINE: ComputeProb - Compute probability using a bivariate
*                           binomial distribution as a model
* ----------------------------------------------------------------------
	SUBROUTINE ComputeProb()
	CHARACTER TN1*12, TN2*12
	INTEGER*2 GL1, GL2, GE, GA2, MNT1, MNW1, MNT2, MNW2, Debug
	DOUBLE PRECISION GA, P, Q
	INTEGER*1 Ch
	COMMON /NUM/ TN1, TN2, GL1, GL2, GE, GA2, MNT1, MNW1, MNT2,
     #  MNW2, GA, P, Q, Ch, Debug
	INTEGER*2 I, J
	DOUBLE PRECISION A, B
	DOUBLE PRECISION E (0:24), S (0:24), F (0:162), G (0:162)
* E: Binomial coefficients, games to play each other
* S: Running sum of 2 * E(I)
* F: Binomial coefficients, games not played with each other
* G: Sum of 2 * E(I) for 2nd place team win, E(I) for tie
* A: Games not played with each other
* ----------------------------------------------------------------------
	A = GL1 + GL2 - GE - GE
	B = 1.0
	F(0) = 1.0
* Compute binomial coefficients
	DO 100 I = 1, MNT1
	  F(I) = F(I - 1) * A / B
	  A = A - 1.0
	  B = B + 1.0
100	CONTINUE
	A = GE
	B = 1.0
	E(0) = 1.0
	S(0) = 2.0
* Compute binomial coefficients
	DO 110 I = 1, GE
	  E(I) = E(I - 1) * A / B
	  A = A - 1.0
	  B = B + 1.0
	  S(I) = S(I - 1) + 2 * E(I)
110	CONTINUE
* Compute G(I)
	DO 120 I = 0, MNT1
	  J = (MNT1 - I) / 2
	  IF (J .LE. GE) THEN
	    G(I) = S(J)
* Adjust for tie
	    IF ((J + J) .EQ. (MNT1 - I)) THEN
	      G(I) = G(I) - E(J)
	    ENDIF
	  ELSE
	    G(I) = S(GE)
	  ENDIF
120	CONTINUE
	IF (Debug .NE. 0) THEN
	  CALL DispCase()
	  DO 122 I = 0, MNT1
	    WRITE(*, 20) I, F(I)
122	  CONTINUE
	  WRITE(*, 11)
	  WRITE(*, 10) 'Press Enter to continue...'
	  READ(*, 10) Ch
	  WRITE(*, 11)
	  DO 124 I = 0, GE
	    WRITE(*, 30) I, E(I)
124	  CONTINUE
	  WRITE(*, 11)
	  WRITE(*, 10) 'Press Enter to continue...'
	  READ(*, 10) Ch
	  WRITE(*, 11)
	  DO 126 I = 0, GE
	    WRITE(*, 40) I, S(I)
126	  CONTINUE
	  WRITE(*, 11)
	  WRITE(*, 10) 'Press Enter to continue...'
	  READ(*, 10) Ch
	  WRITE(*, 11)
	  DO 128 I = 0, MNT1
	    WRITE(*, 50) I, G(I)
128	  CONTINUE
	  WRITE(*, 11)
	  WRITE(*, 10) 'Press Enter to continue...'
	  READ(*, 10) Ch
	  WRITE(*, 11)

10	  FORMAT( 1X, A\)
11	  FORMAT()
20	  FORMAT(' F(', I3, ') = ', G22.17)
30	  FORMAT(' E(', I3, ') = ', G22.17)
40	  FORMAT(' S(', I3, ') = ', G22.17)
50	  FORMAT(' G(', I3, ') = ', G22.17)
* End of Debug
	ENDIF
	Q = 0.0
* Compute probability that 2nd place team beats 1st place team
	DO 130 I = 0, MNT1
	  Q = Q +F(I) * G(I)
130	CONTINUE
	A = GL1 + GL2 - GE + 1
*                              2 ** Flips
	B = 2.0 ** A
	Q = Q / B
	P = 1.0 - Q
	END

* ----------------------------------------------------------------------
* SUBROUTINE: DispProb - Display probability
* ----------------------------------------------------------------------
	SUBROUTINE DispProb()
	CHARACTER TN1*12, TN2*12
	INTEGER*2 GL1, GL2, GE, GA2, MNT1, MNW1, MNT2, MNW2, Debug
	DOUBLE PRECISION GA, P, Q
	INTEGER*1 Ch
	COMMON /NUM/ TN1, TN2, GL1, GL2, GE, GA2, MNT1, MNW1, MNT2,
     #  MNW2, GA, P, Q, Ch, Debug
* ----------------------------------------------------------------------
	WRITE(*, 10) P
	WRITE(*, 20) Q
	IF (Q .GT. 0.0)
     #    WRITE(*, 30) 1.0 / Q,  P / Q
	WRITE(*, 40)

10	FORMAT(' ', F10.4, 
     #  ' = P = Probability that 1st place team beats 2nd place team')
20	FORMAT(' ', F10.4,
     #  ' = Q = Probability that 2nd place team beats 1st place team')
30	FORMAT
     #  (' ', F10.4, ' = 1 / Q, (Odds = ', F10.4, ' : 1)')
40	FORMAT()
	END

* ----------------------------------------------------------------------
* SUBROUTINE: ReadInt - Read in an integer from keyboard
* AUTHOR: HARRY J. SMITH, SARATOGA, CA
* ----------------------------------------------------------------------
*
* ----------------------------------------------------------------------
* This is the FORTRAN subroutine ReadInt to read an integer from the
* keyboard
* ----------------------------------------------------------------------
	SUBROUTINE ReadInt( Mess, Min, Max, Nom, I)
	CHARACTER*(*) Mess
	INTEGER*2 Min, Max, Nom, I
	CHARACTER*255 St
	INTEGER*4 LI
* ----------------------------------------------------------------------
100	WRITE(*, 10) Mess
	WRITE(*, 20) Min, Max, Nom
	READ(*, 30) St
	IF ((St .NE. ' ') .AND. (St(1:1) .NE. '-') .AND.
     #    (LGT( St(1:1), '9') .OR.  LLT( St(1:1), '0')))  GOTO 100
	READ( St, 40)  LI
	IF (((LI .LT. Min) .OR. (LI .GT. Max)) .AND. (St .NE. ' '))
     #  GOTO 100
	IF (St .EQ. ' ')  LI = Nom
	I = LI
	WRITE(*, 50) I
	WRITE(*, 11)

10	FORMAT( 1X, A)
11	FORMAT()
20	FORMAT('   [', I3, ', ', I3, '] (ENTER => ', I3, '): '\)
30	FORMAT( A129)
40	FORMAT( I10)
50	FORMAT(' Input = ', I3)
	END

* ----------------------------------------------------------------------
* SUBROUTINE: ReadReal - Read in a Real from keyboard
* AUTHOR: HARRY J. SMITH, SARATOGA, CA
* ----------------------------------------------------------------------
*
* ----------------------------------------------------------------------
* This is the FORTRAN subroutine ReadReal to read a real number from the
* keyboard
* ----------------------------------------------------------------------
	SUBROUTINE ReadReal( Mess, Min, Max, Nom, R)
	CHARACTER*(*) Mess
	DOUBLE PRECISION Min, Max, Nom, R
	CHARACTER*255 St
* ----------------------------------------------------------------------
100	WRITE(*, 10) Mess
	WRITE(*, 20) Min, Max, Nom
	READ(*, 30) St
	IF ((St .NE. ' ') .AND. (St(1:1) .NE. '-') .AND.
     #    (LGT( St(1:1), '9') .OR.  LLT( St(1:1), '0')))  GOTO 100
	READ( St, 40)  R
	IF (((R .LT. Min) .OR. (LI .GT. Max)) .AND. (St .NE. ' '))
     #  GOTO 100
	IF (St .EQ. ' ')  R = Nom
	WRITE(*, 50) R
	WRITE(*, 11)

10	FORMAT( 1X, A)
11	FORMAT()
20	FORMAT('   [', F5.1, ', ', F5.1, '] (ENTER => ', F5.1, '): '\)
30	FORMAT( A129)
40	FORMAT( F10.0)
50	FORMAT(' Input = ', F5.1)
	END

* End of file BBallF.FOR ***********************************************

Return to Baseball Pennant Race Odds
Return to Harry's Home Page


This page accessed times since October 20, 2004.
Page created by: hjsmithh@sbcglobal.net
Changes last made on Saturday, 14-May-05 12:42:45 PDT

1