-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathMGT2.F
158 lines (136 loc) · 4.49 KB
/
MGT2.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
SUBROUTINE MGT2(IN, VEN)
COMMON /INIT/ NR, NW, ND, NT7, NT8, NDAT, NS1, NS2
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 /SALES/ MDSELL, WTS, NXTSAL
COMMON /BRED/ LBREED, NBREED, IFAR(6, 5), IDB(30), KAGEW, LGTHW, NAGEM
COMMON /BRED2/ ABNORG, GESM, GESS
COMMON /SKIP/ ISTOP4, ISTOP5, ISTOP6, ISTOP7, MAXSKP
COMMON /CLEAN/ NDPREV, NH4CLN, LOSSL
COMMON /BOAR/ MXSDY, MXSWY, MXSDM, MXSWM, NPUR, IPDAT, KAGE, WTPB, IBS
COMMON /SCH/ KS(2, 500), IPT, IEVT, KODE, IWE
COMMON /RPT3/ MJEV
C MGT2 SETS UP SCHEDULES IN ARRAY KS(2,500) AND THEN SENDS THEM TO EVNTS
C
C IFAR(I,1),I=1,6 IS FIRST YEARS FARROWING SCH. FROM S. INIT
C IEVT 1=SELECT, NGLTS PRIOR TO EACH BREEDING
C 2=BREED, ON FOR LBREED DAYS WITH IBS=1, OFF IBS=2
C 3=CLEAN4, PREVIOUS TO FARROWING BY NDPREV DAYS.
C 4=WEAN, ON FOR LGTHW DAYS WITH IWE=1, OFF IWE=2
C 5=SELL, EVERY MDSELL DAYS.
C 7=BOAR PURCHASES
C 6=UPDATES - CALLED EVERY DAY, NOT INC. IN SCH. IN KS(,)
C
C BRANCH TO 1000 FOR SET UP, TO 2000 FOR USING THE SCHEDULE.
IF(KODE-2) 1000, 2000, 1390
C COMPLETE FARROWING DATES ARRY.
1000 DO 365 I = 1,6
DO 365 K = 2,5
365 IFAR(I, K) = IFAR(I, 1) + 365 * (K - 1)
C CALCULATE BREEDING DATES ARRAY IDB().
DO 114 K = 1,5
M = (K - 1) * 6
DO 114 I = 1,6
114 IDB(I + M) = IFAR(I, K) - GESM + GESS
IF(NS1 .EQ. 3) WRITE(ND, 1314) IDB
1314 FORMAT(/' MGT2 SET UP BREEDING SEASONS='/10X,15I5/10X,15I5/)
C FILL DAY TO START BREEDING AND STOP BREEDING, START SET AT OFF
IBS = 2
II = 0
DO 101 I = 1, 60, 2
II = II + 1
KS(1, I) = IDB(II)
KS(2, I) = 2
KS(1, I + 1) = KS(1, I) + LBREED
101 KS(2, I + 1) = 2
C FILL DAY TO SELECT GILTS
IAJ = GESM - 114
DO 103 I = 61,90
KS(1, I) = IDB(I - 60) - 101 + IAJ
103 KS(2, I) = 1
C FILL DAY TO CLEAN HOUSE 4 NDPREV TO FARROWING.
IAJ = GESM - GESS - NDPREV
DO 105 I = 91,120
KS(1, I) = IDB(I - 90) + IAJ
105 KS(2, I) = 3
C FILL DAY TO BEGIN WEANING PROCESS, SET UP LATER FOR LGTHW DAYS.
IAJ = KAGEW + GESM - GESS
DO 107 I = 121,150
KS(1, I) = IDB(I - 120) + IAJ
107 KS(2, I) = 4
C FILL SELL EVENTS, NO. DEPENDING UPON SIZE OF MDSELL.
IDO = NDAYS / MDSELL + 150
IF(IDO .GT. 498) WRITE(ND, 1309) IDO
1309 FORMAT(' ERROR MGT2, ATTEMPT TO LOAD'I4' ITEMS INTO SCHEDULE ARRAY KS(2,500).')
NXTSAL = 1
IDAT = 1
DO 109 I = 151,IDO
KS(1, I) = IDAT
KS(2, I) = 5
109 IDAT = IDAT + MDSELL
C ADD ONE FOR LAST DAYS.
KS(1, IDO + 1) = NDAYS
KS(2, IDO + 1) = 5
C FILL BOAR PURCHASE DATES CODE=7
K7 = IDO + 1
DO 201 I = 1,5
K7 = K7 + 1
IDAT = IPDAT + (365 * (I - 1))
KS(1, K7) = IDAT
201 KS(2, K7) = 7
C SPECIAL WEAN FOR OPENING INVENTORY PIGS, 30 DAY MIN AGE WEAN.
IDAT = KAGEW - 30
IF(IDAT .LT. 1) IDAT = 1
KS(1, K7 + 1) = IDAT
KS(2, K7 + 1) = 4
C ORDER THESE EVENTS BY TIME, I.E. ROW 1
C BUBBLE SORT
I = 1
10 J = I
11 IF(KS(1, I) - KS(1, I + 1)) 98, 98, 9
9 KTS1 = KS(1, I)
KTS2 = KS(2, I)
KS(1, I) = KS(1, I + 1)
KS(2, I) = KS(2, I + 1)
KS(1, I + 1) = KTS1
KS(2, I + 1) = KTS2
IF(I .EQ. 1) GO TO 98
I = I - 1
GO TO 11
98 I = J + 1
IF(I .LT. 500) GO TO 10
C FINISHED BUBBLE SORT
C DROP EMPTY COLUMNS AND THOSE SCHEDULED BEFORE NOWT=1
IF(KS(1, I) .GT. 0) RETURN
DO 117 I = 1,500
IF(KS(1, I) .LT. 1) GO TO 117
DO 118 K = 1,I
C PREVENT EXCEEDING DIMENSIONS.
L= I + K - 1
IF(L-501) 144, 119, 119
144 KS(1, K) = KS(1, L)
118 KS(2, K) = KS(2, L)
117 CONTINUE
119 IPT = 0
C ND TAPE WRITE SCHEDULE
IF(MJEV) 1306, 1306, 1302
1302 WRITE(ND, 1303) NDAYS
1303 FORMAT(//,3X'SCHEDULE OF EVENTS SET UP FOR A RUN OF'I5'DAYS'/,5X'CODES FOLLOWING DATES ARE 1=SELECT, 2=BREED, 3=CLEAN4, 4=WEAN, 5=SELL, 6=UPDATE, 7=BUY BOARS')
IIDO = IDO + 1
WRITE(ND, 1305) ((KS(I, J), I = 1,2), J = 1,IIDO)
1305 FORMAT((3X,12(I6,I2)/))
1306 RETURN
C KODE 2000 FOR FINDING NEXT EVENTS
2000 IPT = IPT + 1
IF(KS(1, IPT) - NOWT) 2000, 300, 400
C EXECUTE THE EVENT.
300 IEVT = KS(2, IPT)
RETURN
C NEXT DAY ITEM.
400 IPT = IPT - 1
JEVT = 6
RETURN
1390 WRITE(ND, 1391) NOWT, IPT, KODE, IDO
1391 FORMAT(/' ERROR MGT2, NOWT='I6' IPT='I4' KODE='I3' IDO='I7' RETURNING'/)
RETURN
END