-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathBREED.F
191 lines (159 loc) · 5.61 KB
/
BREED.F
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
SUBROUTINE BREED(IN, VEN)
COMMON /INIT/ NR, NW, ND, NT7, NT8, NDAT, NS1, NS2, NOWD
COMMON /GEN/ ITOT, ISIZE, NOWT, NOWY, NDAYS, NRUNS, IATRIB(18), ATRIB(4)
COMMON /HOUSE/ NH(6), N1, N2, N3, N4, N5, N6, NXTFAR, MX1, MX2, MX3, MX4
COMMON /BRED/ LBREED, NBREED, IFAR(6, 5), IDB(30), KAGEW, LGTHW, NAGEM
COMMON /BRED2/ ABNORG, GESM, GESS, GMIN, GMAX
COMMON /BIRTH/ BRNM, BRNS, BMIN, BMAX, BWT, BWTS, BWMIN, BWMAX, NOBRN
COMMON /BRED3/ D(3), PCON1, PCON2, ADJ1, ADJ2
COMMON /CULL/ NGLTS, MXSRV, MXAGS, PCULG, PCULS, PSSR, PRGT, MXBOR, LDP
COMMON /BOAR/ MXSDY, MXSWY, MXSDM, MXSWM, NPUR, IPDAT, KAGE, WTPB, IBS
COMMON /GAIN/ GW1, GW23, GSRT, GFIN1, GFIN2, GSOWM, GSOWL, SDP, SSOWM, SSOWL
COMMON /STAT/ SUM(5, 20), SUM2(5, 10), SUM3(5, 10), SUM4(5, 10), SUM5(5, 10)
COMMON /BRED4/ KBRD, KSWGT(4), NONB(4), NONBK(4)
DIMENSION KATRIB(12), BTRIB(2)
C SOW OR GILT IN HEAT IS SENT FROM UPDATE.
C IF IN BREEDING SEASON IBS=1
C SOW RETURNED AS OPEN, K=2, OR IN GESTATION, K=3
C TEST FOR BREEDING SEASON
IATRIB(4) = 0
IF(IBS-1) 127, 28, 127
28 IF(KBRD-NBREED) 29, 27, 27
27 NONB(1) = NONB(1) + 1
NONBK(1) = NONBK(1) + 1
IF(NONB(4)) 107, 107, 109
107 NONB(4) = NOWT
109 RETURN
C COUNT SOWS IN HEAT BUT NO BREEDING SEASON.
127 NONBK(4) = NONBK(4) + 1
RETURN
C SAVE FEMALES ATTRIBUTES
C COUNT NO. SOWS EXPOSED (TARGET NO.)
29 KBRD = KBRD + 1
DO 30 KX = 1,12
30 KATRIB(KX) = IATRIB(KX)
DO 32 KX = 1,2
32 BTRIB(KX) = ATRIB(KX)
C FIND AVAILABLE BOAR IN FILE 8
NSERV = 0
NH5 = NH(5)
IF(NH5 .LT. 1) GO TO 9138
C LOOP FOR BOAR SEARCH
C MTP: THIS IS THE OFFENDING LINE FOR:
C LABEL AT (1) IS NOT IN THE SAME BLOCK AS THE GOTO STATEMENT AT (2)
DO 777 MK = 1,NH5
KUSE = 0
CALL REMOV(IN, VEN, N4 + 1)
K = IATRIB(3)
IF(K-1) 9138, 776, 41
41 IAT10 = IATRIB(10)
IAT11 = IATRIB(11)
IF(IAT11 .LT. 1) GO TO 47
C SUM WEEK SERVICES TALLY
IA = IAT11 / 100000
IT = IAT11 / 1000 - IT * 10 + IT
IT = IAT11 / 1000 - (IAT11 / 10000 * 10) + IT
IT = IAT11 / 100 - (IAT11 / 100 * 10) + IT
IT = IAT11 / 10 - (IAT11 / 10 * 10) + IT
IT = IAT11 - (IAT11 / 10 * 10) + IT
GO TO 49
47 IT = 0
49 IF(K-2) 9138, 5, 50
C YOUNG BOARS CHECK MAX. DAILY AND WEEKLY SERVICES AVAILABLE.
5 IF(IT + IAT10 - MXSWY) 6, 776, 776
6 IF(IAT10 + 1 - MXSDY) 149, 148, 776
C MATURE BOARS CHECK MAX. DAILY AND WEEKLY SERVICES.
50 IF(IT + IAT10 - MXSWM) 52, 776, 776
52 IF(IAT10-MXSDM) 149, 148, 776
C ASSIGN KUSE TO SERVICES USED FOR THIS BOAR.
148 KUSE = 1
GO TO 150
149 KUSE = 2
GO TO 150
776 CALL FILEM(IN, VEN, 8)
777 CONTINUE
IF(NSERV-1) 1377, 161, 161
C DROP THROUGH 777 LOOP IMPLIES NO SERVICES AVAILABLE IF NSERV .EQ. 0.
1377 GO TO 161
C ADJUST BOAR USE ATTRIBUTES AND RE-ENTER LOOP OR RETURN SOW AND QUIT.
C NSERV BECOMES 1,2 OR 3 (1 FROM 1 BOAR+2 FROM SECOND).
150 NSERV = NSERV + KUSE
153 IATRIB(10) = IAT10 + KUSE
IATRIB(12) = IATRIB(12) + KUSE
IF(NSERV-2) 776, 151, 151
C FILE BOAR, BRING BACK SOW ATTRIBUTES.
151 CALL FILEM(IN, VEN, 8)
161 DO 35 KX = 1,12
35 IATRIB(KX) = KATRIB(KX)
DO 37 KX = 1,2
37 ATRIB(KX) = BTRIB(KX)
IF(NSERV) 152, 152, 155
C LACK BOARS NON CONCEPTION COUNT FOR NONB(2)
C CHECK FAILS TO CONCEIVE IN BREEDING SEASON COUNT.
152 IATRIB(12) = IATRIB(12) + 1
IF(IATRIB(12)-MXSRV) 154, 154, 159
C SET AGE UP TO AUTOMATICALLY CULL IN LDP DAYS.
159 IATRIB(1) = MXAGS - LDP
IATRIB(10) = 99
154 NONB(2) = NONB(2) + 1
NONBK(2) = NONBK(2) + 1
RETURN
C CONCEPTION TEST
155 IF(NSERV .GT. 1) GO TO 175
C PROB. OF CONCEPTION WHEN 1 SERVICE GIVEN.
PX = PCON1
C ADJUSTMENT FOR SUMMER DAYS 183-243
173 IF(NOWD-183) 183, 184, 184
184 IF(NOWD-243) 185, 185, 183
185 PC = PC + PSSR
C ADJUSTMENT IF GILT.
183 IF(IATRIB(1)-365) 190, 193, 193
190 PC = PC + PRGT
193 RN = RANUM(0)
IF(RN-PC) 205, 205, 9300
C PROB. OF CONCEPTION WHEN 2 SERVICES= PROB. ON FIRST+
C PROB. ON SECOND IF NOT CONCEIVED ON FIRST.
175 PC = PCON1 + (1.0 - PCON2) * PCON2
GO TO 173
C BRED SOW RETURNED WITH GESTATION ATTRIBUTES.
205 IATRIB(3) = 3
IATRIB(12) = 0
C NO. PIGS ATTRIBUTE ADJUSTED FOR AGE SOW AND NO. SERVICES.
AGE = IATRIB(1) + GESM
V = BRNM - 10.0
IF(AGE .GT. 1300.0) GO TO 207
BRM = V + 5.867 + 0.01 * AGE - 0.00000446 * AGE ** 2.0
GO TO 209
207 BRM = V + 5.867 + 0.01 * 1300 * - 0.00000446 * 1690000.0 - 0.0016 * (AGE - 1300.0)
IF(NSERV .GT. 1) GO TO 708
BRM = BRM + ADJ1
GO TO 209
708 BRM = BRM + ADJ2
209 NPIGS = RNORM(BRM, BRNS, BMIN, BMAX) + 0.5
IATRIB(8) = NPIGS
IATRIB(11) = RNORM(GESM, GESS, GMIN, GMAX) + 0.5
C STATS FOR SEASONAL BREEDING REPORT.
C SUM2( ,7)=AGE AT FARROWING (APPROX.)
C SUM2( , 8) = LITTER SIZE IF SOW FARROWS.
CALL COLLECT(SUM2, 7, AGE)
CALL COLLECT(SUM3, 7, AGE)
RNPIGS = NPIGS
CALL COLLECT(SUM2, 8, RNPIGS)
CALL COLLECT(SUM3, 8, RNPIGS)
RNOWT = NOWT
CALL COLLECT(SUM2, 9, RNOWT)
RETURN
9138 WRITE(ND, 9136) NOWT
9136 FORMAT(5X'BREEDING SEASON ON DAY='I5', NO BOARS EXIST, SOW RETURNED OPEN')
C INCREASE FAILS TO BREED COUNT.
9300 IATRIB(12) = IATRIB(12) + 1
IF(IATRIB(12)-MXSRV) 9309, 9309, 9302
C CHECK FAILS TO CONCEIVE IN BREEDING SEASON COUNT.
C SET AGE UP TO AUTOMATICALLY CULL IN LDP DAYS.
9302 IATRIB(1) = MXAGS - LDP
IATRIB(10) = 99
C NON CONCEPTION COUNT FOR NONB(3).
9309 NONB(3) = NONB(3) + 1
NONBK(3) = NONBK(3) + 1
RETURN
END