Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-08 - 43,50467/brdeal.for
There are no other files named brdeal.for in the archive.


	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*%