SUBROUTINE reduce(ndstk,nr,d1,iold,renum,ndeg,ibw2,ipf2,idpth)
! SUBROUTINE REDUCE DETERMINES A ROW AND COLUMN PERMUTATION WHICH,
! WHEN APPLIED TO A GIVEN SPARSE MATRIX, PRODUCES A PERMUTED
! MATRIX WITH A SMALLER BANDWIDTH AND PROFILE.
! THE INPUT ARRAY IS A CONNECTION TABLE WHICH REPRESENTS THE
! INDICES OF THE NONZERO ELEMENTS OF THE MATRIX, A. THE ALGO-
! RITHM IS DESCRIBED IN TERMS OF THE ADJACENCY GRAPH WHICH
! HAS THE CHARACTERISTIC THAT THERE IS AN EDGE (CONNECTION)
! BETWEEN NODES I AND J IF A(I,J) /= 0 AND I /= J.
! DIMENSIONING INFORMATION--THE FOLLOWING INTEGER ARRAYS MUST BE
! DIMENSIONED IN THE CALLING ROUTINE.
! NDSTK(NR,D1) D1 IS >= MAXIMUM DEGREE OF ALL NODES.
! IOLD(D2) D2 AND NR ARE >= THE TOTAL NUMBER OF
! RENUM(D2+1) NODES IN THE GRAPH.
! NDEG(D2) STORAGE REQUIREMENTS CAN BE SIGNIFICANTLY
! LVL(D2) DECREASED FOR IBM 360 AND 370 COMPUTERS
! LVLS1(D2) BY REPLACING INTEGER NDSTK BY
! LVLS2(D2) INTEGER*2 NDSTK IN SUBROUTINES REDUCE,
! CCSTOR(D2) DGREE, FNDIAM, TREE AND NUMBER.
! COMMON INFORMATION--THE FOLLOWING COMMON BLOCK MUST BE IN THE
! CALLING ROUTINE.
! COMMON/GRA/N,IDPTH,IDEG
! EXPLANATION OF INPUT VARIABLES--
! NDSTK- CONNECTION TABLE REPRESENTING GRAPH.
! NDSTK(I,J)=NODE NUMBER OF JTH CONNECTION TO NODE
! NUMBER I. A CONNECTION OF A NODE TO ITSELF IS NOT
! LISTED. EXTRA POSITIONS MUST HAVE ZERO FILL.
! NR- ROW DIMENSION ASSIGNED NDSTK IN CALLING PROGRAM.
! IOLD(I)- NUMBERING OF ITH NODE UPON INPUT.
! IF NO NUMBERING EXISTS THEN IOLD(I)=I.
! N- NUMBER OF NODES IN GRAPH (EQUAL TO ORDER OF MATRIX).
! IDEG- MAXIMUM DEGREE OF ANY NODE IN THE GRAPH.
! EXPLANATION OF OUTPUT VARIABLES--
! RENUM(I)- THE NEW NUMBER FOR THE ITH NODE.
! NDEG(I)- THE DEGREE OF THE ITH NODE.
! IBW2- THE BANDWIDTH AFTER RENUMBERING.
! IPF2- THE PROFILE AFTER RENUMBERING.
! IDPTH- NUMBER OF LEVELS IN REDUCE LEVEL STRUCTURE.
! THE FOLLOWING ONLY HAVE MEANING IF THE GRAPH WAS CONNECTED--
! LVL(I)- INDEX INTO LVLS1 TO THE FIRST NODE IN LEVEL I.
! LVL(I+1)-LVL(I)= NUMBER OF NODES IN ITH LEVEL
! LVLS1- NODE NUMBERS LISTED BY LEVEL.
! LVLS2(I)- THE LEVEL ASSIGNED TO NODE I BY REDUCE.
! WORKING STORAGE VARIABLE--
! CCSTOR
! LOCAL STORAGE--
! COMMON/CC/-SUBROUTINES REDUCE, SORT2 AND PIKLVL ASSUME THAT
! THE GRAPH HAS AT MOST 50 CONNECTED COMPONENTS.
! SUBROUTINE FNDIAM ASSUMES THAT THERE ARE AT MOST
! 100 NODES IN THE LAST LEVEL.
! COMMON/LVLW/-SUBROUTINES SETUP AND PIKLVL ASSUME THAT THERE
! ARE AT MOST 100 LEVELS.
! USE INTEGER*2 NDSTK WITH AN IBM 360 OR 370.
! COMMON /GRA/ N, IDPTH, IDEG
! IT IS ASSUMED THAT THE GRAPH HAS AT MOST 50 CONNECTED COMPONENTS.
! COMMON /CC/ XCC, SIZEG(50), STPT(50)
! COMMON /LVLW/ NHIGH(100), NLOW(100), NACUM(100)
!
INTEGER :: d1
INTEGER :: stnode, rvnode, stnum, sbnum
INTEGER :: ndstk(nr,d1), iold(nr), renum(nr+1), ndeg(nr)
INTEGER :: lvl(nr), lvls1(nr), lvls2(nr), ccstor(nr)
n = nr
idpth = 0
ideg = d1
ALLOCATE(SIZEG(NR),STPT(NR), STAT=INFO)
IF(INFO /= 0) THEN
WRITE(*,*) 'ERROR! Memory allocation # 1 failure in GPS'
STOP
END IF
!
ALLOCATE(NHIGH(INIT), NLOW(INIT), NACUM(INIT), AUX(INIT), STAT=INFO)
IF(INFO /= 0) THEN
WRITE(*,*) 'ERROR! Memory allocation # 2 failure in GPS'
STOP
END IF
!
IBW2 = 0
IPF2 = 0
! SET RENUM(I)=0 FOR ALL I TO INDICATE NODE I IS UNNUMBERED
DO 10 I=1,N
RENUM(I) = 0
10 END DO
! COMPUTE DEGREE OF EACH NODE AND ORIGINAL BANDWIDTH AND PROFILE
CALL DGREE(NDSTK, NR, NDEG, IOLD, IBW1, IPF1)
! SBNUM= LOW END OF AVAILABLE NUMBERS FOR RENUMBERING
! STNUM= HIGH END OF AVAILABLE NUMBERS FOR RENUMBERING
SBNUM = 1
STNUM = N
! NUMBER THE NODES OF DEGREE ZERO
DO 20 I=1,N
IF (NDEG(I)>0) CYCLE
RENUM(I) = STNUM
STNUM = STNUM - 1
20 END DO
! FIND AN UNNUMBERED NODE OF MIN DEGREE TO START ON
30 LOWDG = IDEG + 1
NFLG = 1
ISDIR = 1
DO 40 I=1,N
IF (NDEG(I)>=LOWDG) CYCLE
IF (RENUM(I)>0) CYCLE
LOWDG = NDEG(I)
STNODE = I
40 END DO
! FIND PSEUDO-DIAMETER AND ASSOCIATED LEVEL STRUCTURES.
! STNODE AND RVNODE ARE THE ENDS OF THE DIAM AND LVLS1 AND LVLS2
! ARE THE RESPECTIVE LEVEL STRUCTURES.
CALL FNDIAM(STNODE, RVNODE, NDSTK, NR, NDEG, LVL, LVLS1,LVLS2, CCSTOR, IDFLT)
IF (NDEG(STNODE) <= NDEG(RVNODE)) GO TO 50
! NFLG INDICATES THE END TO BEGIN NUMBERING ON
NFLG = -1
STNODE = RVNODE
50 CALL SETUP(LVL, LVLS1, LVLS2)
! FIND ALL THE CONNECTED COMPONENTS (XCC COUNTS THEM)
XCC = 0
LROOT = 1
LVLN = 1
DO 60 I=1,N
IF (LVL(I)/=0) CYCLE
XCC = XCC + 1
STPT(XCC) = LROOT
CALL TREE(I, NDSTK, NR, LVL, CCSTOR, NDEG, LVLWTH, LVLBOT,LVLN, MAXLW, N)
SIZEG(XCC) = LVLBOT + LVLWTH - LROOT
LROOT = LVLBOT + LVLWTH
LVLN = LROOT
60 END DO
IF (SORT2() == 0) GO TO 70
CALL PIKLVL(LVLS1, LVLS2, CCSTOR, IDFLT, ISDIR)
! ON RETURN FROM PIKLVL, ISDIR INDICATES THE DIRECTION THE LARGEST
! COMPONENT FELL. ISDIR IS MODIFIED NOW TO INDICATE THE NUMBERING
! DIRECTION. NUM IS SET TO THE PROPER VALUE FOR THIS DIRECTION.
70 ISDIR = ISDIR*NFLG
NUM = SBNUM
IF (ISDIR < 0) NUM = STNUM
CALL NUMBER(STNODE, NUM, NDSTK, LVLS2, NDEG, RENUM, LVLS1,LVL,&
& NR, NFLG, IBW2, IPF2, CCSTOR, ISDIR)
! UPDATE STNUM OR SBNUM AFTER NUMBERING
IF (ISDIR < 0) STNUM = NUM
IF (ISDIR>0) SBNUM = NUM
IF (SBNUM <= STNUM) GO TO 30
IF (IBW2 <= IBW1) GO TO 90
! IF ORIGINAL NUMBERING IS BETTER THAN NEW ONE, SET UP TO RETURN IT
DO 80 I=1,N
RENUM(I) = IOLD(I)
80 END DO
IBW2 = IBW1
IPF2 = IPF1
!
90 DEALLOCATE(SIZEG,STPT)
DEALLOCATE(NHIGH,NLOW,AUX,NACUM)
RETURN
END SUBROUTINE REDUCE