1
2
3
4
5
6
7 INTEGER GETOBJ(OIDX,AIDX,SPCOBJ)
8 IMPLICIT INTEGER(A-Z)
9 %include dparam
10 LOGICAL THISIT,GHERE,LIT,CHOMP,DFLAG,NOADJS
11
12
13 DFLAG=AND(PRSFLG,8).NE.0
14 CHOMP=.FALSE.
15 AV=AVEHIC(WINNER)
16 OBJ=0
17 IF(.NOT.LIT(HERE)) GO TO 200
18
19 OBJ=SCHLST(OIDX,AIDX,HERE,0,0,SPCOBJ)
20 IF(DFLAG) WRITE(OUTCH,10) OBJ
21 10 FORMAT(' SCHLST- ROOM SCH ',I6)
22 IF(OBJ) 1000,200,100
23
24
25 100 IF((AV.EQ.0).OR.(AV.EQ.OBJ).OR.(OCAN(OBJ).EQ.AV).OR.
26 & (AND(OFLAG2(OBJ),FINDBT).NE.0)) GO TO 200
27 CHOMP=.TRUE.
28
29 200 IF(AV.EQ.0) GO TO 400
30 NOBJ=SCHLST(OIDX,AIDX,0,AV,0,SPCOBJ)
31 IF(DFLAG) WRITE(OUTCH,220) NOBJ
32 220 FORMAT(' SCHLST- VEH SCH ',I6)
33 IF(NOBJ) 800,400,300
34 300 CHOMP=.FALSE.
35 IF(OBJ.EQ.NOBJ) GO TO 400
36 IF(OBJ.NE.0) NOBJ=-NOBJ
37 OBJ=NOBJ
38
39 400 NOBJ=SCHLST(OIDX,AIDX,0,0,WINNER,SPCOBJ)
40 IF(DFLAG) WRITE(OUTCH,430) NOBJ
41 430 FORMAT(' SCHLST- ADV SCH ',I6)
42 IF(NOBJ) 800,900,500
43 500 IF(OBJ.EQ.0) GO TO 800
44 IF(AIDX.NE.0) GO TO 600
45 IF(NOADJS(OBJ).NEQV.NOADJS(NOBJ)) GO TO 700
46 600 OBJ=-NOBJ
47 GO TO 900
48 700 IF(NOADJS(OBJ)) GO TO 900
49 800 OBJ=NOBJ
50 900 IF(CHOMP) OBJ=-10000
51 1000 GETOBJ=OBJ
52
53 IF(GETOBJ.NE.0) GO TO 1500
54 DO 1200 I=STRBIT+1,OLNT
55 IF(.NOT.THISIT(OIDX,AIDX,I,SPCOBJ)) GO TO 1200
56 IF(.NOT.GHERE(I,HERE)) GO TO 1200
57 IF(GETOBJ.EQ.0) GO TO 1150
58 IF(AIDX.NE.0) GO TO 1050
59 IF(NOADJS(GETOBJ).NEQV.NOADJS(I)) GO TO 1100
60 1050 GETOBJ=-I
61 GO TO 1200
62 1100 IF(NOADJS(GETOBJ)) GO TO 1200
63 1150 GETOBJ=I
64 1200 CONTINUE
65
66 1500 CONTINUE
67 IF(DFLAG) WRITE(OUTCH,1540) GETOBJ
68 1540 FORMAT(' SCHLST- RESULT ',I6)
69 RETURN
70
71
72
73
74
75
76 INTEGER SCHLST(OIDX,AIDX,RM,CN,AD,SPCOBJ)
77 IMPLICIT INTEGER(A-Z)
78 %include dparam
79 LOGICAL THISIT,QHERE,NOTRAN,NOVIS,AEMPTY,NOADJS
80
81
82
83
84
85 NOTRAN(O)=(AND(OFLAG1(O),TRANBT).EQ.0).AND.
86 & (AND(OFLAG2(O),OPENBT).EQ.0)
87
88 NOVIS(O)=(AND(OFLAG1(O),VISIBT).EQ.0)
89
90 SCHLST=0
91 AEMPTY=.FALSE.
92 DO 1000 I=1,OLNT
93 IF(NOVIS(I).OR.
94 & (((RM.EQ.0).OR.(.NOT.QHERE(I,RM))).AND.
95 & ((CN.EQ.0).OR.(OCAN(I).NE.CN)).AND.
96 & ((AD.EQ.0).OR.(OADV(I).NE.AD)))) GO TO 1000
97 IF(.NOT.THISIT(OIDX,AIDX,I,SPCOBJ)) GO TO 200
98 IF(SCHLST.EQ.0) GO TO 150
99 IF(AIDX.NE.0) GO TO 2000
100 IF(NOADJS(I)) GO TO 100
101 AEMPTY=.TRUE.
102 GO TO 200
103 100 IF(NOADJS(SCHLST)) GO TO 2000
104 150 SCHLST=I
105
106
107
108
109 200 IF(NOTRAN(I)) GO TO 1000
110
111
112
113
114
115
116
117 DO 500 J=1,OLNT
118 IF(NOVIS(J).OR. (.NOT.THISIT(OIDX,AIDX,J,SPCOBJ)))
119 & GO TO 500
120 X=OCAN(J)
121 300 IF(X.EQ.I) GO TO 400
122 IF(X.EQ.0) GO TO 500
123
124
125 IF(NOVIS(X).OR.NOTRAN(X).OR.
126 & (AND(OFLAG2(X),SCHBT).EQ.0)) GO TO 500
127 X=OCAN(X)
128 GO TO 300
129
130 400 IF(SCHLST.EQ.0) GO TO 450
131 IF(AIDX.NE.0) GO TO 2000
132 IF(NOADJS(J)) GO TO 425
133 AEMPTY=.TRUE.
134 GO TO 500
135 425 IF(NOADJS(SCHLST)) GO TO 2000
136 450 SCHLST=J
137
138 500 CONTINUE
139
140 1000 CONTINUE
141 IF(.NOT.AEMPTY.OR.(SCHLST.EQ.0)) RETURN
142 IF(NOADJS(SCHLST)) RETURN
143 2000 SCHLST=-SCHLST
144 RETURN
145
146
147
148
149
150
151
152 LOGICAL THISIT(OIDX,AIDX,OBJ,SPCOBJ)
153 IMPLICIT INTEGER(A-Z)
154 %include dparam
155
156 THISIT=.FALSE.
157 IF((SPCOBJ.NE.0).AND.(OBJ.EQ.SPCOBJ)) GO TO 500
158
159
160
161 IF(OIDX.EQ.0) RETURN
162 I=OIDX
163 100 IF(IABS(OVOC(I)).EQ.OBJ) GO TO 200
164 I=I+1
165 IF(OVOC(I).LT.0) GO TO 100
166 RETURN
167
168 200 IF(AIDX.EQ.0) GO TO 500
169 I=AIDX
170 300 IF(IABS(AVOC(I)).EQ.OBJ) GO TO 500
171 I=I+1
172 IF(AVOC(I).LT.0) GO TO 300
173 RETURN
174
175 500 THISIT=.TRUE.
176 RETURN
177
178
179
180
181
182
183
184
185 LOGICAL SYNMCH(X)
186 IMPLICIT INTEGER(A-Z)
187 %include dparam
188 LOGICAL SYNEQL,TAKEIT,DFLAG
189 CHARACTER*(TEXLNT) STR
190 CHARACTER*(WRDLNT) FINDVB,FINDPR,LCIFY,LCWORD
191 CHARACTER*(WRDLNT+2) LCPRP1,LCPRP2
192 external dtext_$read (descriptors)
193
194
195
196 SYNMCH=.FALSE.
197
198 DFLAG=AND(PRSFLG,16).NE.0
199 J=ACT
200 DRIVE=0
201 DFORCE=0
202
203 QPREP=AND(OFLAG,OPREP)
204 LIMIT=J+VVOC(J)+1
205 J=J+1
206
207 200 CALL UNPACK(J,NEWJ)
208 IF(DFLAG) WRITE(OUTCH,210) J,OBJ1,PREP1,DOBJ,DFL1,DFL2
209 210 FORMAT(' SYNMCH DOBJ INPUTS TO SYNEQL- ',6I7)
210
211 SPREP=AND(DOBJ,VPMASK)
212 IF(SYNEQL(PREP1,OBJ1,DOBJ,DFL1,DFL2)) GO TO 1000
213
214
215
216 IF((OBJ2.NE.0).OR.(OBJ1.EQ.0).OR.
217 & (.NOT.SYNEQL(PREP1,OBJ1,IOBJ,IFL1,IFL2)))
218 & GO TO 500
219 OBJ2=OBJ1
220 PREP2=PREP1
221 OBJ1=0
222 PREP1=0
223 DRIVE=J
224 GO TO 3100
225
226
227
228 500 IF(OBJ1.NE.0) GO TO 3000
229 GO TO 2500
230
231
232
233 1000 IF(DFLAG) WRITE(OUTCH,1010) J,OBJ2,PREP2,IOBJ,IFL1,IFL2
234 1010 FORMAT(' SYNMCH IOBJ INPUTS TO SYNEQL- ',6I7)
235
236 SPREP=AND(IOBJ,VPMASK)
237 IF(SYNEQL(PREP2,OBJ2,IOBJ,IFL1,IFL2)) GO TO 6000
238
239
240
241 IF(OBJ2.NE.0) GO TO 3000
242 2500 IF((QPREP.EQ.0).OR.(QPREP.EQ.SPREP)) DFORCE=J
243
244 IF(AND(VFLAG,SDRIV).NE.0) DRIVE=J
245 IF(DFLAG) WRITE(OUTCH,2510) J,QPREP,SPREP,DFORCE,DRIVE
246 2510 FORMAT(' SYNMCH DEFAULT SYNTAXES- ',5I7)
247 3000 J=NEWJ
248 IF(J.LT.LIMIT) GO TO 200
249
250
251
252
253
254
255 3100 IF(DFLAG) WRITE(OUTCH,3110) DRIVE,DFORCE,OBJ1,OBJ2
256 3110 FORMAT(' SYNMCH, DRIVE=',2I6,' OBJECTS =',2I6)
257 IF(DRIVE.EQ.0) DRIVE=DFORCE
258 IF(DRIVE.EQ.0) GO TO 10000
259 CALL UNPACK(DRIVE,DFORCE)
260 LCWORD=LCIFY(FINDVB(DRIVE),2)
261
262 LCPRP1=' '//LCIFY(FINDPR(INT(AND(DOBJ,VPMASK))),1)//' '
263
264 LCPRP2=' '//LCIFY(FINDPR(INT(AND(IOBJ,VPMASK))),1)//' '
265
266
267
268
269 IF((AND(VFLAG,SDIR).EQ.0).OR.(OBJ1.NE.0)) GO TO 4000
270
271 OBJ1=AND(OFLAG,OOBJ1)
272 IF(OBJ1.EQ.0) GO TO 3500
273 IF(SYNEQL(OPREP1,OBJ1,DOBJ,DFL1,DFL2)) GO TO 4000
274
275
276
277 3500 OBJ1=GWIM(DOBJ,DFW1,DFW2)
278 IF(DFLAG) WRITE(OUTCH,3530) OBJ1
279 3530 FORMAT(' SYNMCH- DO GWIM= ',I6)
280 IF(OBJ1.GT.0) GO TO 4000
281
282 CALL ORPHAN(-1,ACT,0,0,INT(AND(DOBJ,VPMASK)),' ',PREP2,OBJ2)
283 BUNSUB=0
284 IF(OBJ2.GT.0) GO TO 3800
285 3700 WRITE(OUTCH,3750)
286 & LCWORD(1:NBLEN(LCWORD)),LCPRP1(1:NBLEN(LCPRP1)+1)
287 3750 FORMAT(1X,A,A,'what?')
288 TELFLG=.TRUE.
289 RETURN
290
291 3800 X=IABS(ODESC2(OBJ2))
292
293 call dtext_$read (x, j, str)
294 CALL TXCRYP(X,STR)
295 WRITE(OUTCH,3880) LCWORD(1:NBLEN(LCWORD)),
296 & LCPRP1(1:NBLEN(LCPRP1)+1),
297 & LCPRP2(1:NBLEN(LCPRP2)+1),STR(1:NBLEN(STR))
298 3880 FORMAT(1X,A,A,'what',A,'the ',A,'?')
299 TELFLG=.TRUE.
300 RETURN
301
302
303
304
305
306
307 4000 IF((AND(VFLAG,SIND).EQ.0).OR.(OBJ2.NE.0)) GO TO 6000
308
309 OBJ2=AND(OFLAG,OOBJ2)
310 IF(OBJ2.EQ.0) GO TO 4500
311 IF(SYNEQL(OPREP2,OBJ2,IOBJ,IFL1,IFL2)) GO TO 6000
312
313
314
315 4500 OBJ2=GWIM(IOBJ,IFW1,IFW2)
316 IF(DFLAG) WRITE(OUTCH,4550) OBJ2
317 4550 FORMAT(' SYNMCH- IO GWIM= ',I6)
318 IF(OBJ2.GT.0) GO TO 6000
319 IF(OBJ1.GT.0) GO TO 4600
320
321
322 CALL ORPHAN(-1,ACT,INT(AND(OFLAG,OPREP1)),
323 & INT(AND(OFLAG,OOBJ1)),INT(AND(IOBJ,VPMASK)),' ',0,0)
324 GO TO 3700
325
326
327
328
329 4600 CALL ORPHAN(-1,ACT,PREP1,OBJ1,INT(AND(IOBJ,VPMASK)),' ',0,0)
330 X=IABS(ODESC2(OBJ1))
331
332 call dtext_$read (x, j, str)
333 CALL TXCRYP(X,STR)
334 WRITE(OUTCH,4660) LCWORD(1:NBLEN(LCWORD)),
335 & LCPRP1(1:NBLEN(LCPRP1)+1),
336 & STR(1:NBLEN(STR)),LCPRP2(1:NBLEN(LCPRP2)+1)
337 4660 FORMAT(1X,A,A,'the ',A,A,'what?')
338 TELFLG=.TRUE.
339 RETURN
340
341
342
343 10000 CALL RSPEAK(601)
344 BUNSUB=0
345 RETURN
346
347
348
349
350
351
352
353 6000 IF(AND(VFLAG,SFLIP).EQ.0) GO TO 7000
354 J=OBJ1
355 OBJ1=OBJ2
356 OBJ2=J
357
358
359 7000 PRSA=AND(VFLAG,SVMASK)
360 PRSO=OBJ1
361 PRSI=OBJ2
362 IF(.NOT.TAKEIT(PRSO,DOBJ)) RETURN
363 IF(.NOT.TAKEIT(PRSI,IOBJ)) RETURN
364 SYNMCH=.TRUE.
365 IF(DFLAG) WRITE(OUTCH,7050) SYNMCH,PRSA,PRSO,PRSI,ACT,OBJ1,OBJ2
366 7050 FORMAT(' SYNMCH- RESULTS ',L1,6I7)
367 RETURN
368
369
370
371
372
373
374
375 UNPACK(OLDJ,J)
376 IMPLICIT INTEGER(A-Z)
377 %include dparam
378
379 DO 10 I=1,11
380 SYN(I)=0
381 10 CONTINUE
382
383 VFLAG=VVOC(OLDJ)
384 J=OLDJ+1
385
386 IF(AND(VFLAG,SDIR).EQ.0) RETURN
387 DFL1=-1
388 DFL2=-1
389
390 IF(AND(VFLAG,SSTD).EQ.0) GO TO 100
391 DFW1=-1
392 DFW2=-1
393 DOBJ=VABIT+VRBIT+VFBIT
394 GO TO 200
395
396 100 DOBJ=VVOC(J)
397 DFW1=VVOC(J+1)
398 DFW2=VVOC(J+2)
399 J=J+3
400
401 IF(AND(DOBJ,VEBIT).EQ.0) GO TO 200
402 DFL1=DFW1
403 DFL2=DFW2
404
405
406 200 IF(AND(VFLAG,SIND).EQ.0) RETURN
407 IFL1=-1
408 IFL2=-1
409 IOBJ=VVOC(J)
410 IFW1=VVOC(J+1)
411 IFW2=VVOC(J+2)
412 J=J+3
413
414 IF(AND(IOBJ,VEBIT).EQ.0) RETURN
415 IFL1=IFW1
416 IFL2=IFW2
417 RETURN
418
419
420
421
422
423
424
425 LOGICAL SYNEQL(PREP,OBJ,SPREP,SFL1,SFL2)
426 IMPLICIT INTEGER(A-Z)
427 %include dparam
428
429 IF(OBJ.EQ.0) GO TO 100
430
431
432
433 SYNEQL=(PREP.EQ.AND(SPREP,VPMASK)).AND.
434 & (OR(AND(SFL1,OFLAG1(OBJ)),
435 & AND(SFL2,OFLAG2(OBJ))).NE.0)
436 RETURN
437
438 100 SYNEQL=(PREP.EQ.0).AND.(SFL1.EQ.0).AND.(SFL2.EQ.0)
439 RETURN
440
441