C ====================================================================== C ====================================================================== C ====================================================================== C C Name C C Proportional-Representation C C Description and Purpose C C Implement Proportional Representation System as detailed in C reference. C C ----------------------------------------------------------------------- C C GPL 3 Licensed. C C (c) Copyright W. Stewart, 7 March 1990. C C This program is free software: you can redistribute it and/or modify C it under the terms of the GNU General Public License as published by C the Free Software Foundation, either version 3 of the License, or C (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You can find a copy of the full license at C www.gnu.org/licenses/gpl.txt. C C ----------------------------------------------------------------------- C C Usage C C Submit program with data (left-justified), according to the C format ( A12, 1X, A20, 1X, I5 ), terminated by 'ENDOFDATA.' C For example: C C Riding Newfoundland East C JONES Left-Wing 15493 C : : : C Riding Newfoundland West C HARRIS Left-Wing 14036 C : : : C ENDOFDATA C C Structure C C 1. Proportional-Representation - Main program C C 2. INITIA - Initialization. C C 2. LSTRID - Print last riding and determine winner. C C 2. ADDCND - Add a new candidate to the data-base. C C 2. PRPREP - Implement Proportional Representation. C C 3. CALCPA - Calculate additional member requirement. C C 3. PRTABL - Print table of statistics. C C 3. QCKSRT - Quicksort for floating point matrix. C C 2. TERMIN - Termination. C C Reference C C Stewart, Wm. M. (1990) Submission to the Royal Commission of C Electoral Reform and Party Financing, Section 3. C C Author and Address C C Wm. Mott Stewart C Fredericton, New Brunswick C C Date C C 7 March 1990 C C -------------------------------------------------------------------- C C Variable Dictionary C C C - Ballot count for each candidate. C C N - Candidate names. C C P - Party affiliation for each candidate. C C R - Riding names. C C RC - Count of ridings. C C T - Total votes in each riding. C C CC - Count of candidates in riding. C C FA - Field A, either 'Riding', Candidate name, or C 'ENDOFDATA' C C FB - Field B, either Riding name or party name. C C FC - Field C, either empty or ballot count. C C GT - Total number of votes cast. C C PA - Additional members required for each party. C C PC - Count of different parties. C C PE - Members elected for each party. C C PV - Votes received for each party. C C PPV - Proportional vote received for each party. C C PP - Names for each party. C C GT - Total number of votes cast. C C ----------------------------------------------------------- IMPLICIT CHARACTER(A-Z) INTEGER C ( 300, 10 ), T ( 300 ), PE ( 10 ), PV ( 10 ), & GT, RC, CC, PC, FC, LNCNTR, PGCNTR CHARACTER*12 N ( 300, 10 ), FA CHARACTER*20 P ( 300, 10 ), R ( 300 ), PP ( 10 ), FB CALL INITIA ( RC, GT, PC, PP, PGCNTR, LNCNTR ) READ 100, FA, FB, FC 100 FORMAT ( A12, 1X, A20, 1X, I5 ) C WHILE ( FA .NE. 'ENDOFDATA' ) DO 1015 IF ( .NOT. ( FA .NE. 'ENDOFDATA' ) ) GOTO 1010 IF ( FA .EQ. 'Riding' ) THEN IF ( RC .NE. 0 ) THEN CALL LSTRID & ( C, N, P, R, T, RC, CC, PP, PV, PE,PC,GT,PGCNTR,LNCNTR) ENDIF RC = RC + 1 R ( RC ) = FB T ( RC ) = 0 CC = 0 ELSE CALL ADDCND & ( C, N, P, T, RC, CC, FA, FB, FC, PE, PP, PV, PC, GT ) ENDIF READ 100, FA, FB, FC GOTO 1015 1010 CONTINUE C ENDWHILE CALL LSTRID &( C, N, P, R, T, RC, CC, PP, PV, PE, PC, GT, PGCNTR, LNCNTR ) CALL PRPREP &( C, N, P, R, T, PE, PP, PV, PC, GT, RC, PGCNTR, LNCNTR) CALL TERMIN RETURN END C ====================================================================== C ====================================================================== C ====================================================================== C C W. Mott Stewart 15 May 1987 C C 1. NAME - LSTRID C C 2. DESCRIPTION – Print last riding and determine winner. C C ---------------------------------------------------------------------- SUBROUTINE LSTRID &( C, N, P, R, T, RC, CC, PP, PV, PE, PC, GT, PGCNTR, LNCNTR ) IMPLICIT CHARACTER(A-Z) INTEGER C ( 300, 10 ), T ( 300 ), PE ( 10 ), PV ( 10 ), & GT, RC, CC, PC, J, W, TEMPI, PGCNTR, LNCNTR REAL FLOAT CHARACTER*12 N ( 300, 10 ), TEMPN CHARACTER*20 P ( 300, 10 ), R ( 300 ), PP ( 10 ), TEMPP CALL PRPAGE ( PGCNTR, LNCNTR ) WRITE (6,*) ' ' WRITE (6,110) RC, R ( RC ) 110 FORMAT ( '0', I3, '.', 3X, 'Riding of ', A20 ) WRITE (6,*) &'-------------------------------------------------------------' WRITE (6,*) ' ' LNCNTR = LNCNTR + 5 W = 1 DO 10 J = 2, CC IF ( FLOAT(C(RC,J)) / FLOAT(T(RC)) .GT. & FLOAT(C(RC,W)) / FLOAT(T(RC)) ) THEN W = J ENDIF 10 CONTINUE DO 30 J = 1, CC IF ( J .EQ. W ) THEN WRITE (6,120) N ( RC, J ), P ( RC, J ), C ( RC, J ), & 100.0 * ( FLOAT(C(RC,J)) / FLOAT(T(RC)) ) 120 FORMAT ( ' ', A12, 1X, A10, 5X, I5, 4X, F5.1, '%', 3X, & '*** Elected ***' ) ELSE WRITE (6,130) N ( RC, J ), P ( RC, J ), C ( RC, J ), & 100.0 * ( FLOAT(C(RC,J)) / FLOAT(T(RC)) ) 130 FORMAT ( ' ', A12, 1X, A10, 5X, I5, 4X, F5.1, '%' ) ENDIF LNCNTR = LNCNTR + 1 30 CONTINUE J = 1 C WHILE ( PP(J) .NE. P(RC,W) ) DO 1025 IF ( .NOT. ( PP(J) .NE. P(RC,W) ) ) GOTO 1020 J = J + 1 GOTO 1025 1020 CONTINUE C ENDWHILE PE ( J ) = PE ( J ) + 1 TEMPI = C ( RC, W ) C ( RC, W ) = C ( RC, 1 ) C ( RC, 1 ) = TEMPI TEMPN = N ( RC, W ) N ( RC, W ) = N ( RC, 1 ) N ( RC, 1 ) = TEMPN TEMPP = P ( RC, W ) P ( RC, W ) = P ( RC, 1 ) P ( RC, 1 ) = TEMPP C ( RC, CC+1 ) = -1 RETURN END C ====================================================================== C ====================================================================== C ====================================================================== C C W. Mott Stewart 15 May 1987 C C 1. NAME - ADDCND C C 2. DESCRIPTION – Add a new candidate to the data-base. C C ---------------------------------------------------------------------- SUBROUTINE ADDCND & ( C, N, P, T, RC, CC, FA, FB, FC, PE, PP, PV, PC, GT ) IMPLICIT CHARACTER(A-Z) INTEGER C ( 300, 10 ), T ( 300 ), PE ( 10 ), PV ( 10 ), & GT, RC, CC, PC, FC, J CHARACTER*12 N ( 300, 10 ), FA CHARACTER*20 P ( 300, 10 ), PP ( 10 ), FB CC = CC + 1 N ( RC, CC ) = FA P ( RC, CC ) = FB C ( RC, CC ) = FC T ( RC ) = T ( RC ) + FC GT = GT + C ( RC, CC ) J = 1 C WHILE ( PP(J) .NE. P(RC,CC) .AND. J .LE. PC ) 1025 IF ( .NOT. ( PP(J) .NE. P(RC,CC) .AND. J .LE. PC ) ) GOTO 1020 J = J + 1 GOTO 1025 1020 CONTINUE C ENDWHILE IF ( PP ( J ) .NE. P ( RC, CC ) ) THEN PP ( J ) = P ( RC, CC ) PV ( J ) = 0 PE ( J ) = 0 PP ( J + 1 ) = ' ' PC = PC + 1 ENDIF PV ( J ) = PV ( J ) + C ( RC, CC ) RETURN END C ====================================================================== C ====================================================================== C ====================================================================== C C W. Mott Stewart 15 May 1987 C C 1. NAME - PRPREP C C 2. DESCRIPTION – Main procedure that implements the proportional C representation system. C C ---------------------------------------------------------------------- SUBROUTINE PRPREP & ( C, N, P, R, T, PE, PP, PV, PC, GT, RC, PGCNTR, LNCNTR ) IMPLICIT CHARACTER(A-Z) INTEGER C ( 300, 10 ), T ( 300 ), PE ( 10 ), PV ( 10 ), & GT, RC, PC, AD, J, K, L, W, TEMPI, & S, E, PGCNTR, LNCNTR, PA ( 10 ), X, INT REAL PPV ( 10 ), M ( 300, 3 ), FLOAT CHARACTER*12 N ( 300, 10 ) CHARACTER*20 P ( 300, 10 ), R ( 300 ), PP ( 10 ) LNCNTR = 999 CALL PRPAGE ( PGCNTR, LNCNTR ) WRITE (6,*) ' Phase 2' WRITE (6,*) ' =======' WRITE (6,*) ' ' WRITE (6,125) 125 FORMAT ( ' ', ' Statistics before Proportional Representation.') WRITE (6,*) ' ' WRITE (6,*) ' ' LNCNTR = LNCNTR + 6 DO 10 J = 1, PC PPV ( J ) = FLOAT ( PV ( J ) ) / FLOAT ( GT ) 10 CONTINUE W = 1 DO 20 J = 2, PC IF ( FLOAT ( PE ( J ) ) / PPV ( J ) .GT. & FLOAT ( PE ( W ) ) / PPV ( W ) ) THEN W = J ENDIF 20 CONTINUE X = INT ( FLOAT ( PE(W) ) / PPV ( W ) ) CALL CALCPA ( PA, PE, PPV, PC, X ) CALL PRTABL ( PA, PE, PP, PPV, PV, PC, GT, RC, PGCNTR,LNCNTR ) WRITE (6,*) ' ' WRITE (6,*) ' ' WRITE (6,*) ' ' WRITE (6,*) ' Phase 3' WRITE (6,*) ' =======' WRITE (6,*) ' ' WRITE (6,*) ' Add additional members from the under-represented' WRITE (6,*) 'parties as necessary, starting with the most closely' WRITE (6,*) 'contested ridings, until the complexion of the House' WRITE (6,*) 'reflects the popular vote.' LNCNTR = LNCNTR + 10 DO 40 J = 1, PC IF ( PA ( J ) .NE. 0 ) THEN WRITE (6,*) ' ' WRITE (6,*) ' ' WRITE (6,130) PA ( J ), PP ( J ) 130 FORMAT (' ', ' Add ', I3,' members from the ', A12,' party.') WRITE (6,*) ' ' WRITE (6,133) 133 FORMAT & (' ', ' Originally') WRITE (6,131) 131 FORMAT & (' ', 'Riding Candidate Lost by ') WRITE (6,132) 132 FORMAT & (' ', '-------------------------------------------------') WRITE (6,*) ' ' LNCNTR = LNCNTR + 8 AD = 0 DO 50 K = 1, RC L = 2 C WHILE ( C ( K, L ) .NE. -1 ) 1035 IF ( .NOT. ( C ( K, L ) .NE. -1 ) ) GOTO 1030 IF ( P ( K, L ) .EQ. PP ( J ) ) THEN AD = AD + 1 M ( AD, 1 ) = (FLOAT ( C(K,1) ) / FLOAT ( T(K) ))- & (FLOAT ( C(K,L) ) / FLOAT ( T(K) )) M ( AD, 2 ) = K M ( AD, 3 ) = L ENDIF L = L + 1 GOTO 1035 1030 CONTINUE C ENDWHILE 50 CONTINUE S = 1 E = AD CALL QCKSRT ( M, S, E ) IF ( PA ( J ) .GT. AD ) PA ( J ) = AD TEMPI = PA ( J ) DO 60 K = 1, TEMPI WRITE (6,140) R ( M(K,2) ), N ( M(K,2), M(K,3) ), & M ( K, 1 ) * 100.0 140 FORMAT ( ' ', A20, 5X, A12, 1X, F8.1, '%' ) LNCNTR = LNCNTR + 1 CALL PRPAGE ( PGCNTR, LNCNTR ) 60 CONTINUE WRITE (6,132) PE ( J ) = PE ( J ) + PA ( J ) ENDIF 40 CONTINUE WRITE (6,*) ' ' WRITE (6,*) ' ' WRITE (6,*) ' ' WRITE (6,*) ' Phase 4' WRITE (6,*) ' =======' WRITE (6,*) ' ' WRITE (6,165) 165 FORMAT ( ' ', ' Statistics after Proportional Representation.' ) WRITE (6,*) ' ' WRITE (6,*) ' ' LNCNTR = LNCNTR + 9 X = 0 DO 88 J = 1, PC X = X + PE ( J ) 88 CONTINUE CALL CALCPA ( PA, PE, PPV, PC, X ) CALL PRTABL ( PA, PE, PP, PPV, PV, PC, GT, X, PGCNTR, LNCNTR) RETURN END C ====================================================================== C ====================================================================== C ====================================================================== C C W. Mott Stewart 15 May 1987 C C 1. NAME - CALCPA C C 2. DESCRIPTION – Calculate the additional members required C for each party. C C ---------------------------------------------------------------------- SUBROUTINE CALCPA ( PA, PE, PPV, PC, X ) IMPLICIT CHARACTER(A-Z) INTEGER PE ( 10 ), PV ( 10 ), PA (10), PC, X, J REAL PPV ( 10 ), FLOAT DO 37 J = 1, PC PA ( J ) = INT ( PPV ( J ) * FLOAT(X) - FLOAT(PE(J)) ) 37 CONTINUE RETURN END C ====================================================================== C ====================================================================== C ====================================================================== C C W. Mott Stewart 15 May 1987 C C 1. NAME - PRTABL C C 2. DESCRIPTION – Print the final results in tabular form of this C proportional representation election. C C ---------------------------------------------------------------------- SUBROUTINE PRTABL & ( PA, PE, PP, PPV, PV, PC, GT, X, PGCNTR, LNCNTR) IMPLICIT CHARACTER(A-Z) INTEGER PE ( 10 ), PV ( 10 ), PA (10), GT, PC, J, X, & PGCNTR, LNCNTR REAL PPV ( 10 ), FLOAT CHARACTER*20 PP ( 10 ) WRITE (6,105) GT 105 FORMAT ( ' ', 'Total number of votes cast in all ridings = ', I8 ) WRITE (6,*) ' ' WRITE (6,110) 110 FORMAT (' ', '-----------------------------------', & '-------------------------------' ) WRITE (6,111) 111 FORMAT (' ', '| Name | | ', & '| | | Additnal |' ) WRITE (6,112) 112 FORMAT (' ', '| of | Number | Number ', & '| Propor.| Propor. | Members |' ) WRITE (6,113) 113 FORMAT (' ', '| Party | Elected | of Votes ', & '| Vote | Elected | Required |' ) WRITE (6,114) 114 FORMAT (' ', '-----------------------------------', & '-------------------------------' ) WRITE (6,115) 115 FORMAT (' ', '| | | ', & '| | | |' ) LNCNTR = LNCNTR + 8 DO 30 J = 1, PC WRITE (6,120) PP ( J ), PE ( J ), PV ( J ), & 100.0 * PPV ( J ), & 100.0 * ( FLOAT ( PE ( J ) ) / FLOAT ( X ) ), & PA ( J ) 120 FORMAT ( ' ', '| ', A12, '| ', I7, ' | ', I8, & ' | ', F5.1, '% | ', F6.1, '% | ', I8, ' |' ) LNCNTR = LNCNTR + 1 30 CONTINUE WRITE (6,115) WRITE (6,110) LNCNTR = LNCNTR + 2 RETURN END C ====================================================================== C ====================================================================== C ====================================================================== C C W. Mott Stewart 15 May 1987 C C 1. NAME - PRPAGE C C 2. DESCRIPTION – Print a page break if the line count is > 105, C then reset line counter to 0. C C 3. CALLS – None, self contained. C C ---------------------------------------------------------------------- SUBROUTINE PRPAGE ( PGCNTR, LNCNTR ) IMPLICIT CHARACTER(A-Z) INTEGER PGCNTR, LNCNTR IF ( LNCNTR .GT. 105 ) THEN PGCNTR = PGCNTR + 1 WRITE (6,10 ) 10 FORMAT ( '1' ) WRITE (6,*) ' ' WRITE (6,20) PGCNTR 20 FORMAT ( ' ', 25X, '-', I2, ' -' ) WRITE (6,*) ' ' LNCNTR = 4 ENDIF RETURN END C ====================================================================== C ====================================================================== C ====================================================================== C C W. Mott Stewart 15 May 1987 C C 1. NAME - QUICKSORT C C 2. DESCRIPTION - This subroutine implement Sedgewick's quicksort C algorithm to sort a real matrix. The recursion is unwrapped. C C Ref: Sedgewick, R. (1978) "Implementing Quicksort Algorithms", C Communications of the ACM, Volume 21, Number 10, October. C C 3. CALLS – None, self contained. C C ---------------------------------------------------------------------- SUBROUTINE QCKSRT ( A, S, E ) IMPLICIT CHARACTER(A-Z) INTEGER I, J, K, L, M, R, STACKP INTEGER LSTACK(100), RSTACK(100), S, E REAL A (300,3), TEMPA, V(10), TEMPRW(10) LOGICAL*1 DONE L = S R = E M = 9 DONE = .FALSE. STACKP = 0 IF (R - L + 1 .LE. M) DONE = .TRUE. 2230 IF (DONE) GOTO 2231 DO 5 K=1, 3 TEMPA = A((L+R)/2,K) A((L+R)/2,K) = A(L+1,K) A(L+1,K) = TEMPA 5 CONTINUE K = 1 160 IF (K .GE. 2 .OR. A(L+1,K) .NE. A(R,K)) GOTO 161 K = K + 1 GOTO 160 161 CONTINUE IF (A(L+1,K) .GT. A(R,K)) THEN DO 10 K=1, 3 TEMPA = A(L+1,K) A(L+1,K) = A(R,K) A(R,K) = TEMPA 10 CONTINUE END IF K = 1 100 IF (K .GE. 2 .OR. A(L,K) .NE. A(R,K)) GOTO 101 K = K + 1 GOTO 100 101 CONTINUE IF (A(L,K) .GT. A(R,K)) THEN DO 20 K=1, 3 TEMPA = A(L,K) A(L,K) = A(R,K) A(R,K) = TEMPA 20 CONTINUE END IF K = 1 110 IF (K .GE. 2 .OR. A(L+1,K) .NE. A(L,K)) GOTO 111 K = K + 1 GOTO 110 111 CONTINUE IF (A(L+1,K) .GT. A(L,K)) THEN DO 30 K=1, 3 TEMPA = A(L+1,K) A(L+1,K) = A(L,K) A(L,K) = TEMPA 30 CONTINUE END IF I = L + 1 J = R DO 40 K=1, 3 V(K) = A(L,K) 40 CONTINUE C START OF LOOP 2240 CONTINUE I = I + 1 2250 K = 1 120 IF (K .GE. 2 .OR. A(I,K) .NE. V(K)) GOTO 121 K = K + 1 GOTO 120 121 CONTINUE IF (A(I,K) .GE. V(K)) GOTO 2251 I = I + 1 GOTO 2250 2251 CONTINUE J = J - 1 2260 K = 1 130 IF (K .GE. 2 .OR. A(J,K) .NE. V(K)) GOTO 131 K = K + 1 GOTO 130 131 CONTINUE IF (A(J,K) .LE. V(K)) GOTO 2261 J = J - 1 GOTO 2260 2261 CONTINUE IF (J .LT. I) GOTO 2270 DO 50 K=1, 3 TEMPA = A(I,K) A(I,K) = A(J,K) A(J,K) = TEMPA 50 CONTINUE GOTO 2240 2270 CONTINUE DO 60 K=1, 3 TEMPA = A(L,K) A(L,K) = A(J,K) A(J,K) = TEMPA 60 CONTINUE IF (J-L .LE. M .AND. R-I+1 .LE. M) THEN IF (STACKP .EQ. 0) THEN DONE = .TRUE. ELSE L = LSTACK(STACKP) R = RSTACK(STACKP) STACKP = STACKP - 1 END IF ELSE IF (J-L .LE. M .OR. R-I+1 .LE. M) THEN IF (J-L .GE. R-I+1) THEN R = J - 1 ELSE L = I END IF ELSE STACKP = STACKP + 1 IF (J - L .GE. R - I + 1) THEN LSTACK(STACKP) = L RSTACK(STACKP) = J - 1 L = I ELSE LSTACK(STACKP) = I RSTACK(STACKP) = R R = J - 1 END IF END IF END IF GOTO 2230 2231 CONTINUE L = S R = E - 1 I = R 380 IF (I .LT. L) GOTO 381 K = 1 140 IF (K .GE. 2 .OR. A(I,K) .NE. A(I+1,K)) GOTO 141 K = K + 1 GOTO 140 141 CONTINUE IF (A(I,K) .GT. A(I+1,K)) THEN DO 70 K=1, 3 TEMPRW(K) = A(I,K) 70 CONTINUE J = I + 1 DO 80 K=1, 3 A(J-1,K) = A(J,K) 80 CONTINUE J = J + 1 2280 IF (J .GT. E) GOTO 2281 K = 1 150 IF (K .GE. 2 .OR. A(J,K) .NE. TEMPRW(K)) GOTO 151 K = K + 1 GOTO 150 151 CONTINUE IF (A(J,K) .GE. TEMPRW(K)) GOTO 2281 DO 90 K=1, 3 A(J-1,K) = A(J,K) 90 CONTINUE J = J + 1 GOTO 2280 2281 CONTINUE DO 95 K=1, 3 A(J-1,K) = TEMPRW(K) 95 CONTINUE END IF I = I - 1 GOTO 380 381 CONTINUE RETURN END C ====================================================================== C ====================================================================== C ====================================================================== C C W. Mott Stewart 15 May 1987 C C 1. NAME - INITIA C C 2. DESCRIPTION – Handles all initialization items. C C ---------------------------------------------------------------------- SUBROUTINE INITIA ( RC, GT, PC, PP, PGCNTR, LNCNTR ) IMPLICIT CHARACTER(A-Z) INTEGER RC, PC, GT, PGCNTR, LNCNTR CHARACTER * 20 PP ( 10 ) GT = 0 RC = 0 PC = 0 PP ( 1 ) = ' ' PGCNTR = 0 LNCNTR = 999 CALL PRPAGE ( PGCNTR, LNCNTR ) WRITE (6,*) ' Phase 1' WRITE (6,*) ' =======' WRITE (6,*) ' ' WRITE (6,*) ' Determine the outright winners in each riding.' WRITE (6,*) ' ' WRITE (6,*) ' ' WRITE (6,*) ' ' LNCNTR = LNCNTR + 7 RETURN END C ====================================================================== C ====================================================================== C ====================================================================== C C W. Mott Stewart 15 May 1987 C C 1. NAME - TERMIN C C 2. DESCRIPTION – Handle all termination items. C C ---------------------------------------------------------------------- SUBROUTINE TERMIN WRITE (6,*) ' ' RETURN END C ====================================================================== C ====================================================================== C ====================================================================== C C W. Mott Stewart 15 May 1987 C C 1. NAME - Election Simulator. C C 2. DESCRIPTION – Simulates an election using random generators. C C ---------------------------------------------------------------------- IMPLICIT CHARACTER(A-Z) INTEGER J, K, A, B, V1, V2, V3, MOD, IABS CHARACTER*12 NAME(300) CHARACTER*13 PROV(10) CHARACTER*7 RIDING(10) CHARACTER*6 TYPE REAL*8 INCREM, MODULU, MULTIP, SEED, PI, UNIFOR, NORMAL INCREM = 7 MODULU = 2**31 MULTIP = 65539 PI = 3.1415265358979 SEED = 123456789 READ 101, TYPE 101 FORMAT ( A6 ) DO 10 J = 1, 10 READ 100, PROV(J) 100 FORMAT ( A13 ) 10 CONTINUE DO 20 J = 1, 10 READ 120, RIDING(J) 120 FORMAT ( A7 ) 20 CONTINUE DO 30 J = 1, 300 READ 130, NAME(J) 130 FORMAT ( A12 ) 30 CONTINUE A = 0 B = 0 DO 40 J = 1, 10 DO 50 K = 1, 10 A = 1 + MOD(A, 10) PRINT 140, PROV(J), RIDING(A) 140 FORMAT ( ' ', 'Riding ', 1X, A13, A7) B = B + 1 IF ( TYPE .EQ. 'UNIFOR' ) THEN V1=.25*80000.0*UNIFOR(INCREM,MODULU,MULTIP,SEED) V2=.40*80000.0*UNIFOR(INCREM,MODULU,MULTIP,SEED) V3=.35*80000.0*UNIFOR(INCREM,MODULU,MULTIP,SEED) ELSEIF ( TYPE .EQ. 'NORMAL' ) THEN V1=.25*80000.0*NORMAL(INCREM,MODULU,MULTIP,SEED,PI) V2=.40*80000.0*NORMAL(INCREM,MODULU,MULTIP,SEED,PI) V3=.35*80000.0*NORMAL(INCREM,MODULU,MULTIP,SEED,PI) ELSE PRINT, 'INCORRECT TYPE.' END IF PRINT 151, NAME(B), IABS(V1) 151 FORMAT ( ' ', A12, 1X, 'Left-Wing ', & 1X, I5 ) B = B + 1 PRINT 152, NAME(B), IABS(V2) 152 FORMAT ( ' ', A12, 1X, 'Centre ', & 1X, I5 ) B = B + 1 PRINT 153, NAME(B), IABS(V3) 153 FORMAT ( ' ', A12, 1X, 'Right-Wing ', & 1X, I5 ) 50 CONTINUE 40 CONTINUE RETURN END C ====================================================================== C ====================================================================== C ====================================================================== C C W. Mott Stewart 15 May 1987 C C 1. NAME - UNIFOR C C 2. DESCRIPTION – Random number generator from uniform distribution. C C ---------------------------------------------------------------------- DOUBLE PRECISION FUNCTION UNIFOR ( INCREM, MODULU, MULTIP, SEED ) REAL*8 INCREM, MODULU, MULTIP, SEED SEED = DMOD ( SEED * MULTIP + INCREM, MODULU ) UNIFOR = DABS ( SEED / MODULU ) RETURN END C ====================================================================== C ====================================================================== C ====================================================================== C C W. Mott Stewart 15 May 1987 C C 1. NAME - NORMAL C C 2. DESCRIPTION – Random number generator from normal distribution. C C ---------------------------------------------------------------------- DOUBLE PRECISION FUNCTION NORMAL (INCREM,MODULU,MULTIP,SEED,PI) REAL*8 INCREM, MODULU, MULTIP, SEED, PI, UNIFOR NORMAL = ((DSIN(2.0*PI*UNIFOR(INCREM,MODULU,MULTIP,SEED) X ))*((-2.0*DLOG(UNIFOR(INCREM,MODULU,MULTIP,SEED)))**.5)) RETURN END C ============================================================ C ============================================================ C ============================================================ C ============================================================ C DATA FOR PROPORTIONAL REPRESENTATION C ============================================================ Riding Newfoundland-East JONES Left-Wing 10469 BOWLEN Centre 19643 CHUTE Right-Wing 3229 Riding Newfoundland-West HARRIS Left-Wing 28432 LLARK Centre 47954 FOURNIER Right-Wing 9226 Riding Newfoundland-North MCWHINNEY Left-Wing 8890 FOSTER Centre 23219 MERRITHEW Right-Wing 33412 Riding Newfoundland-South MASTON Left-Wing 1608 BEAVER Centre 22874 KITCHEN Right-Wing 47107 Riding Newfoundland-N. East MURRAY Left-Wing 9297 MORRE Centre 41256 HOVEY Right-Wing 165 Riding Newfoundland-N. West FLYNN Left-Wing 18107 FRENCH Centre 21705 HAYWARD Right-Wing 18467 Riding Newfoundland-S. East LITTLE Left-Wing 40084 BARDINER Centre 30806 KANE Right-Wing 5622 Riding Newfoundland-S. West GUNTER Left-Wing 8599 BIRD Centre 13831 HALLETT Right-Wing 41514 Riding Newfoundland-Central MOXON Left-Wing 21179 BOUMA Centre 32844 HARPER Right-Wing 4241 Riding Newfoundland-Royal DOBBELSTEYN Left-Wing 8976 FLETCHER Centre 19011 MACALPINE Right-Wing 9410 Riding P. E. I.- East CLOWATER Left-Wing 19682 MORRE Centre 993 KING Right-Wing 18603 Riding P. E. I.- West BRIDGED Left-Wing 26868 DRYDEN Centre 7392 PAINTER Right-Wing 9579 Riding P. E. I.- North BYE Left-Wing 34359 DYKEMAN Centre 33686 FINN Right-Wing 12475 Riding P. E. I.- South CLARKE Left-Wing 9875 HICKEY Centre 46146 LEGERE Right-Wing 19758 Riding P. E. I.- N. East EVANS Left-Wing 29274 DESJARDINES Centre 34928 BROWN Right-Wing 2060 Riding P. E. I.- N. West NEWBY Left-Wing 23983 COY Centre 29376 HAINES Right-Wing 25183 Riding P. E. I.- S. East HOLT Left-Wing 11660 MARSHALL Centre 6904 JAFFREY Right-Wing 4211 Riding P. E. I.- S. West CHILDS Left-Wing 38063 BARNES Centre 28074 DUPOINT Right-Wing 20853 Riding P. E. I.- Central HANSEN Left-Wing 244 JOHNSTON Centre 55904 BILKS Right-Wing 26128 Riding P. E. I.- Royal BANKS Left-Wing 6429 BREWER Centre 28148 EDSON Right-Wing 7350 Riding N. B.- East MCCOY Left-Wing 4215 BAIRD Centre 3619 KELLY Right-Wing 48614 Riding N. B.- West MACFARLANE Left-Wing 23629 FREEMAN Centre 45534 OROMOCTO Right-Wing 80 Riding N. B.- North BARTLETT Left-Wing 6469 BARLOW Centre 21540 AUSTIN Right-Wing 57861 Riding N. B.- South BOONE Left-Wing 4653 GEE Centre 23410 FLEMMING Right-Wing 8358 Riding N. B.- N. East DIAMON Left-Wing 4674 BEEK Centre 25562 LARSEN Right-Wing 20762 Riding N. B.- N. West CHRISTENSEN Left-Wing 17247 LAWS Centre 13469 MCLEAN Right-Wing 23745 Riding N. B.- S. East MACDONALD Left-Wing 6091 CLOSE Centre 22690 GIBBS Right-Wing 4913 Riding N. B.- S. West CARROLL Left-Wing 12086 KING Centre 87232 GRANT Right-Wing 20762 Riding N. B.- Central BEAIRSTO Left-Wing 12780 BIGGS Centre 61041 CALHOUN Right-Wing 32929 Riding N. B.- Royal CURRIE Left-Wing 22147 BARRETT Centre 45814 LEANS Right-Wing 8230 Riding Nova Scotia- East BOGART Left-Wing 4605 ESTEY Centre 27218 DZUBA Right-Wing 42399 Riding Nova Scotia- West EASTWOOD Left-Wing 2419 CRANDALL Centre 11108 BOYD Right-Wing 51941 Riding Nova Scotia- North MULDER Left-Wing 521 HOSSACK Centre 26545 MACRAE Right-Wing 28076 Riding Nova Scotia- South JENNINGS Left-Wing 10980 GILBERT Centre 15205 HUI Right-Wing 8013 Riding Nova Scotia- N. East CUMMINGS Left-Wing 1807 KEARENEY Centre 8647 MITTON Right-Wing 5043 Riding Nova Scotia- N. West GRASS Left-Wing 12188 LENNON Centre 50537 OAKES Right-Wing 2224 Riding Nova Scotia- S. East DOLAN Left-Wing 16123 GIBSON Centre 43423 JOUDRIE Right-Wing 2820 Riding Nova Scotia- S. West CAMP Left-Wing 2742 HAY Centre 57903 BRIGGS Right-Wing 4366 Riding Nova Scotia- Central AHERN Left-Wing 6265 MILLER Centre 56623 BERRY Right-Wing 2486 Riding Nova Scotia- Royal CAMERON Left-Wing 23973 JONES Centre 12218 BENNETT Right-Wing 792 Riding Quebec- East POWER Left-Wing 10694 BLACQUIER Centre 24647 CHARTERS Right-Wing 16670 Riding Quebec- West MACNABB Left-Wing 3320 CANADIAN Centre 53655 NICKS Right-Wing 17623 Riding Quebec- North CABIN Left-Wing 25338 ARMSTRONG Centre 28501 MCCULLUM Right-Wing 25986 Riding Quebec- South BROOKS Left-Wing 19714 MCCARTNEY Centre 30344 MCADAM Right-Wing 28932 Riding Quebec- N. East HOWIE Left-Wing 8632 DOOHAN Centre 3780 CLARKSON Right-Wing 18617 Riding Quebec- N. West HALL Left-Wing 15584 BOONE Centre 22561 ARSENEAU Right-Wing 29475 Riding Quebec- S. East HOWE Left-Wing 7190 AMBERMAN Centre 20000 GOSSIP Right-Wing 4698 Riding Quebec- S. West HUGHES Left-Wing 8585 DICKINSON Centre 6374 ASTLE Right-Wing 20252 Riding Quebec- Central MCPHERSON Left-Wing 24058 BURKE Centre 19782 CORMIER Right-Wing 6173 Riding Quebec- Royal FISHER Left-Wing 36035 CURRIE Centre 36972 HACHEY Right-Wing 37590 Riding Ontario- East FEENEY Left-Wing 8194 GREER Centre 27146 CHAI Right-Wing 17592 Riding Ontario- West FINNIE Left-Wing 45972 LOMBARD Centre 2181 ECOLLE Right-Wing 23548 Riding Ontario- North HAZLETT Left-Wing 11344 CAMERON Centre 49006 BILLIS Right-Wing 7773 Riding Ontario- South MACDONALD Left-Wing 16581 ANGELOPOULOS Centre 12133 AANJOY Right-Wing 37352 Riding Ontario- N. East LOWE Left-Wing 24795 HARDING Centre 132 BOG Right-Wing 9069 Riding Ontario- N. West KILBURN Left-Wing 21309 MORRISON Centre 19292 MUNRO Right-Wing 4848 Riding Ontario- S. East BROWN Left-Wing 2414 JARDINE Centre 23153 BERGE Right-Wing 17812 Riding Ontario- S. West CLACK Left-Wing 35832 DUNNETT Centre 18184 ANTWORTH Right-Wing 9386 Riding Ontario- Central MACKINNON Left-Wing 16107 APPLEBY Centre 70793 KINSMAN Right-Wing 25173 Riding Ontario- Royal ELLIS Left-Wing 4801 INDUSTRIAL Centre 2632 CARTEN Right-Wing 15132 Riding Manitoba- East COCKBUIRN Left-Wing 6254 BIGG Centre 26829 HAWKINS Right-Wing 27572 Riding Manitoba- West BRADFORD Left-Wing 3945 ATKINSON Centre 42594 GALLANT Right-Wing 105 Riding Manitoba- North KORTH Left-Wing 41450 MAHER Centre 3306 BROWN Right-Wing 27756 Riding Manitoba- South FOX Left-Wing 5672 AYLES Centre 11485 LAAGLAND Right-Wing 41378 Riding Manitoba- N. East HETHERINGTON Left-Wing 7066 BARKER Centre 37045 BURGE Right-Wing 26998 Riding Manitoba- N. West BUCKLEY Left-Wing 13526 LEBLANC Centre 15017 FRANCIS Right-Wing 3866 Riding Manitoba- S. East DINGLEY Left-Wing 43735 FORBES Centre 21939 DRAKE Right-Wing 50072 Riding Manitoba- S. West MORRE Left-Wing 21080 FAIRCHILD Centre 38651 BAMBLE Right-Wing 9525 Riding Manitoba- Central FLEMING Left-Wing 1465 BIG Centre 16397 JEWWETT Right-Wing 5331 Riding Manitoba- Royal HORNCASTLE Left-Wing 7257 LOCKE Centre 43105 HEFFERMAN Right-Wing 43980 Riding Saskatchewan-East KENYOU Left-Wing 10185 MCALOON Centre 27065 LLEWELLYN Right-Wing 764 Riding Saskatchewan-West FULTON Left-Wing 28886 CLARK Centre 7168 CONLON Right-Wing 4577 Riding Saskatchewan-North HUESTIS Left-Wing 871 LEWIS Centre 4726 GODIN Right-Wing 1659 Riding Saskatchewan-South BASQUE Left-Wing 7004 COCCI Centre 25862 GOGUEN Right-Wing 5191 Riding Saskatchewan-N. East FOSTER Left-Wing 14154 FORD Centre 27666 GUNNE Right-Wing 6336 Riding Saskatchewan-N. West MACDONALD Left-Wing 20551 HARDY Centre 5007 CAMPBELL Right-Wing 53253 Riding Saskatchewan-S. East FINNAMORE Left-Wing 30 ESTABROOK Centre 27089 COREY Right-Wing 3815 Riding Saskatchewan-S. West CHALMERS Left-Wing 14186 HILLMAN Centre 5350 BAILEY Right-Wing 1136 Riding Saskatchewan-Central MURPHY Left-Wing 2500 ISENOR Centre 10099 LAMEY Right-Wing 7829 Riding Saskatchewan-Royal GRAHAM Left-Wing 16046 ALLEN Centre 17394 EVERTT Right-Wing 25297 Riding Alberta- East BEANEY Left-Wing 13709 DONAHOE Centre 14590 ROEEHOUSE Right-Wing 49864 Riding Alberta- West JOHNSTON Left-Wing 51556 CARLETON Centre 7363 ASHFIELD Right-Wing 34233 Riding Alberta- North ELGEE Left-Wing 11172 BAY Centre 21756 CURTIS Right-Wing 15354 Riding Alberta- South OLMSTEAD Left-Wing 19529 MCLAREN Centre 9134 BOOKER Right-Wing 4292 Riding Alberta- N. East BELL Left-Wing 14664 CAMPBELL Centre 17841 MCCLENNAN Right-Wing 16595 Riding Alberta- N. West NASON Left-Wing 3977 HUNT Centre 8277 FRASER Right-Wing 24629 Riding Alberta- S. East INTER Left-Wing 2578 ALLEN Centre 19614 KENNEDY Right-Wing 4430 Riding Alberta- S. West EPPERT Left-Wing 19811 CARR Centre 7043 MILLS Right-Wing 41096 Riding Alberta- Central GOODYEAR Left-Wing 28097 CHAN Centre 27725 COOPER Right-Wing 17765 Riding Alberta- Royal HAWKES Left-Wing 12315 DUNCAN Centre 22294 CARSON Right-Wing 56562 Riding B. C.- East CREAGHAN Left-Wing 16704 BLISS Centre 18742 CHISHOLM Right-Wing 58615 Riding B. C.- West CROWLEY Left-Wing 22853 GREENE Centre 4861 ARNOLD Right-Wing 28079 Riding B. C.- North COMEAU Left-Wing 19884 COOK Centre 19442 CARLIN Right-Wing 5434 Riding B. C.- South NEILL Left-Wing 2743 COUCETTE Centre 19176 GUILBAULT Right-Wing 12045 Riding B. C.- N. East LAPOINT Left-Wing 24786 LLECK Centre 17381 ASHFIELD Right-Wing 4366 Riding B. C.- N. West MARKERT Left-Wing 14458 BISHOP Centre 9962 MERSEREAU Right-Wing 7680 Riding B. C.- S. East BOUDREAD Left-Wing 8189 BAMMON Centre 20119 BLIZZARD Right-Wing 6845 Riding B. C.- S. West CRAWFORD Left-Wing 24471 DEMERCHANT Centre 51633 LEE Right-Wing 64062 Riding B. C.- Central JOHNSON Left-Wing 10679 HIGGINS Centre 54173 CHAPPELLE Right-Wing 35524 Riding B. C.- Royal HARVEY Left-Wing 19422 MACKAY Centre 36299 LEGER Right-Wing 15633 ENDOFDATA // C C ============================================================ C DATA FOR PROPORTIONAL REPRESENTATION RANDOM NUMBER GENERATOR C ============================================================ C $ENTRY NORMAL Newfoundland- P. E. I.- N. B.- Nova Scotia- Quebec- Ontario- Manitoba- Saskatchewan- Alberta- B. C.- East West North South N. East N. West S. East S. West Central Royal JONES BOWLEN CHUTE HARRIS LLARK FOURNIER MCWHINNEY FOSTER MERRITHEW MASTON BEAVER KITCHEN MURRAY MORRE HOVEY FLYNN FRENCH HAYWARD LITTLE BARDINER KANE GUNTER BIRD HALLETT MOXON BOUMA HARPER DOBBELSTEYN FLETCHER MACALPINE CLOWATER MORRE KING BRIDGED DRYDEN PAINTER BYE DYKEMAN FINN CLARKE HICKEY LEGERE EVANS DESJARDINES BROWN NEWBY COY HAINES HOLT MARSHALL JAFFREY CHILDS BARNES DUPOINT HANSEN JOHNSTON BILKS BANKS BREWER EDSON MCCOY BAIRD KELLY MACFARLANE FREEMAN OROMOCTO BARTLETT BARLOW AUSTIN BOONE GEE FLEMMING DIAMON BEEK LARSEN CHRISTENSEN LAWS MCLEAN MACDONALD CLOSE GIBBS CARROLL KING GRANT BEAIRSTO BIGGS CALHOUN CURRIE BARRETT LEANS BOGART ESTEY DZUBA EASTWOOD CRANDALL BOYD MULDER HOSSACK MACRAE JENNINGS GILBERT HUI CUMMINGS KEARENEY MITTON GRASS LENNON OAKES DOLAN GIBSON JOUDRIE CAMP HAY BRIGGS AHERN MILLER BERRY CAMERON JONES BENNETT POWER BLACQUIER CHARTERS MACNABB CANADIAN NICKS CABIN ARMSTRONG MCCULLUM BROOKS MCCARTNEY MCADAM HOWIE DOOHAN CLARKSON HALL BOONE ARSENEAU HOWE AMBERMAN GOSSIP HUGHES DICKINSON ASTLE MCPHERSON BURKE CORMIER FISHER CURRIE HACHEY FEENEY GREER CHAI FINNIE LOMBARD ECOLLE HAZLETT CAMERON BILLIS MACDONALD ANGELOPOULOS AANJOY LOWE HARDING BOG KILBURN MORRISON MUNRO BROWN JARDINE BERGE CLACK DUNNETT ANTWORTH MACKINNON APPLEBY KINSMAN ELLIS INDUSTRIAL CARTEN COCKBUIRN BIGG HAWKINS BRADFORD ATKINSON GALLANT KORTH MAHER BROWN FOX AYLES LAAGLAND HETHERINGTON BARKER BURGE BUCKLEY LEBLANC FRANCIS DINGLEY FORBES DRAKE MORRE FAIRCHILD BAMBLE FLEMING BIG JEWWETT HORNCASTLE LOCKE HEFFERMAN KENYOU MCALOON LLEWELLYN FULTON CLARK CONLON HUESTIS LEWIS GODIN BASQUE COCCI GOGUEN FOSTER FORD GUNNE MACDONALD HARDY CAMPBELL FINNAMORE ESTABROOK COREY CHALMERS HILLMAN BAILEY MURPHY ISENOR LAMEY GRAHAM ALLEN EVERTT BEANEY DONAHOE ROEEHOUSE JOHNSTON CARLETON ASHFIELD ELGEE BAY CURTIS OLMSTEAD MCLAREN BOOKER BELL CAMPBELL MCCLENNAN NASON HUNT FRASER INTER ALLEN KENNEDY EPPERT CARR MILLS GOODYEAR CHAN COOPER HAWKES DUNCAN CARSON CREAGHAN BLISS CHISHOLM CROWLEY GREENE ARNOLD COMEAU COOK CARLIN NEILL COUCETTE GUILBAULT LAPOINT LLECK ASHFIELD MARKERT BISHOP MERSEREAU BOUDREAD BAMMON BLIZZARD CRAWFORD DEMERCHANT LEE JOHNSON HIGGINS CHAPPELLE HARVEY MACKAY LEGER BURNS BOSTON ELLIOTT HOLLIDAY MCLELLAN JONES HAWKES CARR HALE MANAGERIAL BEORGE LAWSON ARMSTRONG DONOVAN CRAIG MCMINNIMAN BATES GAHAN GRANT COLEMAN CUTHVERTSON MONTGOMERY HENRY ANDERSON BUTLER ESTEY BREQU CASSIDY MODERN HOHNSON GUTHRIE CAIN BRYAN BURDEN EMERY FOSTER HAROLD MACPHEE GRAHAM MCKINLEY MAJOR HOBEN ARSENAULT ANDERSON CRITCHLOW BRIGGS JACKSON BILES HAGERMAN KEIVER ARCHIBALD GRATTAN MACLEAN COATES INGERSOLL BURPEE HARRISOHN CANADIAN GRAY BIL BAILEY ADAMS BUCHANAN BALTZER DAVIDSON DURELL AVERY JORDAN DALEY MILL HAMILTON KIDNEY PAQUIN HILL LEVINE LYNCH BALASUBRAMAN COWPERTHWAIT FERRID BOROKS HUBLEY FREDERICTON HUXTABLE GRIFFITHS KIBBURN HANN CLARK DUNBAR BISS ALLARDYCE CLARK GABRIEL MAXWELL BALLAGHER KNIGHT DAVIDSON COTE BREWER MCNAIR DALZELL //