![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to SCAN.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / pfort|
Return to SCAN.f CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 root 1: SUBROUTINE SCAN(MAINND)
2: INTEGER PLAT, SYMLEN, PNODE, STACK
3: LOGICAL ERR, SYSERR, ABORT
4: COMMON /DETECT/ ERR, SYSERR, ABORT
5: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
6: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
7: COMMON /CEXPRS/ LSTACK, STACK(620)
8: COMMON /HEAD/ LNODE, PNODE, NODE(500)
9: COMMON/ SCR1/ LINODE, INODE(500)
10: COMMON /SCR2/ LICOM, ICOM(500)
11: C
12: C SUBROUTINE PERCOLATES SETTING INFO ABOUT ARGUMENTS AND COMMON
13: C UP THE LATTICE---IN ORDER THAT UNSAFE REFS CAN BE CHECKED
14: C
15: C
16: C STACK(1)-(LSTACK) KEEPS TRACK OF PATH FROM CURRENT TERMINAL NODE
17: C TO SUPEROOT NODE
18: C INODE(J) IS 0 IF A NODE IS UNVISITED SO FAR ON ALL PATHS
19: C 1 IF A NODE HAS BEEN VISITED ON AT LEAST ONE PATH
20: C SYSERR IS SET BY SCAN
21: C
22: DO 10 I=1,PNODE
23: INODE(I) = 0
24: 10 CONTINUE
25: INODE(MAINND) = 1
26: MAIN = NODE(MAINND)
27: NUM = 0
28: C
29: C CYCLE THROUGH ALL TERMINAL NODES
30: C
31: 20 NUM = NUM + 1
32: IF (NUM.GT.PNODE-1) GO TO 240
33: C
34: C CHECK IF AN NODE IS ASF OR IF IT HAS DESC
35: C OR IF IT HAS NO PARENTS
36: C
37: IF (NODE(NUM).LE.0) GO TO 20
38: I = NODE(NUM) + SYMLEN + 4
39: C
40: C NO PARENTS
41: C
42: IF (LAT(I-1).EQ.0) GO TO 20
43: C
44: C TEST DESC FOR BEING ALL ASFS
45: C
46: IF (LAT(I).EQ.0) GO TO 40
47: L = LAT(I)
48: 30 K = LAT(L) + SYMLEN + 6
49: IF (MOD(LAT(K),8).NE.4) GO TO 20
50: L = LAT(I+1)
51: IF (L) 40, 40, 30
52: C
53: C HAVE A TERMINAL NODE;NOW CAN START RECURSIVE TRAVERSE OF ALL
54: C PATHS UPWARDS FROM IT TO ROOT
55: C ILEN--POINTER TO TOP OF CURRENT PATH
56: C JNODE--CURRENT NODE
57: C
58: 40 INODE(NUM) = 1
59: ILEN = 2
60: STACK(2) = NODE(NUM)
61: STACK(1) = 0
62: C
63: C STACK ENTRY IS 1ST WORD-POINTER TO NODE ON LIST OF PARS OFPREV
64: C NODE; 2ND WORD-NODE INDEX
65: C PROCESS NODE
66: C 1. CHECK EACH ARG. IF NOT SET OR IF PARENTS ARGLINKS NONEXISTANT
67: C SKIP TO NEXT ARG (IF NO ARGS GOTO 2); ELSE MARK EACH PARENT
68: C ARGLIST ENTRY AS SET FOR A SET ARG.
69: C 2. ADD EACH COMMON REGION TO PARENTS' LIST OF COMMON REGIONS
70: C 3. GET NEW NODE
71: C
72: 50 J = STACK(ILEN) + SYMLEN + 1
73: C
74: C ARG PROCESSING
75: C
76: J = LAT(J)
77: 60 IF (J.EQ.0) GO TO 90
78: I = IGATT2(J,5)
79: IF (I.NE.1 .OR. LAT(J+2).EQ.0) GO TO 80
80: L = LAT(J+2)
81: 70 IF (L.EQ.0) GO TO 80
82: C
83: C SET PARENT ARGS
84: C
85: CALL SATT2(LAT(L), 5, 1)
86: L = LAT(L+1)
87: GO TO 70
88: C
89: C GO ON TO NEXT ARG
90: C
91: 80 J = LAT(J+3)
92: GO TO 60
93: C
94: C COMMON PROCESSING
95: C
96: 90 J = STACK(ILEN) + SYMLEN + 2
97: II = 0
98: J = LAT(J)
99: C
100: C ACCUMULATE COMMON REGIONS
101: C
102: 100 IF (J.EQ.0) GO TO 110
103: ICOM(II+1) = LAT(J)
104: IF (LAT(J+1).NE.0) ICOM(II+1) = -ICOM(II+1)
105: II = II + 1
106: J = LAT(J+2)
107: GO TO 100
108: 110 IF (II.EQ.0) GO TO 150
109: C
110: C GET PARENT NODE AND ADD COMMON REGIONS TO IT
111: C
112: K = STACK(ILEN) + SYMLEN + 3
113: K = LAT(K)
114: 120 L = LAT(K) + SYMLEN + 2
115: DO 140 I=1,II
116: LL = MATCH(LAT(L),2,IABS(ICOM(I)))
117: IF (LL.EQ.0) GO TO 130
118: IF (ICOM(I).LT.0) LAT(LL+1) = 1
119: GO TO 140
120: C
121: C COPY COMMONNODE ENTRIES ONTO PARENTS LIST
122: C
123: 130 IF (PLAT+3.GT.LLAT) GO TO 270
124: LAT(PLAT+2) = LAT(L)
125: LAT(PLAT+1) = 0
126: LAT(PLAT) = IABS(ICOM(I))
127: IF (ICOM(I).LT.0) LAT(PLAT+1) = 1
128: LAT(L) = PLAT
129: PLAT = PLAT + 3
130: 140 CONTINUE
131: C
132: C GOONTO NEW PARENT
133: C
134: K = LAT(K+1)
135: IF (K.NE.0) GO TO 120
136: C
137: C FIND A PARENT OF THIS NODE AND TRY TO VISIT IT NEXT
138: C I CONTAINS POINTER TO PARENT LIST POSITION OF THE PARENT;
139: C J CONTAINS PARENTS INDEX IN LAT
140: C IF NO MORE PARENTS, MUST BACKUP A LEVEL
141: C
142: 150 I = STACK(ILEN) + SYMLEN + 3
143: 160 IF (LAT(I).EQ.0) GO TO 200
144: I = LAT(I)
145: 170 J = LAT(I)
146: C
147: C CHECK THAT NEW ENTRY HAS PARENTS
148: C AND THAT IT IS NOT THE SUPEROOT
149: C
150: K = J + SYMLEN + 3
151: IF (LAT(K).GT.0) GO TO 210
152: C
153: C IF THIS PARENT UNACCEPTIBLE GO ONTO NEXT PARENT
154: C MARK UNACCEPTIBLE AS VISITED SO WONT BE RECURSIVE
155: C
156: LL = PNODE - 1
157: DO 180 L=1,LL
158: IF (J.NE.NODE(L)) GO TO 180
159: INODE(L) = 1
160: GO TO 190
161: 180 CONTINUE
162: 190 I = I + 1
163: GO TO 160
164: C
165: C MUST BACK DOWN THE PATH TO THE NEXT JUNCTURE WITH
166: C AN UNTRIED PATH; CHECK FIRST FOR DONE WITH ENTIRE PATH
167: C
168: 200 IF (STACK(ILEN-1).EQ.0) GO TO 20
169: ILEN = ILEN - 2
170: J = STACK(ILEN+1)
171: IF (LAT(J+1).EQ.0) GO TO 200
172: C
173: C FOUND AN UNTRIED PATH ON THE STACK
174: C
175: I = LAT(J+1)
176: GO TO 170
177: C
178: C MARK ENTRY AS VISITED
179: C
180: 210 LL = PNODE - 1
181: DO 220 L=1,LL
182: IF (J.NE.NODE(L)) GO TO 220
183: INODE(L) = 1
184: GO TO 230
185: 220 CONTINUE
186: C
187: C ENTER ON STACK
188: C
189: 230 IF (ILEN+2.GT.LSTACK) GO TO 260
190: STACK(ILEN+1) = I
191: STACK(ILEN+2) = J
192: ILEN = ILEN + 2
193: GO TO 50
194: 240 RETURN
195: 250 SYSERR = .TRUE.
196: GO TO 240
197: 260 CALL ERROR1(33H IN SCAN, TABLE OVERFLOW OF STACK, 33)
198: GO TO 250
199: 270 CALL ERROR1(31H IN SCAN, TABLE OVERFLOW OF LAT, 31)
200: GO TO 250
201: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.