Skip to content

Commit ba4c390

Browse files
meatballsmeatballs
committed
Split fortran functions into separate files
1 parent 1ee7a0b commit ba4c390

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

73 files changed

+2871
-2893
lines changed

‎src/AxTest.f

Lines changed: 147 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,147 @@
1+
Program AxTest
2+
c For testings of PD tour program.
3+
c Begun 7/19/93. Ver 1.0 begun 7/27 for nice rules as well as not nice rules
4+
c Compile: set directory. then: RUN tourexec2 -debug -saveall -ov -r
5+
6+
c Changes to make:
7+
c Add Almost-Pavlov and Almost-TFT to col rules
8+
9+
real Version /1.1/
10+
c Next few lines are control parameters
11+
integer ColType/4/ ! 1=TFT, 2=TF2T, 3=Random, 4= Pavlov
12+
integer MoveReport/0/ ! 0= no report of moves, 1 = report moves
13+
integer GameReport/0/ ! 0 = no report of games 1= report games
14+
real Noise/0./ ! prob a choice will be changed
15+
integer minRow/1/ ! normally /1/ to run all rules
16+
integer maxRow/63/ ! normally /63/ to run all rules
17+
integer outcome(308) ! 1=R, 2=T, 3=S, 4=P for Column
18+
integer length(5) /63,77,151,156,308/ ! Game Lengths in Tour
19+
integer game ! Game no. with this pair, 1 to 5
20+
integer*4 RandomSeed !
21+
integer Row, Rank ! Row = Rank = 1..63 for 2nd round rules
22+
integer RowGameScore, ColGameScore ! Score in Current Game
23+
integer Tally(4) ! tally of col's outcomes for game
24+
integer ColOutcomeType ! 1=R, 2=T, 3=S, 4=P for Column
25+
integer RowGameSc, ColGameSc ! Scores in one game
26+
integer RowPairSc, ColPairSc ! Scores over 5 games
27+
integer MoveRecord(308) ! Moves of current game
28+
character*9 day
29+
character*8 timenow
30+
integer ActualTFTTourSc(63)/
31+
1 453,453,453,453,453, 453,453,452,453,453,
32+
1 453,453,453,453,453, 449,453,452,450,453,
33+
2 453,453,453,453,452, 453,446,453,449,453,
34+
3 453,453,453,453,453, 453,453,453,452,453,
35+
4 453,453,453,453,453, 452,453,443,422,452,
36+
5 442,453,452,442,342, 398,377,388,438,155,
37+
6 376,341,198/
38+
integer IRowPairSc(63), IColPairSc(63) ! Integer total over 5 games
39+
real AveRowPairSc(63), AveColPairSc(63) ! real, truncated
40+
integer rowchoice, colchoice
41+
call date_and_time(day, timenow)
42+
write(6,100) Version, day, timenow
43+
100 format(' Ax TourExec Program Output, Version ',f6.2, '.', 1H,
44+
1 A10, A10)
45+
RandomSeed = secnds(0.0) ! uses elapsed time since midnight as random seed
46+
c RandomSeed=66222 ! Uses fixed random number
47+
Write(6,103) RandomSeed
48+
103 format(' RandomSeed = ', i16)
49+
50+
write(6,85) noise
51+
85 format(' Noise (per choice) = ', f8.4)
52+
53+
write(6, 104) ColType
54+
104 format(' Col Type, 1=TFT, 2=TF2F, 3=Random, 4=Pavlov. Col Type = '
55+
1 , i3)
56+
if (movereport==1) write(6, 105)
57+
105 format(' Move report: 1 means R, 2 means T, 3 means S, 4 means P
58+
1 for column.')
59+
if (GameReport==1) write(6,101)
60+
101 format(' Rank Game RScore CScore #ColR #ColT #ColS #ColP')
61+
ITotalColPoints = 0 ! Initialize Col's total points
62+
Do 30 row= minRow,maxRow ! normally 1 to 63
63+
rank = row
64+
RowPairSc = 0
65+
ColPairSc = 0
66+
67+
Do 20 Game = 1,5
68+
RowGameSc = 0
69+
ColGameSc = 0
70+
JA = 0 ! Row's previous move, reported to column
71+
JB = 0 ! Col's previous move, reported to row
72+
Do 10 ColOutcomeType = 1,4
73+
Tally(ColOutcomeType) = 0 ! Zero Col's RTSP game count
74+
10 Continue ! End Do tallyType
75+
Do 15 Move = 1, Length(Game)
76+
RandomNumber = RAN(RandomSeed)
77+
RowChoice = KRowFunction(JB,Move, RowGameSc,ColGameSc,
78+
1 RandomNumber,Row,JA)
79+
if ( RAN(RandomSeed) < noise ) RowChoice = 1-RowChoice ! noise happened to Row
80+
RandomNumber = RAN(RandomSeed)
81+
ColChoice = KColFunction(JA,Move,ColGameSc,RowGameSc,
82+
1 RandomNumber,ColType,JB)
83+
if ( RAN(RandomSeed) < noise ) ColChoice = 1 - ColChoice ! noise happened to Col
84+
C temp test:
85+
c Write(6, 999) Move, RowChoice, ColChoice
86+
c999 Format(' move, rowchoice, colchoice ', 3i6)
87+
ColOutcomeType = 1 + 2*RowChoice + ColChoice ! *check col: 1=R,2=T
88+
Tally(ColOutcomeType) = Tally(ColOutcomeType) + 1
89+
JA = RowChoice ! Reported to col next time
90+
JB = ColChoice ! Reported to row next time
91+
92+
Select Case (ColOutcomeType)
93+
Case (1) ! Both Get R
94+
RowGameSc=RowGameSc+3
95+
ColGameSc=ColGameSc+3
96+
Case (2) ! Col Gets T
97+
ColGameSc=ColGameSc+5
98+
Case (3) ! Col Gets S
99+
RowGameSc=RowGameSc+5
100+
Case (4) ! Both Get P
101+
RowGameSc=RowGameSc+1
102+
ColGameSc=ColGameSc+1
103+
End Select
104+
105+
MoveRecord(move)=ColOutcomeType
106+
15 Continue ! End Do Move
107+
108+
C write game output
109+
RowPairSc=RowPairSc+RowGameSc ! sum over 5 games
110+
ColPairSc=ColPairSc+ColGameSc
111+
if (GameReport==1) Write(6, 110) Rank, Game, RowGameSc,
112+
1 ColGameSc, Tally(1), Tally(2), Tally(3), Tally(4)
113+
110 format(9i6, 10i3)
114+
if (movereport .eq. 1) write(6, 112) (MoveRecord(ir), ir=1,
115+
1 length(game))
116+
112 format(' ', 10i2, 2H, 10i2, 2H, 10i2, 2H, 10i2)
117+
20 Continue ! End Do Game
118+
if (GameReport==1) write(6, 115) RowPairSc, ColPairSc
119+
IRowPairSc(Row) = RowPairSc ! total over 5 games
120+
IColPairSc(Row) = ColPairSc
121+
IColTourSc = IColTourSc +ColPairSc ! running total of col's points
122+
115 format('Totals over 5 games: RowPairSc= ',I7, ' ColPairSc = ', I7)
123+
if (GameReport==1) write (6, 120)
124+
120 format()
125+
126+
30 Continue ! End Do Row
127+
128+
C final report: calc tour score, write tour output
129+
130+
Write(6, 135)
131+
135 format(' Rank RowSc ColSc AveRowSc AveColSc 2ndRndTFT
132+
1 2ndRndTFT-Col')
133+
Do 40 Row = minRow,maxRow
134+
IRowTourPairSc = IRowPairSc(Row)/5
135+
IColTourPairSc = IColPairSc(Row)/5
136+
ITotalColPoints = ITotalColPoints + IColPairSc(Row) ! accumulate col points
137+
Write(6, 140) Row, IRowPairSc(Row), IColPairSc(Row),
138+
1 IRowTourPairSc,IColTourPairSc, ActualTFTTourSc(Row),
139+
2 ActualTFTTourSc(Row)-IColTourPairSc
140+
140 format(i6, 4i8, ' ',i8,' ',i8)
141+
40 continue ! end final report
142+
TotalColPoints = ITotalColPoints ! to make floating point (total over 63*5 games)
143+
ColTourSc =(TotalColPoints/5 )/63 ! Ave per game over 63 pairs
144+
write(6, 150) ColType, ITotalColPoints, ColTourSc
145+
150 format(' Col Type= ', i4, '. Col Pts = ', i7, ' Cols Tour Sc = '
146+
1 , f7.3)
147+
end ! Main Program

‎src/K59R.f

Lines changed: 47 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,47 @@
1+
FUNCTION K59R(LASTMV,MOVEN,K,L,R, JA)
2+
C BY LESLIE DOWNING
3+
C TYPED BY AX, 3/27/79 (SAME AS ROUND ONE REV.DOWNING)
4+
c Redone as copy of K56=RevDowning by Ax, 7/27/93
5+
c INTEGER XDOWNC
6+
c T=0
7+
c K59R=XDOWNC(J,M,K,L,T,R)
8+
c RETURN
9+
c END
10+
INTEGER LASTMV,MOVEN
11+
INTEGER PAST,NICE1,NICE2
12+
REAL GOOD,BAD,C,ALT
13+
INTEGER DEFECT, COOP
14+
INTEGER TOTCOP,TOTDEF
15+
k59r=ja ! Added 7/27/93 to report own old value
16+
IF (MOVEN - 2) 1,4,2
17+
1 GOOD = 1.0
18+
BAD = 0.0
19+
PAST = 0
20+
TOTCOP = 0
21+
TOTDEF = 0
22+
NICE1 = 0
23+
NICE2 = 0
24+
COOP = 0
25+
DEFECT = 1
26+
GOTO 4
27+
2 IF (PAST .EQ. DEFECT) GOTO 3
28+
IF (LASTMV .EQ. COOP) NICE1 = NICE1 + 1
29+
TOTCOP = TOTCOP + 1
30+
GOOD = FLOAT(NICE1) / FLOAT(TOTCOP)
31+
GOTO 4
32+
3 IF (LASTMV .EQ. COOP) NICE2 = NICE2 + 1
33+
TOTDEF = TOTDEF + 1
34+
BAD = FLOAT(NICE2) / FLOAT(TOTDEF)
35+
4 PAST = K59R
36+
C = 6.0 * GOOD - 8.0 * BAD - 2.0
37+
ALT = 4.0 * GOOD - 5.0 * BAD - 1.0
38+
IF (C .GE. 0.0 .AND. C .GE. ALT) GOTO 5
39+
IF (C .GE. 0.0 .AND. C .LT. ALT) GOTO 6
40+
IF (ALT .GE. 0.0) GOTO 6
41+
K59R = DEFECT
42+
GOTO 7
43+
5 K59R = COOP
44+
GOTO 7
45+
6 K59R = 1 - K59R
46+
7 RETURN
47+
END

‎src/K73R.f

Lines changed: 30 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,30 @@
1+
FUNCTION K73R(J,M,K,L,R, JA)
2+
C BY GEORGE ZIMMERMAN
3+
C TYPED BY JM 3/20/79
4+
k73r=ja ! Added 7/27/93 to report own old value
5+
IF (M .GT. 1) GOTO 10
6+
IAGGD = 4
7+
IDUNU = 0
8+
IDUNB = 0
9+
IPAYB = 8
10+
ITEST = 1
11+
IPOST = 0
12+
10 K73R = IPOST
13+
IF (J .NE. ITEST) RETURN
14+
IF (ITEST .EQ. 1) IDUNU = IDUNU + 1
15+
IF (ITEST .EQ. 0) IDUNB = IDUNB + 1
16+
IF ((IDUNU .LT. IAGGD) .AND. (IDUNB .LT. IPAYB)) RETURN
17+
IDUNU = 0
18+
IDUNB = 0
19+
IPOST = 0
20+
IF (J .EQ. 1) IPOST = 1
21+
K73R = IPOST
22+
ITEST = 0
23+
IF (IPOST .EQ. 0) ITEST = 1
24+
IF (ITEST .EQ. 0) GOTO 20
25+
IAGGD = IAGGD - 3 + (K / M)
26+
IF (IAGGD .LE. 0) IAGGD = 1
27+
RETURN
28+
20 IPAYB = INT(1.6667 * FLOAT(IAGGD + 1))
29+
RETURN
30+
END

‎src/K74R.f

Lines changed: 68 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,68 @@
1+
FUNCTION K74R(J,M,K,L,R,JA)
2+
C BY EDWARD FRIEDLAND
3+
C TYPED BY JM 3/20/79
4+
c temp output
5+
K74R=JA ! Added to get self reported
6+
IF (M .NE. 1) GOTO 9
7+
ALPHA = 1.0
8+
BETA = .3
9+
IOLD = 0
10+
QCA = 0
11+
QNA = 0
12+
QCB = 0
13+
QNB = 0
14+
K74R = 0
15+
JSW = 0
16+
JS4 = 0
17+
JS11 = 0
18+
JR = 0
19+
JL = 0
20+
JT = 0
21+
JSM = 1
22+
9 IF (JR .NE. 1) GOTO 10
23+
K74R = 1
24+
RETURN
25+
10 IF (M .LE. 2) GOTO 30
26+
IF (IOLD .EQ. 1) GOTO 20
27+
IF (J .EQ. 0) QCA = QCA + 1
28+
QNA = QNA + 1
29+
ALPHA = QCA / QNA
30+
QCA = QCA * .8
31+
QNA = QNA * .8
32+
GOTO 30
33+
20 IF (J .EQ. 0) QCB = QCB + 1
34+
QNB = QNB + 1
35+
BETA = QCB / QNB
36+
QCB = QCB * .8
37+
QNB = QNB * .8
38+
30 IOLD = K74R
39+
C CHECK FOR RANDOM
40+
IF (M .EQ. 37) GOTO 80
41+
IF (M .GT. 37) GOTO 15
42+
IF (M .EQ. 1) GOTO 15
43+
IF (J .EQ. JL) JSM = JSM + 1
44+
IF (JSM .GE. 3) JS4 = 1
45+
IF (JSM .GE. 11) JS11 = 1
46+
IF (J .NE. JL) JSW = JSW + 1
47+
JSM = 1
48+
JT = JT + J
49+
15 POLC = 6 * ALPHA - 8 * BETA - 2
50+
POLALT = 4 * ALPHA - 5 * BETA - 1
51+
IF (POLC .EQ. 0) GOTO 40
52+
IF (POLALT .GE. 0) GOTO 70
53+
GOTO 60
54+
40 IF (POLC .GE. POLALT) GOTO 50
55+
50 K74R = 0
56+
RETURN
57+
60 K74R = 1
58+
RETURN
59+
70 K74R = 1 - K74R
60+
RETURN
61+
80 IF (JS4 .EQ. 0) GOTO 15
62+
IF (JS11 .EQ. 1) GOTO 15
63+
IF (JT .LE. 10) GOTO 15
64+
IF (JT .GE. 26) GOTO 15
65+
IF (JSW .GE. 26) GOTO 15
66+
JR = 1
67+
GOTO 9
68+
END

‎src/K74RXX.f

Lines changed: 73 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,73 @@
1+
FUNCTION K74RXX(J,M,K,L,R,JA)
2+
C BY EDWARD FRIEDLAND
3+
C TYPED BY JM 3/20/79
4+
c k74dummy added by ax 7/22/93
5+
K74R=JA ! Added 7/32/93 to report own old value
6+
IF (M .NE. 1) GOTO 9
7+
ALPHA = 1.0
8+
BETA = .3
9+
IOLD = 0
10+
QCA = 0
11+
QNA = 0
12+
QCB = 0
13+
QNB = 0
14+
K74R = 0
15+
k74dummy=0
16+
JSW = 0
17+
JS4 = 0
18+
JS11 = 0
19+
JR = 0
20+
JL = 0
21+
JT = 0
22+
JSM = 1
23+
9 IF (JR .NE. 1) GOTO 10
24+
K74R = 1
25+
k74dummy=1
26+
RETURN
27+
10 IF (M .LE. 2) GOTO 30
28+
IF (IOLD .EQ. 1) GOTO 20
29+
IF (J .EQ. 0) QCA = QCA + 1
30+
QNA = QNA + 1
31+
ALPHA = QCA / QNA
32+
QCA = QCA * .8
33+
QNA = QNA * .8
34+
GOTO 30
35+
20 IF (J .EQ. 0) QCB = QCB + 1
36+
QNB = QNB + 1
37+
BETA = QCB / QNB
38+
QCB = QCB * .8
39+
QNB = QNB * .8
40+
30 IOLD = K74dummy
41+
C CHECK FOR RANDOM
42+
IF (M .EQ. 37) GOTO 80
43+
IF (M .GT. 37) GOTO 15
44+
IF (M .EQ. 1) GOTO 15
45+
IF (J .EQ. JL) JSM = JSM + 1
46+
IF (JSM .GE. 3) JS4 = 1
47+
IF (JSM .GE. 11) JS11 = 1
48+
IF (J .NE. JL) JSW = JSW + 1
49+
JSM = 1
50+
JT = JT + J
51+
15 POLC = 6 * ALPHA - 8 * BETA - 2
52+
POLALT = 4 * ALPHA - 5 * BETA - 1
53+
IF (POLC .EQ. 0) GOTO 40
54+
IF (POLALT .GE. 0) GOTO 70
55+
GOTO 60
56+
40 IF (POLC .GE. POLALT) GOTO 50
57+
50 K74R = 0
58+
k74dummy = 0
59+
RETURN
60+
60 K74R = 1
61+
k74dummy=1
62+
RETURN
63+
c70 K74R = 1 - K74R
64+
70 K74R = 1-k74dummy
65+
RETURN
66+
80 IF (JS4 .EQ. 0) GOTO 15
67+
IF (JS11 .EQ. 1) GOTO 15
68+
IF (JT .LE. 10) GOTO 15
69+
IF (JT .GE. 26) GOTO 15
70+
IF (JSW .GE. 26) GOTO 15
71+
JR = 1
72+
GOTO 9
73+
END

0 commit comments

Comments
 (0)