![[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.