*######DATE 8 Oct 1992 COPYRIGHT Rutherford Appleton Laboratory

C######8/10/92 Toolpack tool decs employed.

C######8/10/92 D version created by name change only.

      SUBROUTINE MC21AD(N,ICN,LICN,IP,LENR,IPERM,NUMNZ,IW)

C     .. Scalar Arguments ..

      INTEGER LICN,N,NUMNZ

C     ..

C     .. Array Arguments ..

      INTEGER ICN(LICN),IP(N),IPERM(N),IW(N,4),LENR(N)

C     ..

C     .. External Subroutines ..

      EXTERNAL MC21BD

C     ..

C     .. Executable Statements ..

      CALL MC21BD(N,ICN,LICN,IP,LENR,IPERM,NUMNZ,IW(1,1),IW(1,2),

     +            IW(1,3),IW(1,4))

      RETURN

C

      END

      SUBROUTINE MC21BD(N,ICN,LICN,IP,LENR,IPERM,NUMNZ,PR,ARP,CV,OUT)

C   PR(I) IS THE PREVIOUS ROW TO I IN THE DEPTH FIRST SEARCH.

C IT IS USED AS A WORK ARRAY IN THE SORTING ALGORITHM.

C   ELEMENTS (IPERM(I),I) I=1, ... N  ARE NON-ZERO AT THE END OF THE

C ALGORITHM UNLESS N ASSIGNMENTS HAVE NOT BEEN MADE.  IN WHICH CASE

C (IPERM(I),I) WILL BE ZERO FOR N-NUMNZ ENTRIES.

C   CV(I) IS THE MOST RECENT ROW EXTENSION AT WHICH COLUMN I

C WAS VISITED.

C   ARP(I) IS ONE LESS THAN THE NUMBER OF NON-ZEROS IN ROW I

C WHICH HAVE NOT BEEN SCANNED WHEN LOOKING FOR A CHEAP ASSIGNMENT.

C   OUT(I) IS ONE LESS THAN THE NUMBER OF NON-ZEROS IN ROW I

C WHICH HAVE NOT BEEN SCANNED DURING ONE PASS THROUGH THE MAIN LOOP.

C

C   INITIALIZATION OF ARRAYS.

C     .. Scalar Arguments ..

      INTEGER LICN,N,NUMNZ

C     ..

C     .. Array Arguments ..

      INTEGER ARP(N),CV(N),ICN(LICN),IP(N),IPERM(N),LENR(N),OUT(N),PR(N)

C     ..

C     .. Local Scalars ..

      INTEGER I,II,IN1,IN2,IOUTK,J,J1,JORD,K,KK

C     ..

C     .. Executable Statements ..

      DO 10 I = 1,N

        ARP(I) = LENR(I) - 1

        CV(I) = 0

        IPERM(I) = 0

   10 CONTINUE

      NUMNZ = 0

C

C

C   MAIN LOOP.

C   EACH PASS ROUND THIS LOOP EITHER RESULTS IN A NEW ASSIGNMENT

C OR GIVES A ROW WITH NO ASSIGNMENT.

      DO 100 JORD = 1,N

        J = JORD

        PR(J) = -1

        DO 70 K = 1,JORD

C LOOK FOR A CHEAP ASSIGNMENT

          IN1 = ARP(J)

          IF (IN1.LT.0) GO TO 30

          IN2 = IP(J) + LENR(J) - 1

          IN1 = IN2 - IN1

          DO 20 II = IN1,IN2

            I = ICN(II)

            IF (IPERM(I).EQ.0) GO TO 80

   20     CONTINUE

C   NO CHEAP ASSIGNMENT IN ROW.

          ARP(J) = -1

C   BEGIN LOOKING FOR ASSIGNMENT CHAIN STARTING WITH ROW J.

   30     CONTINUE

          OUT(J) = LENR(J) - 1

C INNER LOOP.  EXTENDS CHAIN BY ONE OR BACKTRACKS.

          DO 60 KK = 1,JORD

            IN1 = OUT(J)

            IF (IN1.LT.0) GO TO 50

            IN2 = IP(J) + LENR(J) - 1

            IN1 = IN2 - IN1

C FORWARD SCAN.

            DO 40 II = IN1,IN2

              I = ICN(II)

              IF (CV(I).EQ.JORD) GO TO 40

C   COLUMN I HAS NOT YET BEEN ACCESSED DURING THIS PASS.

              J1 = J

              J = IPERM(I)

              CV(I) = JORD

              PR(J) = J1

              OUT(J1) = IN2 - II - 1

              GO TO 70

C

   40       CONTINUE

C

C   BACKTRACKING STEP.

   50       CONTINUE

            J = PR(J)

            IF (J.EQ.-1) GO TO 100

   60     CONTINUE

C

   70   CONTINUE

C

C   NEW ASSIGNMENT IS MADE.

   80   CONTINUE

        IPERM(I) = J

        ARP(J) = IN2 - II - 1

        NUMNZ = NUMNZ + 1

        DO 90 K = 1,JORD

          J = PR(J)

          IF (J.EQ.-1) GO TO 100

          II = IP(J) + LENR(J) - OUT(J) - 2

          I = ICN(II)

          IPERM(I) = J

   90   CONTINUE

C

  100 CONTINUE

C

C   IF MATRIX IS STRUCTURALLY SINGULAR, WE NOW COMPLETE THE

C PERMUTATION IPERM.

      IF (NUMNZ.EQ.N) RETURN

      DO 110 I = 1,N

        ARP(I) = 0

  110 CONTINUE

      K = 0

      DO 130 I = 1,N

        IF (IPERM(I).NE.0) GO TO 120

        K = K + 1

        OUT(K) = I

        GO TO 130

C

  120   CONTINUE

        J = IPERM(I)

        ARP(J) = I

  130 CONTINUE

      K = 0

      DO 140 I = 1,N

        IF (ARP(I).NE.0) GO TO 140

        K = K + 1

        IOUTK = OUT(K)

        IPERM(IOUTK) = I

  140 CONTINUE

      RETURN

C

      END