V10/cmd/pfort/SCAN.f

      SUBROUTINE SCAN(MAINND)
      INTEGER PLAT, SYMLEN, PNODE, STACK
      LOGICAL ERR, SYSERR, ABORT
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
      COMMON /CEXPRS/ LSTACK, STACK(620)
      COMMON /HEAD/ LNODE, PNODE, NODE(500)
      COMMON/ SCR1/ LINODE, INODE(500)
      COMMON /SCR2/ LICOM, ICOM(500)
C
C     SUBROUTINE PERCOLATES SETTING INFO ABOUT ARGUMENTS AND COMMON
C     UP THE LATTICE---IN ORDER THAT UNSAFE REFS CAN BE CHECKED
C
C
C     STACK(1)-(LSTACK) KEEPS TRACK OF PATH FROM CURRENT TERMINAL NODE
C     TO SUPEROOT NODE
C     INODE(J) IS 0 IF A NODE IS UNVISITED SO FAR ON ALL PATHS
C               1 IF A NODE HAS BEEN VISITED ON AT LEAST ONE PATH
C     SYSERR IS SET BY SCAN
C
      DO 10 I=1,PNODE
        INODE(I) = 0
   10 CONTINUE
      INODE(MAINND) = 1
      MAIN = NODE(MAINND)
      NUM = 0
C
C     CYCLE THROUGH ALL TERMINAL NODES
C
   20 NUM = NUM + 1
      IF (NUM.GT.PNODE-1) GO TO 240
C
C      CHECK IF AN NODE IS ASF OR IF IT HAS DESC
C     OR IF IT HAS NO PARENTS
C
      IF (NODE(NUM).LE.0) GO TO 20
      I = NODE(NUM) + SYMLEN + 4
C
C     NO PARENTS
C
      IF (LAT(I-1).EQ.0) GO TO 20
C
C     TEST DESC FOR BEING ALL ASFS
C
      IF (LAT(I).EQ.0) GO TO 40
      L = LAT(I)
   30 K = LAT(L) + SYMLEN + 6
      IF (MOD(LAT(K),8).NE.4) GO TO 20
      L = LAT(I+1)
      IF (L) 40, 40, 30
C
C     HAVE A TERMINAL NODE;NOW CAN START RECURSIVE TRAVERSE OF ALL
C     PATHS UPWARDS FROM IT  TO ROOT
C     ILEN--POINTER TO TOP OF CURRENT PATH
C     JNODE--CURRENT NODE
C
   40 INODE(NUM) = 1
      ILEN = 2
      STACK(2) = NODE(NUM)
      STACK(1) = 0
C
C     STACK ENTRY IS 1ST WORD-POINTER TO NODE ON LIST OF PARS OFPREV
C     NODE; 2ND WORD-NODE INDEX
C     PROCESS NODE
C     1. CHECK EACH ARG. IF NOT SET OR IF PARENTS ARGLINKS NONEXISTANT
C      SKIP TO NEXT ARG (IF NO ARGS GOTO 2); ELSE MARK EACH PARENT
C      ARGLIST ENTRY AS SET FOR A SET ARG.
C     2. ADD EACH COMMON REGION TO PARENTS' LIST OF COMMON REGIONS
C     3. GET NEW NODE
C
   50 J = STACK(ILEN) + SYMLEN + 1
C
C     ARG PROCESSING
C
      J = LAT(J)
   60 IF (J.EQ.0) GO TO 90
      I = IGATT2(J,5)
      IF (I.NE.1 .OR. LAT(J+2).EQ.0) GO TO 80
      L = LAT(J+2)
   70 IF (L.EQ.0) GO TO 80
C
C     SET PARENT ARGS
C
      CALL SATT2(LAT(L), 5, 1)
      L = LAT(L+1)
      GO TO 70
C
C     GO ON TO NEXT ARG
C
   80 J = LAT(J+3)
      GO TO 60
C
C     COMMON PROCESSING
C
   90 J = STACK(ILEN) + SYMLEN + 2
      II = 0
      J = LAT(J)
C
C     ACCUMULATE COMMON REGIONS
C
  100 IF (J.EQ.0) GO TO 110
      ICOM(II+1) = LAT(J)
      IF (LAT(J+1).NE.0) ICOM(II+1) = -ICOM(II+1)
      II = II + 1
      J = LAT(J+2)
      GO TO 100
  110 IF (II.EQ.0) GO TO 150
C
C     GET PARENT NODE AND ADD COMMON REGIONS TO IT
C
      K = STACK(ILEN) + SYMLEN + 3
      K = LAT(K)
  120 L = LAT(K) + SYMLEN + 2
      DO 140 I=1,II
        LL = MATCH(LAT(L),2,IABS(ICOM(I)))
        IF (LL.EQ.0) GO TO 130
        IF (ICOM(I).LT.0) LAT(LL+1) = 1
        GO TO 140
C
C     COPY COMMONNODE ENTRIES ONTO PARENTS LIST
C
  130   IF (PLAT+3.GT.LLAT) GO TO 270
        LAT(PLAT+2) = LAT(L)
        LAT(PLAT+1) = 0
        LAT(PLAT) = IABS(ICOM(I))
        IF (ICOM(I).LT.0) LAT(PLAT+1) = 1
        LAT(L) = PLAT
        PLAT = PLAT + 3
  140 CONTINUE
C
C     GOONTO NEW PARENT
C
      K = LAT(K+1)
      IF (K.NE.0) GO TO 120
C
C     FIND A PARENT OF THIS NODE AND TRY TO VISIT IT NEXT
C     I CONTAINS POINTER TO PARENT LIST POSITION OF THE PARENT;
C     J CONTAINS PARENTS INDEX IN LAT
C     IF NO MORE PARENTS, MUST BACKUP A LEVEL
C
  150 I = STACK(ILEN) + SYMLEN + 3
  160 IF (LAT(I).EQ.0) GO TO 200
      I = LAT(I)
  170 J = LAT(I)
C
C     CHECK THAT NEW ENTRY HAS PARENTS
C     AND THAT IT IS NOT THE SUPEROOT
C
      K = J + SYMLEN + 3
      IF (LAT(K).GT.0) GO TO 210
C
C     IF THIS PARENT UNACCEPTIBLE GO ONTO NEXT PARENT
C     MARK UNACCEPTIBLE AS VISITED SO WONT BE RECURSIVE
C
      LL = PNODE - 1
      DO 180 L=1,LL
        IF (J.NE.NODE(L)) GO TO 180
        INODE(L) = 1
        GO TO 190
  180 CONTINUE
  190 I = I + 1
      GO TO 160
C
C     MUST BACK DOWN THE PATH TO THE NEXT JUNCTURE WITH
C     AN UNTRIED PATH;  CHECK FIRST FOR DONE WITH ENTIRE PATH
C
  200 IF (STACK(ILEN-1).EQ.0) GO TO 20
      ILEN = ILEN - 2
      J = STACK(ILEN+1)
      IF (LAT(J+1).EQ.0) GO TO 200
C
C     FOUND AN UNTRIED PATH ON THE STACK
C
      I = LAT(J+1)
      GO TO 170
C
C     MARK ENTRY AS VISITED
C
  210 LL = PNODE - 1
      DO 220 L=1,LL
        IF (J.NE.NODE(L)) GO TO 220
        INODE(L) = 1
        GO TO 230
  220 CONTINUE
C
C     ENTER ON STACK
C
  230 IF (ILEN+2.GT.LSTACK) GO TO 260
      STACK(ILEN+1) = I
      STACK(ILEN+2) = J
      ILEN = ILEN + 2
      GO TO 50
  240 RETURN
  250 SYSERR = .TRUE.
      GO TO 240
  260 CALL ERROR1(33H IN SCAN, TABLE OVERFLOW OF STACK, 33)
      GO TO 250
  270 CALL ERROR1(31H IN SCAN, TABLE OVERFLOW OF LAT, 31)
      GO TO 250
      END