      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
