Return to ASLEV.f CVS log

Up to [Research Unix] / researchv10no / cmd / pfort

researchv10 Norman

      SUBROUTINE ASLEV(IPT)
C
C      ASLEV TAKES A SUBLATTICE WITH ITS ROOT AT NODE(IABS(IPT)))
C      AND READJUSTS THE LEVELS IN THE SUBLATTICE
C      IN ACCORDANCE WITH NEW LEVEL AT ROOT
C     NOTE, IPT LT 0 FROM CALL IN SETREF  (EXT) AND FROM ACTUALS
C     PASSED DOWN IN PROC
C
      INTEGER PNODE, STACK, PLAT, FIND, SYMLEN
      INTEGER ZERO(1)
      LOGICAL SYSERR, ERR, ABORT, GR
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /HEAD/ LNODE, PNODE, NODE(500)
      COMMON /SCR1/ LINODE, INODE(500)
      COMMON /SCR2/ LSTACK, STACK(500)
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
      DATA ZERO(1) /0/
C
C     STACK (IS) IS SIGNED NODE INDEX OF SUBPGM
C     IF GT 0, NODE IS ALONG A RED LINK TO PARENT
C     IF LT 0, NODE IS ALONG  A GREEN LINK TO PARENT
C
C     STACK(IS+1) IS PTR TO TWO WORD DESC ENTRY FOR THIS
C     SUBPGM, OR 0 FOR END OF DESC LIST
C
      K = IABS (IPT )
      K = SYMLEN + NODE(K) + 4
      STACK(2) = IPT
      STACK (1) = IABS ( LAT(K) )
      IS = 2
C      DOES TOP OF STACK ENTRY HAVE UNVISITED DESC
   10 IF (STACK(IS-1).NE.0) GO TO 20
C      TEST IF ARE DONE WITH SUBLATTICE
      IF (IS.EQ.2) RETURN
C      POP UP A LEVEL IN PATH
      IS = IS - 2
      GO TO 10
C      UPDATE ENTRY OF NEXT DESCENDENT TO BE CHECKED ON STACK
   20 K = STACK(IS-1)
      STACK(IS-1) = IABS (LAT(K+1))
C     LAT(K) CONTAINS SIGNED INDEX OF DESC BEING PROCESSED
C     SIGN INDICATES COLOR OF LINK TO PARENT, (I.E.
C     NODE AT TOP OF STACK)
C     LT 0 IS GREEN LINK, GT 0 IS RED LINK
C     L IS INDEX IN NODE(*) OF DESC BEING PROCESSED
C     KK IS INDEX IN LAT(*) OF DESC BEING PROCESSED
      LL = 1
      IF( LAT(K) .LT. 0) LL = -1
      KK = IABS(LAT(K))
      L = FIND(KK)
C     SKIP ALL DESC WITH NEGATIVE LEVELS
      IF (INODE(L).LT.0) GO TO 10
C     SEE IF STACK TOO SHORT FOR LOOPS
      IF( IS.LE.2) GOTO 40
C     CHECK FOR LOOPS IN PATH STACK DESC
      LOOP = 0
      GR = .FALSE.
      IF(LL.EQ.(-1)) GR = .TRUE.
      DO 60 I = 2,IS,2
      IF(LOOP) 70,70,90
   90 IF(STACK(I).LT.0) GR = .TRUE.
      GOTO 60
 70   IF(L.EQ.IABS(STACK(I))) LOOP = I
 60   CONTINUE
C      NO LOOPS
      IF(LOOP.EQ.0) GOTO 40
C     LOOP OF MIXED COLORED LINKS
C     DO NOT STACK DESC
      IF(GR) GOTO 10
C     RECURSION
      ABORT = .TRUE.
      CALL ERROR2(19H RECURSIVE CALL OF ,19,LAT(KK), 1, 1, 0)
      DO 80 K=LOOP,IS,2
      KK = IABS(STACK(K))
      KK = NODE(KK)
 80   CALL ERROR2(11H INVOLVING ,11,LAT(KK),1, 0, 0)
      CALL ERROR2(1H1, 0, ZERO, -3, 0, 1)
   30 RETURN
C      TEST IF DESC LEVEL IS ALREADY GT LEVEL OF PAR
C      THEN NEEDNT CHECK PART OF SUBLATTICE UNDER THIS DESC
   40 K = IABS (STACK(IS))
      IF (INODE(L).GT.INODE(K)) GO TO 10
C      PUSH DESC ONTO STACK AFTER FIXING HIS LEVEL
      INODE(L) = INODE(K) + 1
C      TEST AGAINST LNODE BECAUSE  SCRATCH ARRAY
C      IS AS LONG AS NODE ARRAY
      IF (IS+2.GT.LNODE) GO TO 50
      STACK(IS+2) = LL * L
      K = NODE(L) + SYMLEN + 4
      STACK(IS+1) = IABS( LAT(K))
      IS = IS + 2
      GO TO 10
   50 SYSERR = .TRUE.
      CALL ERROR1(43H IN ASLEV, PATH LONGER THAN NUMBER OF NODES, 43)
      GO TO 30
      END

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.