SUBROUTINE NUMBER(SND, NUM, NDSTK, LVLS2, NDEG, RENUM, LVLST,LSTPT,&
& NR, NFLG, IBW2, IPF2, IPFA, ISDIR)
! NUMBER PRODUCES THE NUMBERING OF THE GRAPH FOR MIN BANDWIDTH
! SND- ON INPUT THE NODE TO BEGIN NUMBERING ON
! NUM- ON INPUT AND OUTPUT, THE NEXT AVAILABLE NUMBER
! LVLS2- THE LEVEL STRUCTURE TO BE USED IN NUMBERING
! RENUM- THE ARRAY USED TO STORE THE NEW NUMBERING
! LVLST- ON OUTPUT CONTAINS LEVEL STRUCTURE
! LSTPT(I)- ON OUTPUT, INDEX INTO LVLST TO FIRST NODE IN ITH LVL
! LSTPT(I+1) - LSTPT(I) = NUMBER OF NODES IN ITH LVL
! NFLG- =+1 IF SND IS FORWARD END OF PSEUDO-DIAM
! =-1 IF SND IS REVERSE END OF PSEUDO-DIAM
! IBW2- BANDWIDTH OF NEW NUMBERING COMPUTED BY NUMBER
! IPF2- PROFILE OF NEW NUMBERING COMPUTED BY NUMBER
! IPFA- WORKING STORAGE USED TO COMPUTE PROFILE AND BANDWIDTH
! ISDIR- INDICATES STEP DIRECTION USED IN NUMBERING(+1 OR -1)
! USE INTEGER*2 NDSTK WITH AN IBM 360 OR 370.
INTEGER NDSTK
INTEGER SND, XA, XB, XC, XD, CX, ENDC,RENUM, TEST
! COMMON /GRA/ N, IDPTH, IDEG
! THE STORAGE IN COMMON BLOCKS CC AND LVLW IS NOW FREE AND CAN
! BE USED FOR STACKS.
!COMMON /LVLW/ STKA(100), STKB(100), STKC(100)
!COMMON /CC/ STKD(100)
DIMENSION IPFA(N)
DIMENSION NDSTK(NR,IDEG), LVLS2(N), NDEG(N), RENUM(N+1), LVLST(N),LSTPT(N)
INTEGER,POINTER ::STKA(:),STKB(:),STKC(:),STKD(:)
INTEGER :: SZ1,SZ2
!
STKA => NHIGH
STKB => NLOW
STKC => NACUM
STKD => AUX
!
! SET UP LVLST AND LSTPT FROM LVLS2
DO 10 I=1,N
IPFA(I) = 0
10 END DO
NSTPT = 1
DO 30 I=1,IDPTH
LSTPT(I) = NSTPT
DO 20 J=1,N
IF (LVLS2(J)/=I) CYCLE
LVLST(NSTPT) = J
NSTPT = NSTPT + 1
20 END DO
30 END DO
LSTPT(IDPTH+1) = NSTPT
! STKA, STKB, STKC AND STKD ARE STACKS WITH POINTERS
! XA,XB,XC, AND XD. CX IS A SPECIAL POINTER INTO STKC WHICH
! INDICATES THE PARTICULAR NODE BEING PROCESSED.
! LVLN KEEPS TRACK OF THE LEVEL WE ARE WORKING AT.
! INITIALLY STKC CONTAINS ONLY THE INITIAL NODE, SND.
LVLN = 0
IF (NFLG < 0) LVLN = IDPTH + 1
XC = 1
STKC(XC) = SND
40 CX = 1
XD = 0
LVLN = LVLN + NFLG
LST = LSTPT(LVLN)
LND = LSTPT(LVLN+1) - 1
! BEGIN PROCESSING NODE STKC(CX)
50 IPRO = STKC(CX)
RENUM(IPRO) = NUM
NUM = NUM + ISDIR
ENDC = NDEG(IPRO)
XA = 0
XB = 0
! CHECK ALL ADJACENT NODES
DO 80 I=1,ENDC
TEST = NDSTK(IPRO,I)
INX = RENUM(TEST)
! ONLY NODES NOT NUMBERED OR ALREADY ON A STACK ARE ADDED
IF (INX == 0) GO TO 60
IF (INX < 0) CYCLE
! DO PRELIMINARY BANDWIDTH AND PROFILE CALCULATIONS
NBW = (RENUM(IPRO)-INX)*ISDIR
IF (ISDIR>0) INX = RENUM(IPRO)
IF (IPFA(INX) < NBW) IPFA(INX) = NBW
CYCLE
60 RENUM(TEST) = -1
! PUT NODES ON SAME LEVEL ON STKA, ALL OTHERS ON STKB
IF (LVLS2(TEST) == LVLS2(IPRO)) GO TO 70
XB = XB + 1
STKB(XB) = TEST
CYCLE
70 XA = XA + 1
STKA(XA) = TEST
80 END DO
! SORT STKA AND STKB INTO INCREASING DEGREE AND ADD STKA TO STKC
! AND STKB TO STKD
IF (XA == 0) GO TO 100
IF (XA == 1) GO TO 90
!---------------------------------------------------------------------
SZ1=SIZE(STKC)
SZ2=XC+XA
IF(SZ1 < SZ2) THEN
WRITE(*,*) 'GPS_NUMBER - Check #1: on the fly reallocation of STKC'
CALL psb_realloc(sz2,nacum,info) !CALL REALLOC(NACUM,SZ1,SZ2)
STKC => NACUM
END IF
!---------------------------------------------------------------------
CALL SORTDG(STKC, STKA, XC, XA, NDEG)
GO TO 100
90 XC = XC + 1
!---------------------------------------------------------------------
SZ1=SIZE(STKC)
SZ2=XC
IF(SZ1 < SZ2) THEN
WRITE(*,*) 'GPS_NUMBER - Check #2: on the fly reallocation of STKC'
SZ2=SZ2+INIT
CALL psb_realloc(sz2,nacum,info) !CALL REALLOC(NACUM,SZ1,SZ2)
STKC => NACUM
END IF
!---------------------------------------------------------------------
STKC(XC) = STKA(XA)
100 IF (XB == 0) GO TO 120
IF (XB == 1) GO TO 110
!---------------------------------------------------------------------
SZ1=SIZE(STKD)
SZ2=XD+XB
IF(SZ1 < SZ2) THEN
WRITE(*,*) 'GPS_NUMBER - Check #3: on the fly reallocation of STKD'
CALL psb_realloc(sz2,aux,info) !CALL REALLOC(AUX,SZ1,SZ2)
STKD => AUX
END IF
!---------------------------------------------------------------------
CALL SORTDG(STKD, STKB, XD, XB, NDEG)
GO TO 120
110 XD = XD + 1
!---------------------------------------------------------------------
SZ1=SIZE(STKD)
SZ2=XD
IF(SZ1 < SZ2) THEN
WRITE(*,*) 'GPS_NUMBER - Check #4: on the fly reallocation of STKD'
SZ2=SZ2+INIT
CALL psb_realloc(sz2,aux,info) ! CALL REALLOC(AUX,SZ1,SZ2)
STKD => AUX
END IF
!---------------------------------------------------------------------
STKD(XD) = STKB(XB)
! BE SURE TO PROCESS ALL NODES IN STKC
120 CX = CX + 1
IF (XC>=CX) GO TO 50
! WHEN STKC IS EXHAUSTED LOOK FOR MIN DEGREE NODE IN SAME LEVEL
! WHICH HAS NOT BEEN PROCESSED
MAX = IDEG + 1
SND = N + 1
DO 130 I=LST,LND
TEST = LVLST(I)
IF (RENUM(TEST)/=0) CYCLE
IF (NDEG(TEST)>=MAX) CYCLE
RENUM(SND) = 0
RENUM(TEST) = -1
MAX = NDEG(TEST)
SND = TEST
130 END DO
IF (SND == N+1) GO TO 140
XC = XC + 1
!---------------------------------------------------------------------
SZ1=SIZE(STKC)
SZ2=XC
IF(SZ1 < SZ2) THEN
WRITE(*,*) 'GPS_NUMBER - Check #5: on the fly reallocation of STKC'
SZ2=SZ2+INIT
CALL psb_realloc(sz2,nacum,info) !CALL REALLOC(NACUM,SZ1,SZ2)
STKC => NACUM
END IF
!---------------------------------------------------------------------
STKC(XC) = SND
GO TO 50
! IF STKD IS EMPTY WE ARE DONE, OTHERWISE COPY STKD ONTO STKC
! AND BEGIN PROCESSING NEW STKC
140 IF (XD == 0) GO TO 160
!---------------------------------------------------------------------
SZ1=SIZE(STKC)
SZ2=XD
IF(SZ1 < SZ2) THEN
WRITE(*,*) 'GPS_NUMBER - Check #6: on the fly reallocation of STKC'
SZ2=SZ2+INIT
CALL psb_realloc(sz2,nacum,info) !CALL REALLOC(NACUM,SZ1,SZ2)
STKC => NACUM
END IF
!---------------------------------------------------------------------
DO 150 I=1,XD
STKC(I) = STKD(I)
150 END DO
XC = XD
GO TO 40
! DO FINAL BANDWIDTH AND PROFILE CALCULATIONS
160 DO 170 I=1,N
IF (IPFA(I)>IBW2) IBW2 = IPFA(I)
IPF2 = IPF2 + IPFA(I)
170 END DO
!
RETURN
END SUBROUTINE NUMBER