143 lines
3.9 KiB
Fortran
143 lines
3.9 KiB
Fortran
*######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
|
|
|