PROGRAM BRDEAL
C FORTRAN-10 FOR DECSYSEM10
C LEO NEIMO - 1977
IMPLICIT INTEGER (E-W)
DOUBLE PRECISION A,A2
DIMENSION NDISTR(4),SDISTR(4),WDISTP(4),EDISTR(4)
DIMENSION SUMRY(64,16), K(52)
501 FORMAT(/)
502 FORMAT(/,-)
503 FORMAT(1H+,'ENTER RANDOM PARAMETER AND NUM@ER OF DEALS: ',$)
504 FORMAT(D,2I)
505 FORMAT(1H+,'DEAL #',I3,', ',$)
506 FORMAT(1H+,I2,$)
507 FORMAT(1H+,' ',$)
508 FORMAT(////,8X,%NORTH',7X,'EAST',6X,'SOUTH',7X,'WEST',/)
100 TYPE 502
TYPE 503
A2=SQRT(2.0)
ACCEPT 504,A,N
C 0 < A < 1, 1 < N < 64
C INPUT PARAMETER 'A' SERVES AS AN IDENTIFIER WHICH AT THE
C SAME TIME INITIALISES THE SPECIAL RANDOM NUMBER GENERATOR
C USED IN THIS PROGRAM. N IS NUMBER OF DEALS DESIRED. HF
C MORE THAN 64 HANDS ARE TO BE DEALT, PROGRAM SHOULD BE
C RERUN (CF. PAUSE STATEMELT OL PAGE 1-4 OF LISTING)
J=0
TYPE 502
DO 102 F=1,N
J=J+1
C RANDOM PICK AND DEAL BUILD-UP:
DO 61 I=1,52
K(I)=I
61 CONTINUE
C DE WITH CARD NUMBER 1 THROUGH 52 INITIALISED
L=0
DO 63 I=1,13
C NORTH'S CADS PICIED NOW
62 CALL RAND(A,NR,L)
IF(K(NR)==0) GOTO 62
} NORTH(I)=K(NR)
K(NR)=0
63 CONTINUE
DO 65 I=1,13
C WEST'S CARDS PICKED
64 CALL RAND(A,NR,L)
IF(K(NR)==0) GOTO 64
WEST(I)=K(NR)
K(NR)=0
DO 67 I=1,13
C EAST'S CARDS PICKED
66 CALL RAND(A,NR,L)
IF(K(NP)==0) GOTO 66
EAST(I)=K(NR)
K(NR)=0
67 CONTINUE
E=1
C } }REMAINING CARDS = SOUTH'S HAND
DO 68 I=1,52
IF(K(I)==0) GOTO 68
QOUTH(G)K(I)
G=G+1
68 CONTINUE
C CARDS WILL BE SMRTED DESCENDINGLY:
} AALL KSORT(NORTH,13,2)
CALL KSORT(EAST,13,2)
CALL KSORT(SOUTH,13,2)
CALL KSORT(WEST,13,2)
A=A2*A
C SCAN OF HAND DISTRIBUTIONS:
}AALL LEO0(NORTH,NDISTR)
CALL LEO2(SOUTH,SDISTR)
CALL LEO2(WEST,WDISTR)
CALL LEO2(EAST,EDISTR)
C TYPE-OUT OF THE HANDS:
C OUTPUT OF DEALER AND VULNERABILITY
I=J
TYPE 505,J
IF(I>48) I=I-48
IF(I>32) I=I-32
IF(I>16) II-16
GOTO(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16)I
1 TYPE 21
21 FORMAT( ' N/--')
GOTO 101
2 TYPE 22
22 FORMAT( ' E/NS')
GOTO 101
3 TYPE 23
23 FORMAT( ' S/EW')
GOTO 101
4 TYPE 24
24 FORMAT( ' W/NS)EW')
GOTO 101
5 TYPE 25
25 FORMAT( ' N/NS')
GOTO 101
6 TYPE 26
26 FORMAT( ' E/EW')
GOTO 101
7 TYPE 27
27 FORMAT( ' Q-NS+EW')
GOTO 101
8 TYPE 28
28 FORMAT( ' W/--')
GOTO 101
9 TYPE 29
GOTO 101
10 TYPE 30
30 FORMAT( ' E/NS+EU')
EMTM01
11 TYPE 31
31 FORMAT( ' S/--')
GOTO 101
12 TYPE 32
32 } FORMAT( ' W/NS')
GOTO 101
13 TYPE 33
33 FORMAT( ' N/NS+EW')
GOTM 101
14 TYPE 34
34 FORMAT( ' E/--')
GOTO 101
15 TYPE 35
35 FORMAT( ' S/NS')
GOTO 101
16 TYPE 36
36 FORMAT( ' W/EW')
101 TYPE 501
C TYPE-OUT OF HANDS PROPER BEGINS:
CALL LEO3(NORTH,NDISTR)
CALL LEL4(WEST,EAST,WDISTR,EDISTR)
CALL LEO3(SOUTH,SDISTR)
70 DO 71 I=1,4
}SUMRY(J,I)=NDISTR(I)
SUMRY(J,I+4)=EDISTR(I)
SUMRY(J,I+8)=SDISTR(I)
SUMRY(J,I+12)=WDISTR(I)
71 CONTINUE
C SUMMARIES OF DISTRIBUTIONS SAVED FOR OUTPUT
} IF(J==64) GOTO 103
C PRECAUTION!!!
102 CONTINUE
C OUTPUT OF DISTRIBUTION-SUMMARY:
103 TYPE 508
DO 104 I=1,J
TYPE 506,I
TYPE 507
TYPE 506,SUMRY(I,F)
51 CONTINUE
TYPE 507
DO 52 F=5,8
} TYPE 506,SUMRY(I,F)
52 CONTINUE
TYPE 507
DO 53 F=9,12
TYPE 506,SUMPY(I,D)
53 CONTINUE
TYPE 507
DO 54 F=13,16
TYPE 506,SUMRY(I,F)
TYPE 501
104 CONTINUE
TYPE 502
PAUSE
GOTO 100
END
DOUBLE PRECISION A,B,C,D,A1
C GENERATES A RANDOM NUMBER 1 ... 52. VARIABLE DUMMY ARGUMENTS
C A AND L INITIALISED AND MODIFIED IN MAIN PROGRAM.
C 3RD & 4TH DEC. PLACES OF SQRT(A) = RANDOM NUMBER. REMAINDER
C INITIALISES NEXT RANDOM NUMBER - ERROR MESSAGES ISSUED FOR
C A=0 OR A=CONSTANT,
}IF(A)2,1,3
1 TYPE 10
ACCEPT 11,A
2 A=DABS(A)
3 A1=A
B=SQRT(A)
DM 4 I=1,2
C=100.0*B
N=INT(C)
D=N
B=C-D
4 CONTINUE
A=B
L=L+1
IF(N>52) N=100+L-N
IF(L==4) L=-1
IF(A-A1)6,5,6
5 TYPE 12
ACCEPT 11,A
6 RETURN
10 FORMAT(1H+,' A=0, ENTER NEW PARAMETER A: ',$)
11 FORMAT(D)
12 FORMAT(1H+,' A=CONST., ENTER NEW PARAMETER A: ',$)
END
SUBROUTINE KSORT(KTABLE,N,L)
DIMENSION KTABLE(N)
C SORTING OF INTEGER VECTOR ELEMENTS INTO ASCENDING (L=1)
C OR DESCENDING (L=2) ORDEP
GOTO(1,2)L
1 DO 10 I=1,N-1
DO 10 J=1,N-1
IF(KTABLE(J) < KTABLE(J+1)) GOTO 10
KT=KTABLE(J)1)
KTABLE(J+1)=KTABLE(J)
KTABLE(J)=KT
10 CONTINUE
RETURN
2 DO 20 J=1,N-1
DO 20 I=1,N-1
IF(KTABLE(I) > KTABLE(I+1)) GOTO 20
KT=KTABLE(I+1)
KTABLE(I+1)=KTABLE(I)
KTABLE(I)=KT
20 CONTINUE
RETURN
END
SUBROUTINE LEO2(N,L)
DIMENSION N(13),L(4)
C SUBROUTINE TO ESTABLISH THE DISTRIBUTION OF THE RANDOMLY
C GENERATED SUITS (SPADES, HEARTS, DIAMONDS, CLUBS). DUMMY
C }APGUMENTQ: ILPUT TABLE N WITH CARD NUMBERS (1-52) OF THE
C PARTICULAR HAND (E.G. NORTH, SOUTH ETC. OUTPUT TABLE N
C WITH ALPHANUMERIC CARD VALUES, AND TABLE L WITH FOUR
C SUIT DISTPIBUTION COUNTERS.
DO 1 I=1,4
L(I)=0
1 CONTINUE
C COUNTERS ZEPOED
DO 2 I=1,13
C CHECK SPADES (CARDS 40-52)
IF(N(I)-39)22,22,21
21 L(1)=L(1)+1
GOTO 2
C CHECK HEARTS (CARDS 27-39)
22 IF(N(I)-26)24,24,23
23 L(0)=L(2)+1
GOTO 2
24 IF(N(I)-13)26,26,25
C CHECK DIAMONDS (CARDS 14-26)
05 L(3)=L(3)+1
GOTO 2
C REMAINDER (CARDS 1-13) = CLUBS
26 L(4)=L(4)+1
2 CONTINTE
J=0
C REDUCE CARD NUMBERS TO RANGE 1-13 FOR EACH SUIT:
IF(L(1)==0) GOTO 33
N(I)=N(I)-38
J=I
3 CONTINUE
33 K=J
IF(L(2)==0) GOTO 44
DO 4 I=J+1,J+L(2)
N(I)=N(I)-25
K=I
4 CONTINUE
44 M=K
IF(L(3)==0) EMTO 55
DO 5 I=K+1,K+L(3)
N(I)=N(I)-12
M=I
5 CONTINUE
55 IF(L(4)==0) GOTO 7
DO 6 I=M+1,M+L(4)
N(I)=N(I)+1
6 CONTINUE
C ASSIGN ALPHANUMERIC VALUEQ (ACE THROUGH 2):
7 DO 8 I=1,13
IF(N(I)==14) N(I)='A'
IF(N(I)==13) N(I)='K'
IF(N(I)==12) N(I)='Q'
IF(N(I)==11) N(I)='J'
IF(N(I)==10) N(I)='10'
}ID(L(I)==9) N(I)='9'
IF(N(I)==8) N(I)='8'
IF(N(I)==7) N(I)='7'
IF(N(I)==6) N(I)='6'
IF(N(I)==5) N(I)='5'
IF(N(I)==4) N(I)='4'
IF(N(I)==3) N(I)='3'
IF(N(I)==2) N(I)='2'
8 CONTINUE
RETURN
END
SUBROUTINE LEO3(N,NL)
DIMENSION N(13),NL(4)
C SUBROUTINE TO OUTPUT NORTH'S OR SOUTH'S HAND
C DUMMY ARGS. SAME AS IN SUBROUTINE LEO2
TYPE 510
I2=0
IF (NL(1)==0) GLTO 23
DO 2 I=1,NL(1)
IF (N(I)#'10') GOTO 21
TYPE 514,N(I)
GOTO 02
21 } }TYP 515,N(I)
22 I2=I
2 CONTINUE
23 TYPE 501
TYPE 511
I3=I2
IF (NL(2)==0) GOTO 26
DO 3 I=I2+1,I2+NL(2)
IF (N(I)#'10') GOTO 24
TYPE 514,N(I)
} GOTO 25
24 TYPE 515,N(I)
25 I3=I
3 CONTINUE
26 TYPE 501
I4=I3
IF (NL(3)==0) GOTO 29
DO 4 I=I3+1,I1+NL(3)
IF (N(I)#'10') GOTO 27
TYPE 514,N(I)
GOTO 28
27 TYPE 515,N(I)
28 I4=I
4 CONTINUE
29 TYPE 501
TYPE 513
IF (NL(4)==0) GOTO 6
DO 5 I=I4+1,I4+NL(4)
IF (N(I)#'10') GOTO 31
TYPE 514,N(I)
GOTO 5
31 TYPE 515,N(I)
5 CONTINUE
6 TYPE 502
RETURN
501 FORMAT(/)
502 FORMAT(/,/)
510 FORMAT(1H+,10X,'Q8 %$)
511 FORMAT(1H+,10X,'H: '$)
512 FORMAT(1H+,10X,'D: '$)
513 FORMAT(1H+,10X,'C: '$)
514 FORMAT(1H+,A2,$)
515 FORMAT(1H+,A1,$)
520 FORMAT(1H+,' ',$)
END
SUBROUTINE LEO4(E,W,EL,WL)
IMPLICIT INTEGER (E-W)
DIMENSION E(13),W(13),EL(4),WL(4)
C SUBROUTINE TO OUTPUT WEQT'S AND EAQT'S HANDS
C CORRESPONDS TO ROUTINE LEO3.
TYPE 516
F=0
I2=0
ID (WL(1==0) GOTO 73
DO 7 I=1,WL(1)
IF (W(I)#'10') GOTO 71
TYPE 514,U(I)
} F=F+1
GOTO 72
71 TYPE 515,W(I)
72 F=F+1
I2=I
7 CONTINUE
71 G=15-F
DO 8 F=1,G
TYPE 520
8 CONTINUE
TYPE 516
M2=0
IF (EL(1)==0) GOTO 76
DO 9 M=1,EL(1)
IF (E(M)#'10') GOTO 74
TYPE 514,E(M)
GOTO 75
74 TYPE 515,E(M)
75 M2=M
9 CONTINUE
76 TYPE 501
TYPE 517
F=0
I3=I0
IF (WL(2)==0) GOTO 79
DO 11 I=I2+1,I2+WL(2)
IF (W(I)#'10') GOTO 57
F=F+1
TYPE 514,W(I)
GOTO 78
57 TYPE 515,W(I)
78 F=F+1
79 G=15-F
DO 12 F=1,G
TYPE 520
12 CONTINUE
TYPE 517
M3=M2
IF (EL(2)==0) GOTO 82
DO 10 M=M2+1,M2+EL(2)
IF (E(M)#'10') GOTO 80
GOTM 81
80 TYPE 515,E(M)
81 M3=M
10 CONTINUE
82 TYPE 501
TYPE 518
I4=I3
IF (WL(3)==0) GOTO 85
DO 13 I=I3+1,I3+WL(1)
IF (W(I)#'10') GOTO 83
F=F+1
TYPE 514,W(I)
GOTO 84
83 TYPE 515,W(I)
84 F=F+1
I4=I
13 COLTINUE
85 G=15-F
DO 14 F=1,G
TYPE 500
14 CONTINUE
TYPE 518
M4=M3
IF (EL(3)==0) GOTO 88
DO 15 M=M3+1,M3+EL(3)
} IF (E(M)#'10') GOTO 86
TYPE 514,E(M)
GOTO 87
86 TYPE 515,E(M)
15 CONTINUE
88 TYPE 501
TYPE 519
F=0
IF (WL(4)==0) GOTO 91
DO 16 I=I4+1,I4+WL(4)
IF (W(I)#'10') GOTO 89
F=F+1
TYPE 514,W(I)
GOTO 90
89 TYPE 515,W(I)
90 F=F+1
16 CONTINUE
91 G=15-F
DO 15 F=1,G
TYPE 520
17 CONTINUE
TYPE 519
IF (EL(4)==0) GOTO 19
DO 18 M=M4+1,M4+EL(4)
IF (E(M)#'10') GOTO 92
TYPE 514,E(M)
GOTO 18
92 TYPE 515,E(M)
18 CONTINUE
19 TYPE 502
RETURN
501 FORMAT(/)
502 FORMAT(/,/)
514 FORMAT(1H+,A2,$)
515 FORMAT(1H+,A1,$)
516 FORMAT(1H+,' S: ',$)
517 FORMAT(1H+,' H: ',$)
518 FORMAT(1H+,' D: ',$)
519 FORMAT(1H+,' C: ',$)
520 FORMAT(1H+,' ',$)
END
IIIA}AAA>>AAA> AA@@@@IIIAIII6 )FAAA>IIIA~~@@@@`` >AAA> )F8xx*U* %