|
kusano |
7d535a |
*######DATE 8 Oct 1992 COPYRIGHT Rutherford Appleton Laboratory
|
|
kusano |
7d535a |
C######8/10/92 Toolpack tool decs employed.
|
|
kusano |
7d535a |
C######8/10/92 D version created by name change only.
|
|
kusano |
7d535a |
SUBROUTINE MC21AD(N,ICN,LICN,IP,LENR,IPERM,NUMNZ,IW)
|
|
kusano |
7d535a |
C .. Scalar Arguments ..
|
|
kusano |
7d535a |
INTEGER LICN,N,NUMNZ
|
|
kusano |
7d535a |
C ..
|
|
kusano |
7d535a |
C .. Array Arguments ..
|
|
kusano |
7d535a |
INTEGER ICN(LICN),IP(N),IPERM(N),IW(N,4),LENR(N)
|
|
kusano |
7d535a |
C ..
|
|
kusano |
7d535a |
C .. External Subroutines ..
|
|
kusano |
7d535a |
EXTERNAL MC21BD
|
|
kusano |
7d535a |
C ..
|
|
kusano |
7d535a |
C .. Executable Statements ..
|
|
kusano |
7d535a |
CALL MC21BD(N,ICN,LICN,IP,LENR,IPERM,NUMNZ,IW(1,1),IW(1,2),
|
|
kusano |
7d535a |
+ IW(1,3),IW(1,4))
|
|
kusano |
7d535a |
RETURN
|
|
kusano |
7d535a |
C
|
|
kusano |
7d535a |
END
|
|
kusano |
7d535a |
SUBROUTINE MC21BD(N,ICN,LICN,IP,LENR,IPERM,NUMNZ,PR,ARP,CV,OUT)
|
|
kusano |
7d535a |
C PR(I) IS THE PREVIOUS ROW TO I IN THE DEPTH FIRST SEARCH.
|
|
kusano |
7d535a |
C IT IS USED AS A WORK ARRAY IN THE SORTING ALGORITHM.
|
|
kusano |
7d535a |
C ELEMENTS (IPERM(I),I) I=1, ... N ARE NON-ZERO AT THE END OF THE
|
|
kusano |
7d535a |
C ALGORITHM UNLESS N ASSIGNMENTS HAVE NOT BEEN MADE. IN WHICH CASE
|
|
kusano |
7d535a |
C (IPERM(I),I) WILL BE ZERO FOR N-NUMNZ ENTRIES.
|
|
kusano |
7d535a |
C CV(I) IS THE MOST RECENT ROW EXTENSION AT WHICH COLUMN I
|
|
kusano |
7d535a |
C WAS VISITED.
|
|
kusano |
7d535a |
C ARP(I) IS ONE LESS THAN THE NUMBER OF NON-ZEROS IN ROW I
|
|
kusano |
7d535a |
C WHICH HAVE NOT BEEN SCANNED WHEN LOOKING FOR A CHEAP ASSIGNMENT.
|
|
kusano |
7d535a |
C OUT(I) IS ONE LESS THAN THE NUMBER OF NON-ZEROS IN ROW I
|
|
kusano |
7d535a |
C WHICH HAVE NOT BEEN SCANNED DURING ONE PASS THROUGH THE MAIN LOOP.
|
|
kusano |
7d535a |
C
|
|
kusano |
7d535a |
C INITIALIZATION OF ARRAYS.
|
|
kusano |
7d535a |
C .. Scalar Arguments ..
|
|
kusano |
7d535a |
INTEGER LICN,N,NUMNZ
|
|
kusano |
7d535a |
C ..
|
|
kusano |
7d535a |
C .. Array Arguments ..
|
|
kusano |
7d535a |
INTEGER ARP(N),CV(N),ICN(LICN),IP(N),IPERM(N),LENR(N),OUT(N),PR(N)
|
|
kusano |
7d535a |
C ..
|
|
kusano |
7d535a |
C .. Local Scalars ..
|
|
kusano |
7d535a |
INTEGER I,II,IN1,IN2,IOUTK,J,J1,JORD,K,KK
|
|
kusano |
7d535a |
C ..
|
|
kusano |
7d535a |
C .. Executable Statements ..
|
|
kusano |
7d535a |
DO 10 I = 1,N
|
|
kusano |
7d535a |
ARP(I) = LENR(I) - 1
|
|
kusano |
7d535a |
CV(I) = 0
|
|
kusano |
7d535a |
IPERM(I) = 0
|
|
kusano |
7d535a |
10 CONTINUE
|
|
kusano |
7d535a |
NUMNZ = 0
|
|
kusano |
7d535a |
C
|
|
kusano |
7d535a |
C
|
|
kusano |
7d535a |
C MAIN LOOP.
|
|
kusano |
7d535a |
C EACH PASS ROUND THIS LOOP EITHER RESULTS IN A NEW ASSIGNMENT
|
|
kusano |
7d535a |
C OR GIVES A ROW WITH NO ASSIGNMENT.
|
|
kusano |
7d535a |
DO 100 JORD = 1,N
|
|
kusano |
7d535a |
J = JORD
|
|
kusano |
7d535a |
PR(J) = -1
|
|
kusano |
7d535a |
DO 70 K = 1,JORD
|
|
kusano |
7d535a |
C LOOK FOR A CHEAP ASSIGNMENT
|
|
kusano |
7d535a |
IN1 = ARP(J)
|
|
kusano |
7d535a |
IF (IN1.LT.0) GO TO 30
|
|
kusano |
7d535a |
IN2 = IP(J) + LENR(J) - 1
|
|
kusano |
7d535a |
IN1 = IN2 - IN1
|
|
kusano |
7d535a |
DO 20 II = IN1,IN2
|
|
kusano |
7d535a |
I = ICN(II)
|
|
kusano |
7d535a |
IF (IPERM(I).EQ.0) GO TO 80
|
|
kusano |
7d535a |
20 CONTINUE
|
|
kusano |
7d535a |
C NO CHEAP ASSIGNMENT IN ROW.
|
|
kusano |
7d535a |
ARP(J) = -1
|
|
kusano |
7d535a |
C BEGIN LOOKING FOR ASSIGNMENT CHAIN STARTING WITH ROW J.
|
|
kusano |
7d535a |
30 CONTINUE
|
|
kusano |
7d535a |
OUT(J) = LENR(J) - 1
|
|
kusano |
7d535a |
C INNER LOOP. EXTENDS CHAIN BY ONE OR BACKTRACKS.
|
|
kusano |
7d535a |
DO 60 KK = 1,JORD
|
|
kusano |
7d535a |
IN1 = OUT(J)
|
|
kusano |
7d535a |
IF (IN1.LT.0) GO TO 50
|
|
kusano |
7d535a |
IN2 = IP(J) + LENR(J) - 1
|
|
kusano |
7d535a |
IN1 = IN2 - IN1
|
|
kusano |
7d535a |
C FORWARD SCAN.
|
|
kusano |
7d535a |
DO 40 II = IN1,IN2
|
|
kusano |
7d535a |
I = ICN(II)
|
|
kusano |
7d535a |
IF (CV(I).EQ.JORD) GO TO 40
|
|
kusano |
7d535a |
C COLUMN I HAS NOT YET BEEN ACCESSED DURING THIS PASS.
|
|
kusano |
7d535a |
J1 = J
|
|
kusano |
7d535a |
J = IPERM(I)
|
|
kusano |
7d535a |
CV(I) = JORD
|
|
kusano |
7d535a |
PR(J) = J1
|
|
kusano |
7d535a |
OUT(J1) = IN2 - II - 1
|
|
kusano |
7d535a |
GO TO 70
|
|
kusano |
7d535a |
C
|
|
kusano |
7d535a |
40 CONTINUE
|
|
kusano |
7d535a |
C
|
|
kusano |
7d535a |
C BACKTRACKING STEP.
|
|
kusano |
7d535a |
50 CONTINUE
|
|
kusano |
7d535a |
J = PR(J)
|
|
kusano |
7d535a |
IF (J.EQ.-1) GO TO 100
|
|
kusano |
7d535a |
60 CONTINUE
|
|
kusano |
7d535a |
C
|
|
kusano |
7d535a |
70 CONTINUE
|
|
kusano |
7d535a |
C
|
|
kusano |
7d535a |
C NEW ASSIGNMENT IS MADE.
|
|
kusano |
7d535a |
80 CONTINUE
|
|
kusano |
7d535a |
IPERM(I) = J
|
|
kusano |
7d535a |
ARP(J) = IN2 - II - 1
|
|
kusano |
7d535a |
NUMNZ = NUMNZ + 1
|
|
kusano |
7d535a |
DO 90 K = 1,JORD
|
|
kusano |
7d535a |
J = PR(J)
|
|
kusano |
7d535a |
IF (J.EQ.-1) GO TO 100
|
|
kusano |
7d535a |
II = IP(J) + LENR(J) - OUT(J) - 2
|
|
kusano |
7d535a |
I = ICN(II)
|
|
kusano |
7d535a |
IPERM(I) = J
|
|
kusano |
7d535a |
90 CONTINUE
|
|
kusano |
7d535a |
C
|
|
kusano |
7d535a |
100 CONTINUE
|
|
kusano |
7d535a |
C
|
|
kusano |
7d535a |
C IF MATRIX IS STRUCTURALLY SINGULAR, WE NOW COMPLETE THE
|
|
kusano |
7d535a |
C PERMUTATION IPERM.
|
|
kusano |
7d535a |
IF (NUMNZ.EQ.N) RETURN
|
|
kusano |
7d535a |
DO 110 I = 1,N
|
|
kusano |
7d535a |
ARP(I) = 0
|
|
kusano |
7d535a |
110 CONTINUE
|
|
kusano |
7d535a |
K = 0
|
|
kusano |
7d535a |
DO 130 I = 1,N
|
|
kusano |
7d535a |
IF (IPERM(I).NE.0) GO TO 120
|
|
kusano |
7d535a |
K = K + 1
|
|
kusano |
7d535a |
OUT(K) = I
|
|
kusano |
7d535a |
GO TO 130
|
|
kusano |
7d535a |
C
|
|
kusano |
7d535a |
120 CONTINUE
|
|
kusano |
7d535a |
J = IPERM(I)
|
|
kusano |
7d535a |
ARP(J) = I
|
|
kusano |
7d535a |
130 CONTINUE
|
|
kusano |
7d535a |
K = 0
|
|
kusano |
7d535a |
DO 140 I = 1,N
|
|
kusano |
7d535a |
IF (ARP(I).NE.0) GO TO 140
|
|
kusano |
7d535a |
K = K + 1
|
|
kusano |
7d535a |
IOUTK = OUT(K)
|
|
kusano |
7d535a |
IPERM(IOUTK) = I
|
|
kusano |
7d535a |
140 CONTINUE
|
|
kusano |
7d535a |
RETURN
|
|
kusano |
7d535a |
C
|
|
kusano |
7d535a |
END
|
|
kusano |
7d535a |
|