From: wolf Date: Fri, 7 Jun 2002 08:01:48 +0000 (+0000) Subject: Move into repository, so that it is possible to get these files via CVS. Have to... X-Git-Url: https://gitweb.dealii.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=36703fdce8d87ee7387c5d1c4c78a7c260ac8a98;p=dealii-svn.git Move into repository, so that it is possible to get these files via CVS. Have to delete them again immediately to avoid copyright problems. git-svn-id: https://svn.dealii.org/trunk@6021 0785d39b-7218-0410-832d-ea1e28bc413d --- diff --git a/deal.II/contrib/hsl/source/ma27.f b/deal.II/contrib/hsl/source/ma27.f new file mode 100644 index 0000000000..19b0ab4104 --- /dev/null +++ b/deal.II/contrib/hsl/source/ma27.f @@ -0,0 +1,2053 @@ +C ******************************************************************* +* COPYRIGHT (c) 1993 AEA Technology + +C None of the comments in this Copyright notice between the lines +C of asterisks shall be removed or altered in any way. + +C This Package is intended for compilation without modification, +C so most of the embedded comments have been removed. + +C ALL USE IS SUBJECT TO LICENCE. For full details of an HSL ARCHIVE +C Licence, see http://hsl.rl.ac.uk/archive/cou.html + +C Please note that for an HSL ARCHIVE Licence: + +C 1. The Package must not be copied for use by any other person. +C Supply of any part of the library by the Licensee to a third party +C shall be subject to prior written agreement between AEA +C Technology plc and the Licensee on suitable terms and conditions, +C which will include financial conditions. +C 2. All information on the Package is provided to the Licensee on the +C understanding that the details thereof are confidential. +C 3. All publications issued by the Licensee that include results obtained +C with the help of one or more of the Packages shall acknowledge the +C use of the Packages. The Licensee will notify the Numerical Analysis +C Group at Rutherford Appleton Laboratory of any such publication. +C 4. The Packages may be modified by or on behalf of the Licensee +C for such use in research applications but at no time shall such +C Packages or modifications thereof become the property of the +C Licensee. The Licensee shall make available free of charge to the +C copyright holder for any purpose all information relating to +C any modification. +C 5. Neither CCLRC nor AEA Technology plc shall be liable for any +C direct or consequential loss or damage whatsoever arising out of +C the use of Packages by the Licensee. +C ******************************************************************* + +*######DATE 13 Jan 1993 +C Toolpack tool decs employed. +C MA27SD reference removed - replaced for the vax (9/12/93). +C MA27ED and MA27FD not used in MA27CD. +C SAVE statements added. +C DATA statements made PARAMETER. +C 19/3/98 If there is an error (IFLAG<0), NSTEPS is set to zero and no +C monitor printing is produced on exit. Extra tests for NZ=0 added. +C 16/4/98 Small alteration to format of monitor printing +C 7/12/98 Real copy of NELIM used in OPS calculation. +C 26/3/99 Special treatment of full and near-full rows added to MA27AD. +C 29/3/99 Test on NSTEPS added to MA27BD. +C 29/3/00 Test on absolute size of pivots added (MA27TD/PIVTOL). +C 3/7/00 Bug associated with 26/3/99 changes corrected in MA27HD. + + SUBROUTINE MA27AD(N,NZ,IRN,ICN,IW,LIW,IKEEP,IW1,NSTEPS,IFLAG) + INTEGER IFLAG,LIW,N,NSTEPS,NZ + INTEGER ICN(*),IKEEP(N,3),IRN(*),IW(LIW),IW1(N,2) + INTEGER I,IWFR,K,L1,L2,LLIW + EXTERNAL MA27GD,MA27HD,MA27JD,MA27KD,MA27LD,MA27MD,MA27SD + INTRINSIC MIN0 + COMMON /MA27DD/U,LP,MP,LDIAG + COMMON /MA27ED/OPS,IERROR,NRLTOT,NIRTOT,NRLNEC,NIRNEC,NRLADU, + + NIRADU,NRLBDU,NIRBDU,NCMPA,NCMPBR,NCMPBI,NTWO,NEIG + COMMON /MA27FD/IOVFLO,NEMIN,IFRLVL(20) + DOUBLE PRECISION OPS,U + INTEGER IERROR,IOVFLO,LDIAG,LP,MP,NCMPA,NCMPBI,NCMPBR,NEIG,NEMIN, + + NIRADU,NIRBDU,NIRNEC,NIRTOT,NRLADU,NRLBDU,NRLNEC,NRLTOT, + + NTWO + INTEGER IFRLVL + SAVE /MA27DD/,/MA27ED/,/MA27FD/ + IF (LDIAG.LE.0 .OR. MP.LE.0) GO TO 40 + WRITE (MP,FMT=10) N,NZ,LIW,IFLAG + 10 FORMAT(/,/,' ENTERING MA27AD WITH N NZ LIW IFLAG', + + /,21X,I7,I7,I9,I7) + NSTEPS = 0 + K = MIN0(8,NZ) + IF (LDIAG.GT.1) K = NZ + IF (K.GT.0) WRITE (MP,FMT=20) (IRN(I),ICN(I),I=1,K) + 20 FORMAT (17H MATRIX NON-ZEROS,/,4 (I9,I6),/, + + (I9,I6,I9,I6,I9,I6,I9,I6)) + K = MIN0(10,N) + IF (LDIAG.GT.1) K = N + IF (IFLAG.EQ.1 .AND. K.GT.0) WRITE (MP,FMT=30) (IKEEP(I,1),I=1,K) + 30 FORMAT (12H IKEEP(.,1)=,10I6,/, (12X,10I6)) + 40 IF (N.LT.1 .OR. N.GT.IOVFLO) GO TO 70 + IF (NZ.LT.0) GO TO 100 + LLIW = LIW - 2*N + L1 = LLIW + 1 + L2 = L1 + N + IF (IFLAG.EQ.1) GO TO 50 + IF (LIW.LT.2*NZ+3*N+1) GO TO 130 + IFLAG = 0 + CALL MA27GD(N,NZ,IRN,ICN,IW,LLIW,IW1,IW1(1,2),IW(L1),IWFR,IFLAG) + CALL MA27HD(N,IW1,IW,LLIW,IWFR,IW(L1),IW(L2),IKEEP(1,2), + + IKEEP(1,3),IKEEP) + GO TO 60 + 50 IF (LIW.LT.NZ+3*N+1) GO TO 120 + CALL MA27JD(N,NZ,IRN,ICN,IKEEP,IW,LLIW,IW1,IW1(1,2),IW(L1),IWFR, + + IFLAG) + CALL MA27KD(N,IW1,IW,LLIW,IWFR,IKEEP,IKEEP(1,2),IW(L1),IW(L2)) + 60 CALL MA27LD(N,IW1,IW(L1),IKEEP,IKEEP(1,2),IKEEP(1,3),IW(L2), + + NSTEPS) + IF(NZ.GE.1) IW(1) = IRN(1) + 1 + CALL MA27MD(N,NZ,IRN,ICN,IKEEP,IKEEP(1,3),IKEEP(1,2),IW(L2), + + NSTEPS,IW1,IW1(1,2),IW) + GO TO 160 + 70 IFLAG = -1 + IF (LP.GT.0) WRITE (LP,FMT=80) IFLAG + 80 FORMAT (42H **** ERROR RETURN FROM MA27AD **** IFLAG=,I3) + IF (LP.GT.0) WRITE (LP,FMT=90) N + 90 FORMAT (30H VALUE OF N OUT OF RANGE ... =,I10) + GO TO 160 + 100 IFLAG = -2 + IF (LP.GT.0) WRITE (LP,FMT=80) IFLAG + IF (LP.GT.0) WRITE (LP,FMT=110) NZ + 110 FORMAT (30H VALUE OF NZ OUT OF RANGE .. =,I10) + GO TO 160 + 120 IERROR = NZ + 3*N + 1 + GO TO 140 + 130 IERROR = 2*NZ + 3*N + 1 + 140 IFLAG = -3 + IF (LP.GT.0) WRITE (LP,FMT=80) IFLAG + IF (LP.GT.0) WRITE (LP,FMT=150) LIW,IERROR + 150 FORMAT (38H LIW TOO SMALL, MUST BE INCREASED FROM,I10,3H TO, + + 9H AT LEAST,I10) + 160 IF (LDIAG.LE.0 .OR. MP.LE.0 .OR. IFLAG.LT.0) GO TO 200 + WRITE (MP,FMT=170) NSTEPS,IFLAG,OPS,IERROR,NRLTOT,NIRTOT,NRLNEC, + + NIRNEC,NRLADU,NIRADU,NCMPA + 170 FORMAT (/,53H LEAVING MA27AD WITH NSTEPS IFLAG OPS IERROR NRLT + + ,2HOT,7H NIRTOT,/,20X,2I7,F7.0,3I7,/,20X, + + 20H NRLNEC NIRNEC NRLAD,15HU NIRADU NCMPA,/,20X,6I7) + K = MIN0(9,N) + IF (LDIAG.GT.1) K = N + IF (K.GT.0) WRITE (MP,FMT=30) (IKEEP(I,1),I=1,K) + K = MIN0(K,NSTEPS) + IF (K.GT.0) WRITE (MP,FMT=180) (IKEEP(I,2),I=1,K) + 180 FORMAT (12H IKEEP(.,2)=,10I6,/, (12X,10I6)) + IF (K.GT.0) WRITE (MP,FMT=190) (IKEEP(I,3),I=1,K) + 190 FORMAT (12H IKEEP(.,3)=,10I6,/, (12X,10I6)) + 200 RETURN + END + SUBROUTINE MA27BD(N,NZ,IRN,ICN,A,LA,IW,LIW,IKEEP,NSTEPS,MAXFRT, + + IW1,IFLAG) + INTEGER IFLAG,LA,LIW,MAXFRT,N,NSTEPS,NZ + DOUBLE PRECISION A(LA) + INTEGER ICN(*),IKEEP(N,3),IRN(*),IW(LIW),IW1(N) + INTEGER I,IAPOS,IBLK,IPOS,IROWS,J1,J2,JJ,K,KBLK,KZ,LEN,NCOLS, + + NROWS,NZ1 + EXTERNAL MA27ND,MA27OD + INTRINSIC IABS,MIN0 + COMMON /MA27DD/U,LP,MP,LDIAG + COMMON /MA27ED/OPS,IERROR,NRLTOT,NIRTOT,NRLNEC,NIRNEC,NRLADU, + + NIRADU,NRLBDU,NIRBDU,NCMPA,NCMPBR,NCMPBI,NTWO,NEIG + COMMON /MA27FD/IOVFLO,NEMIN,IFRLVL(20) + DOUBLE PRECISION OPS,U + INTEGER IERROR,IOVFLO,LDIAG,LP,MP,NCMPA,NCMPBI,NCMPBR,NEIG,NEMIN, + + NIRADU,NIRBDU,NIRNEC,NIRTOT,NRLADU,NRLBDU,NRLNEC,NRLTOT, + + NTWO + INTEGER IFRLVL + SAVE /MA27DD/,/MA27ED/,/MA27FD/ + IF (LDIAG.LE.0 .OR. MP.LE.0) GO TO 60 + WRITE (MP,FMT=10) N,NZ,LA,LIW,NSTEPS,U + 10 FORMAT (/,/, + + ' ENTERING MA27BD WITH N NZ LA LIW', + + ' NSTEPS U',/,21X,I7,I7,I9,I9,I7,1PE10.2) + KZ = MIN0(6,NZ) + IF (LDIAG.GT.1) KZ = NZ + IF (NZ.GT.0) WRITE (MP,FMT=20) (A(K),IRN(K),ICN(K),K=1,KZ) + 20 FORMAT (17H MATRIX NON-ZEROS,/,1X,2 (1P,D16.3,2I6),/, + + (1X,1P,D16.3,2I6,1P,D16.3,2I6)) + K = MIN0(9,N) + IF (LDIAG.GT.1) K = N + IF (K.GT.0) WRITE (MP,FMT=30) (IKEEP(I,1),I=1,K) + 30 FORMAT (12H IKEEP(.,1)=,10I6,/, (12X,10I6)) + K = MIN0(K,NSTEPS) + IF (K.GT.0) WRITE (MP,FMT=40) (IKEEP(I,2),I=1,K) + 40 FORMAT (12H IKEEP(.,2)=,10I6,/, (12X,10I6)) + IF (K.GT.0) WRITE (MP,FMT=50) (IKEEP(I,3),I=1,K) + 50 FORMAT (12H IKEEP(.,3)=,10I6,/, (12X,10I6)) + 60 IF (N.LT.1 .OR. N.GT.IOVFLO) GO TO 70 + IF (NZ.LT.0) GO TO 100 + IF (LIW.LT.NZ) GO TO 120 + IF (LA.LT.NZ+N) GO TO 150 + IF (NSTEPS.LT.1 .OR. NSTEPS.GT.N) GO TO 175 + CALL MA27ND(N,NZ,NZ1,A,LA,IRN,ICN,IW,LIW,IKEEP,IW1,IFLAG) + IF (IFLAG.EQ.-3) GO TO 130 + IF (IFLAG.EQ.-4) GO TO 160 + CALL MA27OD(N,NZ1,A,LA,IW,LIW,IKEEP,IKEEP(1,3),NSTEPS,MAXFRT, + + IKEEP(1,2),IW1,IFLAG) + IF (IFLAG.EQ.-3) GO TO 130 + IF (IFLAG.EQ.-4) GO TO 160 + IF (IFLAG.EQ.-5) GO TO 180 + IF (IFLAG.EQ.-6) GO TO 200 + IF (IFLAG.EQ.3 .AND. MP.GT.0) WRITE (MP,FMT=65) IFLAG,IERROR + 65 FORMAT (52H *** WARNING MESSAGE FROM SUBROUTINE MA27BD *** IFLA, + + 3HG =,I2,/,5X,25HMATRIX IS SINGULAR. RANK=,I5) + GO TO 220 + 70 IFLAG = -1 + IF (LP.GT.0) WRITE (LP,FMT=80) IFLAG + 80 FORMAT (42H **** ERROR RETURN FROM MA27BD **** IFLAG=,I3) + IF (LP.GT.0) WRITE (LP,FMT=90) N + 90 FORMAT (30H VALUE OF N OUT OF RANGE ... =,I10) + GO TO 220 + 100 IFLAG = -2 + IF (LP.GT.0) WRITE (LP,FMT=80) IFLAG + IF (LP.GT.0) WRITE (LP,FMT=110) NZ + 110 FORMAT (30H VALUE OF NZ OUT OF RANGE .. =,I10) + GO TO 220 + 120 IFLAG = -3 + IERROR = NZ + 130 IF (LP.GT.0) WRITE (LP,FMT=80) IFLAG + IF (LP.GT.0) WRITE (LP,FMT=140) LIW,IERROR + 140 FORMAT (38H LIW TOO SMALL, MUST BE INCREASED FROM,I10,3H TO, + + 9H AT LEAST,I10) + GO TO 220 + 150 IFLAG = -4 + IERROR = NZ + N + 160 IF (LP.GT.0) WRITE (LP,FMT=80) IFLAG + IF (LP.GT.0) WRITE (LP,FMT=170) LA,IERROR + 170 FORMAT (38H LA TOO SMALL, MUST BE INCREASED FROM ,I10,3H TO, + + 9H AT LEAST,I10) + GO TO 220 + 175 IFLAG = -7 + IF (LP.GT.0) WRITE (LP,FMT=80) IFLAG + IF (LP.GT.0) WRITE (LP,FMT='(A)') ' NSTEPS is out of range' + GO TO 220 + 180 IF (LP.GT.0) WRITE (LP,FMT=80) IFLAG + IF (LP.GT.0) WRITE (LP,FMT=190) IERROR + 190 FORMAT (20H ZERO PIVOT AT STAGE,I10,24H WHEN INPUT MATRIX DECLA, + + 12HRED DEFINITE) + GO TO 220 + 200 IF (LP.GT.0) WRITE (LP,FMT=80) IFLAG + IF (LP.GT.0) WRITE (LP,FMT=210) + 210 FORMAT (36H CHANGE IN SIGN OF PIVOT ENCOUNTERED,13H WHEN FACTORI, + + 28HNG ALLEGEDLY DEFINITE MATRIX) + 220 IF (LDIAG.LE.0 .OR. MP.LE.0 .OR. IFLAG.LT.0) GO TO 310 + WRITE (MP,FMT=230) MAXFRT,IFLAG,NRLBDU,NIRBDU,NCMPBR,NCMPBI,NTWO, + + IERROR + 230 FORMAT (/,20H LEAVING MA27BD WITH,/,10X, + + 36H MAXFRT IFLAG NRLBDU NIRBDU NCMPBR, + + 21H NCMPBI NTWO IERROR,/,11X,8I7) + IF (IFLAG.LT.0) GO TO 310 + KBLK = IABS(IW(1)+0) + IF (KBLK.EQ.0) GO TO 310 + IF (LDIAG.EQ.1) KBLK = 1 + IPOS = 2 + IAPOS = 1 + DO 300 IBLK = 1,KBLK + NCOLS = IW(IPOS) + NROWS = IW(IPOS+1) + J1 = IPOS + 2 + IF (NCOLS.GT.0) GO TO 240 + NCOLS = -NCOLS + NROWS = 1 + J1 = J1 - 1 + 240 WRITE (MP,FMT=250) IBLK,NROWS,NCOLS + 250 FORMAT (14H BLOCK PIVOT =,I8,8H NROWS =,I8,8H NCOLS =,I8) + J2 = J1 + NCOLS - 1 + IPOS = J2 + 1 + WRITE (MP,FMT=260) (IW(JJ),JJ=J1,J2) + 260 FORMAT (17H COLUMN INDICES =,10I6,/, (17X,10I6)) + WRITE (MP,FMT=270) + 270 FORMAT (46H REAL ENTRIES .. EACH ROW STARTS ON A NEW LINE) + LEN = NCOLS + DO 290 IROWS = 1,NROWS + J1 = IAPOS + J2 = IAPOS + LEN - 1 + WRITE (MP,FMT=280) (A(JJ),JJ=J1,J2) + 280 FORMAT (1P,5D13.3) + LEN = LEN - 1 + IAPOS = J2 + 1 + 290 CONTINUE + 300 CONTINUE + 310 RETURN + END + SUBROUTINE MA27CD(N,A,LA,IW,LIW,W,MAXFRT,RHS,IW1,NSTEPS) + INTEGER LA,LIW,MAXFRT,N,NSTEPS + DOUBLE PRECISION A(LA),RHS(N),W(MAXFRT) + INTEGER IW(LIW),IW1(NSTEPS) + INTEGER I,IAPOS,IBLK,IPOS,IROWS,J1,J2,JJ,K,KBLK,LATOP,LEN,NBLK, + + NCOLS,NROWS + EXTERNAL MA27QD,MA27RD + INTRINSIC IABS,MIN0 + COMMON /MA27DD/U,LP,MP,LDIAG + DOUBLE PRECISION U + INTEGER LDIAG,LP,MP + SAVE /MA27DD/ + IF (LDIAG.LE.0 .OR. MP.LE.0) GO TO 110 + WRITE (MP,FMT=10) N,LA,LIW,MAXFRT,NSTEPS + 10 FORMAT (/,/,49H ENTERING MA27CD WITH N LA LIW MAXFRT, + + 8H NSTEPS,/,21X,5I7) + KBLK = IABS(IW(1)+0) + IF (KBLK.EQ.0) GO TO 90 + IF (LDIAG.EQ.1) KBLK = 1 + IPOS = 2 + IAPOS = 1 + DO 80 IBLK = 1,KBLK + NCOLS = IW(IPOS) + NROWS = IW(IPOS+1) + J1 = IPOS + 2 + IF (NCOLS.GT.0) GO TO 20 + NCOLS = -NCOLS + NROWS = 1 + J1 = J1 - 1 + 20 WRITE (MP,FMT=30) IBLK,NROWS,NCOLS + 30 FORMAT (14H BLOCK PIVOT =,I8,8H NROWS =,I8,8H NCOLS =,I8) + J2 = J1 + NCOLS - 1 + IPOS = J2 + 1 + WRITE (MP,FMT=40) (IW(JJ),JJ=J1,J2) + 40 FORMAT (17H COLUMN INDICES =,10I6,/, (17X,10I6)) + WRITE (MP,FMT=50) + 50 FORMAT (46H REAL ENTRIES .. EACH ROW STARTS ON A NEW LINE) + LEN = NCOLS + DO 70 IROWS = 1,NROWS + J1 = IAPOS + J2 = IAPOS + LEN - 1 + WRITE (MP,FMT=60) (A(JJ),JJ=J1,J2) + 60 FORMAT (1P,5D13.3) + LEN = LEN - 1 + IAPOS = J2 + 1 + 70 CONTINUE + 80 CONTINUE + 90 K = MIN0(10,N) + IF (LDIAG.GT.1) K = N + IF (N.GT.0) WRITE (MP,FMT=100) (RHS(I),I=1,K) + 100 FORMAT (4H RHS,1P,5D13.3,/, (4X,1P,5D13.3)) + 110 IF (IW(1).LT.0) GO TO 130 + NBLK = IW(1) + IF (NBLK.GT.0) GO TO 140 + DO 120 I = 1,N + RHS(I) = 0.0D0 + 120 CONTINUE + GO TO 150 + 130 NBLK = -IW(1) + 140 CALL MA27QD(N,A,LA,IW(2),LIW-1,W,MAXFRT,RHS,IW1,NBLK,LATOP) + CALL MA27RD(N,A,LA,IW(2),LIW-1,W,MAXFRT,RHS,IW1,NBLK,LATOP) + 150 IF (LDIAG.LE.0 .OR. MP.LE.0) GO TO 170 + WRITE (MP,FMT=160) + 160 FORMAT (/,/,20H LEAVING MA27CD WITH) + IF (N.GT.0) WRITE (MP,FMT=100) (RHS(I),I=1,K) + 170 RETURN + END + BLOCK DATA MA27SD + COMMON /MA27DD/U,LP,MP,LDIAG + COMMON /MA27FD/IOVFLO,NEMIN,IFRLVL(20) + DOUBLE PRECISION U + INTEGER IOVFLO,LDIAG,LP,MP,NEMIN + INTEGER IFRLVL + COMMON /MA27TD/FRATIO,PIVTOL + DOUBLE PRECISION FRATIO,PIVTOL + SAVE /MA27DD/,/MA27FD/,/MA27TD/ + DATA U/0.1D0/,LP/6/,MP/6/,LDIAG/0/ + DATA FRATIO/1.0D0/, PIVTOL/0.0D0/ + DATA IOVFLO/2139062143/,NEMIN/1/, + + IFRLVL(1),IFRLVL(2),IFRLVL(3),IFRLVL(4),IFRLVL(5),IFRLVL(6), + + IFRLVL(7),IFRLVL(8),IFRLVL(9),IFRLVL(10),IFRLVL(11), + + IFRLVL(12),IFRLVL(13),IFRLVL(14),IFRLVL(15),IFRLVL(16), + + IFRLVL(17),IFRLVL(18),IFRLVL(19),IFRLVL(20)/32639,32639, + + 32639,32639,14,9,8,8,9,10,32639,32639,32639,32689,24,11,9,8, + + 9,10/ + END + SUBROUTINE MA27GD(N,NZ,IRN,ICN,IW,LW,IPE,IQ,FLAG,IWFR,IFLAG) + INTEGER IFLAG,IWFR,LW,N,NZ + INTEGER FLAG(N),ICN(*),IPE(N),IQ(N),IRN(*),IW(LW) + INTEGER I,ID,J,JN,K,K1,K2,L,LAST,LR,N1,NDUP + COMMON /MA27DD/U,LP,MP,LDIAG + COMMON /MA27ED/OPS,IERROR,NRLTOT,NIRTOT,NRLNEC,NIRNEC,NRLADU, + + NIRADU,NRLBDU,NIRBDU,NCMPA,NCMPBR,NCMPBI,NTWO,NEIG + DOUBLE PRECISION OPS,U + INTEGER IERROR,LDIAG,LP,MP,NCMPA,NCMPBI,NCMPBR,NEIG,NIRADU,NIRBDU, + + NIRNEC,NIRTOT,NRLADU,NRLBDU,NRLNEC,NRLTOT,NTWO + SAVE /MA27DD/,/MA27ED/ + IERROR = 0 + DO 10 I = 1,N + IPE(I) = 0 + 10 CONTINUE + LR = NZ + IF (NZ.EQ.0) GO TO 120 + DO 110 K = 1,NZ + I = IRN(K) + J = ICN(K) + IF (I-J) 20,40,30 + 20 IF (I.GE.1 .AND. J.LE.N) GO TO 90 + GO TO 50 + 30 IF (J.GE.1 .AND. I.LE.N) GO TO 90 + GO TO 50 + 40 IF (I.GE.1 .AND. I.LE.N) GO TO 80 + 50 IERROR = IERROR + 1 + IFLAG = 1 + IF (IERROR.LE.1 .AND. MP.GT.0) WRITE (MP,FMT=60) IFLAG + 60 FORMAT (52H *** WARNING MESSAGE FROM SUBROUTINE MA27AD *** IFLA, + + 3HG =,I2) + IF (IERROR.LE.10 .AND. MP.GT.0) WRITE (MP,FMT=70) K,I,J + 70 FORMAT (I6,19HTH NON-ZERO (IN ROW,I6,11H AND COLUMN,I6, + + 9H) IGNORED) + 80 I = 0 + J = 0 + GO TO 100 + 90 IPE(I) = IPE(I) + 1 + IPE(J) = IPE(J) + 1 + 100 IW(K) = J + LR = LR + 1 + IW(LR) = I + 110 CONTINUE + 120 IQ(1) = 1 + N1 = N - 1 + IF (N1.LE.0) GO TO 140 + DO 130 I = 1,N1 + FLAG(I) = 0 + IF (IPE(I).EQ.0) IPE(I) = -1 + IQ(I+1) = IPE(I) + IQ(I) + 1 + IPE(I) = IQ(I) + 130 CONTINUE + 140 LAST = IPE(N) + IQ(N) + FLAG(N) = 0 + IF (LR.GE.LAST) GO TO 160 + K1 = LR + 1 + DO 150 K = K1,LAST + IW(K) = 0 + 150 CONTINUE + 160 IPE(N) = IQ(N) + IWFR = LAST + 1 + IF (NZ.EQ.0) GO TO 230 + DO 220 K = 1,NZ + J = IW(K) + IF (J.LE.0) GO TO 220 + L = K + IW(K) = 0 + DO 210 ID = 1,NZ + IF (L.GT.NZ) GO TO 170 + L = L + NZ + GO TO 180 + 170 L = L - NZ + 180 I = IW(L) + IW(L) = 0 + IF (I.LT.J) GO TO 190 + L = IQ(J) + 1 + IQ(J) = L + JN = IW(L) + IW(L) = -I + GO TO 200 + 190 L = IQ(I) + 1 + IQ(I) = L + JN = IW(L) + IW(L) = -J + 200 J = JN + IF (J.LE.0) GO TO 220 + 210 CONTINUE + 220 CONTINUE + 230 NDUP = 0 + DO 280 I = 1,N + K1 = IPE(I) + 1 + K2 = IQ(I) + IF (K1.LE.K2) GO TO 240 + IPE(I) = 0 + IQ(I) = 0 + GO TO 280 + 240 DO 260 K = K1,K2 + J = -IW(K) + IF (J.LE.0) GO TO 270 + L = IQ(J) + 1 + IQ(J) = L + IW(L) = I + IW(K) = J + IF (FLAG(J).NE.I) GO TO 250 + NDUP = NDUP + 1 + IW(L) = 0 + IW(K) = 0 + 250 FLAG(J) = I + 260 CONTINUE + 270 IQ(I) = IQ(I) - IPE(I) + IF (NDUP.EQ.0) IW(K1-1) = IQ(I) + 280 CONTINUE + IF (NDUP.EQ.0) GO TO 310 + IWFR = 1 + DO 300 I = 1,N + K1 = IPE(I) + 1 + IF (K1.EQ.1) GO TO 300 + K2 = IQ(I) + IPE(I) + L = IWFR + IPE(I) = IWFR + IWFR = IWFR + 1 + DO 290 K = K1,K2 + IF (IW(K).EQ.0) GO TO 290 + IW(IWFR) = IW(K) + IWFR = IWFR + 1 + 290 CONTINUE + IW(L) = IWFR - L - 1 + 300 CONTINUE + 310 RETURN + END + SUBROUTINE MA27HD(N,IPE,IW,LW,IWFR,NV,NXT,LST,IPD,FLAG) + INTEGER IWFR,LW,N + INTEGER FLAG(N),IPD(N),IPE(N),IW(LW),LST(N),NV(N),NXT(N) + INTEGER I,ID,IDL,IDN,IE,IP,IS,JP,JP1,JP2,JS,K,K1,K2,KE,KP,KP0,KP1, + + KP2,KS,L,LEN,LIMIT,LN,LS,LWFR,MD,ME,ML,MS,NEL,NFLG,NP, + + NP0,NS,NVPIV,NVROOT,ROOT + EXTERNAL MA27ID + INTRINSIC IABS,MIN0 + COMMON /MA27ED/OPS,IERROR,NRLTOT,NIRTOT,NRLNEC,NIRNEC,NRLADU, + + NIRADU,NRLBDU,NIRBDU,NCMPA,NCMPBR,NCMPBI,NTWO,NEIG + COMMON /MA27FD/IOVFLO,NEMIN,IFRLVL(20) + DOUBLE PRECISION OPS + INTEGER IERROR,IOVFLO,NCMPA,NCMPBI,NCMPBR,NEIG,NEMIN,NIRADU, + + NIRBDU,NIRNEC,NIRTOT,NRLADU,NRLBDU,NRLNEC,NRLTOT,NTWO + INTEGER IFRLVL + COMMON /MA27TD/FRATIO,PIVTOL + DOUBLE PRECISION FRATIO,PIVTOL + SAVE /MA27ED/,/MA27FD/,/MA27TD/ + DO 10 I = 1,N + IPD(I) = 0 + NV(I) = 1 + FLAG(I) = IOVFLO + 10 CONTINUE + MD = 1 + NCMPA = 0 + NFLG = IOVFLO + NEL = 0 + ROOT = N+1 + NVROOT = 0 + DO 30 IS = 1,N + K = IPE(IS) + IF (K.LE.0) GO TO 20 + ID = IW(K) + 1 + NS = IPD(ID) + IF (NS.GT.0) LST(NS) = IS + NXT(IS) = NS + IPD(ID) = IS + LST(IS) = -ID + GO TO 30 + 20 NEL = NEL + 1 + FLAG(IS) = -1 + NXT(IS) = 0 + LST(IS) = 0 + 30 CONTINUE + DO 340 ML = 1,N + IF (NEL+NVROOT+1.GE.N) GO TO 350 + DO 40 ID = MD,N + MS = IPD(ID) + IF (MS.GT.0) GO TO 50 + 40 CONTINUE + 50 MD = ID + NVPIV = NV(MS) + NS = NXT(MS) + NXT(MS) = 0 + LST(MS) = 0 + IF (NS.GT.0) LST(NS) = -ID + IPD(ID) = NS + ME = MS + NEL = NEL + NVPIV + IDN = 0 + KP = IPE(ME) + FLAG(MS) = -1 + IP = IWFR + LEN = IW(KP) + DO 140 KP1 = 1,LEN + KP = KP + 1 + KE = IW(KP) + IF (FLAG(KE).LE.-2) GO TO 60 + IF (FLAG(KE).LE.0) THEN + IF (IPE(KE).NE.-ROOT) GO TO 140 + KE = ROOT + IF (FLAG(KE).LE.0) GO TO 140 + END IF + JP = KP - 1 + LN = LEN - KP1 + 1 + IE = MS + GO TO 70 + 60 IE = KE + JP = IPE(IE) + LN = IW(JP) + 70 DO 130 JP1 = 1,LN + JP = JP + 1 + IS = IW(JP) + IF (FLAG(IS).LE.0) THEN + IF (IPE(IS).EQ.-ROOT) THEN + IS = ROOT + IW(JP) = ROOT + IF (FLAG(IS).LE.0) GO TO 130 + ELSE + GO TO 130 + END IF + END IF + FLAG(IS) = 0 + IF (IWFR.LT.LW) GO TO 100 + IPE(MS) = KP + IW(KP) = LEN - KP1 + IPE(IE) = JP + IW(JP) = LN - JP1 + CALL MA27ID(N,IPE,IW,IP-1,LWFR) + JP2 = IWFR - 1 + IWFR = LWFR + IF (IP.GT.JP2) GO TO 90 + DO 80 JP = IP,JP2 + IW(IWFR) = IW(JP) + IWFR = IWFR + 1 + 80 CONTINUE + 90 IP = LWFR + JP = IPE(IE) + KP = IPE(ME) + 100 IW(IWFR) = IS + IDN = IDN + NV(IS) + IWFR = IWFR + 1 + LS = LST(IS) + LST(IS) = 0 + NS = NXT(IS) + NXT(IS) = 0 + IF (NS.GT.0) LST(NS) = LS + IF (LS) 110,130,120 + 110 LS = -LS + IPD(LS) = NS + GO TO 130 + 120 NXT(LS) = NS + 130 CONTINUE + IF (IE.EQ.MS) GO TO 150 + IPE(IE) = -ME + FLAG(IE) = -1 + 140 CONTINUE + 150 NV(MS) = IDN + NVPIV + IF (IWFR.EQ.IP) GO TO 330 + K1 = IP + K2 = IWFR - 1 + LIMIT = NINT(FRATIO*(N-NEL)) + DO 310 K = K1,K2 + IS = IW(K) + IF (IS.EQ.ROOT) GO TO 310 + IF (NFLG.GT.2) GO TO 170 + DO 160 I = 1,N + IF (FLAG(I).GT.0) FLAG(I) = IOVFLO + IF (FLAG(I).LE.-2) FLAG(I) = -IOVFLO + 160 CONTINUE + NFLG = IOVFLO + 170 NFLG = NFLG - 1 + ID = IDN + KP1 = IPE(IS) + 1 + NP = KP1 + KP2 = IW(KP1-1) + KP1 - 1 + DO 220 KP = KP1,KP2 + KE = IW(KP) + IF (FLAG(KE).EQ.-1) THEN + IF (IPE(KE).NE.-ROOT) GO TO 220 + KE = ROOT + IW(KP) = ROOT + IF (FLAG(KE).EQ.-1) GO TO 220 + END IF + IF (FLAG(KE).GE.0) GO TO 230 + JP1 = IPE(KE) + 1 + JP2 = IW(JP1-1) + JP1 - 1 + IDL = ID + DO 190 JP = JP1,JP2 + JS = IW(JP) + IF (FLAG(JS).LE.NFLG) GO TO 190 + ID = ID + NV(JS) + FLAG(JS) = NFLG + 190 CONTINUE + IF (ID.GT.IDL) GO TO 210 + DO 200 JP = JP1,JP2 + JS = IW(JP) + IF (FLAG(JS).NE.0) GO TO 210 + 200 CONTINUE + IPE(KE) = -ME + FLAG(KE) = -1 + GO TO 220 + 210 IW(NP) = KE + FLAG(KE) = -NFLG + NP = NP + 1 + 220 CONTINUE + NP0 = NP + GO TO 250 + 230 KP0 = KP + NP0 = NP + DO 240 KP = KP0,KP2 + KS = IW(KP) + IF (FLAG(KS).LE.NFLG) THEN + IF (IPE(KS).EQ.-ROOT) THEN + KS = ROOT + IW(KP) = ROOT + IF (FLAG(KS).LE.NFLG) GO TO 240 + ELSE + GO TO 240 + END IF + END IF + ID = ID + NV(KS) + FLAG(KS) = NFLG + IW(NP) = KS + NP = NP + 1 + 240 CONTINUE + 250 IF (ID.GE.LIMIT) GO TO 295 + IW(NP) = IW(NP0) + IW(NP0) = IW(KP1) + IW(KP1) = ME + IW(KP1-1) = NP - KP1 + 1 + JS = IPD(ID) + DO 280 L = 1,N + IF (JS.LE.0) GO TO 300 + KP1 = IPE(JS) + 1 + IF (IW(KP1).NE.ME) GO TO 300 + KP2 = KP1 - 1 + IW(KP1-1) + DO 260 KP = KP1,KP2 + IE = IW(KP) + IF (IABS(FLAG(IE)+0).GT.NFLG) GO TO 270 + 260 CONTINUE + GO TO 290 + 270 JS = NXT(JS) + 280 CONTINUE + 290 IPE(JS) = -IS + NV(IS) = NV(IS) + NV(JS) + NV(JS) = 0 + FLAG(JS) = -1 + NS = NXT(JS) + LS = LST(JS) + IF (NS.GT.0) LST(NS) = IS + IF (LS.GT.0) NXT(LS) = IS + LST(IS) = LS + NXT(IS) = NS + LST(JS) = 0 + NXT(JS) = 0 + IF (IPD(ID).EQ.JS) IPD(ID) = IS + GO TO 310 + 295 IF (NVROOT.EQ.0) THEN + ROOT = IS + IPE(IS) = 0 + ELSE + IW(K) = ROOT + IPE(IS) = -ROOT + NV(ROOT) = NV(ROOT) + NV(IS) + NV(IS) = 0 + FLAG(IS) = -1 + END IF + NVROOT = NV(ROOT) + GO TO 310 + 300 NS = IPD(ID) + IF (NS.GT.0) LST(NS) = IS + NXT(IS) = NS + IPD(ID) = IS + LST(IS) = -ID + MD = MIN0(MD,ID) + 310 CONTINUE + DO 320 K = K1,K2 + IS = IW(K) + IF (NV(IS).EQ.0) GO TO 320 + FLAG(IS) = NFLG + IW(IP) = IS + IP = IP + 1 + 320 CONTINUE + IWFR = K1 + FLAG(ME) = -NFLG + IW(IP) = IW(K1) + IW(K1) = IP - K1 + IPE(ME) = K1 + IWFR = IP + 1 + GO TO 335 + 330 IPE(ME) = 0 + 335 CONTINUE + 340 CONTINUE + 350 DO 360 IS = 1,N + IF(NXT(IS).NE.0 .OR. LST(IS).NE.0) THEN + IF (NVROOT.EQ.0) THEN + ROOT = IS + IPE(IS) = 0 + ELSE + IPE(IS) = -ROOT + END IF + NVROOT = NVROOT + NV(IS) + NV(IS) = 0 + END IF + 360 CONTINUE + DO 370 IE = 1,N + IF (IPE(IE).GT.0) IPE(IE) = -ROOT + 370 CONTINUE + IF(NVROOT.GT.0)NV(ROOT)=NVROOT + END + SUBROUTINE MA27ID(N,IPE,IW,LW,IWFR) + INTEGER IWFR,LW,N + INTEGER IPE(N),IW(LW) + INTEGER I,IR,K,K1,K2,LWFR + COMMON /MA27ED/OPS,IERROR,NRLTOT,NIRTOT,NRLNEC,NIRNEC,NRLADU, + + NIRADU,NRLBDU,NIRBDU,NCMPA,NCMPBR,NCMPBI,NTWO,NEIG + DOUBLE PRECISION OPS + INTEGER IERROR,NCMPA,NCMPBI,NCMPBR,NEIG,NIRADU,NIRBDU,NIRNEC, + + NIRTOT,NRLADU,NRLBDU,NRLNEC,NRLTOT,NTWO + SAVE /MA27ED/ + NCMPA = NCMPA + 1 + DO 10 I = 1,N + K1 = IPE(I) + IF (K1.LE.0) GO TO 10 + IPE(I) = IW(K1) + IW(K1) = -I + 10 CONTINUE + IWFR = 1 + LWFR = IWFR + DO 60 IR = 1,N + IF (LWFR.GT.LW) GO TO 70 + DO 20 K = LWFR,LW + IF (IW(K).LT.0) GO TO 30 + 20 CONTINUE + GO TO 70 + 30 I = -IW(K) + IW(IWFR) = IPE(I) + IPE(I) = IWFR + K1 = K + 1 + K2 = K + IW(IWFR) + IWFR = IWFR + 1 + IF (K1.GT.K2) GO TO 50 + DO 40 K = K1,K2 + IW(IWFR) = IW(K) + IWFR = IWFR + 1 + 40 CONTINUE + 50 LWFR = K2 + 1 + 60 CONTINUE + 70 RETURN + END + SUBROUTINE MA27JD(N,NZ,IRN,ICN,PERM,IW,LW,IPE,IQ,FLAG,IWFR,IFLAG) + INTEGER IFLAG,IWFR,LW,N,NZ + INTEGER FLAG(N),ICN(*),IPE(N),IQ(N),IRN(*),IW(LW),PERM(N) + INTEGER I,ID,IN,J,JDUMMY,K,K1,K2,L,LBIG,LEN + INTRINSIC MAX0 + COMMON /MA27DD/U,LP,MP,LDIAG + COMMON /MA27ED/OPS,IERROR,NRLTOT,NIRTOT,NRLNEC,NIRNEC,NRLADU, + + NIRADU,NRLBDU,NIRBDU,NCMPA,NCMPBR,NCMPBI,NTWO,NEIG + COMMON /MA27FD/IOVFLO,NEMIN,IFRLVL(20) + DOUBLE PRECISION OPS,U + INTEGER IERROR,IOVFLO,LDIAG,LP,MP,NCMPA,NCMPBI,NCMPBR,NEIG,NEMIN, + + NIRADU,NIRBDU,NIRNEC,NIRTOT,NRLADU,NRLBDU,NRLNEC,NRLTOT, + + NTWO + INTEGER IFRLVL + SAVE /MA27DD/,/MA27ED/,/MA27FD/ + IFLAG = 0 + IERROR = 0 + DO 10 I = 1,N + IQ(I) = 0 + 10 CONTINUE + IF (NZ.EQ.0) GO TO 110 + DO 100 K = 1,NZ + I = IRN(K) + J = ICN(K) + IW(K) = -I + IF (I-J) 20,40,30 + 20 IF (I.GE.1 .AND. J.LE.N) GO TO 80 + GO TO 50 + 30 IF (J.GE.1 .AND. I.LE.N) GO TO 80 + GO TO 50 + 40 IW(K) = 0 + IF (I.GE.1 .AND. I.LE.N) GO TO 100 + 50 IERROR = IERROR + 1 + IFLAG = 1 + IW(K) = 0 + IF (IERROR.LE.1 .AND. MP.GT.0) WRITE (MP,FMT=60) IFLAG + 60 FORMAT (52H *** WARNING MESSAGE FROM SUBROUTINE MA27AD *** IFLA, + + 3HG =,I2) + IF (IERROR.LE.10 .AND. MP.GT.0) WRITE (MP,FMT=70) K,I,J + 70 FORMAT (I6,19HTH NON-ZERO (IN ROW,I6,11H AND COLUMN,I6, + + 9H) IGNORED) + GO TO 100 + 80 IF (PERM(J).GT.PERM(I)) GO TO 90 + IQ(J) = IQ(J) + 1 + GO TO 100 + 90 IQ(I) = IQ(I) + 1 + 100 CONTINUE + 110 IWFR = 1 + LBIG = 0 + DO 120 I = 1,N + L = IQ(I) + LBIG = MAX0(L,LBIG) + IWFR = IWFR + L + IPE(I) = IWFR - 1 + 120 CONTINUE + IF (NZ.EQ.0) GO TO 250 + DO 160 K = 1,NZ + I = -IW(K) + IF (I.LE.0) GO TO 160 + L = K + IW(K) = 0 + DO 150 ID = 1,NZ + J = ICN(L) + IF (PERM(I).LT.PERM(J)) GO TO 130 + L = IPE(J) + IPE(J) = L - 1 + IN = IW(L) + IW(L) = I + GO TO 140 + 130 L = IPE(I) + IPE(I) = L - 1 + IN = IW(L) + IW(L) = J + 140 I = -IN + IF (I.LE.0) GO TO 160 + 150 CONTINUE + 160 CONTINUE + K = IWFR - 1 + L = K + N + IWFR = L + 1 + DO 190 I = 1,N + FLAG(I) = 0 + J = N + 1 - I + LEN = IQ(J) + IF (LEN.LE.0) GO TO 180 + DO 170 JDUMMY = 1,LEN + IW(L) = IW(K) + K = K - 1 + L = L - 1 + 170 CONTINUE + 180 IPE(J) = L + L = L - 1 + 190 CONTINUE + IF (LBIG.GE.IOVFLO) GO TO 210 + DO 200 I = 1,N + K = IPE(I) + IW(K) = IQ(I) + IF (IQ(I).EQ.0) IPE(I) = 0 + 200 CONTINUE + GO TO 250 + 210 IWFR = 1 + DO 240 I = 1,N + K1 = IPE(I) + 1 + K2 = IPE(I) + IQ(I) + IF (K1.LE.K2) GO TO 220 + IPE(I) = 0 + GO TO 240 + 220 IPE(I) = IWFR + IWFR = IWFR + 1 + DO 230 K = K1,K2 + J = IW(K) + IF (FLAG(J).EQ.I) GO TO 230 + IW(IWFR) = J + IWFR = IWFR + 1 + FLAG(J) = I + 230 CONTINUE + K = IPE(I) + IW(K) = IWFR - K - 1 + 240 CONTINUE + 250 RETURN + END + SUBROUTINE MA27KD(N,IPE,IW,LW,IWFR,IPS,IPV,NV,FLAG) + INTEGER IWFR,LW,N + INTEGER FLAG(N),IPE(N),IPS(N),IPV(N),IW(LW),NV(N) + INTEGER I,IE,IP,J,JE,JP,JP1,JP2,JS,KDUMMY,LN,LWFR,ME,MINJS,ML,MS + EXTERNAL MA27ID + INTRINSIC MIN0 + COMMON /MA27ED/OPS,IERROR,NRLTOT,NIRTOT,NRLNEC,NIRNEC,NRLADU, + + NIRADU,NRLBDU,NIRBDU,NCMPA,NCMPBR,NCMPBI,NTWO,NEIG + DOUBLE PRECISION OPS + INTEGER IERROR,NCMPA,NCMPBI,NCMPBR,NEIG,NIRADU,NIRBDU,NIRNEC, + + NIRTOT,NRLADU,NRLBDU,NRLNEC,NRLTOT,NTWO + SAVE /MA27ED/ + DO 10 I = 1,N + FLAG(I) = 0 + NV(I) = 0 + J = IPS(I) + IPV(J) = I + 10 CONTINUE + NCMPA = 0 + DO 100 ML = 1,N + MS = IPV(ML) + ME = MS + FLAG(MS) = ME + IP = IWFR + MINJS = N + IE = ME + DO 70 KDUMMY = 1,N + JP = IPE(IE) + LN = 0 + IF (JP.LE.0) GO TO 60 + LN = IW(JP) + DO 50 JP1 = 1,LN + JP = JP + 1 + JS = IW(JP) + IF (FLAG(JS).EQ.ME) GO TO 50 + FLAG(JS) = ME + IF (IWFR.LT.LW) GO TO 40 + IPE(IE) = JP + IW(JP) = LN - JP1 + CALL MA27ID(N,IPE,IW,IP-1,LWFR) + JP2 = IWFR - 1 + IWFR = LWFR + IF (IP.GT.JP2) GO TO 30 + DO 20 JP = IP,JP2 + IW(IWFR) = IW(JP) + IWFR = IWFR + 1 + 20 CONTINUE + 30 IP = LWFR + JP = IPE(IE) + 40 IW(IWFR) = JS + MINJS = MIN0(MINJS,IPS(JS)+0) + IWFR = IWFR + 1 + 50 CONTINUE + 60 IPE(IE) = -ME + JE = NV(IE) + NV(IE) = LN + 1 + IE = JE + IF (IE.EQ.0) GO TO 80 + 70 CONTINUE + 80 IF (IWFR.GT.IP) GO TO 90 + IPE(ME) = 0 + NV(ME) = 1 + GO TO 100 + 90 MINJS = IPV(MINJS) + NV(ME) = NV(MINJS) + NV(MINJS) = ME + IW(IWFR) = IW(IP) + IW(IP) = IWFR - IP + IPE(ME) = IP + IWFR = IWFR + 1 + 100 CONTINUE + RETURN + END + SUBROUTINE MA27LD(N,IPE,NV,IPS,NE,NA,ND,NSTEPS) + INTEGER N,NSTEPS + INTEGER IPE(N),IPS(N),NA(N),ND(N),NE(N),NV(N) + INTEGER I,IB,IF,IL,IS,ISON,K,L,NR + COMMON /MA27FD/IOVFLO,NEMIN,IFRLVL(20) + INTEGER IOVFLO,NEMIN + INTEGER IFRLVL + SAVE /MA27FD/ + DO 10 I = 1,N + IPS(I) = 0 + NE(I) = 0 + 10 CONTINUE + DO 20 I = 1,N + IF (NV(I).GT.0) GO TO 20 + IF = -IPE(I) + IS = -IPS(IF) + IF (IS.GT.0) IPE(I) = IS + IPS(IF) = -I + 20 CONTINUE + NR = N + 1 + DO 50 I = 1,N + IF (NV(I).LE.0) GO TO 50 + IF = -IPE(I) + IF (IF.EQ.0) GO TO 40 + IS = -IPS(IF) + IF (IS.LE.0) GO TO 30 + IPE(I) = IS + 30 IPS(IF) = -I + GO TO 50 + 40 NR = NR - 1 + NE(NR) = I + 50 CONTINUE + IS = 1 + I = 0 + DO 160 K = 1,N + IF (I.GT.0) GO TO 60 + I = NE(NR) + NE(NR) = 0 + NR = NR + 1 + IL = N + NA(N) = 0 + 60 DO 70 L = 1,N + IF (IPS(I).GE.0) GO TO 80 + ISON = -IPS(I) + IPS(I) = 0 + I = ISON + IL = IL - 1 + NA(IL) = 0 + 70 CONTINUE + 80 IPS(I) = K + NE(IS) = NE(IS) + 1 + IF (NV(I).LE.0) GO TO 120 + IF (IL.LT.N) NA(IL+1) = NA(IL+1) + 1 + NA(IS) = NA(IL) + ND(IS) = NV(I) + IF (NA(IS).NE.1) GO TO 90 + IF (ND(IS-1)-NE(IS-1).EQ.ND(IS)) GO TO 100 + 90 IF (NE(IS).GE.NEMIN) GO TO 110 + IF (NA(IS).EQ.0) GO TO 110 + IF (NE(IS-1).GE.NEMIN) GO TO 110 + 100 NA(IS-1) = NA(IS-1) + NA(IS) - 1 + ND(IS-1) = ND(IS) + NE(IS-1) + NE(IS-1) = NE(IS) + NE(IS-1) + NE(IS) = 0 + GO TO 120 + 110 IS = IS + 1 + 120 IB = IPE(I) + IF (IB) 150,140,130 + 130 NA(IL) = 0 + 140 I = IB + GO TO 160 + 150 I = -IB + IL = IL + 1 + 160 CONTINUE + NSTEPS = IS - 1 + RETURN + END + SUBROUTINE MA27MD(N,NZ,IRN,ICN,PERM,NA,NE,ND,NSTEPS,LSTKI,LSTKR, + + IW) + INTEGER N,NSTEPS,NZ + INTEGER ICN(*),IRN(*),IW(*),LSTKI(N),LSTKR(N),NA(NSTEPS), + + ND(NSTEPS),NE(NSTEPS),PERM(N) + INTEGER I,INEW,IOLD,IORG,IROW,ISTKI,ISTKR,ITOP,ITREE,JOLD,JORG,K, + + LSTK,NASSR,NELIM,NFR,NSTK,NUMORG,NZ1,NZ2 + DOUBLE PRECISION DELIM + INTRINSIC MAX0,MIN0 + COMMON /MA27ED/OPS,IERROR,NRLTOT,NIRTOT,NRLNEC,NIRNEC,NRLADU, + + NIRADU,NRLBDU,NIRBDU,NCMPA,NCMPBR,NCMPBI,NTWO,NEIG + DOUBLE PRECISION OPS + INTEGER IERROR,NCMPA,NCMPBI,NCMPBR,NEIG,NIRADU,NIRBDU,NIRNEC, + + NIRTOT,NRLADU,NRLBDU,NRLNEC,NRLTOT,NTWO + SAVE /MA27ED/ + IF (NZ.EQ.0) GO TO 20 + IF (IRN(1).NE.IW(1)) GO TO 20 + IRN(1) = IW(1) - 1 + NZ2 = 0 + DO 10 IOLD = 1,N + INEW = PERM(IOLD) + LSTKI(INEW) = LSTKR(IOLD) + 1 + NZ2 = NZ2 + LSTKR(IOLD) + 10 CONTINUE + NZ1 = NZ2/2 + N + NZ2 = NZ2 + N + GO TO 60 + 20 DO 30 I = 1,N + LSTKI(I) = 1 + 30 CONTINUE + NZ1 = N + IF (NZ.EQ.0) GO TO 50 + DO 40 I = 1,NZ + IOLD = IRN(I) + JOLD = ICN(I) + IF (IOLD.LT.1 .OR. IOLD.GT.N) GO TO 40 + IF (JOLD.LT.1 .OR. JOLD.GT.N) GO TO 40 + IF (IOLD.EQ.JOLD) GO TO 40 + NZ1 = NZ1 + 1 + IROW = MIN0(PERM(IOLD)+0,PERM(JOLD)+0) + LSTKI(IROW) = LSTKI(IROW) + 1 + 40 CONTINUE + 50 NZ2 = NZ1 + 60 ISTKI = 0 + ISTKR = 0 + OPS = 0.0D0 + NRLADU = 0 + NIRADU = 1 + NIRTOT = NZ1 + NRLTOT = NZ1 + NIRNEC = NZ2 + NRLNEC = NZ2 + NUMORG = 0 + ITOP = 0 + DO 100 ITREE = 1,NSTEPS + NELIM = NE(ITREE) + DELIM = NELIM + NFR = ND(ITREE) + NSTK = NA(ITREE) + NASSR = NFR* (NFR+1)/2 + IF (NSTK.NE.0) NASSR = NASSR - LSTKR(ITOP) + 1 + NRLTOT = MAX0(NRLTOT,NRLADU+NASSR+ISTKR+NZ1) + NIRTOT = MAX0(NIRTOT,NIRADU+NFR+2+ISTKI+NZ1) + NRLNEC = MAX0(NRLNEC,NRLADU+NASSR+ISTKR+NZ2) + NIRNEC = MAX0(NIRNEC,NIRADU+NFR+2+ISTKI+NZ2) + DO 70 IORG = 1,NELIM + JORG = NUMORG + IORG + NZ2 = NZ2 - LSTKI(JORG) + 70 CONTINUE + NUMORG = NUMORG + NELIM + IF (NSTK.LE.0) GO TO 90 + DO 80 K = 1,NSTK + LSTK = LSTKR(ITOP) + ISTKR = ISTKR - LSTK + LSTK = LSTKI(ITOP) + ISTKI = ISTKI - LSTK + ITOP = ITOP - 1 + 80 CONTINUE + 90 NRLADU = NRLADU + (NELIM* (2*NFR-NELIM+1))/2 + NIRADU = NIRADU + 2 + NFR + IF (NELIM.EQ.1) NIRADU = NIRADU - 1 + OPS = OPS + ((NFR*DELIM* (NFR+1)- (2*NFR+1)*DELIM* (DELIM+1)/2+ + + DELIM* (DELIM+1)* (2*DELIM+1)/6)/2) + IF (ITREE.EQ.NSTEPS) GO TO 100 + IF (NFR.EQ.NELIM) GO TO 100 + ITOP = ITOP + 1 + LSTKR(ITOP) = (NFR-NELIM)* (NFR-NELIM+1)/2 + LSTKI(ITOP) = NFR - NELIM + 1 + ISTKI = ISTKI + LSTKI(ITOP) + ISTKR = ISTKR + LSTKR(ITOP) + NIRTOT = MAX0(NIRTOT,NIRADU+ISTKI+NZ1) + NIRNEC = MAX0(NIRNEC,NIRADU+ISTKI+NZ2) + 100 CONTINUE + NRLNEC = MAX0(NRLNEC,N+MAX0(NZ,NZ1)) + NRLTOT = MAX0(NRLTOT,N+MAX0(NZ,NZ1)) + NRLNEC = MIN0(NRLNEC,NRLTOT) + NIRNEC = MAX0(NZ,NIRNEC) + NIRTOT = MAX0(NZ,NIRTOT) + NIRNEC = MIN0(NIRNEC,NIRTOT) + RETURN + END + SUBROUTINE MA27ND(N,NZ,NZ1,A,LA,IRN,ICN,IW,LIW,PERM,IW2,IFLAG) + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D0) + INTEGER IFLAG,LA,LIW,N,NZ,NZ1 + DOUBLE PRECISION A(LA) + INTEGER ICN(*),IRN(*),IW(LIW),IW2(N),PERM(N) + DOUBLE PRECISION ANEXT,ANOW + INTEGER I,IA,ICH,II,IIW,INEW,IOLD,IPOS,J1,J2,JJ,JNEW,JOLD,JPOS,K + INTRINSIC MIN0 + COMMON /MA27DD/U,LP,MP,LDIAG + COMMON /MA27ED/OPS,IERROR,NRLTOT,NIRTOT,NRLNEC,NIRNEC,NRLADU, + + NIRADU,NRLBDU,NIRBDU,NCMPA,NCMPBR,NCMPBI,NTWO,NEIG + DOUBLE PRECISION OPS,U + INTEGER IERROR,LDIAG,LP,MP,NCMPA,NCMPBI,NCMPBR,NEIG,NIRADU,NIRBDU, + + NIRNEC,NIRTOT,NRLADU,NRLBDU,NRLNEC,NRLTOT,NTWO + SAVE /MA27DD/,/MA27ED/ + IFLAG = 0 + IA = LA + DO 10 IOLD = 1,N + IW2(IOLD) = 1 + A(IA) = ZERO + IA = IA - 1 + 10 CONTINUE + IERROR = 0 + NZ1 = N + IF (NZ.EQ.0) GO TO 80 + DO 70 K = 1,NZ + IOLD = IRN(K) + IF (IOLD.GT.N .OR. IOLD.LE.0) GO TO 30 + JOLD = ICN(K) + IF (JOLD.GT.N .OR. JOLD.LE.0) GO TO 30 + INEW = PERM(IOLD) + JNEW = PERM(JOLD) + IF (INEW.NE.JNEW) GO TO 20 + IA = LA - N + IOLD + A(IA) = A(IA) + A(K) + GO TO 60 + 20 INEW = MIN0(INEW,JNEW) + IW2(INEW) = IW2(INEW) + 1 + IW(K) = -IOLD + NZ1 = NZ1 + 1 + GO TO 70 + 30 IFLAG = 1 + IERROR = IERROR + 1 + IF (IERROR.LE.1 .AND. MP.GT.0) WRITE (MP,FMT=40) IFLAG + 40 FORMAT (52H *** WARNING MESSAGE FROM SUBROUTINE MA27BD *** IFLA, + + 3HG =,I2) + IF (IERROR.LE.10 .AND. MP.GT.0) WRITE (MP,FMT=50) K,IRN(K), + + ICN(K) + 50 FORMAT (I6,19HTH NON-ZERO (IN ROW,I6,11H AND COLUMN,I6, + + 9H) IGNORED) + 60 IW(K) = 0 + 70 CONTINUE + 80 IF (NZ.LT.NZ1 .AND. NZ1.NE.N) GO TO 100 + K = 1 + DO 90 I = 1,N + K = K + IW2(I) + IW2(I) = K + 90 CONTINUE + GO TO 120 + 100 K = 1 + DO 110 I = 1,N + K = K + IW2(I) - 1 + IW2(I) = K + 110 CONTINUE + 120 IF (NZ1.GT.LIW) GO TO 210 + IF (NZ1+N.GT.LA) GO TO 220 + IF (NZ1.EQ.N) GO TO 180 + DO 140 K = 1,NZ + IOLD = -IW(K) + IF (IOLD.LE.0) GO TO 140 + JOLD = ICN(K) + ANOW = A(K) + IW(K) = 0 + DO 130 ICH = 1,NZ + INEW = PERM(IOLD) + JNEW = PERM(JOLD) + INEW = MIN0(INEW,JNEW) + IF (INEW.EQ.PERM(JOLD)) JOLD = IOLD + JPOS = IW2(INEW) - 1 + IOLD = -IW(JPOS) + ANEXT = A(JPOS) + A(JPOS) = ANOW + IW(JPOS) = JOLD + IW2(INEW) = JPOS + IF (IOLD.EQ.0) GO TO 140 + ANOW = ANEXT + JOLD = ICN(JPOS) + 130 CONTINUE + 140 CONTINUE + IF (NZ.GE.NZ1) GO TO 180 + IPOS = NZ1 + JPOS = NZ1 - N + DO 170 II = 1,N + I = N - II + 1 + J1 = IW2(I) + J2 = JPOS + IF (J1.GT.JPOS) GO TO 160 + DO 150 JJ = J1,J2 + IW(IPOS) = IW(JPOS) + A(IPOS) = A(JPOS) + IPOS = IPOS - 1 + JPOS = JPOS - 1 + 150 CONTINUE + 160 IW2(I) = IPOS + 1 + IPOS = IPOS - 1 + 170 CONTINUE + 180 DO 190 IOLD = 1,N + INEW = PERM(IOLD) + JPOS = IW2(INEW) - 1 + IA = LA - N + IOLD + A(JPOS) = A(IA) + IW(JPOS) = -IOLD + 190 CONTINUE + IPOS = NZ1 + IA = LA + IIW = LIW + DO 200 I = 1,NZ1 + A(IA) = A(IPOS) + IW(IIW) = IW(IPOS) + IPOS = IPOS - 1 + IA = IA - 1 + IIW = IIW - 1 + 200 CONTINUE + GO TO 230 + 210 IFLAG = -3 + IERROR = NZ1 + GO TO 230 + 220 IFLAG = -4 + IERROR = NZ1 + N + 230 RETURN + END + SUBROUTINE MA27OD(N,NZ,A,LA,IW,LIW,PERM,NSTK,NSTEPS,MAXFRT,NELIM, + + IW2,IFLAG) + DOUBLE PRECISION ZERO,HALF,ONE + PARAMETER (ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0) + INTEGER IFLAG,LA,LIW,MAXFRT,N,NSTEPS,NZ + DOUBLE PRECISION A(LA) + INTEGER IW(LIW),IW2(N),NELIM(NSTEPS),NSTK(NSTEPS),PERM(N) + DOUBLE PRECISION AMAX,AMULT,AMULT1,AMULT2,DETPIV,RMAX,SWOP,THRESH, + + TMAX,UU + INTEGER AINPUT,APOS,APOS1,APOS2,APOS3,ASTK,ASTK2,AZERO,I,IASS, + + IBEG,IDUMMY,IELL,IEND,IEXCH,IFR,IINPUT,IOLDPS,IORG,IPIV, + + IPMNP,IPOS,IROW,ISNPIV,ISTK,ISTK2,ISWOP,IWPOS,IX,IY,J,J1, + + J2,JCOL,JDUMMY,JFIRST,JJ,JJ1,JJJ,JLAST,JMAX,JMXMIP,JNEW, + + JNEXT,JPIV,JPOS,K,K1,K2,KDUMMY,KK,KMAX,KROW,LAELL,LAPOS2, + + LIELL,LNASS,LNPIV,LT,LTOPST,NASS,NBLK,NEWEL,NFRONT,NPIV, + + NPIVP1,NTOTPV,NUMASS,NUMORG,NUMSTK,PIVSIZ,POSFAC,POSPV1, + + POSPV2 + EXTERNAL MA27PD + INTRINSIC DABS,DMAX1,DMIN1,MAX0,MIN0 + COMMON /MA27DD/U,LP,MP,LDIAG + COMMON /MA27ED/OPS,IERROR,NRLTOT,NIRTOT,NRLNEC,NIRNEC,NRLADU, + + NIRADU,NRLBDU,NIRBDU,NCMPA,NCMPBR,NCMPBI,NTWO,NEIG + DOUBLE PRECISION OPS,U + INTEGER IERROR,LDIAG,LP,MP,NCMPA,NCMPBI,NCMPBR,NEIG,NIRADU,NIRBDU, + + NIRNEC,NIRTOT,NRLADU,NRLBDU,NRLNEC,NRLTOT,NTWO + COMMON /MA27TD/FRATIO,PIVTOL + DOUBLE PRECISION FRATIO,PIVTOL + INTEGER IDIAG + SAVE /MA27DD/,/MA27ED/,/MA27TD/ + IDIAG(IX,IY) = ((IY-1)* (2*IX-IY+2))/2 + NBLK = 0 + NTWO = 0 + NEIG = 0 + NCMPBI = 0 + NCMPBR = 0 + MAXFRT = 0 + UU = DMIN1(U,HALF) + UU = DMAX1(UU,-HALF) + DO 10 I = 1,N + IW2(I) = 0 + 10 CONTINUE + IWPOS = 2 + POSFAC = 1 + ISTK = LIW - NZ + 1 + ISTK2 = ISTK - 1 + ASTK = LA - NZ + 1 + ASTK2 = ASTK - 1 + IINPUT = ISTK + AINPUT = ASTK + AZERO = 0 + NTOTPV = 0 + NUMASS = 0 + DO 760 IASS = 1,NSTEPS + NASS = NELIM(IASS) + NEWEL = IWPOS + 1 + JFIRST = N + 1 + NFRONT = 0 + NUMSTK = NSTK(IASS) + LTOPST = 1 + LNASS = 0 + IF (NUMSTK.EQ.0) GO TO 80 + J2 = ISTK - 1 + LNASS = NASS + LTOPST = ((IW(ISTK)+1)*IW(ISTK))/2 + DO 70 IELL = 1,NUMSTK + JNEXT = JFIRST + JLAST = N + 1 + J1 = J2 + 2 + J2 = J1 - 1 + IW(J1-1) + DO 60 JJ = J1,J2 + J = IW(JJ) + IF (IW2(J).GT.0) GO TO 60 + JNEW = PERM(J) + IF (JNEW.LE.NUMASS) NASS = NASS + 1 + DO 20 IDUMMY = 1,N + IF (JNEXT.EQ.N+1) GO TO 30 + IF (PERM(JNEXT).GT.JNEW) GO TO 30 + JLAST = JNEXT + JNEXT = IW2(JLAST) + 20 CONTINUE + 30 IF (JLAST.NE.N+1) GO TO 40 + JFIRST = J + GO TO 50 + 40 IW2(JLAST) = J + 50 IW2(J) = JNEXT + JLAST = J + NFRONT = NFRONT + 1 + 60 CONTINUE + 70 CONTINUE + LNASS = NASS - LNASS + 80 NUMORG = NELIM(IASS) + J1 = IINPUT + DO 150 IORG = 1,NUMORG + J = -IW(J1) + DO 140 IDUMMY = 1,LIW + JNEW = PERM(J) + IF (IW2(J).GT.0) GO TO 130 + JLAST = N + 1 + JNEXT = JFIRST + DO 90 JDUMMY = 1,N + IF (JNEXT.EQ.N+1) GO TO 100 + IF (PERM(JNEXT).GT.JNEW) GO TO 100 + JLAST = JNEXT + JNEXT = IW2(JLAST) + 90 CONTINUE + 100 IF (JLAST.NE.N+1) GO TO 110 + JFIRST = J + GO TO 120 + 110 IW2(JLAST) = J + 120 IW2(J) = JNEXT + NFRONT = NFRONT + 1 + 130 J1 = J1 + 1 + IF (J1.GT.LIW) GO TO 150 + J = IW(J1) + IF (J.LT.0) GO TO 150 + 140 CONTINUE + 150 CONTINUE + IF (NEWEL+NFRONT.LT.ISTK) GO TO 160 + CALL MA27PD(A,IW,ISTK,ISTK2,IINPUT,2) + IF (NEWEL+NFRONT.LT.ISTK) GO TO 160 + IERROR = LIW + 1 + NEWEL + NFRONT - ISTK + GO TO 770 + 160 J = JFIRST + DO 170 IFR = 1,NFRONT + NEWEL = NEWEL + 1 + IW(NEWEL) = J + JNEXT = IW2(J) + IW2(J) = NEWEL - (IWPOS+1) + J = JNEXT + 170 CONTINUE + MAXFRT = MAX0(MAXFRT,NFRONT) + IW(IWPOS) = NFRONT + LAELL = ((NFRONT+1)*NFRONT)/2 + APOS2 = POSFAC + LAELL - 1 + IF (NUMSTK.NE.0) LNASS = LNASS* (2*NFRONT-LNASS+1)/2 + IF (POSFAC+LNASS-1.GE.ASTK) GO TO 180 + IF (APOS2.LT.ASTK+LTOPST-1) GO TO 190 + 180 CALL MA27PD(A,IW,ASTK,ASTK2,AINPUT,1) + IF (POSFAC+LNASS-1.GE.ASTK) GO TO 780 + IF (APOS2.GE.ASTK+LTOPST-1) GO TO 780 + 190 IF (APOS2.LE.AZERO) GO TO 220 + APOS = AZERO + 1 + LAPOS2 = MIN0(APOS2,ASTK-1) + IF (LAPOS2.LT.APOS) GO TO 210 + DO 200 K = APOS,LAPOS2 + A(K) = ZERO + 200 CONTINUE + 210 AZERO = APOS2 + 220 IF (NUMSTK.EQ.0) GO TO 260 + DO 250 IELL = 1,NUMSTK + J1 = ISTK + 1 + J2 = ISTK + IW(ISTK) + DO 240 JJ = J1,J2 + IROW = IW(JJ) + IROW = IW2(IROW) + APOS = POSFAC + IDIAG(NFRONT,IROW) + DO 230 JJJ = JJ,J2 + J = IW(JJJ) + APOS2 = APOS + IW2(J) - IROW + A(APOS2) = A(APOS2) + A(ASTK) + A(ASTK) = ZERO + ASTK = ASTK + 1 + 230 CONTINUE + 240 CONTINUE + ISTK = J2 + 1 + 250 CONTINUE + 260 DO 280 IORG = 1,NUMORG + J = -IW(IINPUT) + IROW = IW2(J) + APOS = POSFAC + IDIAG(NFRONT,IROW) + DO 270 IDUMMY = 1,NZ + APOS2 = APOS + IW2(J) - IROW + A(APOS2) = A(APOS2) + A(AINPUT) + AINPUT = AINPUT + 1 + IINPUT = IINPUT + 1 + IF (IINPUT.GT.LIW) GO TO 280 + J = IW(IINPUT) + IF (J.LT.0) GO TO 280 + 270 CONTINUE + 280 CONTINUE + NUMASS = NUMASS + NUMORG + J1 = IWPOS + 2 + J2 = IWPOS + NFRONT + 1 + DO 290 K = J1,J2 + J = IW(K) + IW2(J) = 0 + 290 CONTINUE + LNPIV = -1 + NPIV = 0 + DO 650 KDUMMY = 1,NASS + IF (NPIV.EQ.NASS) GO TO 660 + IF (NPIV.EQ.LNPIV) GO TO 660 + LNPIV = NPIV + NPIVP1 = NPIV + 1 + JPIV = 1 + DO 640 IPIV = NPIVP1,NASS + JPIV = JPIV - 1 + IF (JPIV.EQ.1) GO TO 640 + APOS = POSFAC + IDIAG(NFRONT-NPIV,IPIV-NPIV) + IF (UU.GT.ZERO) GO TO 320 + IF (ABS(A(APOS)).LE.PIVTOL) GO TO 790 + IF (NTOTPV.GT.0) GO TO 300 + IF (A(APOS).GT.ZERO) ISNPIV = 1 + IF (A(APOS).LT.ZERO) ISNPIV = -1 + 300 IF (A(APOS).GT.ZERO .AND. ISNPIV.EQ.1) GO TO 560 + IF (A(APOS).LT.ZERO .AND. ISNPIV.EQ.-1) GO TO 560 + IF (IFLAG.NE.2) IERROR = 0 + IERROR = IERROR + 1 + IFLAG = 2 + I = NTOTPV + 1 + IF (MP.GT.0 .AND. IERROR.LE.10) WRITE (MP,FMT=310) IFLAG,I + 310 FORMAT (48H *** WARNING MESSAGE FROM SUBROUTINE MA27BD *** , + + 7HIFLAG =,I2,/,6H PIVOT,I6, + + 27H HAS DIFFERENT SIGN FROM TH,10HE PREVIOUS,4H ONE) + ISNPIV = -ISNPIV + IF (UU.EQ.ZERO) GO TO 560 + GO TO 800 + 320 AMAX = ZERO + TMAX = AMAX + J1 = APOS + 1 + J2 = APOS + NASS - IPIV + IF (J2.LT.J1) GO TO 340 + DO 330 JJ = J1,J2 + IF (DABS(A(JJ)).LE.AMAX) GO TO 330 + JMAX = IPIV + JJ - J1 + 1 + AMAX = DABS(A(JJ)) + 330 CONTINUE + 340 J1 = J2 + 1 + J2 = APOS + NFRONT - IPIV + IF (J2.LT.J1) GO TO 360 + DO 350 JJ = J1,J2 + TMAX = DMAX1(DABS(A(JJ)),TMAX) + 350 CONTINUE + 360 RMAX = DMAX1(TMAX,AMAX) + APOS1 = APOS + KK = NFRONT - IPIV + LT = IPIV - (NPIV+1) + IF (LT.EQ.0) GO TO 380 + DO 370 K = 1,LT + KK = KK + 1 + APOS1 = APOS1 - KK + RMAX = DMAX1(RMAX,DABS(A(APOS1))) + 370 CONTINUE + 380 IF (DABS(A(APOS)).GT.MAX(PIVTOL,UU*RMAX)) GO TO 450 + IF (ABS(AMAX).LE.PIVTOL) GO TO 640 + APOS2 = POSFAC + IDIAG(NFRONT-NPIV,JMAX-NPIV) + DETPIV = A(APOS)*A(APOS2) - AMAX*AMAX + THRESH = DABS(DETPIV) + THRESH = THRESH/ (UU*DMAX1(DABS(A(APOS))+AMAX, + + DABS(A(APOS2))+AMAX)) + IF (THRESH.LE.RMAX) GO TO 640 + RMAX = ZERO + J1 = APOS2 + 1 + J2 = APOS2 + NFRONT - JMAX + IF (J2.LT.J1) GO TO 400 + DO 390 JJ = J1,J2 + RMAX = DMAX1(RMAX,DABS(A(JJ))) + 390 CONTINUE + 400 KK = NFRONT - JMAX + 1 + APOS3 = APOS2 + JMXMIP = JMAX - IPIV - 1 + IF (JMXMIP.EQ.0) GO TO 420 + DO 410 K = 1,JMXMIP + APOS2 = APOS2 - KK + KK = KK + 1 + RMAX = DMAX1(RMAX,DABS(A(APOS2))) + 410 CONTINUE + 420 IPMNP = IPIV - NPIV - 1 + IF (IPMNP.EQ.0) GO TO 440 + APOS2 = APOS2 - KK + KK = KK + 1 + DO 430 K = 1,IPMNP + APOS2 = APOS2 - KK + KK = KK + 1 + RMAX = DMAX1(RMAX,DABS(A(APOS2))) + 430 CONTINUE + 440 IF (THRESH.LE.RMAX) GO TO 640 + PIVSIZ = 2 + GO TO 460 + 450 PIVSIZ = 1 + 460 IROW = IPIV - NPIV + DO 550 KROW = 1,PIVSIZ + IF (IROW.EQ.1) GO TO 530 + J1 = POSFAC + IROW + J2 = POSFAC + NFRONT - (NPIV+1) + IF (J2.LT.J1) GO TO 480 + APOS2 = APOS + 1 + DO 470 JJ = J1,J2 + SWOP = A(APOS2) + A(APOS2) = A(JJ) + A(JJ) = SWOP + APOS2 = APOS2 + 1 + 470 CONTINUE + 480 J1 = POSFAC + 1 + J2 = POSFAC + IROW - 2 + APOS2 = APOS + KK = NFRONT - (IROW+NPIV) + IF (J2.LT.J1) GO TO 500 + DO 490 JJJ = J1,J2 + JJ = J2 - JJJ + J1 + KK = KK + 1 + APOS2 = APOS2 - KK + SWOP = A(APOS2) + A(APOS2) = A(JJ) + A(JJ) = SWOP + 490 CONTINUE + 500 IF (NPIV.EQ.0) GO TO 520 + APOS1 = POSFAC + KK = KK + 1 + APOS2 = APOS2 - KK + DO 510 JJ = 1,NPIV + KK = KK + 1 + APOS1 = APOS1 - KK + APOS2 = APOS2 - KK + SWOP = A(APOS2) + A(APOS2) = A(APOS1) + A(APOS1) = SWOP + 510 CONTINUE + 520 SWOP = A(APOS) + A(APOS) = A(POSFAC) + A(POSFAC) = SWOP + IPOS = IWPOS + NPIV + 2 + IEXCH = IWPOS + IROW + NPIV + 1 + ISWOP = IW(IPOS) + IW(IPOS) = IW(IEXCH) + IW(IEXCH) = ISWOP + 530 IF (PIVSIZ.EQ.1) GO TO 550 + IF (KROW.EQ.2) GO TO 540 + IROW = JMAX - (NPIV+1) + JPOS = POSFAC + POSFAC = POSFAC + NFRONT - NPIV + NPIV = NPIV + 1 + APOS = APOS3 + GO TO 550 + 540 NPIV = NPIV - 1 + POSFAC = JPOS + 550 CONTINUE + IF (PIVSIZ.EQ.2) GO TO 600 + 560 A(POSFAC) = ONE/A(POSFAC) + IF (A(POSFAC).LT.ZERO) NEIG = NEIG + 1 + J1 = POSFAC + 1 + J2 = POSFAC + NFRONT - (NPIV+1) + IF (J2.LT.J1) GO TO 590 + IBEG = J2 + 1 + DO 580 JJ = J1,J2 + AMULT = -A(JJ)*A(POSFAC) + IEND = IBEG + NFRONT - (NPIV+JJ-J1+2) +CDIR$ IVDEP + DO 570 IROW = IBEG,IEND + JCOL = JJ + IROW - IBEG + A(IROW) = A(IROW) + AMULT*A(JCOL) + 570 CONTINUE + IBEG = IEND + 1 + A(JJ) = AMULT + 580 CONTINUE + 590 NPIV = NPIV + 1 + NTOTPV = NTOTPV + 1 + JPIV = 1 + POSFAC = POSFAC + NFRONT - NPIV + 1 + GO TO 640 + 600 IPOS = IWPOS + NPIV + 2 + NTWO = NTWO + 1 + IW(IPOS) = -IW(IPOS) + POSPV1 = POSFAC + POSPV2 = POSFAC + NFRONT - NPIV + SWOP = A(POSPV2) + IF (DETPIV.LT.ZERO) NEIG = NEIG + 1 + IF (DETPIV.GT.ZERO .AND. SWOP.LT.ZERO) NEIG = NEIG + 2 + A(POSPV2) = A(POSPV1)/DETPIV + A(POSPV1) = SWOP/DETPIV + A(POSPV1+1) = -A(POSPV1+1)/DETPIV + J1 = POSPV1 + 2 + J2 = POSPV1 + NFRONT - (NPIV+1) + IF (J2.LT.J1) GO TO 630 + JJ1 = POSPV2 + IBEG = POSPV2 + NFRONT - (NPIV+1) + DO 620 JJ = J1,J2 + JJ1 = JJ1 + 1 + AMULT1 = - (A(POSPV1)*A(JJ)+A(POSPV1+1)*A(JJ1)) + AMULT2 = - (A(POSPV1+1)*A(JJ)+A(POSPV2)*A(JJ1)) + IEND = IBEG + NFRONT - (NPIV+JJ-J1+3) +CDIR$ IVDEP + DO 610 IROW = IBEG,IEND + K1 = JJ + IROW - IBEG + K2 = JJ1 + IROW - IBEG + A(IROW) = A(IROW) + AMULT1*A(K1) + AMULT2*A(K2) + 610 CONTINUE + IBEG = IEND + 1 + A(JJ) = AMULT1 + A(JJ1) = AMULT2 + 620 CONTINUE + 630 NPIV = NPIV + 2 + NTOTPV = NTOTPV + 2 + JPIV = 2 + POSFAC = POSPV2 + NFRONT - NPIV + 1 + 640 CONTINUE + 650 CONTINUE + 660 IF (NPIV.NE.0) NBLK = NBLK + 1 + IOLDPS = IWPOS + IWPOS = IWPOS + NFRONT + 2 + IF (NPIV.EQ.0) GO TO 690 + IF (NPIV.GT.1) GO TO 680 + IW(IOLDPS) = -IW(IOLDPS) + DO 670 K = 1,NFRONT + J1 = IOLDPS + K + IW(J1) = IW(J1+1) + 670 CONTINUE + IWPOS = IWPOS - 1 + GO TO 690 + 680 IW(IOLDPS+1) = NPIV + 690 LIELL = NFRONT - NPIV + IF (LIELL.EQ.0 .OR. IASS.EQ.NSTEPS) GO TO 750 + IF (IWPOS+LIELL.LT.ISTK) GO TO 700 + CALL MA27PD(A,IW,ISTK,ISTK2,IINPUT,2) + 700 ISTK = ISTK - LIELL - 1 + IW(ISTK) = LIELL + J1 = ISTK + KK = IWPOS - LIELL - 1 +CDIR$ IVDEP + DO 710 K = 1,LIELL + J1 = J1 + 1 + KK = KK + 1 + IW(J1) = IW(KK) + 710 CONTINUE + LAELL = ((LIELL+1)*LIELL)/2 + KK = POSFAC + LAELL + IF (KK.NE.ASTK) GO TO 720 + ASTK = ASTK - LAELL + GO TO 740 + 720 KMAX = KK - 1 +CDIR$ IVDEP + DO 730 K = 1,LAELL + KK = KK - 1 + ASTK = ASTK - 1 + A(ASTK) = A(KK) + 730 CONTINUE + KMAX = MIN0(KMAX,ASTK-1) + DO 735 K = KK,KMAX + A(K) = ZERO + 735 CONTINUE + 740 AZERO = MIN0(AZERO,ASTK-1) + 750 IF (NPIV.EQ.0) IWPOS = IOLDPS + 760 CONTINUE + IW(1) = NBLK + IF (NTWO.GT.0) IW(1) = -NBLK + NRLBDU = POSFAC - 1 + NIRBDU = IWPOS - 1 + IF (NTOTPV.EQ.N) GO TO 810 + IFLAG = 3 + IERROR = NTOTPV + GO TO 810 + 770 IFLAG = -3 + GO TO 810 + 780 IFLAG = -4 + IERROR = LA + MAX0(POSFAC+LNASS,APOS2-LTOPST+2) - ASTK + GO TO 810 + 790 IFLAG = -5 + IERROR = NTOTPV + 1 + GO TO 810 + 800 IFLAG = -6 + IERROR = NTOTPV + 1 + 810 RETURN + END + SUBROUTINE MA27PD(A,IW,J1,J2,ITOP,IREAL) + INTEGER IREAL,ITOP,J1,J2 + DOUBLE PRECISION A(*) + INTEGER IW(*) + INTEGER IPOS,JJ,JJJ + COMMON /MA27ED/OPS,IERROR,NRLTOT,NIRTOT,NRLNEC,NIRNEC,NRLADU, + + NIRADU,NRLBDU,NIRBDU,NCMPA,NCMPBR,NCMPBI,NTWO,NEIG + DOUBLE PRECISION OPS + INTEGER IERROR,NCMPA,NCMPBI,NCMPBR,NEIG,NIRADU,NIRBDU,NIRNEC, + + NIRTOT,NRLADU,NRLBDU,NRLNEC,NRLTOT,NTWO + SAVE /MA27ED/ + IPOS = ITOP - 1 + IF (J2.EQ.IPOS) GO TO 50 + IF (IREAL.EQ.2) GO TO 20 + NCMPBR = NCMPBR + 1 + IF (J1.GT.J2) GO TO 40 + DO 10 JJJ = J1,J2 + JJ = J2 - JJJ + J1 + A(IPOS) = A(JJ) + IPOS = IPOS - 1 + 10 CONTINUE + GO TO 40 + 20 NCMPBI = NCMPBI + 1 + IF (J1.GT.J2) GO TO 40 + DO 30 JJJ = J1,J2 + JJ = J2 - JJJ + J1 + IW(IPOS) = IW(JJ) + IPOS = IPOS - 1 + 30 CONTINUE + 40 J2 = ITOP - 1 + J1 = IPOS + 1 + 50 RETURN + END + SUBROUTINE MA27QD(N,A,LA,IW,LIW,W,MAXFNT,RHS,IW2,NBLK,LATOP) + INTEGER LA,LATOP,LIW,MAXFNT,N,NBLK + DOUBLE PRECISION A(LA),RHS(N),W(MAXFNT) + INTEGER IW(LIW),IW2(NBLK) + DOUBLE PRECISION W1,W2 + INTEGER APOS,IBLK,IFR,ILVL,IPIV,IPOS,IRHS,IROW,IST,J,J1,J2,J3,JJ, + + JPIV,K,K1,K2,K3,LIELL,NPIV + INTRINSIC IABS,MIN0 + COMMON /MA27FD/IOVFLO,NEMIN,IFRLVL(20) + INTEGER IOVFLO,NEMIN + INTEGER IFRLVL + SAVE /MA27FD/ + APOS = 1 + IPOS = 1 + J2 = 0 + IBLK = 0 + NPIV = 0 + DO 140 IROW = 1,N + IF (NPIV.GT.0) GO TO 90 + IBLK = IBLK + 1 + IF (IBLK.GT.NBLK) GO TO 150 + IPOS = J2 + 1 + IW2(IBLK) = IPOS + LIELL = -IW(IPOS) + NPIV = 1 + IF (LIELL.GT.0) GO TO 10 + LIELL = -LIELL + IPOS = IPOS + 1 + NPIV = IW(IPOS) + 10 J1 = IPOS + 1 + J2 = IPOS + LIELL + ILVL = MIN0(NPIV,10) + IF (LIELL.LT.IFRLVL(ILVL)) GO TO 90 + IFR = 0 + DO 20 JJ = J1,J2 + J = IABS(IW(JJ)+0) + IFR = IFR + 1 + W(IFR) = RHS(J) + 20 CONTINUE + JPIV = 1 + J3 = J1 + DO 70 IPIV = 1,NPIV + JPIV = JPIV - 1 + IF (JPIV.EQ.1) GO TO 70 + IF (IW(J3).LT.0) GO TO 40 + JPIV = 1 + J3 = J3 + 1 + APOS = APOS + 1 + IST = IPIV + 1 + IF (LIELL.LT.IST) GO TO 70 + W1 = W(IPIV) + K = APOS + DO 30 J = IST,LIELL + W(J) = W(J) + A(K)*W1 + K = K + 1 + 30 CONTINUE + APOS = APOS + LIELL - IST + 1 + GO TO 70 + 40 JPIV = 2 + J3 = J3 + 2 + APOS = APOS + 2 + IST = IPIV + 2 + IF (LIELL.LT.IST) GO TO 60 + W1 = W(IPIV) + W2 = W(IPIV+1) + K1 = APOS + K2 = APOS + LIELL - IPIV + DO 50 J = IST,LIELL + W(J) = W(J) + W1*A(K1) + W2*A(K2) + K1 = K1 + 1 + K2 = K2 + 1 + 50 CONTINUE + 60 APOS = APOS + 2* (LIELL-IST+1) + 1 + 70 CONTINUE + IFR = 0 + DO 80 JJ = J1,J2 + J = IABS(IW(JJ)+0) + IFR = IFR + 1 + RHS(J) = W(IFR) + 80 CONTINUE + NPIV = 0 + GO TO 140 + 90 IF (IW(J1).LT.0) GO TO 110 + NPIV = NPIV - 1 + APOS = APOS + 1 + J1 = J1 + 1 + IF (J1.GT.J2) GO TO 140 + IRHS = IW(J1-1) + W1 = RHS(IRHS) + K = APOS + DO 100 J = J1,J2 + IRHS = IABS(IW(J)+0) + RHS(IRHS) = RHS(IRHS) + A(K)*W1 + K = K + 1 + 100 CONTINUE + APOS = APOS + J2 - J1 + 1 + GO TO 140 + 110 NPIV = NPIV - 2 + J1 = J1 + 2 + APOS = APOS + 2 + IF (J1.GT.J2) GO TO 130 + IRHS = -IW(J1-2) + W1 = RHS(IRHS) + IRHS = IW(J1-1) + W2 = RHS(IRHS) + K1 = APOS + K3 = APOS + J2 - J1 + 2 + DO 120 J = J1,J2 + IRHS = IABS(IW(J)+0) + RHS(IRHS) = RHS(IRHS) + W1*A(K1) + W2*A(K3) + K1 = K1 + 1 + K3 = K3 + 1 + 120 CONTINUE + 130 APOS = APOS + 2* (J2-J1+1) + 1 + 140 CONTINUE + 150 LATOP = APOS - 1 + RETURN + END + SUBROUTINE MA27RD(N,A,LA,IW,LIW,W,MAXFNT,RHS,IW2,NBLK,LATOP) + INTEGER LA,LATOP,LIW,MAXFNT,N,NBLK + DOUBLE PRECISION A(LA),RHS(N),W(MAXFNT) + INTEGER IW(LIW),IW2(NBLK) + DOUBLE PRECISION W1,W2 + INTEGER APOS,APOS2,I1RHS,I2RHS,IBLK,IFR,IIPIV,IIRHS,ILVL,IPIV, + + IPOS,IRHS,IST,J,J1,J2,JJ,JJ1,JJ2,JPIV,JPOS,K,LIELL,LOOP, + + NPIV + INTRINSIC IABS,MIN0 + COMMON /MA27FD/IOVFLO,NEMIN,IFRLVL(20) + INTEGER IOVFLO,NEMIN + INTEGER IFRLVL + SAVE /MA27FD/ + APOS = LATOP + 1 + NPIV = 0 + IBLK = NBLK + 1 + DO 180 LOOP = 1,N + IF (NPIV.GT.0) GO TO 110 + IBLK = IBLK - 1 + IF (IBLK.LT.1) GO TO 190 + IPOS = IW2(IBLK) + LIELL = -IW(IPOS) + NPIV = 1 + IF (LIELL.GT.0) GO TO 10 + LIELL = -LIELL + IPOS = IPOS + 1 + NPIV = IW(IPOS) + 10 JPOS = IPOS + NPIV + J2 = IPOS + LIELL + ILVL = MIN0(10,NPIV) + 10 + IF (LIELL.LT.IFRLVL(ILVL)) GO TO 110 + J1 = IPOS + 1 + IFR = 0 + DO 20 JJ = J1,J2 + J = IABS(IW(JJ)+0) + IFR = IFR + 1 + W(IFR) = RHS(J) + 20 CONTINUE + JPIV = 1 + DO 90 IIPIV = 1,NPIV + JPIV = JPIV - 1 + IF (JPIV.EQ.1) GO TO 90 + IPIV = NPIV - IIPIV + 1 + IF (IPIV.EQ.1) GO TO 30 + IF (IW(JPOS-1).LT.0) GO TO 60 + 30 JPIV = 1 + APOS = APOS - (LIELL+1-IPIV) + IST = IPIV + 1 + W1 = W(IPIV)*A(APOS) + IF (LIELL.LT.IST) GO TO 50 + JJ1 = APOS + 1 + DO 40 J = IST,LIELL + W1 = W1 + A(JJ1)*W(J) + JJ1 = JJ1 + 1 + 40 CONTINUE + 50 W(IPIV) = W1 + JPOS = JPOS - 1 + GO TO 90 + 60 JPIV = 2 + APOS2 = APOS - (LIELL+1-IPIV) + APOS = APOS2 - (LIELL+2-IPIV) + IST = IPIV + 1 + W1 = W(IPIV-1)*A(APOS) + W(IPIV)*A(APOS+1) + W2 = W(IPIV-1)*A(APOS+1) + W(IPIV)*A(APOS2) + IF (LIELL.LT.IST) GO TO 80 + JJ1 = APOS + 2 + JJ2 = APOS2 + 1 + DO 70 J = IST,LIELL + W1 = W1 + W(J)*A(JJ1) + W2 = W2 + W(J)*A(JJ2) + JJ1 = JJ1 + 1 + JJ2 = JJ2 + 1 + 70 CONTINUE + 80 W(IPIV-1) = W1 + W(IPIV) = W2 + JPOS = JPOS - 2 + 90 CONTINUE + IFR = 0 + DO 100 JJ = J1,J2 + J = IABS(IW(JJ)+0) + IFR = IFR + 1 + RHS(J) = W(IFR) + 100 CONTINUE + NPIV = 0 + GO TO 180 + 110 IF (NPIV.EQ.1) GO TO 120 + IF (IW(JPOS-1).LT.0) GO TO 150 + 120 NPIV = NPIV - 1 + APOS = APOS - (J2-JPOS+1) + IIRHS = IW(JPOS) + W1 = RHS(IIRHS)*A(APOS) + J1 = JPOS + 1 + IF (J1.GT.J2) GO TO 140 + K = APOS + 1 + DO 130 J = J1,J2 + IRHS = IABS(IW(J)+0) + W1 = W1 + A(K)*RHS(IRHS) + K = K + 1 + 130 CONTINUE + 140 RHS(IIRHS) = W1 + JPOS = JPOS - 1 + GO TO 180 + 150 NPIV = NPIV - 2 + APOS2 = APOS - (J2-JPOS+1) + APOS = APOS2 - (J2-JPOS+2) + I1RHS = -IW(JPOS-1) + I2RHS = IW(JPOS) + W1 = RHS(I1RHS)*A(APOS) + RHS(I2RHS)*A(APOS+1) + W2 = RHS(I1RHS)*A(APOS+1) + RHS(I2RHS)*A(APOS2) + J1 = JPOS + 1 + IF (J1.GT.J2) GO TO 170 + JJ1 = APOS + 2 + JJ2 = APOS2 + 1 + DO 160 J = J1,J2 + IRHS = IABS(IW(J)+0) + W1 = W1 + RHS(IRHS)*A(JJ1) + W2 = W2 + RHS(IRHS)*A(JJ2) + JJ1 = JJ1 + 1 + JJ2 = JJ2 + 1 + 160 CONTINUE + 170 RHS(I1RHS) = W1 + RHS(I2RHS) = W2 + JPOS = JPOS - 2 + 180 CONTINUE + 190 RETURN + END diff --git a/deal.II/contrib/hsl/source/ma47.f b/deal.II/contrib/hsl/source/ma47.f new file mode 100644 index 0000000000..ebe3a41921 --- /dev/null +++ b/deal.II/contrib/hsl/source/ma47.f @@ -0,0 +1,5075 @@ +C ******************************************************************* +C COPYRIGHT (c) 1993 Rutherford Appleton Laboratory. + +C None of the comments in this Copyright notice between the lines +C of asterisks shall be removed or altered in any way. + +C This Package is intended for compilation without modification, +C so most of the embedded comments have been removed. + +C ALL USE IS SUBJECT TO LICENCE. For full details of an HSL ARCHIVE +C Licence, see http://hsl.rl.ac.uk/archive/cou.html + +C Please note that for an HSL ARCHIVE Licence: + +C 1. The Package must not be copied for use by any other person. +C Supply of any part of the library by the Licensee to a third party +C shall be subject to prior written agreement between AEA +C Technology plc and the Licensee on suitable terms and conditions, +C which will include financial conditions. +C 2. All information on the Package is provided to the Licensee on the +C understanding that the details thereof are confidential. +C 3. All publications issued by the Licensee that include results obtained +C with the help of one or more of the Packages shall acknowledge the +C use of the Packages. The Licensee will notify the Numerical Analysis +C Group at Rutherford Appleton Laboratory of any such publication. +C 4. The Packages may be modified by or on behalf of the Licensee +C for such use in research applications but at no time shall such +C Packages or modifications thereof become the property of the +C Licensee. The Licensee shall make available free of charge to the +C copyright holder for any purpose all information relating to +C any modification. +C 5. Neither CCLRC nor AEA Technology plc shall be liable for any +C direct or consequential loss or damage whatsoever arising out of +C the use of Packages by the Licensee. +C ******************************************************************* + +C######DATE 24 May 1993 +C 4 Feb 1994. Modified to limit searches for structured pivots under +C control of ICNTL(4). +C July 1994. Code added to avoid thrashing when there are no +C nondefective rows of minimal row count. +C 7/12/94. Some defaults changed following further testing. Minor +C defects (mostly in comments) remedied. + + SUBROUTINE MA47AD(N,NE,IRN,JCN,IW,LIW,KEEP,ICNTL,RINFO,INFO) + INTEGER N,NE,IRN(NE),JCN(NE),LIW,IW(LIW),KEEP(NE+5*N+2),ICNTL(7) + DOUBLE PRECISION RINFO(4) + INTEGER INFO(24) + INTRINSIC MIN + EXTERNAL MA47GD,MA47HD,MA47JD,MA47KD,MA47LD,MA47MD,MA47ND + INTEGER FATHER,I,IPE,COUNT,IWFR,K,LDIAG,LEAF,LP,LW,LROW,MAP,MARK, + + MP,NODE,NODES,NV,PERM,SIZES + LP = ICNTL(1) + MP = ICNTL(2) + LDIAG = ICNTL(3) + DO 10 I = 1,14 + INFO(I) = 0 + 10 CONTINUE + IF (LDIAG.GE.3 .AND. MP.GT.0) THEN + WRITE (MP,'(//A,I6,A,I7,A,I7)') ' Entering MA47AD with N =',N, + + ' NE =',NE,' LIW =',LIW + WRITE (MP,'(A,6I6)') ' ICNTL(1:6) =', (ICNTL(I),I=1,6) + K = MIN(9,NE) + IF (LDIAG.EQ.4) K = NE + IF (K.GT.0) THEN + WRITE (MP,'(A/(3(I6,A,2I6,A)))') ' Matrix entries:', + + (I,': (',IRN(I),JCN(I),')',I=1,K) + IF (K.LT.NE) WRITE (MP,'(A)') ' . . .' + END IF + K = MIN(10,N) + IF (LDIAG.EQ.4) K = N + IF (ICNTL(4).EQ.1 .AND. K.GT.0) THEN + WRITE (MP,'(A,10I6:/(7X,10I6))') ' KEEP =', (KEEP(I),I=1,K) + IF (K.LT.N) WRITE (MP,'(7X,A)') ' . . .' + END IF + END IF + IF (N.LT.1 .OR. (N+N+N)/3.NE.N) GO TO 20 + IF (NE.LT.1) GO TO 30 + LW = LIW - 4*N - 4 + IPE = LW + 1 + COUNT = IPE + N + 1 + NV = COUNT + N + 1 + LEAF = NV + N + 1 + PERM = 1 + LROW = PERM + N + NODE = LROW + N + MARK = NODE + N + FATHER = MARK + N + SIZES = FATHER + N + MAP = SIZES + 2 + IF (ICNTL(4).NE.1) THEN + IF (LW.LT.NE*2+N) GO TO 60 + CALL MA47GD(N,NE,IRN,JCN,IW,IW(IPE),IW(COUNT),IW(NV),KEEP(MARK), + + IWFR,ICNTL,INFO) + KEEP(SIZES) = IW(COUNT) + CALL MA47HD(N,IW(IPE+1),IW,LW,IWFR,IW(COUNT),IW(NV), + + KEEP(FATHER),KEEP(LROW),KEEP(NODE),KEEP(MARK), + + IW(LEAF),KEEP(PERM),ICNTL,INFO) + IF (INFO(1).EQ.-3) GO TO 50 + ELSE + IF (LW.LT.NE+N) GO TO 40 + CALL MA47JD(N,NE,IRN,JCN,KEEP,IW,IW(IPE),IW(COUNT),IW(NV), + + KEEP(MARK),IWFR,ICNTL,INFO) + DO 12 I = 1,N + KEEP(FATHER+I-1) = IW(NV+I) + 12 CONTINUE + IF (INFO(1).LT.0) GO TO 80 + CALL MA47KD(N,IW(IPE+1),IW,LW,IWFR,KEEP,IW(COUNT),KEEP(FATHER), + + KEEP(LROW),IW(NV),KEEP(NODE),KEEP(MARK),IW(LEAF), + + ICNTL,INFO) + IF (INFO(1).EQ.-3) GO TO 50 + IF (INFO(1).LT.0) GO TO 90 + END IF + CALL MA47LD(N,KEEP(FATHER),KEEP(LROW),KEEP(NODE),IW(COUNT),IW(NV), + + IW(LEAF),KEEP(MARK),KEEP(PERM),NODES,ICNTL) + KEEP(SIZES) = INFO(3) + KEEP(SIZES+1) = NODES + CALL MA47ND(N,NE,IRN,JCN,KEEP(MAP),KEEP(LROW),KEEP(PERM), + + IW(COUNT),IW(IPE)) + DO 15 K = 1,NE + IW(KEEP(MAP+K-1)+LIW-NE) = JCN(K) + 15 CONTINUE + CALL MA47MD(N,NE-KEEP(SIZES),IW(NODES+N+2),LIW-NODES-N-1, + + KEEP(LROW),KEEP(PERM),NODES,IW,KEEP(NODE),IW(NODES+1), + + KEEP(FATHER),ICNTL(5),INFO,RINFO) + GO TO 100 + 20 INFO(1) = -1 + IF (LDIAG.GT.0 .AND. LP.GT.0) WRITE (LP,'(A,I3/A,I8)') + + ' **** Error return from MA47AD **** INFO(1) =',INFO(1), + + ' N has value',N + GO TO 100 + 30 INFO(1) = -2 + IF (LDIAG.GT.0 .AND. LP.GT.0) WRITE (LP,'(A,I3/A,I10)') + + ' **** Error return from MA47AD **** INFO(1) =',INFO(1), + + ' NE has value',NE + GO TO 100 + 40 INFO(2) = NE + 5*N + 4 + GO TO 70 + 50 INFO(2) = LIW + INFO(2) + GO TO 70 + 60 INFO(2) = 2*NE + 5*N + 4 + 70 INFO(1) = -3 + IF (LDIAG.GT.0 .AND. LP.GT.0) WRITE (LP,'(A,I3/A,I10,A,I10)') + + ' **** Error return from MA47AD **** INFO(1) =',INFO(1), + + ' LIW is too small. It must be increased from',LIW, + + ' to at least',INFO(2) + RETURN + 80 IF (LDIAG.GT.0 .AND. LP.GT.0) WRITE (LP,'(A,I3/A/I10,A)') + + ' **** Error return from MA47AD **** INFO(1) =',INFO(1), + + ' Invalid permutation supplied in KEEP. Component',INFO(2), + + ' is faulty.' + RETURN + 90 IF (LDIAG.GT.0 .AND. LP.GT.0) WRITE (LP,'(A,I3/A/I10,A)') + + ' **** Error return from MA47AD **** INFO(1) =',INFO(1), + + ' Invalid pivot sequence supplied in KEEP. Component',INFO(2), + + ' is negative but the next component is not negative.' + RETURN + 100 IF (LDIAG.GE.3 .AND. MP.GT.0) THEN + WRITE (MP,'(/A,I7,A,2F7.0/A,5I8/(14X,5(I8)))') + + ' Leaving MA47AD with INFO(1) =',INFO(1),' RINFO(1:2) =', + + RINFO(1),RINFO(2),' INFO(2:14) = ', (INFO(I),I=2,14) + IF (INFO(1).GE.0) THEN + K = MIN(10,NE) + IF (LDIAG.EQ.4) K = NE + WRITE (MP,'(A/(10I6))') ' Column indices:', (JCN(K),K=1,K) + IF (K.LT.NE) WRITE (MP,'(A)') ' . . .' + K = MIN(9,N) + IF (LDIAG.EQ.4) K = N + WRITE (MP,9000) ' KEEP(1:',N,') =',' (Permutation)', + + (KEEP(I),I=1,K) + IF (K.LT.N) WRITE (MP,'(16X,A)') ' . . .' + 9000 FORMAT (A,I7,A/A/ (12X,10I6)) + WRITE (MP,9000) ' KEEP(N+1:N+',N,') =', + + ' (No. of entries in permuted rows)', (KEEP(I),I=N+1,N+K) + IF (K.LT.N) WRITE (MP,'(16X,A)') ' . . .' + WRITE (MP,9000) ' KEEP(2N+1:2N+',N,') =', + + ' (Tree nodes at which variables eliminated)', + + (KEEP(I),I=2*N+1,2*N+K) + IF (K.LT.N) WRITE (MP,'(16X,A)') ' . . .' + K = MIN(10,KEEP(5*N+2)) + WRITE (MP,9000) ' KEEP(3N+1:3N+',KEEP(5*N+2),') =', + + ' (Markowitz costs at tree nodes)', (KEEP(I),I=3*N+1,3*N+K) + IF (K.LT.KEEP(5*N+2)) WRITE (MP,'(16X,A)') ' . . .' + WRITE (MP,9000) ' KEEP(4N+1:4N+',KEEP(5*N+2),') =', + + ' (Fathers of nodes in tree)', (KEEP(I),I=4*N+1,4*N+K) + IF (K.LT.KEEP(5*N+2)) WRITE (MP,'(16X,A)') ' . . .' + WRITE (MP,9010) ' KEEP(5N+1:5N+2) =', + + ' (Nos. of faulty entries and tree nodes)',KEEP(5*N+1), + + KEEP(5*N+2) + 9010 FORMAT (A/A/ (12X,2I6)) + K = MIN(10,NE) + IF (LDIAG.EQ.4) K = NE + WRITE (MP,9000) ' KEEP(5N+3:5N+2+',NE,') =',' (Map array)', + + (KEEP(I),I=5*N+3,5*N+2+K) + IF (K.LT.NE) WRITE (MP,'(16X,A)') ' . . .' + END IF + END IF + END + SUBROUTINE MA47BD(N,NE,JCN,A,LA,IW,LIW,KEEP,CNTL,ICNTL,IW1,RINFO, + + INFO) + INTEGER N,NE,JCN(NE),LA,ICNTL(7) + DOUBLE PRECISION A(LA),CNTL(2),RINFO(4) + INTEGER LIW,IW(LIW),KEEP(NE+5*N+2),IW1(2*N+2),INFO(24) + INTRINSIC MIN + EXTERNAL MA47OD,MA47UD + INTEGER FATHER,I,K,KE,LDIAG,LP,LROW,MAP,MARK,MP,NODE,PERM,SIZES + LP = ICNTL(1) + MP = ICNTL(2) + LDIAG = ICNTL(3) + IF (N.LT.1) GO TO 30 + IF ((N+N+N)/3.NE.N) GO TO 30 + IF (NE.LT.1) GO TO 40 + IF (LIW.LT.NE*2) GO TO 50 + IF (LA.LT.NE*2) GO TO 70 + INFO(1) = 0 + INFO(2) = 0 + DO 10 I = 15,24 + INFO(I) = 0 + 10 CONTINUE + IF (LDIAG.GT.2 .AND. MP.GT.0) THEN + WRITE (MP,'(//A,I6,3(A,I7)/A,3I7/A,I7/A,1P2D12.4)') + + ' Entering MA47BD with N =',N,' NE =',NE,' LA =',LA, + + ' LIW =',LIW,' ICNTL(1:3) =', (ICNTL(I),I=1,3), + + ' ICNTL(5) =',ICNTL(5),' CNTL(1:2) =',CNTL(1),CNTL(2) + KE = MIN(6,NE) + IF (LDIAG.EQ.4) KE = NE + IF (KE.GT.0) THEN + WRITE (MP,'(A/( 3(I6,'':'',1PD12.4) ) )') + + ' Matrix entries:', (K,A(K),K=1,KE) + IF (K.LT.NE) WRITE (MP,'(A)') ' . . .' + WRITE (MP,'(A/(10I6))') ' Column indices:', (JCN(K),K=1,KE) + IF (K.LT.NE) WRITE (MP,'(A)') ' . . .' + END IF + K = MIN(10,N) + IF (LDIAG.EQ.4) K = N + WRITE (MP,9000) ' KEEP(1:',N,') =',' (Permutation)', + + (KEEP(I),I=1,K) + IF (K.LT.N) WRITE (MP,'(16X,A)') ' . . .' + 9000 FORMAT (A,I7,A/A/ (12X,10I6)) + WRITE (MP,9000) ' KEEP(N+1:N+',N,') =', + + ' (No. of entries in permuted rows)', (KEEP(I),I=N+1,N+K) + IF (K.LT.N) WRITE (MP,'(16X,A)') ' . . .' + WRITE (MP,9000) ' KEEP(2N+1:2N+',N,') =', + + ' (Tree nodes at which variables eliminated)', + + (KEEP(I),I=2*N+1,2*N+K) + K = MIN(K,KEEP(5*N+2)) + IF (K.LT.KEEP(5*N+2)) WRITE (MP,'(16X,A)') ' . . .' + WRITE (MP,9000) ' KEEP(3N+1:3N+',KEEP(5*N+2),') =', + + ' (Markowitz costs at tree nodes)', (KEEP(I),I=3*N+1,3*N+K) + IF (K.LT.KEEP(5*N+2)) WRITE (MP,'(16X,A)') ' . . .' + WRITE (MP,9000) ' KEEP(4N+1:4N+',KEEP(5*N+2),') =', + + ' (Fathers of nodes in tree)', (KEEP(I),I=4*N+1,4*N+K) + IF (K.LT.KEEP(5*N+2)) WRITE (MP,'(16X,A)') ' . . .' + WRITE (MP,9010) ' KEEP(5N+1:5N+2) =', + + ' (Nos. of faulty entries and tree nodes)',KEEP(5*N+1), + + KEEP(5*N+2) + 9010 FORMAT (A/A/ (12X,2I6)) + WRITE (MP,9000) ' KEEP(5N+3:5N+2+',NE,') =',' (Map array)', + + (KEEP(I),I=5*N+3,5*N+2+KE) + IF (KE.LT.NE) WRITE (MP,'(16X,A)') ' . . .' + END IF + PERM = 1 + LROW = PERM + N + NODE = LROW + N + MARK = NODE + N + FATHER = MARK + N + SIZES = FATHER + N + MAP = SIZES + 2 +CDIR@ IVDEP + DO 20 K = 1,NE + A(KEEP(MAP+K-1)+LA-NE) = A(K) + IW(KEEP(MAP+K-1)+LIW-NE) = JCN(K) + 20 CONTINUE + CALL MA47OD(N,NE-KEEP(SIZES),A,LA,IW,LIW,KEEP(LROW),KEEP(PERM), + + KEEP(SIZES+1),IW1,KEEP(MARK),KEEP(NODE),IW1(N+1), + + KEEP(FATHER),CNTL,ICNTL(5),INFO,RINFO) + IF (INFO(1).EQ.-3) GO TO 60 + IF (INFO(1).EQ.-4) GO TO 80 + GO TO 90 + 30 INFO(1) = -1 + IF (LP.GT.0 .AND. LDIAG.GT.0) WRITE (LP,9020) INFO(1) + 9020 FORMAT (' **** Error return from MA47BD **** INFO(1)=',I3) + IF (LP.GT.0 .AND. LDIAG.GT.0) + + WRITE (LP,'(A,I10)') ' N has value',N + GO TO 100 + 40 INFO(1) = -2 + IF (LP.GT.0 .AND. LDIAG.GT.0) WRITE (LP,9020) INFO(1) + IF (LP.GT.0 .AND. LDIAG.GT.0) WRITE (LP, + + '(A,I10)') ' NE has value',NE + GO TO 100 + 50 INFO(1) = -3 + INFO(2) = NE*2 + 60 IF (LP.GT.0 .AND. LDIAG.GT.0) WRITE (LP,9020) INFO(1) + IF (LP.GT.0 .AND. LDIAG.GT.0) WRITE (LP,'(A,I10,A,I10)') + + ' LIW is too small. It must be increased from',LIW, + + ' to at least',INFO(2) + GO TO 100 + 70 INFO(1) = -4 + INFO(2) = NE*2 + 80 IF (LP.GT.0 .AND. LDIAG.GT.0) WRITE (LP,9020) INFO(1) + IF (LP.GT.0 .AND. LDIAG.GT.0) WRITE (LP,'(A,I10,A,I10)') + + ' LA is too small. It must be increased from',LA, + + ' to at least',INFO(2) + GO TO 100 + 90 IF (LDIAG.GT.2 .AND. MP.GT.0) THEN + WRITE (MP,'(/A,I7,A,I7/A,2F9.0/A,2I8/A,5I8/(15X,5I8))') + + ' Leaving MA47BD with INFO(1) =',INFO(1),' IERROR =', + + INFO(2),' RINFO(3:4) = ',RINFO(3),RINFO(4),' INFO(6:7) = ', + + (INFO(I),I=6,7),' INFO(15:24) = ', (INFO(I),I=15,24) + CALL MA47UD(A,LA,IW,LIW,ICNTL) + END IF + 100 RETURN + END + SUBROUTINE MA47CD(N,A,LA,IW,LIW,W,RHS,IW1,ICNTL) + INTEGER N,LA + DOUBLE PRECISION A(LA) + INTEGER LIW,IW(LIW) + DOUBLE PRECISION W(N),RHS(N) + INTEGER IW1(N),ICNTL(7) + INTRINSIC MIN + EXTERNAL MA47QD,MA47RD,MA47UD + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D0) + INTEGER I,K,LDIAG,MP + MP = ICNTL(2) + LDIAG = ICNTL(3) + IF (LDIAG.GE.3 .AND. MP.GT.0) THEN + WRITE (MP,'(//A,I6,3(A,I7))') ' Entering MA47CD with N =',N, + + ' LA =',LA,' LIW =',LIW + CALL MA47UD(A,LA,IW,LIW,ICNTL) + K = MIN(10,N) + IF (LDIAG.EQ.4) K = N + WRITE (MP,'(A, 1P,5D13.3/(4X, 1P,5D13.3))') ' RHS', + + (RHS(I),I=1,K) + IF (K.LT.N) WRITE (MP,'(A)') ' . . .' + END IF + IF (IW(2).EQ.0) THEN + ELSE + CALL MA47QD(N,A,LA,IW,LIW,W,RHS,IW1,ICNTL) + CALL MA47RD(N,A,LA,IW,LIW,W,RHS,IW1,ICNTL) + END IF + IF (LDIAG.GE.3 .AND. MP.GT.0) THEN + WRITE (MP,'(//A)') ' Leaving MA47CD with RHS:' + WRITE (MP,'(1P,5D13.3)') (RHS(I),I=1,K) + IF (K.LT.N) WRITE (MP,'(A)') ' . . .' + END IF + END + SUBROUTINE MA47FD(N,IPE,FLAG,IW,LW,IWFR,NCMPA) + INTEGER N,IPE(N),FLAG(N),LW,IW(LW),IWFR,NCMPA + INTEGER I,IR,K,L,LEN1,LEN2,LEN3,LWFR + NCMPA = NCMPA + 1 + DO 10 I = 1,N + L = IPE(I) + IF (L.LE.0 .OR. FLAG(I).EQ.-1) GO TO 10 + IPE(I) = IW(L) + IW(L) = -I + 10 CONTINUE + IWFR = 1 + LWFR = 1 + DO 80 IR = 1,N + DO 20 K = LWFR,LW + IF (IW(K).LT.0) GO TO 30 + 20 CONTINUE + GO TO 90 + 30 I = -IW(K) + IW(IWFR) = IPE(I) + IPE(I) = IWFR + IWFR = IWFR + 1 + IF (FLAG(I).LE.-2) THEN + L = IWFR - 1 + LEN1 = IW(K+1) + IW(L+1) = LEN1 + LEN3 = IW(K+2) + IW(L+2) = LEN3 + LEN2 = IW(L) - LEN1 - LEN3 - 2 + IWFR = L + 3 + DO 40 LWFR = K + 3,K + 2 + LEN1 + IF (FLAG(IW(LWFR)).LT.0) THEN + IW(L+1) = IW(L+1) - 1 + IW(L) = IW(L) - 1 + ELSE + IW(IWFR) = IW(LWFR) + IWFR = IWFR + 1 + END IF + 40 CONTINUE + K = LWFR + DO 50 LWFR = K,K - 1 + LEN2 + IF (FLAG(IW(LWFR)).LT.0) THEN + IW(L) = IW(L) - 1 + ELSE + IW(IWFR) = IW(LWFR) + IWFR = IWFR + 1 + END IF + 50 CONTINUE + K = LWFR + DO 60 LWFR = K,K - 1 + LEN3 + IF (FLAG(IW(LWFR)).LT.0) THEN + IW(L+2) = IW(L+2) - 1 + IW(L) = IW(L) - 1 + ELSE + IW(IWFR) = IW(LWFR) + IWFR = IWFR + 1 + END IF + 60 CONTINUE + ELSE + DO 70 LWFR = K + 1,K + IW(IWFR-1) + IW(IWFR) = IW(LWFR) + IWFR = IWFR + 1 + 70 CONTINUE + END IF + 80 CONTINUE + 90 CONTINUE + END + SUBROUTINE MA47GD(N,NE,IRN,JCN,IW,IPE,COUNT,NV,FLAG,IWFR,ICNTL, + + INFO) + INTEGER N,NE,IRN(NE),JCN(NE),IW(NE*2+N),IPE(0:N),COUNT(0:N),NV(N), + + FLAG(N),IWFR,ICNTL(3),INFO(4) + INTRINSIC MAX,MIN + INTEGER I,J,K,L,LDIAG,MP + MP = ICNTL(2) + LDIAG = ICNTL(3) + IF (MP.LE.0) LDIAG = 0 + INFO(1) = 0 + COUNT(0) = 0 + DO 10 I = 1,N + FLAG(I) = 0 + COUNT(I) = 0 + NV(I) = -1 + 10 CONTINUE + DO 20 K = 1,NE + I = IRN(K) + J = JCN(K) + IF (MIN(I,J).LT.1 .OR. MAX(I,J).GT.N) THEN + IRN(K) = 0 + JCN(K) = 0 + COUNT(0) = COUNT(0) + 1 + INFO(1) = 1 + IF (COUNT(0).LE.1 .AND. LDIAG.GT.1) WRITE (MP,'(2A,I2)') + + ' *** Warning message from subroutine MA47AD ***', + + ' INFO(1) =',INFO(1) + IF (COUNT(0).LE.10 .AND. LDIAG.GT.1) WRITE (MP,'(3(I6,A))') K, + + 'th entry (in row',I,' and column',J,') ignored' + ELSE IF (I.NE.J) THEN + COUNT(I) = COUNT(I) + 1 + COUNT(J) = COUNT(J) + 1 + ELSE + COUNT(I) = COUNT(I) + 1 + NV(I) = 1 + END IF + 20 CONTINUE + IPE(0) = COUNT(0) + DO 30 I = 1,N + IPE(I) = IPE(I-1) + COUNT(I) + 1 + 30 CONTINUE + DO 40 K = 1,NE + I = IRN(K) + J = JCN(K) + IW(IPE(I)) = J + IPE(I) = IPE(I) - 1 + IF (I.NE.J) THEN + IW(IPE(J)) = I + IPE(J) = IPE(J) - 1 + END IF + 40 CONTINUE + INFO(3) = COUNT(0) + INFO(4) = 0 + IWFR = 1 + DO 60 I = 1,N + L = IPE(I) + IPE(I) = IWFR + DO 50 K = L + 1,L + COUNT(I) + J = IW(K) + IF (FLAG(J).NE.I) THEN + FLAG(J) = I + IWFR = IWFR + 1 + IW(IWFR) = J + ELSE + IF (I.LE.J) INFO(4) = INFO(4) + 1 + END IF + 50 CONTINUE + IW(IPE(I)) = IWFR - IPE(I) + IWFR = IWFR + 1 + 60 CONTINUE + IF (INFO(4).GT.0) THEN + INFO(1) = INFO(1) + 2 + IF (LDIAG.GT.1) WRITE (MP,'(A/I6,A)') + + ' *** Warning message from subroutine MA47AD ***',INFO(4), + + ' duplicate entries found.' + END IF + END + SUBROUTINE MA47HD(N,IPE,IW,LW,IWFR,COUNT,NV,NEXT,LAST,IPR,FLAG, + + LEAF,SVARS,ICNTL,INFO) + INTEGER N,IPE(N),LW,IW(LW),IWFR,COUNT(N),NV(N),NEXT(N),LAST(N), + + IPR(N),FLAG(N),LEAF(N),SVARS(N),ICNTL(7),INFO(24) + INTRINSIC ABS,MAX,MIN,REAL + EXTERNAL MA47FD,MA47TD,MA47VD,MA47ZD + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0D0) + LOGICAL BOUND + DOUBLE PRECISION CMIN,COST + INTEGER FLG,FLG1,I,IE,IEL,IP,IR,IRL,IS,ITHR,JP,JP1,JP2,JP3,JP4,JS, + + K,KE,KIND,KP,KP1,KP2,KS,K1,K2,LDIAG,LIST,LOOP,LS,ME,MINF, + + MINR,ML,MP,MROWS,MS,NCMP,NEL,NFLG,NP,NP0,NR(3),NROWS,NS, + + NSC(3),NSVARS,NVC,NVPIV,PART,PIV(2),PIVOT(2),PIVT,RANK + INTEGER SHIFT,THRESH + MP = ICNTL(2) + LDIAG = ICNTL(3) + IF (MP.LE.0) LDIAG = 0 + MROWS = N + IF (ICNTL(4).GT.1)MROWS = ICNTL(4) + CALL MA47TD(N,IPE,IW,LW,NV,NEXT,LAST,LEAF,FLAG,COUNT,SVARS) + IF (LDIAG.GT.4) THEN + WRITE (MP,'(/A)') ' Row NV List' + DO 10 I = 1,N + KP = IPE(I) + IF (KP.EQ.0) THEN + WRITE (MP,'(I7,I5)') I,NV(I) + ELSE + WRITE (MP,'(I7,I5,10I6:/ (12X,10I6))') I,NV(I), + + (IW(K),K=KP+1,KP+IW(KP)) + END IF + 10 CONTINUE + END IF + THRESH = MAX(SQRT(REAL(N)),3.) + RANK = N + MINF = 1 + MINR = 1 + NCMP = 0 + NFLG = N*3 + NEL = 0 + DO 20 IS = 1,N + IPR(IS) = 0 + FLAG(IS) = NFLG + 20 CONTINUE + DO 30 IS = 1,N + K = IPE(IS) + IF (K.EQ.0) THEN + FLAG(IS) = -1 + ELSE + IR = IW(K) + IF (IR.EQ.0) THEN + RANK = RANK + NV(IS) + NV(IS) = -NV(IS) + IR = 1 + END IF + COUNT(IS) = IR + NS = IPR(IR) + IF (NS.GT.0) LAST(NS) = IS + NEXT(IS) = NS + IPR(IR) = IS + LAST(IS) = 0 + END IF + 30 CONTINUE + DO 670 ML = 1,N + IF (NEL.GE.N) GO TO 680 + IR = MINR + DO 40 MINR = IR,N + IF (IPR(MINR).NE.0) GO TO 50 + 40 CONTINUE + 50 DO 170 ITHR = 1,N + NROWS = 0 + CMIN = REAL(N)**2 + DO 140 IR = MINR,N + IF (MINF.GT.IR) GO TO 70 + MS = IPR(IR) + DO 60 LIST = 1,N + IF (MS.EQ.0) THEN + MINF = IR + 1 + GO TO 70 + END IF + IF (NV(MS).GT.0) THEN + IF (IR.LE.THRESH) GO TO 180 + GO TO 160 + END IF + MS = NEXT(MS) + 60 CONTINUE + 70 MS = IPR(IR) + DO 120 LIST = 1,N + IF (MS.EQ.0) GO TO 130 + IF (NFLG.LE.4) CALL MA47ZD(N,FLAG,NFLG) + NROWS = NROWS + 1 + NFLG = NFLG - 1 + KP = IPE(MS) + KP1 = KP + 1 + KP2 = KP + IW(KP) + DO 100 KP = KP1,KP2 + PART = (IW(KP)-1)/N + KE = IW(KP) - PART*N + IF (FLAG(KE).EQ.-1) GO TO 100 + IF (FLAG(KE).LE.-2) THEN + JP = IPE(KE) + IF (PART.EQ.2) THEN + JP1 = JP + 3 + IW(JP+1) + JP2 = JP + IW(JP) + ELSE + JP1 = JP + 3 + JP2 = JP + IW(JP) - IW(JP+2) + END IF + ELSE + JP1 = KP + JP2 = KP2 + END IF + DO 90 JP = JP1,JP2 + IS = IW(JP) + IF (FLAG(IS).GT.NFLG) THEN + FLAG(IS) = NFLG + IF (NV(IS).LT.0) THEN + COST = REAL(COUNT(IS)-1)*REAL(IR-1) + ELSE + COST = REAL(IR+COUNT(IS)-3)*REAL(IR-1) + END IF + IF (COST.LT.CMIN) THEN + CMIN = COST + PIVOT(1) = IS + PIVOT(2) = MS + IF (CMIN.LE.REAL(IR-1)**2) GO TO 150 + END IF + END IF + 90 CONTINUE + IF (JP2.EQ.KP2) GO TO 110 + 100 CONTINUE + 110 IF (NROWS.GE.MROWS) GO TO 150 + MS = NEXT(MS) + 120 CONTINUE + 130 IF (CMIN.LE.REAL(IR)**2) GO TO 150 + 140 CONTINUE + 150 IR = MAX(COUNT(PIVOT(1)),COUNT(PIVOT(2))) + IF (IR.LE.THRESH) GO TO 190 + 160 CALL MA47VD(THRESH,IR+N/10,N,IPE,IW,LW,COUNT,NV,NEXT,LAST,IPR, + + FLAG,NFLG) + 170 CONTINUE + 180 KIND = 1 + ME = MS + PIVOT(1) = MS + PIVOT(2) = MS + PIVT = 0 + NVPIV = NV(MS) + CMIN = REAL(IR-1)**2 + FLAG(MS) = -1 + IF (LDIAG.GT.4) WRITE (MP,'(A,I5,A,2I5,A,I5,A,F7.0)') + + ' Pivot',NEL,':',PIVOT(1),NV(PIVOT(1)),' Row count:', + + COUNT(PIVOT(1)),' M-cost=',CMIN + NEL = NEL + NVPIV + GO TO 210 + 190 KIND = 2 + IF (NV(PIVOT(1)).LT.0) KIND = 3 + FLAG(PIVOT(1)) = -1 + FLAG(PIVOT(2)) = -1 + PIV(1) = PIVOT(1) + PIV(2) = PIVOT(2) + NVPIV = ABS(NV(PIVOT(1))) + IF (NVPIV.EQ.ABS(NV(PIVOT(2)))) THEN + PIVT = 0 + ELSE + IF (NVPIV.GT.ABS(NV(PIVOT(2)))) THEN + PIVT = PIVOT(1) + NVPIV = ABS(NV(PIVOT(2))) + ELSE + PIVT = PIVOT(2) + END IF + MS = LEAF(PIVT) + DO 200 K = 2,NVPIV + MS = -NEXT(MS) + 200 CONTINUE + LEAF(MS) = LEAF(PIVT) + LEAF(PIVT) = -NEXT(MS) + FLAG(PIVT) = NFLG + NEXT(MS) = 0 + NV(PIVT) = SIGN(ABS(NV(PIVT))-NVPIV,NV(PIVT)) + NV(MS) = SIGN(NVPIV,NV(PIVT)) + COUNT(MS) = COUNT(PIVT) + IF (PIVT.EQ.PIVOT(1)) THEN + PIV(1) = MS + ELSE + PIV(2) = MS + END IF + END IF + ME = PIV(1) + IF (LDIAG.GT.4) WRITE (*,'(A,I5,A,3I5,A,2I5,A,F7.0)') + + ' Pivot',NEL,':',PIV(1),PIV(2),NV(ME),' Row counts:', + + COUNT(PIVOT(1)),COUNT(PIVOT(2)),' M-cost=',CMIN + NSC(2) = 0 + NVC = 0 + NEL = NEL + NVPIV*2 + 210 NSVARS = 0 + IR = 0 + DO 280 LOOP = MIN(KIND,2),1,-1 + MS = PIVOT(LOOP) + NSC(1) = NSVARS + NR(1) = IR + IF (MS.NE.PIVT) THEN + NS = NEXT(MS) + LS = LAST(MS) + NEXT(MS) = 0 + IF (NS.GT.0) LAST(NS) = LS + IF (LS.GT.0) THEN + NEXT(LS) = NS + ELSE + IPR(COUNT(MS)) = NS + END IF + END IF + KP = IPE(MS) + KP1 = KP + 1 + KP2 = KP + IW(KP) + DO 270 KP = KP1,KP2 + PART = (IW(KP)-1)/N + KE = IW(KP) - PART*N + IF (FLAG(KE).EQ.-1) GO TO 270 + IF (FLAG(KE).LE.-2) THEN + IE = KE + DO 220 LIST = 1,N + IF (NEXT(IE).EQ.0) GO TO 230 + IEL = IE + IE = -LAST(IE) + IF (IE.EQ.ME) GO TO 240 + LAST(IEL) = -ME + 220 CONTINUE + 230 NEXT(IE) = -ME + LAST(IE) = -ME + 240 JP = IPE(KE) + JP1 = JP + 3 + JP2 = JP + IW(JP) + IF (PART.EQ.0) THEN + ELSE IF (PART.EQ.2) THEN + JP1 = JP1 + IW(JP+1) + ELSE + JP2 = JP2 - IW(JP+2) + END IF + ELSE + JP1 = KP + JP2 = KP2 + END IF + DO 250 JP = JP1,JP2 + IS = IW(JP) + IF (FLAG(IS).LE.LOOP) THEN + ELSE IF (FLAG(IS).EQ.2) THEN + NVC = NVC + ABS(NV(IS)) + NSC(2) = NSC(2) + 1 + FLAG(IS) = 0 + COUNT(IS) = COUNT(IS) - NVPIV + ELSE + IR = IR + ABS(NV(IS)) + FLAG(IS) = LOOP + NSVARS = NSVARS + 1 + SVARS(NSVARS) = IS + LS = LAST(IS) + LAST(IS) = 0 + NS = NEXT(IS) + NEXT(IS) = 0 + IF (NS.GT.0) LAST(NS) = LS + IF (LS.GT.0) THEN + NEXT(LS) = NS + ELSE + IPR(COUNT(IS)) = NS + END IF + COUNT(IS) = COUNT(IS) - NVPIV + END IF + 250 CONTINUE + IF (JP2.NE.KP2 .AND. LOOP.EQ.1) THEN + IF (KIND.EQ.1) THEN + IF (PART.EQ.0) FLAG(KE) = -1 + ELSE + DO 260 JP = JP1,JP2 + IF (IW(JP).EQ.PIVOT(2)) THEN + FLAG(KE) = -1 + GO TO 270 + END IF + 260 CONTINUE + END IF + END IF + 270 CONTINUE + 280 CONTINUE + IF (KIND.EQ.1) THEN + NSC(2) = NSVARS + NR(1) = IR + NSC(3) = 0 + NR(3) = 0 + ELSE + NEXT(PIV(2)) = -ME + LAST(PIV(2)) = -ME + COUNT(PIV(2)) = -COUNT(PIV(2)) + IF (KIND.EQ.2) THEN + NSC(3) = NSVARS - NSC(1) + NR(3) = IR - NR(1) + NSC(2) = NSC(1) + NR(2) = NR(1) + NSC(1) = 0 + NR(1) = IR + ELSE + NSC(3) = NSVARS - NSC(1) + NR(3) = IR - NR(1) + NVC + NSC(1) = NSC(1) - NSC(2) + NR(2) = NR(1) + NR(1) = IR + K1 = 1 + DO 310 K = 1,NSC(1) + NSC(2) + IF (FLAG(SVARS(K)).EQ.2) THEN + KS = SVARS(K) + SVARS(K) = SVARS(K1) + SVARS(K1) = KS + K1 = K1 + 1 + END IF + 310 CONTINUE + END IF + END IF + IF (NSVARS.EQ.0) THEN + IPE(ME) = 0 + GO TO 670 + END IF + IF (NFLG.LE.4) CALL MA47ZD(N,FLAG,NFLG) + NFLG = NFLG - 1 + DO 450 K = 1,NSVARS + IS = SVARS(K) + KP = IPE(IS) + KP1 = KP + 1 + KP2 = IW(KP) + KP + DO 440 KP = KP1,KP2 + PART = (IW(KP)-1)/N + KE = IW(KP) - N*PART + IF (FLAG(KE).GE.0) GO TO 450 + IF (FLAG(KE).EQ.-1) GO TO 440 + IF (FLAG(KE).EQ.-NFLG) GO TO 440 + FLAG(KE) = -NFLG + JP = IPE(KE) + JP1 = JP + 3 + JP2 = JP1 + IW(JP+1) + JP4 = JP + IW(JP) + JP3 = JP4 - IW(JP+2) + IF (KIND.EQ.1) THEN + DO 340 JP = JP1,JP4 + IF (FLAG(IW(JP)).GT.2) GO TO 440 + 340 CONTINUE + ELSE IF (KIND.EQ.2) THEN + DO 350 JP = JP2,JP3 + IF (FLAG(IW(JP)).GT.2) GO TO 440 + IF (FLAG(IW(JP)).EQ.1) GO TO 440 + 350 CONTINUE + FLG1 = 0 + DO 360 JP = JP3 + 1,JP4 + FLG = FLAG(IW(JP)) + IF (FLG.GT.2) GO TO 440 + IF (FLG.LE.0) GO TO 360 + FLG1 = FLG + 360 CONTINUE + DO 370 JP = JP1,JP2 - 1 + FLG = FLAG(IW(JP)) + IF (FLG.GT.2) GO TO 440 + IF (FLG.LE.0) GO TO 370 + IF (FLG1.NE.0) GO TO 440 + 370 CONTINUE + ELSE + DO 380 JP = JP2,JP3 + IF (FLAG(IW(JP)).GT.0) GO TO 440 + 380 CONTINUE + FLG1 = 0 + DO 390 JP = JP3 + 1,JP4 + FLG = FLAG(IW(JP)) + IF (FLG.GT.2) GO TO 440 + IF (FLG.LE.0) GO TO 390 + IF (FLG1.EQ.0) FLG1 = FLG + IF (FLG.NE.FLG1) GO TO 440 + 390 CONTINUE + FLG1 = 3 - FLG1 + DO 400 JP = JP1,JP2 - 1 + FLG = FLAG(IW(JP)) + IF (FLG.GT.2) GO TO 440 + IF (FLG.LE.0) GO TO 400 + IF (FLG1.EQ.3) FLG1 = FLG + IF (FLG.NE.FLG1) GO TO 440 + 400 CONTINUE + END IF + FLAG(KE) = -1 + IE = KE + DO 420 LIST = 1,N + IF (NEXT(IE).EQ.0) GO TO 430 + IEL = IE + IE = -LAST(IE) + IF (IE.EQ.ME) GO TO 440 + LAST(IEL) = -ME + 420 CONTINUE + 430 NEXT(IE) = -ME + LAST(IE) = -ME + 440 CONTINUE + 450 CONTINUE + DO 630 LOOP = 1,KIND + IF (LOOP.EQ.1) THEN + K1 = 1 + NSC(1) + K2 = K1 + NSC(2) - 1 + ELSE IF (LOOP.EQ.2) THEN + K1 = K2 + 1 + K2 = NSVARS + DO 460 K = K1,K2 + IS = SVARS(K) + IF (NV(IS).NE.0) FLAG(IS) = NFLG + 460 CONTINUE + ELSE + DO 470 K = K1,K2 + IS = SVARS(K) + IF (NV(IS).NE.0) FLAG(IS) = 1 + 470 CONTINUE + K1 = 1 + K2 = NSC(1) + DO 480 K = K1,K2 + IS = SVARS(K) + IF (NV(IS).NE.0) FLAG(IS) = NFLG + 480 CONTINUE + END IF + DO 620 K = K1,K2 + IS = SVARS(K) + BOUND = COUNT(IS) .GT. THRESH + IF (LOOP.EQ.1) NV(IS) = ABS(NV(IS)) + IF (NFLG.LE.4) CALL MA47ZD(N,FLAG,NFLG) + NFLG = NFLG - 1 + IR = NR(LOOP) + KP = IPE(IS) + NP = KP + 1 + KP1 = KP + 1 + KP2 = IW(KP) + KP + DO 520 KP = KP1,KP2 + PART = (IW(KP)-1)/N + KE = IW(KP) - N*PART + IF (FLAG(KE).LE.-2) THEN + FLAG(KE) = -NFLG + IF (BOUND) GO TO 510 + LEAF(KE) = PART + JP = IPE(KE) + JP1 = JP + 3 + JP2 = JP + IW(JP) + IF (PART.EQ.0) THEN + ELSE IF (PART.EQ.2) THEN + JP1 = JP1 + IW(JP+1) + ELSE + JP2 = JP2 - IW(JP+2) + END IF + IRL = IR + DO 500 JP = JP1,JP2 + JS = IW(JP) + IF (FLAG(JS).LE.NFLG) GO TO 500 + IR = IR + ABS(NV(JS)) + FLAG(JS) = NFLG + 500 CONTINUE + IF (IR.EQ.IRL .AND. LAST(KE).EQ.-ME) GO TO 520 + 510 IW(NP) = IW(KP) + NP = NP + 1 + ELSE IF (FLAG(KE).GE.0) THEN + GO TO 530 + END IF + 520 CONTINUE + NP0 = NP + GO TO 550 + 530 NP0 = NP + KP1 = KP + DO 540 KP = KP1,KP2 + KS = IW(KP) + IF (FLAG(KS).LE.NFLG) GO TO 540 + IR = IR + ABS(NV(KS)) + FLAG(KS) = NFLG + IW(NP) = KS + NP = NP + 1 + 540 CONTINUE + 550 IF (BOUND) IR = COUNT(IS) + IF (NP.GT.KP2) THEN + KP = IPE(IS) + IF (NP+IWFR-KP.GE.LW) THEN + CALL MA47FD(N,IPE,FLAG,IW,IWFR-1,IWFR,NCMP) + IF (NP+IWFR-KP.GE.LW) THEN + INFO(1) = -3 + INFO(2) = NP + IWFR - KP + 1 - LW + END IF + SHIFT = IPE(IS) - KP + KP = KP + SHIFT + KP2 = KP2 + SHIFT + NP = NP + SHIFT + NP0 = NP0 + SHIFT + END IF + NP = NP + IWFR - KP + NP0 = NP0 + IWFR - KP + IPE(IS) = IWFR + KP1 = KP + DO 560 KP = KP1,KP2 + IW(IWFR) = IW(KP) + IWFR = IWFR + 1 + 560 CONTINUE + IW(IWFR) = 0 + IWFR = IWFR + 1 + END IF + IW(NP) = IW(NP0) + KP = IPE(IS) + IW(NP0) = IW(KP+1) + IW(KP+1) = ME + (LOOP-1)*N + IW(KP) = NP - KP + IF (IR.EQ.0) THEN + IR = -NV(IS) + NV(IS) = IR + RANK = RANK - IR + IR = 1 + END IF + IF (CMIN.EQ.ZERO) GO TO 610 + IF (IR.GT.THRESH) GO TO 610 + JS = IPR(IR) + DO 590 LIST = 1,N + IF (JS.LE.0) GO TO 610 + KP = IPE(JS) + IF (IW(KP+1).NE.ME+ (LOOP-1)*N) GO TO 610 + IF (SIGN(1,NV(JS)).NE.SIGN(1,NV(IS))) GO TO 580 + KP1 = KP + DO 570 KP = KP1 + 2,KP1 + IW(KP1) + PART = (IW(KP)-1)/N + IE = IW(KP) - PART*N + IF (ABS(FLAG(IE)).GT.NFLG) GO TO 580 + IF (FLAG(IE).EQ.-NFLG) THEN + IF (PART.NE.LEAF(IE)) GO TO 580 + END IF + 570 CONTINUE + GO TO 600 + 580 JS = NEXT(JS) + 590 CONTINUE + 600 IPE(JS) = 0 + NV(IS) = NV(IS) + NV(JS) + NV(JS) = 0 + FLAG(JS) = -1 + NS = NEXT(JS) + LS = LAST(JS) + IF (NS.GT.0) LAST(NS) = IS + IF (LS.GT.0) NEXT(LS) = IS + LAST(IS) = LS + NEXT(IS) = NS + IF (IPR(IR).EQ.JS) IPR(IR) = IS + COUNT(IS) = IR + NEXT(JS) = -LEAF(IS) + LEAF(IS) = LEAF(JS) + LAST(JS) = -IS + GO TO 620 + 610 NS = IPR(IR) + IF (NS.GT.0) LAST(NS) = IS + NEXT(IS) = NS + IPR(IR) = IS + LAST(IS) = 0 + MINR = MIN(MINR,IR) + IF(NV(IS).GT.0)MINF = MIN(MINF,IR) + COUNT(IS) = IR + 620 CONTINUE + 630 CONTINUE + IF (IWFR+NSVARS+3.GE.LW) THEN + CALL MA47FD(N,IPE,FLAG,IW,IWFR-1,IWFR,NCMP) + IF (IWFR+NSVARS+3.GE.LW) THEN + INFO(1) = -3 + INFO(2) = IWFR + NSVARS + 4 - LW + RETURN + END IF + END IF + IP = IWFR + IWFR = IWFR + 3 + K2 = 0 + DO 650 LOOP = 1,3 + K1 = K2 + 1 + K2 = K1 + NSC(LOOP) - 1 + DO 640 K = K1,K2 + IS = SVARS(K) + IF (NV(IS).EQ.0) THEN + NSC(LOOP) = NSC(LOOP) - 1 + ELSE + FLAG(IS) = NFLG + IW(IWFR) = IS + IWFR = IWFR + 1 + END IF + 640 CONTINUE + 650 CONTINUE + IW(IP) = IWFR - IP - 1 + IW(IP+1) = NSC(1) + IW(IP+2) = NSC(3) + FLAG(ME) = -NFLG + IPE(ME) = IP + 670 CONTINUE + 680 IF (RANK.LT.N) INFO(1) = INFO(1) + 4 + INFO(8) = N - RANK + INFO(12) = NCMP + END + SUBROUTINE MA47ID(CNTL,ICNTL) + INTEGER ICNTL(7) + DOUBLE PRECISION CNTL(2) + CNTL(1) = 0.001D0 + CNTL(2) = 0.0D0 + ICNTL(1) = 6 + ICNTL(2) = 6 + ICNTL(3) = 1 + ICNTL(4) = 0 + ICNTL(5) = 5 + ICNTL(6) = 5 + ICNTL(7) = 4 + RETURN + END + SUBROUTINE MA47JD(N,NE,IRN,JCN,KEEP,IW,IPE,COUNT,PERM,FLAG,IWFR, + + ICNTL,INFO) + INTEGER N,NE,IRN(NE),JCN(NE),KEEP(N),IW(NE+N),IPE(0:N),COUNT(0:N), + + PERM(0:N),FLAG(N),IWFR,ICNTL(3),INFO(4) + INTRINSIC MAX,MIN + INTEGER I,J,K,L,LDIAG,MP + MP = ICNTL(2) + LDIAG = ICNTL(3) + IF (MP.LE.0) LDIAG = 0 + INFO(1) = 0 + DO 10 I = 1,N + PERM(I) = 0 + FLAG(I) = 0 + COUNT(I) = 0 + 10 CONTINUE + COUNT(0) = 0 + PERM(0) = 0 + DO 20 I = 1,N + J = ABS(KEEP(I)) + IF (J.LT.1 .OR. J.GT.N) GO TO 80 + IF (PERM(J).NE.0) GO TO 80 + PERM(J) = I + 20 CONTINUE + DO 30 K = 1,NE + I = IRN(K) + J = JCN(K) + IF (MIN(I,J).LT.1 .OR. MAX(I,J).GT.N) THEN + IRN(K) = 0 + JCN(K) = 0 + COUNT(0) = COUNT(0) + 1 + INFO(1) = 1 + IF (COUNT(0).LE.1 .AND. LDIAG.GT.1) WRITE (MP,'(2A,I2)') + + ' *** Warning message from subroutine MA47AD ***', + + ' INFO(1) =',INFO(1) + IF (COUNT(0).LE.10 .AND. LDIAG.GT.1) WRITE (MP,'(3(I6,A))') K, + + 'th entry (in row',I,' and column',J,') ignored' + ELSE IF (PERM(I).LE.PERM(J)) THEN + COUNT(I) = COUNT(I) + 1 + ELSE + COUNT(J) = COUNT(J) + 1 + END IF + 30 CONTINUE + IPE(0) = COUNT(0) + DO 40 I = 1,N + IPE(I) = IPE(I-1) + COUNT(I) + 1 + 40 CONTINUE + DO 50 K = 1,NE + I = IRN(K) + J = JCN(K) + IF (PERM(I).LE.PERM(J)) THEN + IW(IPE(I)) = J + IPE(I) = IPE(I) - 1 + ELSE + IW(IPE(J)) = I + IPE(J) = IPE(J) - 1 + END IF + 50 CONTINUE + IWFR = 1 + INFO(4) = 0 + DO 70 I = 1,N + L = IPE(I) + IPE(I) = IWFR + DO 60 K = L + 1,L + COUNT(I) + J = IW(K) + IF (FLAG(J).NE.I) THEN + FLAG(J) = I + IWFR = IWFR + 1 + IW(IWFR) = J + ELSE + INFO(4) = INFO(4) + 1 + END IF + 60 CONTINUE + IF (IWFR.GT.IPE(I)) THEN + IW(IPE(I)) = IWFR - IPE(I) + IWFR = IWFR + 1 + ELSE + IPE(I) = 0 + END IF + 70 CONTINUE + IF (INFO(4).GT.0) THEN + INFO(1) = INFO(1) + 2 + IF (LDIAG.GT.1) WRITE (MP,'(A/I6,A)') + + ' *** Warning message from subroutine MA47AD ***', + + INFO(4),' duplicate entries found.' + END IF + INFO(3) = COUNT(0) + RETURN + 80 INFO(1) = -5 + INFO(2) = I + END + SUBROUTINE MA47KD(N,IPE,IW,LW,IWFR,KEEP,COUNT,NEXT,LAST,IPR,FLAG, + + NEXTE,VARS,ICNTL,INFO) + INTEGER N,IPE(N),LW,IW(LW),IWFR,KEEP(N),COUNT(N),NEXT(N),LAST(N), + + IPR(N),FLAG(N),NEXTE(N),VARS(N),ICNTL(7),INFO(24) + INTRINSIC MIN + EXTERNAL MA47FD + LOGICAL A11,A22,A21,DIAG + INTEGER IE,IEL,IP,IS,JP,JP1,JP2,JP3,JP4,JS,K,KE,KIND,KP,KP1,KP2, + + KS,K1,LDIAG,LIST,LOOP,ME,ML,MP,MS,NCMP,NE,NEL,NSC(3), + + NVARS,NVC,NV1,NV2,PIVE(2),PIVOT(2),RANK + MP = ICNTL(2) + LDIAG = ICNTL(3) + IF (MP.LE.0) LDIAG = 0 + IF (LDIAG.GT.4) THEN + WRITE (MP,'(/A)') ' Row List' + DO 1 IS = 1,N + KP = IPE(IS) + IF (KP.EQ.0) THEN + WRITE (MP,'(I7)') IS + ELSE + WRITE (MP,'(I7,10I6:/ (7X,10I6))') IS, + + (IW(K),K=KP+1,KP+IW(KP)) + END IF + 1 CONTINUE + END IF + RANK = N + NCMP = 0 + NEL = 0 + DO 10 IS = 1,N + IPR(IS) = 0 + FLAG(IS) = 4 + 10 CONTINUE + DO 210 ML = 1,N + IF (NEL.GE.N) GO TO 220 + MS = KEEP(NEL+1) + IF (MS.GT.0) THEN + KIND = 1 + PIVOT(1) = MS + PIVOT(2) = MS + NEL = NEL + 1 + ELSE + KIND = 2 + MS = -MS + IF (NEL+2.GT.N) GO TO 230 + IS = -KEEP(NEL+2) + IF (IS.LT.0) GO TO 230 + PIVOT(1) = MS + PIVOT(2) = IS + NVC = 0 + NEL = NEL + 2 + END IF + NVARS = 0 + A21 = .FALSE. + DO 180 LOOP = 1,KIND + DIAG = .FALSE. + MS = PIVOT(LOOP) + KE = IPR(MS) + PIVE(LOOP) = KE + IPR(MS) = 1 + DO 110 KP = 1,N + 1 + IF (KE.NE.0) THEN + JP = IPE(KE) + JP1 = JP + 3 + JP4 = JP + IW(JP) + JP2 = JP1 + IW(JP+1) + JP3 = JP4 - IW(JP+2) + KP1 = JP1 + KP2 = JP4 + DO 20 JP = JP1,JP2 - 1 + IF (IW(JP).EQ.MS) GO TO 40 + 20 CONTINUE + DO 30 JP = JP3 + 1,JP4 + IF (IW(JP).EQ.MS) GO TO 50 + 30 CONTINUE + JP2 = JP4 + GO TO 60 + 40 JP1 = JP2 + JP2 = JP4 + GO TO 60 + 50 JP2 = JP3 + ELSE + JP = IPE(MS) + IF (JP.EQ.0) GO TO 120 + JP1 = JP + 1 + JP2 = JP + IW(JP) + END IF + 60 DO 70 JP = JP1,JP2 + IS = IW(JP) + IF (FLAG(IS).LE.3-LOOP) THEN + ELSE IF (FLAG(IS).EQ.2) THEN + FLAG(IS) = 0 + IF (IS.EQ.MS) THEN + DIAG = .TRUE. + ELSE + NVC = NVC + 1 + END IF + ELSE + FLAG(IS) = 3 - LOOP + IF (IS.EQ.MS) THEN + DIAG = .TRUE. + ELSE IF (IS.EQ.PIVOT(2)) THEN + A21 = .TRUE. + ELSE + NVARS = NVARS + 1 + VARS(NVARS) = IS + END IF + END IF + 70 CONTINUE + IF (KE.EQ.0) GO TO 120 + IF (LOOP.EQ.1) THEN + IF (KIND.EQ.1) THEN + IF (JP1.EQ.KP1 .AND. JP2.EQ.KP2) FLAG(KE) = -2 + ELSE + DO 80 JP = JP1,JP2 + IF (IW(JP).EQ.PIVOT(2)) THEN + FLAG(KE) = -2 + GO TO 90 + END IF + 80 CONTINUE + 90 END IF + END IF + KE = NEXTE(KE) + 110 CONTINUE + 120 IF (LOOP.EQ.1) THEN + A11 = DIAG + ME = PIVOT(2) + IF (DIAG) ME = PIVOT(1) + NV1 = NVARS + ELSE + A22 = DIAG + END IF + KE = PIVE(LOOP) + DO 170 KP = 1,N + 1 + IF (KE.EQ.0) GO TO 180 + IF (FLAG(KE).LE.-2) THEN + IE = KE + DO 130 LIST = 1,N + IF (NEXT(IE).EQ.0) GO TO 140 + IEL = IE + IE = -LAST(IE) + IF (IE.EQ.ME) GO TO 150 + LAST(IEL) = -ME + 130 CONTINUE + 140 NEXT(IE) = -ME + LAST(IE) = -ME + IF (FLAG(KE).EQ.-2 .AND. LOOP.EQ.KIND) FLAG(KE) = -1 + END IF + 150 NE = NEXTE(KE) + FLAG(MS) = -1 + IF (FLAG(KE).LE.-2) THEN + JP = IPE(KE) + JP1 = JP + 3 + JP2 = JP + IW(JP) + JS = N + 1 + DO 160 JP = JP1,JP2 + IS = IW(JP) + IF (FLAG(IS).GE.0) JS = MIN(JS,NEXT(IS)) + 160 CONTINUE + IF (JS.LE.N) THEN + JS = ABS(KEEP(JS)) + NEXTE(KE) = IPR(JS) + IPR(JS) = KE + ELSE + FLAG(KE) = -1 + END IF + END IF + KE = NE + 170 CONTINUE + 180 CONTINUE + NSC(1) = 0 + NSC(3) = 0 + IF (KIND.EQ.1) THEN + COUNT(MS) = NVARS + 1 + FLAG(MS) = -1 + ELSE + NV2 = NVARS - NV1 + NVC + COUNT(PIVOT(1)) = NV1 + COUNT(PIVOT(2)) = NV2 + IF (A11) COUNT(PIVOT(1)) = NV1 + 1 + IF (A22) COUNT(PIVOT(2)) = NV2 + 1 + IF (A21) THEN + COUNT(PIVOT(1)) = COUNT(PIVOT(1)) + 1 + COUNT(PIVOT(2)) = COUNT(PIVOT(2)) + 1 + END IF + FLAG(PIVOT(1)) = -1 + FLAG(PIVOT(2)) = -1 + KIND = 4 + IF (A11) THEN + IF (A21 .AND. .NOT.A22) THEN + KIND = 2 + NSC(1) = NVARS - NV2 + IPR(PIVOT(2)) = -1 + END IF + ELSE + IF (A21) THEN + IF (A22) THEN + KIND = 2 + NSC(3) = NV2 - NVC + IPR(PIVOT(1)) = -1 + ELSE + KIND = 3 + IPR(PIVOT(1)) = -1 + IPR(PIVOT(2)) = -1 + NSC(1) = NVARS - NV2 + NSC(3) = NV2 - NVC + END IF + END IF + END IF + IF (.NOT.A22) THEN + K1 = 1 + DO 190 K = 1,NV1 + IF (FLAG(VARS(K)).EQ.2) THEN + KS = VARS(K) + VARS(K) = VARS(K1) + VARS(K1) = KS + K1 = K1 + 1 + END IF + 190 CONTINUE + END IF + IF (ME.EQ.PIVOT(1)) THEN + NEXT(PIVOT(2)) = -ME + LAST(PIVOT(2)) = -ME + COUNT(PIVOT(2)) = -COUNT(PIVOT(2)) + ELSE + NEXT(PIVOT(1)) = -ME + LAST(PIVOT(1)) = -ME + COUNT(PIVOT(1)) = -COUNT(PIVOT(1)) + END IF + IF (KIND.EQ.4) THEN + COUNT(PIVOT(1)) = NVARS + 2 + COUNT(PIVOT(2)) = NVARS + 2 + IPR(PIVOT(1)) = 0 + IPR(PIVOT(2)) = 0 + IPR(ME) = 2 + END IF + END IF + NEXT(ME) = 0 + IF (NVARS.EQ.0) THEN + IF (KIND.EQ.1) THEN + IF (.NOT.A11) RANK = RANK - 1 + ELSE + IF (.NOT.A21) THEN + IF (.NOT.A11) RANK = RANK - 1 + IF (.NOT.A22) RANK = RANK - 1 + END IF + END IF + IPE(ME) = 0 + GO TO 210 + END IF + IF (IWFR+NVARS+3.GE.LW) THEN + CALL MA47FD(N,IPE,FLAG,IW,IWFR-1,IWFR,NCMP) + IF (IWFR+NVARS+3.GE.LW) THEN + INFO(1) = -3 + INFO(2) = IWFR + NVARS + 4 - LW + RETURN + END IF + END IF + IP = IWFR + IWFR = IWFR + 3 + MS = N + 1 + DO 200 K = 1,NVARS + IS = VARS(K) + MS = MIN(MS,NEXT(IS)) + FLAG(IS) = 4 + IW(IWFR) = IS + IWFR = IWFR + 1 + 200 CONTINUE + IW(IP) = IWFR - IP - 1 + IW(IP+1) = NSC(1) + IW(IP+2) = NSC(3) + FLAG(ME) = -4 + IPE(ME) = IP + MS = ABS(KEEP(MS)) + NEXTE(ME) = IPR(MS) + IPR(MS) = ME + 210 CONTINUE + 220 IF (RANK.LT.N) INFO(1) = INFO(1) + 4 + INFO(8) = N - RANK + INFO(12) = NCMP + RETURN + 230 INFO(2) = NEL + 1 + INFO(1) = -6 + END + SUBROUTINE MA47LD(N,FATHER,SON,NODE,COUNT,NE,NA,MARK,PERM,NODES, + + ICNTL) + INTEGER N,FATHER(N),SON(N),NODE(N),COUNT(N),NE(N),NA(N),MARK(N), + + PERM(N),NODES,ICNTL(7) + INTEGER COUNT2,I,IBRTHR,IFATHR,ISON,J,K,L,LDIAG,LEVEL,MP,NDE, + + NEMIN,NR,NRL,NST,NVPIV,STAGE + MP = ICNTL(2) + LDIAG = ICNTL(3) + IF (MP.LE.0) LDIAG = 0 + NEMIN = ICNTL(6) + DO 10 I = 1,N + SON(I) = 0 + NODE(I) = 0 + 10 CONTINUE + NRL = N + 1 + DO 20 I = 1,N + IFATHR = -FATHER(I) + NA(I) = -IFATHR + IF (IFATHR.EQ.0) THEN + NRL = NRL - 1 + MARK(NRL) = I + ELSE + IBRTHR = SON(IFATHR) + IF (IBRTHR.GT.0) NA(I) = IBRTHR + SON(IFATHR) = I + IF (COUNT(I).LT.0) THEN + NE(IFATHR) = NE(IFATHR)*2 + NE(I) = 0 + NODE(IFATHR) = -COUNT(I) + END IF + END IF + 20 CONTINUE + NR = NRL + I = 0 + DO 70 K = 1,N + IF (I.LE.0) THEN + I = MARK(NR) + NR = NR + 1 + LEVEL = N + NST = 0 + PERM(LEVEL) = I + END IF + DO 30 L = 1,N + IF (SON(I).LE.0) GO TO 40 + ISON = SON(I) + SON(I) = 0 + I = ISON + IF (NODE(I).NE.0) NST = NST + 1 + LEVEL = LEVEL - 1 + PERM(LEVEL) = I + 30 CONTINUE + 40 NVPIV = NE(I) + IF (NVPIV.EQ.0) GO TO 60 + IF (LEVEL.EQ.N) GO TO 60 + IFATHR = PERM(LEVEL+1) + IF (NODE(I).EQ.0 .AND. NODE(IFATHR).EQ.0) THEN + IF (COUNT(I)-NVPIV.EQ.COUNT(IFATHR)) GO TO 50 + IF (NST.GT.0) GO TO 60 + IF (NVPIV.GE.NEMIN) GO TO 60 + IF (NE(IFATHR).GE.NEMIN) GO TO 60 + ELSE + IF (NODE(I).EQ.0 .OR. NODE(IFATHR).EQ.0) GO TO 60 + IF (NVPIV.GT.0 .AND. NE(IFATHR).GT.0) THEN + IF (NODE(I)-NVPIV/2.NE.NODE(IFATHR)) GO TO 60 + IF (COUNT(I)-NVPIV.NE.COUNT(IFATHR)) GO TO 60 + ELSE IF (NVPIV.LT.0 .AND. NE(IFATHR).LT.0) THEN + NVPIV = -NVPIV/2 + IF (NODE(I)-NVPIV.NE.NODE(IFATHR)) GO TO 60 + IF (COUNT(I)-NVPIV.NE.COUNT(IFATHR)) GO TO 60 + IF (COUNT(I).EQ.NODE(I)) GO TO 60 + ELSE + GO TO 60 + END IF + NODE(IFATHR) = NODE(I) + NST = NST - 1 + END IF + 50 NE(IFATHR) = NE(IFATHR) + NE(I) + NE(I) = 0 + IF (LDIAG.GT.4) WRITE (MP,'(A,2I5)') ' Merging nodes',I,IFATHR + COUNT(IFATHR) = COUNT(IFATHR) + NVPIV + NODE(I) = -1 + 60 IBRTHR = NA(I) + IF (NODE(I).GT.0) NST = NST - 1 + IF (IBRTHR.GT.0) THEN + PERM(LEVEL) = IBRTHR + I = IBRTHR + IF (NODE(I).GT.0) NST = NST + 1 + ELSE + LEVEL = LEVEL + 1 + I = -IBRTHR + END IF + 70 CONTINUE + DO 80 I = 1,N + SON(I) = 0 + 80 CONTINUE + DO 90 I = 1,N + IFATHR = -FATHER(I) + NA(I) = -IFATHR + IF (IFATHR.NE.0) THEN + IBRTHR = SON(IFATHR) + IF (IBRTHR.GT.0) NA(I) = IBRTHR + SON(IFATHR) = I + END IF + 90 CONTINUE + I = 0 + NR = NRL + DO 120 K = 1,N + IF (I.LE.0) THEN + I = MARK(NR) + NR = NR + 1 + LEVEL = N + PERM(N) = I + END IF + DO 100 L = 1,N + IF (SON(I).LE.0) GO TO 110 + ISON = SON(I) + SON(I) = 0 + I = ISON + FATHER(I) = -PERM(LEVEL) + IF (NODE(I).GE.0) THEN + LEVEL = LEVEL - 1 + PERM(LEVEL) = I + END IF + 100 CONTINUE + 110 IBRTHR = NA(I) + IF (IBRTHR.GT.0) THEN + IF (NODE(I).LT.0) LEVEL = LEVEL - 1 + I = IBRTHR + PERM(LEVEL) = I + FATHER(I) = -PERM(LEVEL+1) + IF (NODE(I).LT.0) LEVEL = LEVEL + 1 + ELSE + IF (NODE(I).GE.0) LEVEL = LEVEL + 1 + I = -IBRTHR + END IF + 120 CONTINUE + DO 130 I = 1,N + SON(I) = 0 + 130 CONTINUE + DO 140 I = 1,N + IF (NE(I).EQ.0 .AND. COUNT(I).GE.0) THEN + IFATHR = -FATHER(I) + IBRTHR = SON(IFATHR) + IF (IBRTHR.GT.0) FATHER(I) = IBRTHR + SON(IFATHR) = I + END IF + 140 CONTINUE + DO 150 I = 1,N + IF (COUNT(I).LT.0) THEN + IFATHR = -FATHER(I) + IBRTHR = SON(IFATHR) + IF (IBRTHR.GT.0) FATHER(I) = IBRTHR + SON(IFATHR) = I + END IF + 150 CONTINUE + DO 160 I = 1,N + IF (NE(I).NE.0) THEN + IFATHR = -FATHER(I) + IF (IFATHR.NE.0) THEN + IBRTHR = SON(IFATHR) + IF (IBRTHR.GT.0) FATHER(I) = IBRTHR + SON(IFATHR) = I + END IF + END IF + 160 CONTINUE + STAGE = 1 + I = 0 + NR = NRL + DO 220 K = 1,N + IF (I.LE.0) THEN + I = MARK(NR) + NR = NR + 1 + LEVEL = N + NA(N) = 0 + END IF + L = LEVEL + DO 170 LEVEL = L,1,-1 + IF (SON(I).LE.0) GO TO 180 + ISON = SON(I) + SON(I) = 0 + I = ISON + NA(LEVEL-1) = 0 + 170 CONTINUE + 180 PERM(K) = I + COUNT2 = NODE(I) + NODE(I) = STAGE + IF (NE(I).EQ.0) GO TO 210 + IF (LEVEL.LT.N) NA(LEVEL+1) = NA(LEVEL+1) + 1 + NA(STAGE) = NA(LEVEL) + IF (COUNT2.EQ.0) THEN + MARK(STAGE) = (COUNT(I)-1)**2 + ELSE IF (NE(I).GT.0) THEN + DO 190 J = K - NE(I) + 1,K - NE(I)/2 + NODE(PERM(J)) = -NODE(PERM(J)) + 190 CONTINUE + MARK(STAGE) = (COUNT(I)+COUNT2-3)* (COUNT2-1) + ELSE + DO 195 J = K + NE(I) + 1,K + NODE(PERM(J)) = -NODE(PERM(J)) + 195 CONTINUE + MARK(STAGE) = (COUNT(I)-1)* (COUNT2-1) + END IF + STAGE = STAGE + 1 + 210 IBRTHR = FATHER(I) + IF (IBRTHR.GT.0) THEN + NA(LEVEL) = 0 + I = IBRTHR + ELSE + LEVEL = LEVEL + 1 + ISON = I + I = -IBRTHR + END IF + 220 CONTINUE + NODES = STAGE - 1 + K = 0 + L = 1 + DO 240 NDE = 1,NODES + FATHER(NDE) = NODES + 1 + DO 230 I = 1,NA(NDE) + FATHER(NA(K)) = NDE + K = K - 1 + 230 CONTINUE + K = K + 1 + NA(K) = NDE + 240 CONTINUE + END + SUBROUTINE MA47MD(N,NE,IW,LIW,LROW,PERM,NODES,ELEMS,NODE,PPOS, + + FATHER,NBLOC,INFO,RINFO) + INTEGER N,NE + INTEGER LIW,IW(LIW),LROW(N),PERM(N),NODES,ELEMS(NODES),NODE(N), + + PPOS(0:N),FATHER(NODES),NBLOC,INFO(24) + DOUBLE PRECISION RINFO(4) + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D0) + INTEGER APOS,APOS1,APOS3,APOS4,ELT,FLAG + DOUBLE PRECISION FLOPSB,FLOPSX + INTEGER I,IASS,IELL,IELLN,IINPUT,INTSPA,IORG,ISTK,ISW,IWNFS,IWPOS, + + J,J1,J2,JJ,JP1,JP2,JP3,JP4,KIND,LAELL,LEFT,LIELL,LOOP, + + MAXFRT,N1,N2,N3,NCMP,NELL,NFRONT + LOGICAL NOSURE + INTEGER NOTIN1,NOXO,NPIV,NPOTPV,NSC1,NSC2,NSCHUR,NSTKAC(2),NTILE, + + NTOTPV,NULL,NUM1,NUM2,NUM3,NUMM1,NUMM2,NUMM3,NUMORG,NORG1, + + PTRIRN,RLSPA,RSTKAC + INTRINSIC MIN,MAX,ABS + EXTERNAL MA47PD + NCMP = 0 + NTILE = 0 + NOXO = 0 + FLOPSB = ZERO + FLOPSX = ZERO + MAXFRT = 0 + NSTKAC(1) = NE + NSTKAC(2) = NE + RLSPA = NE + INTSPA = NE + PTRIRN = LIW - NE + 1 + ISTK = PTRIRN - 1 + IINPUT = 0 + NTOTPV = 0 + NPOTPV = 0 + APOS = 1 + IWPOS = 8 + DO 10 I = 0,N + PPOS(I) = N + 1 + 10 CONTINUE + DO 20 I = 1,NODES + ELEMS(I) = 0 + 20 CONTINUE + DO 380 IASS = 1,NODES + INTSPA = MAX(INTSPA,IWPOS+2* (N-NTOTPV)+NSTKAC(2)) + IF (1+2* (N-NTOTPV).GT.ISTK) THEN + CALL MA47PD(IW,ISTK,PTRIRN,IINPUT,NCMP) + IF (1+2* (N-NTOTPV).GT.ISTK) THEN + INFO(2) = NSTKAC(2) + 1 + 2* (N-NTOTPV) + INFO(1) = -3 + GO TO 390 + END IF + END IF + FLAG = ISTK - (N-NTOTPV) + NUMORG = 0 + DO 30 I = NPOTPV + 1,N + J = PERM(I) + IF (ABS(NODE(J)).GT.IASS) GO TO 40 + NUMORG = NUMORG + 1 + IW(NUMORG) = J + PPOS(J) = NUMORG + IW(FLAG+PPOS(J)) = 0 + 30 CONTINUE + 40 NULL = 0 + DO 50 I = 1,NUMORG + NULL = NULL + LROW(NPOTPV+I) + 50 CONTINUE + IF (NULL.EQ.0 .AND. ELEMS(IASS).EQ.0) THEN + NPOTPV = NPOTPV + NUMORG + GO TO 380 + END IF + KIND = 1 + IF (NUMORG.GE.2) THEN + IF (NODE(PERM(NPOTPV+NUMORG/2)).LT.0) THEN + KIND = 2 + IF (NODE(PERM(NPOTPV+NUMORG)).LT.0) KIND = 3 + END IF + END IF + IWNFS = NUMORG + 1 + NORG1 = NUMORG + IF (KIND.GT.1) NORG1 = NUMORG/2 + RSTKAC = 0 + DO 170 LOOP = 1,MIN(2,KIND) + NUM1 = IWNFS - NUMORG - 1 + NUM2 = 0 + IF (NULL.EQ.0) GO TO 80 + J1 = PTRIRN + DO 70 IORG = (LOOP-1)*NORG1 + 1,LOOP*NORG1 + J2 = J1 + LROW(NPOTPV+IORG) - 1 + DO 60 JJ = J1,J2 + J = IW(JJ) + IF (PPOS(J).LE.N) THEN + IF (LOOP.EQ.2) THEN + IF (IW(FLAG+PPOS(J)).EQ.1) THEN + IW(FLAG+PPOS(J)) = 3 + NUM2 = NUM2 + 1 + END IF + END IF + ELSE + IW(IWNFS) = J + IWNFS = IWNFS + 1 + PPOS(J) = IWNFS - 1 + IW(FLAG+PPOS(J)) = LOOP + END IF + 60 CONTINUE + J1 = J2 + 1 + 70 CONTINUE + NSTKAC(2) = NSTKAC(2) - J1 + PTRIRN + RSTKAC = RSTKAC + J1 - PTRIRN + IINPUT = IINPUT + J1 - PTRIRN + PTRIRN = J1 + 80 NELL = ELEMS(IASS) + IELL = ISTK + 1 + PPOS(0) = 0 + DO 160 ELT = 1,NELL + IF (IW(IELL).LT.0) IELL = IELL - IW(IELL) + JP1 = IELL + 3 + JP2 = JP1 + IW(IELL+1) + JP3 = JP2 + IW(IELL+2) + JP4 = IELL + IW(IELL) - 2 + J1 = JP1 + J2 = JP4 + DO 90 JJ = JP2,JP3 - 1 + J = IW(JJ) + IF (PPOS(J).GE. (LOOP-1)*NORG1+1 .AND. + + PPOS(J).LE.LOOP*NORG1) GO TO 130 + 90 CONTINUE + NOTIN1 = 0 + DO 100 JJ = JP1,JP2 - 1 + J = IW(JJ) + IF (PPOS(J).GE. (LOOP-1)*NORG1+1 .AND. + + PPOS(J).LE.LOOP*NORG1) GO TO 110 + 100 CONTINUE + NOTIN1 = 1 + J2 = JP3 - 1 + 110 DO 120 JJ = JP3,JP4 + J = IW(JJ) + IF (PPOS(J).GE. (LOOP-1)*NORG1+1 .AND. + + PPOS(J).LE.LOOP*NORG1) GO TO 130 + 120 CONTINUE + IF (NOTIN1.EQ.1) GO TO 150 + J1 = JP2 + 130 DO 140 JJ = J1,J2 + J = IW(JJ) + IF (J.EQ.0) GO TO 140 + IF (PPOS(J).LE.N) THEN + NULL = 1 + IF (LOOP.EQ.2) THEN + IF (IW(FLAG+PPOS(J)).EQ.1) THEN + IW(FLAG+PPOS(J)) = 3 + NUM2 = NUM2 + 1 + END IF + END IF + ELSE + IW(IWNFS) = J + IWNFS = IWNFS + 1 + PPOS(J) = IWNFS - 1 + IW(FLAG+PPOS(J)) = LOOP + END IF + 140 CONTINUE + 150 IELL = IELL + IW(IELL) + 160 CONTINUE + 170 CONTINUE + PPOS(0) = N + 1 + IF (NULL.EQ.0) GO TO 190 + NFRONT = IWNFS - 1 + MAXFRT = MAX(MAXFRT,NFRONT) + IF (KIND.EQ.1) THEN + NUM1 = 0 + NUM2 = NFRONT - NUMORG + NUM3 = 0 + ELSE + IF (KIND.EQ.3) THEN + JJ = NUMORG + J1 = JJ + DO 180 J = 1,NUM1 + JJ = JJ + 1 + IF (IW(FLAG+JJ).EQ.1) THEN + J1 = J1 + 1 + ISW = IW(JJ) + IW(JJ) = IW(J1) + IW(J1) = ISW + PPOS(IW(JJ)) = JJ + PPOS(IW(J1)) = J1 + END IF + 180 CONTINUE + NUM3 = NFRONT - NUMORG - NUM1 + NUM1 = NUM1 - NUM2 + ELSE + NUM2 = NUM1 + NUM1 = 0 + NUM3 = NFRONT - NUMORG - NUM2 + END IF + END IF + RLSPA = MAX(RLSPA,APOS+ (NUMORG* (NUMORG+1))/2+NFRONT*NUMORG+ + + NSTKAC(1)) + 190 IF (NULL.NE.0) NTOTPV = NTOTPV + NUMORG + NPOTPV = NPOTPV + NUMORG + IELL = ISTK + 1 + DO 250 ELT = 1,NELL + IF (IW(IELL).LT.0) IELL = IELL - IW(IELL) + LEFT = 0 + JP1 = IELL + 3 + JP4 = IELL + IW(IELL) - 2 + JP2 = JP1 + IW(IELL+1) + NUMM1 = IW(IELL+1) + NUMM2 = IW(IELL+2) + JP3 = JP2 + NUMM2 + NUMM3 = IW(IELL) - NUMM1 - NUMM2 - 4 + DO 200 JJ = JP1,JP2 - 1 + J = IW(JJ) + IF (J.EQ.0) GO TO 200 + IF (PPOS(J).LE.NUMORG) THEN + IW(JJ) = 0 + ELSE + LEFT = LEFT + 1 + END IF + 200 CONTINUE + DO 210 JJ = JP2,JP3 - 1 + J = IW(JJ) + IF (J.EQ.0) GO TO 210 + IF (PPOS(J).LE.NUMORG) THEN + IW(JJ) = 0 + ELSE + LEFT = LEFT + 1 + END IF + 210 CONTINUE + IF (LEFT.EQ.0) GO TO 230 + DO 220 JJ = JP3,JP4 + J = IW(JJ) + IF (J.EQ.0) GO TO 220 + IF (PPOS(J).LE.NUMORG) THEN + IW(JJ) = 0 + ELSE + LEFT = LEFT + 1 + END IF + 220 CONTINUE + 230 PPOS(0) = N + 1 + IELLN = IELL + IW(IELL) + IF (LEFT.EQ.0) THEN + NELL = NELL - 1 + ELEMS(IASS) = ELEMS(IASS) - 1 + LAELL = (NUMM2* (NUMM2+1))/2 + NUMM1* (NUMM2+NUMM3) + + + NUMM2*NUMM3 + 2 + NSTKAC(1) = NSTKAC(1) - LAELL + LIELL = IW(IELL) + NSTKAC(2) = NSTKAC(2) - LIELL + J1 = IELL + J2 = IELLN - 1 + IF (IELLN.LT.PTRIRN-IINPUT) THEN + IF (IW(IELLN).LT.0) THEN + LIELL = LIELL - IW(IELLN) + J2 = J2 - IW(IELLN) + END IF + END IF + IF ((IELL-1).EQ.ISTK) THEN + ISTK = ISTK + LIELL + ELSE + IF (IW(IELL-1).LT.0) THEN + LIELL = LIELL - IW(IELL-1) + J1 = IELL + IW(IELL-1) + END IF + IW(J1) = -LIELL + IW(J2) = -LIELL + END IF + END IF + IELL = IELLN + 250 CONTINUE + NSTKAC(1) = NSTKAC(1) - RSTKAC + IF (NULL.EQ.0) GO TO 380 + NPIV = NUMORG + IF (KIND.EQ.2) NTILE = NTILE + NPIV/2 + IF (KIND.EQ.3) NOXO = NOXO + NPIV/2 + IF (KIND.EQ.1) THEN + DO 270 J = 1,NPIV + FLOPSB = FLOPSB + 1 + J2 = NPIV - J + DO 260 J1 = 1,NPIV - J + FLOPSB = FLOPSB + 1 + 2* (NFRONT-NPIV+J2) + J2 = J2 - 1 + 260 CONTINUE + FLOPSB = FLOPSB + NUM2 + 270 CONTINUE + ELSE + DO 290 J = 1,NORG1 + FLOPSB = FLOPSB + 3 + (NORG1-J)* (2* (NFRONT-NPIV/2-J)+1) + J2 = NORG1 - J + DO 280 J1 = 1,NORG1 - J + FLOPSB = FLOPSB + 4* (NFRONT-NPIV+J2+1) + J2 = J2 - 1 + 280 CONTINUE + FLOPSB = FLOPSB + NUM1 + 4*NUM2 + NUM3 + 290 CONTINUE + END IF + NOSURE = (NBLOC.GE. (NFRONT-NUMORG)) .AND. (KIND.EQ.1) + IF (NPIV.EQ.NFRONT) GO TO 360 + IF (KIND.GT.1) THEN + NSC1 = NUM1 + NUM2 + NSC2 = NUM2 + NUM3 + ELSE + NSC1 = NFRONT - NUMORG + NSC2 = NFRONT - NUMORG + END IF + IF (NSC1*NSC2.EQ.0) GO TO 360 + APOS3 = APOS + (NUMORG* (NUMORG+1))/2 + NFRONT*NPIV + IF (NOSURE) THEN + RLSPA = MAX(RLSPA,APOS3+ ((NSC1+1)*NSC1)/2+2+NSTKAC(1)) + ELSE + APOS4 = APOS3 + NPIV*NSC2 + IF (KIND.GT.1) THEN + NSCHUR = MAX(NSC1*NSC2+1,NUM1* (NUM2+NUM3)+NUM2*NUM3+ + + (NUM2* (NUM2+1))/2+2) + ELSE + NSCHUR = MAX(NSC1*NSC2+1, (NSC1* (NSC1+1))/2+2) + END IF + RLSPA = MAX(RLSPA,APOS4+NSCHUR+NSTKAC(1)) + END IF + IF (KIND.GT.1) THEN + FLOPSB = FLOPSB + 2*NPIV*NUM1* (NUM2+NUM3) + FLOPSB = FLOPSB + NPIV* (2*NUM3+NUM2+1)*NUM2 + FLOPSX = FLOPSX + NPIV*NUM2*NUM3 + + + NBLOC* (NBLOC-1)*NPIV* (NUM2/NBLOC) + ELSE + FLOPSB = FLOPSB + NPIV* (NFRONT-NUMORG)* (NFRONT-NUMORG+1) + IF (NPIV.GE.NBLOC) + + FLOPSX = FLOPSX + NBLOC* (NBLOC-1)*NPIV* (NUM2/NBLOC) + END IF + IF (KIND.GT.1) THEN + NUMM1 = NUM1 + NUMM2 = NUM2 + ELSE + NUMM1 = 0 + NUMM2 = NFRONT - NUMORG + END IF + NELL = ELEMS(IASS) + IELL = ISTK + 1 + PPOS(0) = 0 + DO 340 ELT = 1,NELL + IF (IW(IELL).LT.0) IELL = IELL - IW(IELL) + IELLN = IELL + IW(IELL) + JP1 = IELL + 3 + JP2 = JP1 + IW(IELL+1) + JP3 = JP2 + IW(IELL+2) + JP4 = IELL + IW(IELL) - 2 + DO 300 JJ = JP2,JP3 - 1 + IF (IW(JJ).EQ.0) GO TO 300 + IF (PPOS(IW(JJ))-NUMORG.LE.NUMM1 .OR. + + PPOS(IW(JJ))-NUMORG.GT.NUMM1+NUMM2) GO TO 330 + 300 CONTINUE + APOS1 = 0 + DO 310 JJ = JP1,JP2 - 1 + IF (IW(JJ).EQ.0) GO TO 310 + IF (PPOS(IW(JJ))-NUMORG.LE.NUMM1) THEN + IF (APOS1.EQ.2) GO TO 330 + APOS1 = 1 + END IF + IF (PPOS(IW(JJ))-NUMORG.GT.NUMM1+NUMM2) THEN + IF (PPOS(IW(JJ)).EQ.N+1) GO TO 330 + IF (APOS1.EQ.1) GO TO 330 + APOS1 = 2 + END IF + 310 CONTINUE + DO 320 JJ = JP3,JP4 + IF (IW(JJ).EQ.0) GO TO 320 + IF (PPOS(IW(JJ))-NUMORG.LE.NUMM1) THEN + IF (APOS1.EQ.1) GO TO 330 + END IF + IF (PPOS(IW(JJ))-NUMORG.GT.NUMM1+NUMM2) THEN + IF (PPOS(IW(JJ)).EQ.N+1) GO TO 330 + IF (APOS1.EQ.2) GO TO 330 + END IF + 320 CONTINUE + NELL = NELL - 1 + ELEMS(IASS) = ELEMS(IASS) - 1 + N1 = IW(IELL+1) + N2 = IW(IELL+2) + N3 = IW(IELL) - 4 - N1 - N2 + LAELL = (N2* (N2+1))/2 + N1* (N2+N3) + N2*N3 + 2 + NSTKAC(1) = NSTKAC(1) - LAELL + LIELL = IW(IELL) + NSTKAC(2) = NSTKAC(2) - LIELL + J1 = IELL + J2 = IELLN - 1 + IF (IELLN.LT.PTRIRN-IINPUT) THEN + IF (IW(IELLN).LT.0) THEN + LIELL = LIELL - IW(IELLN) + J2 = J2 - IW(IELLN) + END IF + END IF + IF ((IELL-1).EQ.ISTK) THEN + ISTK = ISTK + LIELL + ELSE + IF (IW(IELL-1).LT.0) THEN + LIELL = LIELL - IW(IELL-1) + J1 = IELL + IW(IELL-1) + END IF + IW(J1) = -LIELL + IW(J2) = -LIELL + END IF + 330 IELL = IELLN + 340 CONTINUE + PPOS(0) = N + 1 + ELEMS(FATHER(IASS)) = ELEMS(FATHER(IASS)) + 1 + IF (KIND.GT.1) THEN + LAELL = NUM1* (NUM2+NUM3) + (NUM2* (NUM2+1))/2 + NUM2*NUM3 + 2 + ELSE + LAELL = ((NSC1+1)* (NSC1))/2 + 2 + END IF + NSTKAC(1) = NSTKAC(1) + LAELL + LIELL = NFRONT - NUMORG + 4 + NSTKAC(2) = NSTKAC(2) + LIELL + INTSPA = MAX(INTSPA,IWPOS+2*NFRONT+LIELL+NSTKAC(2)) + IF (1+2*NFRONT+LIELL.GT.ISTK) THEN + CALL MA47PD(IW,ISTK,PTRIRN,IINPUT,NCMP) + IF (1+2*NFRONT+LIELL.GT.ISTK) THEN + INFO(2) = NSTKAC(2) + 1 + 2*NFRONT + LIELL + INFO(1) = -3 + GO TO 390 + END IF + END IF + IW(ISTK) = LIELL + ISTK = ISTK - 1 + DO 350 I = 1,NFRONT - NUMORG + IW(ISTK) = IW(NFRONT+1-I) + ISTK = ISTK - 1 + 350 CONTINUE + IF (KIND.GT.1) THEN + IW(ISTK) = NUM2 + IW(ISTK-1) = NUM1 + ELSE + IW(ISTK) = NFRONT - NUMORG + IW(ISTK-1) = 0 + END IF + IW(ISTK-2) = LIELL + ISTK = ISTK - 3 + 360 DO 370 JJ = NPIV + 1,NFRONT + J = ABS(IW(JJ)) + PPOS(J) = N + 1 + 370 CONTINUE + IF (FATHER(IASS).LE.NODES) THEN + ELEMS(FATHER(IASS)) = ELEMS(FATHER(IASS)) + NELL + END IF +C******************************** +C******************************** + IF (KIND.EQ.1) THEN + IWPOS = IWPOS - 2 + APOS = APOS + (NPIV* (NPIV+1))/2 + NPIV* (NFRONT-NPIV) + ELSE + IF (KIND.EQ.2) THEN + IWPOS = IWPOS - 1 + APOS = APOS + 3* (NORG1* (NORG1+1))/2 + + + NORG1* (NUM1+2*NUM2+NUM3) + ELSE + APOS = APOS + NORG1* (NORG1+2) + NORG1* (NUM1+2*NUM2+NUM3) + END IF + END IF + IWPOS = IWPOS + NFRONT + 4 + 380 CONTINUE + INFO(5) = NODES + INFO(6) = MAX(2*NE,RLSPA) + INFO(7) = MAX(2*NE,INTSPA) + INFO(8) = N - NTOTPV + INFO(9) = MAXFRT + INFO(10) = APOS - 1 + INFO(11) = IWPOS - 5 + INFO(12) = INFO(12) + NCMP + INFO(13) = NTILE + INFO(14) = NOXO + RINFO(1) = FLOPSB + RINFO(2) = FLOPSX + 390 RETURN + END + SUBROUTINE MA47ND(N,NE,IRN,JCN,MAP,LROW,PERM,COUNT,PERM0) + INTEGER N,NE + INTEGER IRN(NE),JCN(NE),MAP(NE),LROW(N),PERM(N),COUNT(0:N), + + PERM0(0:N) + INTEGER I,J,K + COUNT(0) = 0 + PERM0(0) = 0 + DO 10 I = 1,N + COUNT(I) = 0 + PERM0(PERM(I)) = I + 10 CONTINUE + DO 20 K = 1,NE + I = IRN(K) + J = JCN(K) + IF (PERM0(I).LE.PERM0(J)) THEN + I = PERM0(I) + COUNT(I) = COUNT(I) + 1 + ELSE + JCN(K) = I + IRN(K) = J + J = PERM0(J) + COUNT(J) = COUNT(J) + 1 + END IF + 20 CONTINUE + DO 30 I = 1,N + LROW(I) = COUNT(I) + COUNT(I) = COUNT(I-1) + LROW(I) + 30 CONTINUE + DO 40 K = 1,NE + I = PERM0(IRN(K)) + MAP(K) = COUNT(I) + COUNT(I) = COUNT(I) - 1 + 40 CONTINUE + RETURN + END + SUBROUTINE MA47OD(N,NE,A,LA,IW,LIW,LROW,PERM,NODES,ELEMS,MARK, + + NODE,PPOS,FATHER,CNTL,NBLOC,INFO,RINFO) + INTEGER N,NE,LA + DOUBLE PRECISION A(LA),CNTL(2),RINFO(4) + INTEGER LIW,IW(LIW),LROW(N),PERM(N),NODES,ELEMS(NODES), + + MARK(NODES),NODE(N),PPOS(0:N),FATHER(NODES),NBLOC,INFO(24) + DOUBLE PRECISION ZERO,HALF,ONE + PARAMETER (ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0) + INTEGER AINPUT + DOUBLE PRECISION AMAX,A1MAX,AMULT1,AMULT2 + INTEGER APOS,APOSA,APOSB,APOSBB,APOSC,APOSH,APOSI,APOSJ,APOS1, + + APOS2,APOS3,APOS4,ASTK,ATRASH,CNTNZ1,CNTNZ2 + DOUBLE PRECISION DETPIV + INTEGER ELT + DOUBLE PRECISION FLOPSB,FLOPSX + INTEGER I,I1,IASS,IBEG,IELL,IELLN,IEND,IEXCH,IINPUT,INC,INTSPA, + + IORG,IPIV,IPOS,IROW,ISTK,ISWOP,IWNFS,IWPOS,J,JA1,JA2,JAY, + + J1,J2,JCOL,JJ,JJJ,JMAX,J1MAX,JP1,JP2,JP3,JP4,JPIV,K,K1,K2, + + KBLK,KIND,KR,KROW,KSWEEP,L,LAELL,LDUMMY,LEFT,LIELL,LNPIV, + + LPIV + LOGICAL LTWO + INTEGER MA1,MAXFRT + DOUBLE PRECISION MAXPIV + INTEGER NASS,NBLK,NCMPBI,NCMPBR,NCOL,NEIG,NELL,NFRONT,NFS,NFULLB, + + NIRBDU,NNELL,NNULL + LOGICAL NOSURE + INTEGER NOTIN1,NOXOB,NPIV,NPIVD2,NPOTPV,NRLBDU,NSC1,NSC2,NSCHUR, + + NSTKAC(2),NSTRUC,NTILEB,NTOTPV,NUM1,NUM2,NUM3,NUMM1,NUMM2, + + NUMORG,NUMPVT,OFFDAG + DOUBLE PRECISION PIVOT + INTEGER PIVSIZ,POSELT,POSPV1,POSPV2,PTRA,PTRELT,PTRIRN,RLSPA + DOUBLE PRECISION RMAX,SWOP,TMAX,TOL,UU + INTEGER ZCOL + DOUBLE PRECISION ZONE +C?? We could refine this count and have NCOLST, NCOLP etc. + INTRINSIC MIN,MAX,ABS,NINT + INTEGER IDAMAX + EXTERNAL MA47PD,MA47SD,MA47YD,MA47WD,MA47XD,IDAMAX,DGEMM + TOL = CNTL(2) + NBLK = 0 + NTILEB = 0 + NOXOB = 0 + NFULLB = 0 + NCMPBI = 0 + NCMPBR = 0 + FLOPSB = ZERO + FLOPSX = ZERO + NEIG = 0 + MAXFRT = 0 + UU = MIN(CNTL(1),HALF) + UU = MAX(UU,ZERO) + DO 10 I = 0,N + PPOS(I) = N + 1 + 10 CONTINUE + DO 20 I = 1,NODES + ELEMS(I) = 0 + 20 CONTINUE + IWPOS = 8 + APOSBB = 1 + NSTKAC(1) = NE + NSTKAC(2) = NE + INTSPA = NE + RLSPA = NE + PTRIRN = LIW - NE + 1 + PTRA = LA - NE + 1 + ISTK = PTRIRN - 1 + ASTK = PTRA - 1 + AINPUT = 0 + IINPUT = 0 + NTOTPV = 0 + NPOTPV = 0 + DO 2160 IASS = 1,NODES + NNULL = 0 + INTSPA = MAX(INTSPA,IWPOS+2* (N-NTOTPV)+NSTKAC(2)) + IF (IWPOS+2* (N-NTOTPV).GT.ISTK) THEN + CALL MA47PD(IW,ISTK,PTRIRN,IINPUT,NCMPBI) + IF (IWPOS+2* (N-NTOTPV).GT.ISTK) THEN + INFO(2) = INTSPA + INFO(1) = -3 + GO TO 2170 + END IF + END IF + NUMORG = 0 + DO 30 I = NPOTPV + 1,N + J = PERM(I) + IF (ABS(NODE(J)).GT.IASS) GO TO 40 + IW(IWPOS+NUMORG) = J + NUMORG = NUMORG + 1 + PPOS(J) = NUMORG + 30 CONTINUE + 40 KIND = 1 + IF (NUMORG.GE.2) THEN + IF (NODE(PERM(NPOTPV+NUMORG/2)).LT.0) THEN + KIND = 2 + NUMPVT = NUMORG/2 + IF (NODE(PERM(NPOTPV+NUMORG)).LT.0) KIND = 3 + END IF + END IF + NASS = NUMORG + NELL = ELEMS(IASS) + NNELL = NELL + IELL = ISTK + 1 + DO 70 ELT = 1,NELL + IF (IW(IELL).LT.0) IELL = IELL - IW(IELL) + IF (IW(IELL+1).NE.-1) GO TO 60 + DO 50 JJ = IELL + 3,IELL + 2 + IW(IELL+2) + J = IW(JJ) + IW(IWPOS+NASS) = J + NASS = NASS + 1 + PPOS(J) = NASS + 50 CONTINUE + 60 IELL = IELL + IW(IELL) + 70 CONTINUE + IWNFS = IWPOS + NASS + J1 = PTRIRN + DO 90 IORG = 1,NUMORG + J2 = J1 + LROW(NPOTPV+IORG) - 1 + DO 80 JJ = J1,J2 + J = IW(JJ) + IF (PPOS(J).LE.N) GO TO 80 + IW(IWNFS) = J + IWNFS = IWNFS + 1 + PPOS(J) = IWNFS - IWPOS + 80 CONTINUE + J1 = J2 + 1 + 90 CONTINUE + IELL = ISTK + 1 + DO 170 ELT = 1,NELL + IF (IW(IELL).LT.0) IELL = IELL - IW(IELL) + IF (IW(IELL+1).EQ.-1) GO TO 160 + JP1 = IELL + 3 + JP2 = JP1 + IW(IELL+1) + JP3 = JP2 + IW(IELL+2) + JP4 = IELL + IW(IELL) - 2 + J1 = JP1 + J2 = JP4 + DO 100 JJ = JP2,JP3 - 1 + J = IW(JJ) + IF (PPOS(J).LE.NASS) GO TO 140 + 100 CONTINUE + NOTIN1 = 0 + DO 110 JJ = JP1,JP2 - 1 + J = IW(JJ) + IF (PPOS(J).LE.NASS) GO TO 120 + 110 CONTINUE + NOTIN1 = 1 + J2 = JP3 - 1 + 120 DO 130 JJ = JP3,JP4 + J = IW(JJ) + IF (PPOS(J).LE.NASS) GO TO 140 + 130 CONTINUE + IF (NOTIN1.EQ.1) GO TO 160 + J1 = JP2 + 140 PPOS(0) = 0 + DO 150 JJ = J1,J2 + J = IW(JJ) + IF (PPOS(J).LE.N) GO TO 150 + IW(IWNFS) = J + IWNFS = IWNFS + 1 + PPOS(J) = IWNFS - IWPOS + 150 CONTINUE + PPOS(0) = N + 1 + 160 IELL = IELL + IW(IELL) + 170 CONTINUE + NCOL = IWNFS - IWPOS + IELL = ISTK + 1 + DO 200 ELT = 1,NELL + IF (IW(IELL).LT.0) IELL = IELL - IW(IELL) + IF (IW(IELL+1).NE.-1) GO TO 190 + PPOS(0) = 0 + DO 180 JJ = IELL + 3 + IW(IELL+2),IELL + IW(IELL) - 2 + J = IW(JJ) + IF (PPOS(J).LE.N) GO TO 180 + IW(IWNFS) = J + IWNFS = IWNFS + 1 + PPOS(J) = IWNFS - IWPOS + 180 CONTINUE + PPOS(0) = N + 1 + 190 IELL = IELL + IW(IELL) + 200 CONTINUE + NFRONT = IWNFS - IWPOS + MAXFRT = MAX(MAXFRT,NFRONT) + IF (INFO(1).NE.-4) THEN + APOS = APOSBB + (NASS* (NASS+1))/2 + ELSE + APOS = 1 + END IF + RLSPA = MAX(RLSPA,INFO(2)+APOS+NFRONT*NASS+NSTKAC(1)) + IF (APOS+NFRONT*NASS.GT.ASTK) THEN + CALL MA47SD(A,ASTK,PTRA,AINPUT,NCMPBR) + IF (APOS+NFRONT*NASS.GT.ASTK) THEN + INFO(2) = INFO(2) + APOS - 1 + APOS = 1 + APOSBB = 1 + INFO(1) = -4 + IF (NFRONT*NASS.GT.ASTK) THEN + INFO(2) = RLSPA + GO TO 2170 + END IF + END IF + END IF + ATRASH = APOS + NFRONT*NASS + DO 210 JJ = APOS,ATRASH + A(JJ) = ZERO + 210 CONTINUE + J1 = PTRIRN + DO 230 IORG = 1,NUMORG + J = PERM(NPOTPV+IORG) + APOSI = APOS + (PPOS(J)-1)*NFRONT - 1 + J2 = J1 + LROW(NPOTPV+IORG) - 1 + DO 220 JJ = J1,J2 + APOS2 = APOSI + PPOS(IW(JJ)) + A(APOS2) = A(APOS2) + A(PTRA) + PTRA = PTRA + 1 + 220 CONTINUE + AINPUT = AINPUT + J2 - J1 + 1 + NSTKAC(1) = NSTKAC(1) - J2 + J1 - 1 + J1 = J2 + 1 + 230 CONTINUE + IINPUT = IINPUT + J1 - PTRIRN + NSTKAC(2) = NSTKAC(2) - J1 + PTRIRN + PTRIRN = J1 + NPOTPV = NPOTPV + NUMORG + NFS = NUMORG + IELL = ISTK + 1 + PTRELT = ASTK + 1 + DO 380 ELT = 1,NELL + IF (NINT(A(PTRELT)).LT.0) PTRELT = PTRELT - NINT(A(PTRELT)) + IF (IW(IELL).LT.0) IELL = IELL - IW(IELL) + LEFT = 0 + POSELT = PTRELT + 1 + JP1 = IELL + 3 + JP4 = IELL + IW(IELL) - 2 + IF (IW(IELL+1).NE.-1) GO TO 260 + LIELL = JP4 - JP1 + 1 + I1 = 1 + DO 250 JJ = JP1,JP4 + J = IW(JJ) + APOS2 = APOS + NFS*NFRONT - 1 + PPOS(J) + APOS1 = POSELT + DO 240 I = 1,MIN(I1,IW(IELL+2)) + A(APOS2) = A(APOS1) + APOS1 = APOS1 + LIELL + APOS2 = APOS2 + NFRONT + 240 CONTINUE + I1 = I1 + 1 + POSELT = POSELT + 1 + 250 CONTINUE + NFS = NFS + IW(IELL+2) + GO TO 370 + 260 JP2 = JP1 + IW(IELL+1) + NUM1 = IW(IELL+1) + NUM2 = IW(IELL+2) + JP3 = JP2 + NUM2 + NUM3 = IW(IELL) - NUM1 - NUM2 - 4 + DO 280 JJ = JP1,JP2 - 1 + J = IW(JJ) + IF (J.EQ.0) GO TO 280 + IF (PPOS(J).LE.NASS) THEN + POSELT = PTRELT + 1 + (JJ-JP1)* (NUM2+NUM3) + APOSI = APOS + (PPOS(J)-1)*NFRONT - 1 + PPOS(0) = ATRASH - APOSI + DO 270 JJJ = JP2,JP4 + APOS2 = APOSI + PPOS(IW(JJJ)) + A(APOS2) = A(APOS2) + A(POSELT) + POSELT = POSELT + 1 + 270 CONTINUE + IW(JJ) = 0 + ELSE + LEFT = LEFT + 1 + END IF + 280 CONTINUE + DO 320 JJ = JP2,JP3 - 1 + J = IW(JJ) + IF (J.EQ.0) GO TO 320 + IF (PPOS(J).LE.NASS) THEN + POSELT = PTRELT + 1 + JJ - JP2 + INC = NUM2 + NUM3 + APOSI = APOS + (PPOS(J)-1)*NFRONT - 1 + PPOS(0) = ATRASH - APOSI + DO 290 JJJ = JP1,JP2 - 1 + APOS2 = APOSI + PPOS(IW(JJJ)) + A(APOS2) = A(APOS2) + A(POSELT) + POSELT = POSELT + INC + 290 CONTINUE + DO 300 JJJ = JP2,JJ - 1 + APOS2 = APOSI + PPOS(IW(JJJ)) + A(APOS2) = A(APOS2) + A(POSELT) + INC = INC - 1 + POSELT = POSELT + INC + 300 CONTINUE + DO 310 JJJ = JJ,JP4 + APOS2 = APOSI + PPOS(IW(JJJ)) + A(APOS2) = A(APOS2) + A(POSELT) + POSELT = POSELT + 1 + 310 CONTINUE + IW(JJ) = 0 + ELSE + LEFT = LEFT + 1 + END IF + 320 CONTINUE + IF (LEFT.EQ.0) GO TO 360 + DO 350 JJ = JP3,JP4 + J = IW(JJ) + IF (J.EQ.0) GO TO 350 + IF (PPOS(J).LE.NASS) THEN + POSELT = PTRELT + 1 + NUM2 + JJ - JP3 + APOSI = APOS + (PPOS(J)-1)*NFRONT - 1 + PPOS(0) = ATRASH - APOSI + INC = NUM2 + NUM3 + DO 330 JJJ = JP1,JP2 - 1 + APOS2 = APOSI + PPOS(IW(JJJ)) + A(APOS2) = A(APOS2) + A(POSELT) + POSELT = POSELT + INC + 330 CONTINUE + DO 340 JJJ = JP2,JP3 - 1 + APOS2 = APOSI + PPOS(IW(JJJ)) + A(APOS2) = A(APOS2) + A(POSELT) + INC = INC - 1 + POSELT = POSELT + INC + 340 CONTINUE + IW(JJ) = 0 + ELSE + LEFT = LEFT + 1 + END IF + 350 CONTINUE + 360 PPOS(0) = N + 1 + 370 IELLN = IELL + IW(IELL) + POSELT = PTRELT + NINT(A(PTRELT)) + IF (LEFT.EQ.0) THEN + NELL = NELL - 1 + NNELL = NELL + ELEMS(IASS) = ELEMS(IASS) - 1 + LIELL = IW(IELL) + NSTKAC(2) = NSTKAC(2) - LIELL + J1 = IELL + J2 = IELLN - 1 + IF (IELLN.LT.PTRIRN-IINPUT) THEN + IF (IW(IELLN).LT.0) THEN + LIELL = LIELL - IW(IELLN) + J2 = J2 - IW(IELLN) + END IF + END IF + IF ((IELL-1).EQ.ISTK) THEN + ISTK = ISTK + LIELL + ELSE + IF (IW(IELL-1).LT.0) THEN + LIELL = LIELL - IW(IELL-1) + J1 = IELL + IW(IELL-1) + END IF + IW(J1) = -LIELL + IW(J2) = -LIELL + END IF + LAELL = NINT(A(PTRELT)) + NSTKAC(1) = NSTKAC(1) - LAELL + JA1 = PTRELT + JA2 = POSELT - 1 + IF (POSELT.LT.PTRA-AINPUT) THEN + IF (NINT(A(POSELT)).LT.0) THEN + LAELL = LAELL - NINT(A(POSELT)) + JA2 = JA2 - NINT(A(POSELT)) + END IF + END IF + IF (PTRELT-1.EQ.ASTK) THEN + ASTK = ASTK + LAELL + ELSE + IF (NINT(A(PTRELT-1)).LT.0) THEN + LAELL = LAELL - NINT(A(PTRELT-1)) + JA1 = PTRELT + NINT(A(PTRELT-1)) + END IF + A(JA1) = -LAELL + A(JA2) = -LAELL + END IF + END IF + IELL = IELLN + PTRELT = POSELT + 380 CONTINUE + DO 410 I = 1,NUMORG + APOS2 = APOS + (NFRONT+1)* (I-1) + DO 390 J = 1,NUMORG - I + A(APOS2+J*NFRONT) = A(APOS2+J*NFRONT) + A(APOS2+J) + 390 CONTINUE + DO 400 J = 1,NASS - I + A(APOS2+J) = A(APOS2+J*NFRONT) + 400 CONTINUE + 410 CONTINUE + NPIV = 0 + NSTRUC = 0 + IF (KIND.EQ.1) GO TO 760 + DO 440 K = 1,KIND - 1 + POSELT = APOS + (K-1)* (NUMORG/2* (NFRONT+1)) - 1 + DO 430 I = 1,NUMORG/2 + DO 420 J = I,NUMORG/2 + IF (A(POSELT+J).NE.ZERO) GO TO 760 + 420 CONTINUE + POSELT = POSELT + NFRONT + 430 CONTINUE + 440 CONTINUE + CNTNZ1 = NCOL - NASS + CNTNZ2 = NCOL - NASS + DO 480 J = NASS + 1,NCOL + JA1 = APOS + J - 1 + DO 450 I = 1,NUMPVT + IF (A(JA1).NE.ZERO) GO TO 460 + JA1 = JA1 + NFRONT + 450 CONTINUE + CNTNZ1 = CNTNZ1 - 1 + 460 IF (KIND.EQ.3) THEN + JA2 = APOS + NFRONT*NUMPVT + J - 1 + DO 470 I = 1,NUMPVT + IF (A(JA2).NE.ZERO) GO TO 480 + JA2 = JA2 + NFRONT + 470 CONTINUE + CNTNZ2 = CNTNZ2 - 1 + END IF + 480 CONTINUE + MA1 = (CNTNZ1+NUMPVT-1)* (CNTNZ2+ NUMPVT-1) + IF (FATHER(IASS).NE.NODES+1) THEN + END IF + DO 650 KSWEEP = 1, (NUMORG-NPIV)/2 + NNULL = 0 + LNPIV = NPIV + NPIVD2 = NPIV/2 + DO 640 IPIV = NPIVD2 + 1,NUMPVT + APOSI = APOS + NUMPVT + NPIVD2 + (IPIV-1)*NFRONT + JMAX = IDAMAX(NUMPVT-NPIVD2,A(APOSI),1) + OFFDAG = APOSI + JMAX - 1 + JMAX = JMAX + NUMPVT + NPIVD2 + PIVOT = A(OFFDAG) + A(OFFDAG) = ZERO + JJ = IDAMAX(NCOL- (NUMPVT+NPIVD2),A(APOSI),1) + RMAX = ABS(A(APOSI+JJ-1)) + IF (MAX(RMAX,ABS(PIVOT)).LE.TOL) THEN + NNULL = NNULL + 1 + GO TO 640 + END IF + IF (ABS(PIVOT).LE.TOL) GO TO 640 + POSPV1 = APOS + (IPIV-1)* (NFRONT+1) + POSPV2 = APOS + (JMAX-1)* (NFRONT+1) + IF (MA1.EQ.0) THEN + DETPIV = -PIVOT*PIVOT + IF (ABS(DETPIV/PIVOT).LE.TOL) GO TO 640 + A(OFFDAG) = PIVOT + GO TO 530 + END IF + APOSJ = APOS + (JMAX-1)*NFRONT + AMULT2 = A(POSPV2) + A(POSPV2) = ZERO + J1MAX = NPIVD2 + IDAMAX(NUMPVT-NPIVD2, + + A(APOS+NPIVD2*NFRONT+JMAX-1),NFRONT) + TMAX = ABS(A(APOS+JMAX-1+ (J1MAX-1)*NFRONT)) + IF ( JMAX-1- (NUMPVT+NPIVD2) .GT. 0)THEN + J1MAX = NUMPVT + NPIVD2 + IDAMAX(JMAX-1- (NUMPVT+NPIVD2), + + A(APOS+ (NUMPVT+NPIVD2)*NFRONT+JMAX-1),NFRONT) + TMAX = MAX(TMAX,ABS(A(APOS+JMAX-1+ (J1MAX-1)*NFRONT))) + END IF + J1MAX = JMAX - 1 + IDAMAX(NCOL-JMAX+1,A(POSPV2),1) + TMAX = MAX(TMAX,ABS(A(APOSJ+J1MAX-1))) + A(POSPV2) = AMULT2 + A(OFFDAG) = PIVOT + DETPIV = -PIVOT*PIVOT + IF (ABS(DETPIV/PIVOT).LE.TOL) GO TO 640 + IF ((ABS(A(POSPV2))*RMAX+ABS(PIVOT)*TMAX)*UU.GT. + + ABS(DETPIV)) GO TO 490 + IF ((ABS(PIVOT)*RMAX)*UU.GT.ABS(DETPIV)) GO TO 490 + GO TO 530 + 490 IF (KIND.EQ.3) GO TO 640 + IF (ABS(A(POSPV2)).LT.UU*TMAX) GO TO 640 + TMAX = ZERO + AMULT2 = - (A(OFFDAG)/A(POSPV2)) + JA1 = APOS + NPIVD2*NFRONT + (JMAX-1) + DO 500 J = NPIVD2 + 1,NUMPVT + TMAX = MAX(TMAX,ABS(A(JA1)*AMULT2)) + JA1 = JA1 + NFRONT + 500 CONTINUE + JA1 = APOS + (NUMPVT+NPIVD2)*NFRONT + (JMAX-1) + JA2 = APOS + (IPIV-1)*NFRONT + NUMPVT + NPIVD2 + DO 510 J = NUMPVT + NPIVD2 + 1,JMAX - 1 + TMAX = MAX(TMAX,ABS(A(JA2)+A(JA1)*AMULT2)) + JA1 = JA1 + NFRONT + JA2 = JA2 + 1 + 510 CONTINUE + JA1 = APOS + (JMAX-1)*NFRONT + JMAX + JA2 = APOS + (IPIV-1)*NFRONT + JMAX + DO 520 J = JMAX + 1,NCOL + TMAX = MAX(TMAX,ABS(A(JA2)+A(JA1)*AMULT2)) + JA1 = JA1 + 1 + JA2 = JA2 + 1 + 520 CONTINUE + IF (ABS(DETPIV/A(POSPV2)).LT.UU*TMAX) GO TO 640 + 530 IF (IPIV.EQ.NPIVD2+1) GO TO 550 + JA1 = APOS + (IPIV-1)*NFRONT + NUMPVT + J1 = APOS + NPIVD2*NFRONT + NUMPVT + DO 540 JJ = 1,NCOL - NUMPVT + SWOP = A(JA1) + A(JA1) = A(J1) + A(J1) = SWOP + JA1 = JA1 + 1 + J1 = J1 + 1 + 540 CONTINUE + IPOS = IWPOS + NPIVD2 + IEXCH = IWPOS + IPIV - 1 + ISWOP = IW(IPOS) + IW(IPOS) = IW(IEXCH) + IW(IEXCH) = ISWOP + 550 IF (JMAX.EQ.NUMPVT+NPIVD2+1) GO TO 590 + JA1 = APOS + JMAX - 1 + J1 = APOS + NUMPVT + NPIVD2 + DO 560 JJ = 1,NUMPVT + NPIVD2 + SWOP = A(JA1) + A(JA1) = A(J1) + A(J1) = SWOP + JA1 = JA1 + NFRONT + J1 = J1 + NFRONT + 560 CONTINUE + JA1 = APOS + (NUMPVT+NPIVD2+1)*NFRONT + JMAX - 1 + J1 = APOS + (NUMPVT+NPIVD2)* (NFRONT+1) + 1 + DO 570 JJ = NUMPVT + NPIVD2 + 2,JMAX - 1 + SWOP = A(JA1) + A(JA1) = A(J1) + A(J1) = SWOP + JA1 = JA1 + NFRONT + J1 = J1 + 1 + 570 CONTINUE + DO 580 JJ = 1,NCOL - JMAX + JA1 = JA1 + 1 + J1 = J1 + 1 + SWOP = A(JA1) + A(JA1) = A(J1) + A(J1) = SWOP + 580 CONTINUE + SWOP = A(APOS+ (NUMPVT+NPIVD2)* (NFRONT+1)) + A(APOS+ (NUMPVT+NPIVD2)* (NFRONT+1)) = A(APOS+ + + (JMAX-1)* (NFRONT+1)) + A(APOS+ (JMAX-1)* (NFRONT+1)) = SWOP + IPOS = IWPOS + NUMPVT + NPIVD2 + IEXCH = IWPOS + JMAX - 1 + ISWOP = IW(IPOS) + IW(IPOS) = IW(IEXCH) + IW(IEXCH) = ISWOP + 590 POSPV1 = APOS + NPIVD2* (NFRONT+1) + POSPV2 = APOS + (NUMPVT+NPIVD2)* (NFRONT+1) + OFFDAG = POSPV1 + NUMPVT + FLOPSB = FLOPSB + 3.0 + NEIG = NEIG + 1 +C?? We could decide not to swop these over. +C?? Also could save if pivot was oxo. + A(POSPV1) = A(POSPV2)/DETPIV + A(POSPV2) = ZERO + A(OFFDAG) = -A(OFFDAG)/DETPIV + J1 = OFFDAG + NFRONT + J2 = OFFDAG + (NUMPVT-NPIVD2-1)*NFRONT + IBEG = J1 + 1 + IEND = APOS + (NPIVD2+1)*NFRONT + NCOL - 1 + DO 610 JJ = J1,J2,NFRONT + AMULT1 = - (A(JJ)*A(OFFDAG)) + FLOPSB = FLOPSB + (IEND-IBEG+1)*2 + 1 + K1 = OFFDAG + 1 +CDIR$ IVDEP + DO 600 IROW = IBEG,IEND + A(IROW) = A(IROW) + AMULT1*A(K1) + K1 = K1 + 1 + 600 CONTINUE + A(JJ) = -AMULT1 + IBEG = IBEG + NFRONT + IEND = IEND + NFRONT + 610 CONTINUE + J1 = POSPV2 + 1 + J2 = POSPV2 + NASS - NUMPVT - NPIVD2 - 1 + IBEG = J1 + NFRONT + IEND = APOS + (NUMPVT+NPIVD2+2)*NFRONT - 1 + DO 630 JJ = J1,J2 + AMULT1 = - (A(JJ-NUMPVT*NFRONT)*A(POSPV1)+A(JJ)*A(OFFDAG)) + AMULT2 = - (A(JJ-NUMPVT*NFRONT)*A(OFFDAG)) + FLOPSB = FLOPSB + (IEND-IBEG+2)*4 + K1 = JJ - NFRONT*NUMPVT + K2 = JJ +CDIR$ IVDEP + DO 620 IROW = IBEG,IEND + A(IROW) = A(IROW) + AMULT1*A(K1) + AMULT2*A(K2) + K1 = K1 + 1 + K2 = K2 + 1 + 620 CONTINUE + IF (JJ.LE.POSPV2+NUMPVT-NPIVD2-1) THEN + A(JJ-NUMPVT*NFRONT) = -AMULT2 + A(JJ) = AMULT1 + ELSE + A(JJ-NUMPVT*NFRONT) = AMULT1 + A(JJ) = AMULT2 + END IF + IBEG = IBEG + NFRONT + 1 + IEND = IEND + NFRONT + 630 CONTINUE + IW(IWPOS+NUMPVT+NPIVD2) = -IW(IWPOS+NUMPVT+NPIVD2) + IW(IWPOS+NPIVD2) = -IW(IWPOS+NPIVD2) + NPIV = NPIV + 2 + NPIVD2 = NPIVD2 + 1 + NTOTPV = NTOTPV + 2 + IF (KIND.EQ.3) NOXOB = NOXOB + 1 + IF (KIND.EQ.2) NTILEB = NTILEB + 1 + NSTRUC = NSTRUC + 2 + 640 CONTINUE + IF (LNPIV.EQ.NPIV) GO TO 660 + 650 CONTINUE + 660 IF (NPIV.EQ.NASS) GO TO 930 + IF (NPIV.EQ.NUMORG .OR. NPIV.EQ.0) GO TO 750 + DO 680 I = 1,NPIVD2 + JA1 = APOS + NUMPVT + NPIVD2 + (I-1)*NFRONT + DO 670 J = 1,NUMPVT - NPIVD2 + A(JA1) = -A(JA1) + JA1 = JA1 + 1 + 670 CONTINUE + 680 CONTINUE + DO 700 I = 1,NUMPVT - NPIVD2 + JA1 = APOS + NPIVD2*NFRONT + NUMPVT + (I-1)*NFRONT + DO 690 J = 1,NPIVD2 + A(JA1) = -A(JA1) + JA1 = JA1 + 1 + 690 CONTINUE + 700 CONTINUE + CALL MA47YD(A(APOS+NPIVD2),NFRONT,NPIVD2,NUMPVT-NPIVD2, + + A(APOS+NUMPVT*NFRONT),NFRONT,.FALSE.,.FALSE.) + CALL MA47YD(A(APOS+NUMPVT),NFRONT,NPIVD2,NPIVD2,A(APOS+NPIVD2), + + NFRONT,.FALSE.,.FALSE.) + CALL MA47YD(A(APOS+NUMPVT*NFRONT),NFRONT,NPIVD2,NUMPVT-NPIVD2, + + A(APOS+NPIV),NFRONT,.FALSE.,.FALSE.) + CALL MA47YD(A(APOS+NPIVD2*NFRONT+NUMPVT),NFRONT,NUMPVT-NPIVD2, + + NPIVD2,A(APOS+NUMPVT*NFRONT),NFRONT,.FALSE.,.FALSE.) + CALL MA47YD(A(APOS+NUMPVT* (NFRONT+1)),NFRONT,NPIVD2,NPIVD2, + + A(APOS+NPIVD2* (NFRONT+1)),NFRONT,.TRUE.,.FALSE.) + CALL MA47XD(A(APOS+NPIV* (NFRONT+1)),NFRONT,NUMPVT-NPIVD2, + + NUMPVT-NPIVD2) + CALL MA47YD(A(APOS+NUMPVT*NFRONT),NFRONT,NUMPVT-NPIVD2,NPIVD2, + + A(APOS+NPIVD2*NFRONT+NPIV),NFRONT,.FALSE.,.TRUE.) + ATRASH = (NUMPVT-NPIVD2)* (NFRONT-NUMPVT-NPIVD2) + RLSPA = MAX(RLSPA,INFO(2)+APOS+NFRONT*NASS+ATRASH+NSTKAC(1)) + IF (APOS+NASS*NFRONT+ATRASH.GT.ASTK) THEN + CALL MA47SD(A,ASTK,PTRA,AINPUT,NCMPBR) + IF (APOS+NASS*NFRONT+ATRASH.GT.ASTK) THEN + INFO(2) = INFO(2) + APOS - 1 + DO 710 I = 1,NASS*NFRONT + A(I) = A(APOS+I-1) + 710 CONTINUE + APOS = 1 + APOSBB = 1 + INFO(1) = -4 + IF (NFRONT*NASS+ATRASH.GT.ASTK) THEN + INFO(2) = RLSPA + GO TO 2170 + END IF + END IF + END IF + ASTK = ASTK - ATRASH + CALL MA47YD(A(APOS+NPIVD2*NFRONT+NPIVD2+NUMPVT),NFRONT, + + NUMPVT-NPIVD2,NFRONT-NUMPVT-NPIVD2,A(ASTK), + + NFRONT-NUMPVT-NPIVD2,.FALSE.,.FALSE.) + CALL MA47YD(A(APOS+NUMPVT*NFRONT+NPIVD2+NUMPVT),NFRONT,NPIVD2, + + NFRONT-NUMPVT-NPIVD2,A(APOS+NPIVD2*NFRONT+NPIVD2+ + + NUMPVT),NFRONT,.FALSE.,.FALSE.) + CALL MA47YD(A(ASTK),NFRONT-NUMPVT-NPIVD2,NUMPVT-NPIVD2, + + NFRONT-NUMPVT-NPIVD2,A(APOS+NPIV*NFRONT+NPIVD2+ + + NUMPVT),NFRONT,.FALSE.,.FALSE.) + ASTK = ASTK + ATRASH + CALL MA47YD(A(APOS+NPIV),NFRONT,NPIVD2,2* (NUMPVT-NPIVD2), + + A(APOS+NPIV*NFRONT),NFRONT,.FALSE.,.TRUE.) + CALL MA47YD(A(APOS+NPIVD2*NFRONT+NPIV),NFRONT,NPIVD2, + + 2* (NUMPVT-NPIVD2),A(APOS+NPIV),NFRONT,.FALSE., + + .FALSE.) + CALL MA47YD(A(APOS+NPIV*NFRONT),NFRONT,2* (NUMPVT-NPIVD2), + + NPIVD2,A(APOS+NPIVD2*NFRONT+NPIV),NFRONT,.FALSE., + + .TRUE.) + J1 = IWPOS + N - NTOTPV + NPIV + DO 720 JJ = NPIVD2,NUMPVT - 1 + IW(J1) = IW(IWPOS+JJ) + J1 = J1 + 1 + 720 CONTINUE + J1 = IWPOS + NPIVD2 + DO 730 JJ = NUMPVT,NUMPVT + NPIVD2 - 1 + IW(J1) = IW(IWPOS+JJ) + J1 = J1 + 1 + 730 CONTINUE + DO 740 JJ = 1,NUMPVT - NPIVD2 + IW(J1) = IW(IWPOS+N-NTOTPV+NPIV+JJ-1) + J1 = J1 + 1 + 740 CONTINUE + 750 NCOL = NFRONT + 760 MA1 = (NCOL-NPIV-1)**2 + IF (FATHER(IASS).NE.NODES+1) THEN + END IF + DO 920 KSWEEP = 1,NASS - NPIV + NNULL = 0 + LNPIV = NPIV + JPIV = 1 + DO 910 IPIV = NPIV + 1,NASS + JPIV = JPIV - 1 + IF (JPIV.EQ.1) GO TO 910 + IF (IPIV.GT.NUMORG) NCOL = NFRONT + APOSI = APOS + (IPIV-1)*NFRONT + POSPV1 = APOSI + IPIV - 1 + PIVOT = A(POSPV1) + IF (MA1.EQ.0) THEN + IF (ABS(PIVOT).GT.TOL) THEN + PIVSIZ = 1 + JMAX = IPIV + GO TO 810 + END IF + END IF + A(POSPV1) = ZERO + J1MAX = NPIV + IDAMAX(IPIV-NPIV,A(APOS+NPIV*NFRONT+IPIV-1), + + NFRONT) + A1MAX = ABS(A(APOS+IPIV-1+ (J1MAX-1)*NFRONT)) + JMAX = IPIV - 1 + IDAMAX(NASS-IPIV+1,A(POSPV1),1) + AMAX = ABS(A(APOSI+JMAX-1)) + IF (A1MAX.GT.AMAX) THEN + AMAX = A1MAX + JMAX = J1MAX + END IF + IF (NASS.EQ.NFRONT) THEN + RMAX = ZERO + ELSE + JJ = IDAMAX(NFRONT-NASS,A(APOSI+NASS),1) + RMAX = ABS(A(APOSI+NASS+JJ-1)) + END IF + IF (MAX(AMAX,RMAX,ABS(PIVOT)).LE.TOL) THEN + NNULL = NNULL + 1 + GO TO 910 + END IF + IF (MAX(AMAX,ABS(PIVOT)).LE.TOL) GO TO 910 + PIVSIZ = 0 + IF (ABS(PIVOT).GT.UU*MAX(RMAX,AMAX)) THEN + PIVSIZ = 1 + A(POSPV1) = PIVOT + GO TO 810 + END IF + IF (NPIV+1.EQ.NASS) THEN + A(POSPV1) = PIVOT + GO TO 910 + END IF + IF (RMAX.LT.AMAX) THEN + AMULT1 = A(APOSI+JMAX-1) + A(APOSI+JMAX-1) = ZERO + J1MAX = NPIV + IDAMAX(IPIV-NPIV, + + A(APOS+NPIV*NFRONT+IPIV-1),NFRONT) + A1MAX = ABS(A(APOS+IPIV-1+ (J1MAX-1)*NFRONT)) + J1MAX = IPIV - 1 + IDAMAX(NASS-IPIV+1,A(POSPV1),1) + RMAX = MAX(RMAX,A1MAX,ABS(A(APOSI+J1MAX-1))) + A(APOSI+JMAX-1) = AMULT1 + END IF + APOSJ = APOS + (JMAX-1)*NFRONT + IF (JMAX.GT.NUMORG) NCOL = NFRONT + POSPV2 = APOSJ + JMAX - 1 + IF (IPIV.GT.JMAX) THEN + OFFDAG = APOSJ + IPIV - 1 + ELSE + OFFDAG = APOSI + JMAX - 1 + END IF + AMULT1 = A(OFFDAG) + A(OFFDAG) = ZERO + AMULT2 = A(POSPV2) + A(POSPV2) = ZERO + J1MAX = NPIV + IDAMAX(JMAX-NPIV,A(APOS+NPIV*NFRONT+JMAX-1), + + NFRONT) + TMAX = ABS(A(APOS+JMAX-1+ (J1MAX-1)*NFRONT)) + J1MAX = JMAX - 1 + IDAMAX(NCOL-JMAX+1,A(POSPV2),1) + TMAX = MAX(TMAX,ABS(A(APOSJ+J1MAX-1))) + A(OFFDAG) = AMULT1 + A(POSPV2) = AMULT2 + A(POSPV1) = PIVOT + DETPIV = A(POSPV1)*A(POSPV2) - AMAX*AMAX + MAXPIV = MAX(ABS(A(POSPV1)),ABS(A(POSPV2))) + IF (MAXPIV.EQ.ZERO) MAXPIV = ONE + IF (ABS(DETPIV)/MAXPIV.LE.TOL) GO TO 910 + PIVSIZ = 2 + IF ((ABS(A(POSPV2))*RMAX+AMAX*TMAX)*UU.GT. + + ABS(DETPIV)) GO TO 770 + IF ((ABS(A(POSPV1))*TMAX+AMAX*RMAX)*UU.GT. + + ABS(DETPIV)) GO TO 770 + GO TO 810 + 770 IF (ABS(A(POSPV2)).LT.UU*MAX(AMAX,TMAX)) GO TO 910 + IF (ABS(A(POSPV2)).LE.TOL) GO TO 910 + TMAX = ZERO + AMULT2 = - (A(OFFDAG)/A(POSPV2)) + JA1 = APOS + (JMAX-1) + NPIV*NFRONT + JA2 = APOS + (IPIV-1) + NPIV*NFRONT + DO 780 J = NPIV + 1,MIN(IPIV,JMAX) - 1 + TMAX = MAX(TMAX,ABS(A(JA2)+A(JA1)*AMULT2)) + JA1 = JA1 + NFRONT + JA2 = JA2 + NFRONT + 780 CONTINUE + IF (JMAX.GT.IPIV) THEN + J1 = NFRONT + J2 = 1 + JA1 = APOS + IPIV*NFRONT + JMAX - 1 + JA2 = APOS + (IPIV-1)*NFRONT + IPIV + ELSE + J1 = 1 + J2 = NFRONT + JA1 = APOS + (JMAX-1)*NFRONT + JMAX + JA2 = APOS + JMAX*NFRONT + IPIV - 1 + END IF + DO 790 J = MIN(IPIV,JMAX) + 1,MAX(IPIV,JMAX) - 1 + TMAX = MAX(TMAX,ABS(A(JA2)+A(JA1)*AMULT2)) + JA1 = JA1 + J1 + JA2 = JA2 + J2 + 790 CONTINUE + JA1 = APOS + (JMAX-1)*NFRONT + JMAX + JA2 = APOS + (IPIV-1)*NFRONT + JMAX + DO 800 J = MAX(IPIV,JMAX) + 1,NCOL + TMAX = MAX(TMAX,ABS(A(JA2)+A(JA1)*AMULT2)) + JA1 = JA1 + 1 + JA2 = JA2 + 1 + 800 CONTINUE + IF (ABS(DETPIV/A(POSPV2)).LT.UU*TMAX) GO TO 910 + 810 LPIV = IPIV + IF (PIVSIZ.EQ.2) LPIV = MIN(IPIV,JMAX) + DO 860 KROW = NPIV,NPIV + PIVSIZ - 1 + IF (LPIV.EQ.KROW+1) GO TO 850 + JA1 = APOS + (LPIV-1) + J1 = APOS + KROW + DO 820 JJ = 1,KROW + SWOP = A(JA1) + A(JA1) = A(J1) + A(J1) = SWOP + JA1 = JA1 + NFRONT + J1 = J1 + NFRONT + 820 CONTINUE + JA1 = JA1 + NFRONT + J1 = J1 + 1 + DO 830 JJ = 1,LPIV - KROW - 2 + SWOP = A(JA1) + A(JA1) = A(J1) + A(J1) = SWOP + JA1 = JA1 + NFRONT + J1 = J1 + 1 + 830 CONTINUE + SWOP = A(APOS+KROW* (NFRONT+1)) + A(APOS+KROW* (NFRONT+1)) = A(JA1) + A(JA1) = SWOP + DO 840 JJ = 1,NCOL - LPIV + JA1 = JA1 + 1 + J1 = J1 + 1 + SWOP = A(JA1) + A(JA1) = A(J1) + A(J1) = SWOP + 840 CONTINUE + IPOS = IWPOS + KROW + IEXCH = IWPOS + LPIV - 1 + ISWOP = IW(IPOS) + IW(IPOS) = IW(IEXCH) + IW(IEXCH) = ISWOP + 850 LPIV = MAX(IPIV,JMAX) + 860 CONTINUE + POSPV1 = APOS + NPIV* (NFRONT+1) + POSPV2 = POSPV1 + NFRONT + 1 + IF (PIVSIZ.EQ.1) THEN + FLOPSB = FLOPSB + ONE + A(POSPV1) = ONE/A(POSPV1) + IF (A(POSPV1).LT.ZERO) NEIG = NEIG + 1 + J1 = POSPV1 + 1 + J2 = POSPV1 + NASS - (NPIV+1) + IBEG = POSPV1 + NFRONT + 1 + IEND = APOS + (NPIV+1)*NFRONT + NCOL - 1 + DO 880 JJ = J1,J2 + AMULT1 = -A(JJ)*A(POSPV1) + JCOL = JJ + FLOPSB = FLOPSB + (IEND-IBEG+1)*2 + 1 +CDIR$ IVDEP + DO 870 IROW = IBEG,IEND + A(IROW) = A(IROW) + AMULT1*A(JCOL) + JCOL = JCOL + 1 + 870 CONTINUE + A(JJ) = AMULT1 + IBEG = IBEG + NFRONT + 1 + IEND = IEND + NFRONT + 880 CONTINUE + NPIV = NPIV + 1 + NTOTPV = NTOTPV + 1 + JPIV = 1 + ELSE + OFFDAG = POSPV1 + 1 + FLOPSB = FLOPSB + 6.0 + SWOP = A(POSPV2) + IF (DETPIV.LT.ZERO) THEN + NEIG = NEIG + 1 + ELSE + IF (SWOP.LT.ZERO) NEIG = NEIG + 2 + END IF + A(POSPV2) = A(POSPV1)/DETPIV + A(POSPV1) = SWOP/DETPIV + A(OFFDAG) = -A(OFFDAG)/DETPIV + J1 = POSPV1 + 2 + J2 = POSPV1 + NASS - (NPIV+1) + IBEG = POSPV2 + NFRONT + 1 + IEND = APOS + (NPIV+2)*NFRONT + NCOL - 1 + DO 900 JJ = J1,J2 + K1 = JJ + K2 = JJ + NFRONT + AMULT1 = - (A(POSPV1)*A(K1)+A(POSPV1+1)*A(K2)) + AMULT2 = - (A(POSPV1+1)*A(K1)+A(POSPV2)*A(K2)) + FLOPSB = FLOPSB + (IEND-IBEG+1)*4 + 6 +CDIR$ IVDEP + DO 890 IROW = IBEG,IEND + A(IROW) = A(IROW) + AMULT1*A(K1) + AMULT2*A(K2) + K1 = K1 + 1 + K2 = K2 + 1 + 890 CONTINUE + A(JJ) = AMULT1 + A(JJ+NFRONT) = AMULT2 + IBEG = IBEG + NFRONT + 1 + IEND = IEND + NFRONT + 900 CONTINUE + IPOS = IWPOS + NPIV + IW(IPOS) = -IW(IPOS) + IW(IPOS+1) = -IW(IPOS+1) + NPIV = NPIV + 2 + NTOTPV = NTOTPV + 2 + NFULLB = NFULLB + 1 + JPIV = 2 + END IF + 910 CONTINUE + IF (LNPIV.EQ.NPIV) GO TO 930 + 920 CONTINUE + 930 IF (NPIV.EQ.0) GO TO 1730 + NOSURE = (NBLOC.GE. (NCOL-NASS)) .AND. (NSTRUC.EQ.0) + ZONE = ZERO + IF (NSTRUC.GT.0 .AND. NPIV.NE.NSTRUC) ZONE = ONE + NUM1 = 0 + NUM2 = 0 + NUM3 = 0 + IF (NPIV.EQ.NFRONT) GO TO 1830 + IF (NSTRUC.GT.0) THEN + J2 = NCOL + DO 1000 J1 = NASS + 1,NCOL + JA1 = APOS + J1 - 1 + DO 940 K = 1,NSTRUC/2 + IF (A(JA1).NE.ZERO) GO TO 990 + JA1 = JA1 + NFRONT + 940 CONTINUE + DO 960 JJ = J2,J1 + 1,-1 + JA2 = APOS + JJ - 1 + DO 950 K = 1,NSTRUC/2 + IF (A(JA2).NE.ZERO) THEN + J2 = JJ + GO TO 970 + END IF + JA2 = JA2 + NFRONT + 950 CONTINUE + 960 CONTINUE + J2 = J1 - 1 + GO TO 1010 + 970 ISWOP = IW(IWPOS-1+J1) + IW(IWPOS-1+J1) = IW(IWPOS-1+J2) + IW(IWPOS-1+J2) = ISWOP + PPOS(ISWOP) = J2 + PPOS(IW(IWPOS-1+J1)) = J1 + JA1 = APOS + J1 - 1 + JA2 = APOS + J2 - 1 + DO 980 LDUMMY = 1,NASS + SWOP = A(JA1) + A(JA1) = A(JA2) + A(JA2) = SWOP + JA1 = JA1 + NFRONT + JA2 = JA2 + NFRONT + 980 CONTINUE + J2 = J2 - 1 + 990 IF (J1.GE.J2) GO TO 1010 + 1000 CONTINUE + 1010 NUM1 = 0 + NUM2 = J2 - NASS + NUM3 = NCOL - J2 + IF (KIND.EQ.3) THEN + DO 1090 J1 = NASS + 1,NASS + NUM2 + JA1 = APOS + (NSTRUC/2)*NFRONT + J1 - 1 + DO 1020 K = 1,NSTRUC/2 + IF (A(JA1).NE.ZERO) GO TO 1030 + JA1 = JA1 + NFRONT + 1020 CONTINUE + GO TO 1080 + 1030 DO 1050 JJ = J2,J1 + 1,-1 + JA2 = APOS + (NSTRUC/2)*NFRONT + JJ - 1 + DO 1040 K = 1,NSTRUC/2 + IF (A(JA2).NE.ZERO) GO TO 1050 + JA2 = JA2 + NFRONT + 1040 CONTINUE + J2 = JJ + GO TO 1060 + 1050 CONTINUE + J2 = J1 - 1 + GO TO 1100 + 1060 ISWOP = IW(IWPOS-1+J1) + IW(IWPOS-1+J1) = IW(IWPOS-1+J2) + IW(IWPOS-1+J2) = ISWOP + PPOS(ISWOP) = J2 + PPOS(IW(IWPOS-1+J1)) = J1 + JA1 = APOS + J1 - 1 + JA2 = APOS + J2 - 1 + DO 1070 LDUMMY = 1,NASS + SWOP = A(JA1) + A(JA1) = A(JA2) + A(JA2) = SWOP + JA1 = JA1 + NFRONT + JA2 = JA2 + NFRONT + 1070 CONTINUE + J2 = J2 - 1 + 1080 IF (J1.GE.J2) GO TO 1100 + 1090 CONTINUE + 1100 NUM1 = J2 - NASS + NUM2 = NUM2 - NUM1 + END IF + END IF + ZCOL = 0 + APOS1 = APOS + NCOL - 1 + APOS2 = APOS + NCOL + DO 1140 J = 1,NCOL - (NUM1+NUM2+NASS) + DO 1110 JA1 = 1,NPIV + IF (A(APOS1+ (JA1-1)*NFRONT).NE.ZERO) GO TO 1130 + 1110 CONTINUE + ZCOL = ZCOL + 1 + APOS2 = APOS2 - 1 + IF (APOS1.EQ.APOS2) GO TO 1130 + DO 1120 JA1 = 1,NASS + SWOP = A(APOS1+ (JA1-1)*NFRONT) + A(APOS1+ (JA1-1)*NFRONT) = A(APOS2+ (JA1-1)*NFRONT) + A(APOS2+ (JA1-1)*NFRONT) = SWOP + 1120 CONTINUE + ISWOP = IW(IWPOS+APOS2-APOS) + IW(IWPOS+APOS2-APOS) = IW(IWPOS+APOS1-APOS) + IW(IWPOS+APOS1-APOS) = ISWOP + PPOS(ISWOP) = APOS1 - APOS + 1 + PPOS(IW(IWPOS+APOS2-APOS)) = APOS2 - APOS + 1 + 1130 APOS1 = APOS1 - 1 + 1140 CONTINUE + NCOL = NCOL - ZCOL + NUM3 = NUM3 - ZCOL + IF (NCOL.EQ.NASS) GO TO 1730 + APOS3 = APOS + NFRONT*NASS + IF (NPIV.EQ.NSTRUC) THEN + NSC1 = NUM1 + NUM2 + NSC2 = NUM2 + NUM3 + IF (NSC1*NSC2.EQ.0) THEN + APOSI = APOS + NASS + OFFDAG = APOS + NSTRUC/2 + FLOPSB = FLOPSB + (NUM1+NUM3)*NSTRUC/2 + DO 1170 K = 1,NSTRUC/2 + DO 1150 JJ = APOSI,APOSI + NUM1 - 1 + A(JJ+NFRONT*NSTRUC/2) = -A(OFFDAG)*A(JJ) + A(JJ) = ZERO + 1150 CONTINUE + DO 1160 JJ = APOSI + NUM1,APOSI + NUM1 + NUM3 - 1 + A(JJ) = - (A(OFFDAG)*A(JJ+NFRONT*NSTRUC/2)) + A(JJ+NFRONT*NSTRUC/2) = ZERO + 1160 CONTINUE + APOSI = APOSI + NFRONT + OFFDAG = OFFDAG + NFRONT + 1 + 1170 CONTINUE + GO TO 1730 + END IF + ELSE + NSC1 = NCOL - NASS + NSC2 = NCOL - NASS + END IF + IF (NOSURE) THEN +C + APOS4 = ASTK - ((NSC1+1)*NSC1)/2 - 1 + RLSPA = MAX(RLSPA,INFO(2)+APOS3+ ((NSC1+1)*NSC1)/2+2+ + + NSTKAC(1)) + IF (APOS3.GT.APOS4) THEN + CALL MA47SD(A,ASTK,PTRA,AINPUT,NCMPBR) +C + APOS4 = ASTK - ((NSC1+1)*NSC1)/2 - 1 + IF (APOS3.GT.APOS4) THEN + INFO(2) = INFO(2) + APOS - 1 + DO 1180 I = 1,NASS*NFRONT + A(I) = A(APOS+I-1) + 1180 CONTINUE + APOSBB = 1 + APOS = 1 + APOS3 = APOS + NFRONT*NASS + INFO(1) = -4 + IF (APOS3.GT.APOS4) THEN + INFO(2) = RLSPA + GO TO 2170 + END IF + END IF + END IF + A(ASTK) = ((NSC1+1)*NSC1)/2 + 2 + A(APOS4) = ((NSC1+1)*NSC1)/2 + 2 + NSTKAC(1) = NSTKAC(1) + ((NSC1+1)*NSC1)/2 + 2 + ELSE + APOS4 = APOS3 + NPIV*NSC2 + IF (NPIV.EQ.NSTRUC) THEN + NSCHUR = MAX(NSC1*NSC2+1,NUM1* (NUM2+NUM3)+NUM2*NUM3+ + + (NUM2* (NUM2+1))/2+2) + ELSE + NSCHUR = MAX(NSC1*NSC2+1, (NSC1* (NSC1+1))/2+2) + END IF + RLSPA = MAX(RLSPA,INFO(2)+APOS4+NSCHUR+NSTKAC(1)) + IF (APOS4+NSCHUR-1.GT.ASTK) THEN + CALL MA47SD(A,ASTK,PTRA,AINPUT,NCMPBR) + IF (APOS4+NSCHUR-1.GT.ASTK) THEN + INFO(2) = INFO(2) + APOS - 1 + DO 1190 I = 1,NASS*NFRONT + A(I) = A(APOS+I-1) + 1190 CONTINUE + APOSBB = 1 + APOS = 1 + APOS3 = APOS + NFRONT*NASS + INFO(1) = -4 + APOS4 = APOS3 + NPIV*NSC2 + IF (APOS4+NSCHUR-1.GT.ASTK) THEN + INFO(2) = RLSPA + GO TO 2170 + END IF + END IF + END IF + IF (ZONE.EQ.ONE) THEN + DO 1200 K = APOS4,APOS4 + NSC1*NSC2 - 1 + A(K) = ZERO + 1200 CONTINUE + END IF + END IF + IF (NSTRUC.GT.0) THEN + POSPV1 = APOS + APOSI = APOS + OFFDAG = POSPV1 + NSTRUC/2 + FLOPSB = FLOPSB + (NUM1+4*NUM2+NUM3)*NSTRUC/2 + DO 1240 K = 1,NSTRUC/2 + DO 1210 JJ = APOSI + NASS,APOSI + NASS + NUM1 - 1 + A(JJ+NFRONT*NSTRUC/2) = -A(OFFDAG)*A(JJ) + A(JJ) = ZERO + 1210 CONTINUE + APOS2 = APOS3 + (K-1)* (NUM2+NUM3) + DO 1220 JJ = APOSI + NASS + NUM1, + + APOSI + NASS + NUM1 + NUM2 - 1 + A(APOS2) = A(JJ) + A(APOS2+ (NSTRUC/2)* (NUM2+NUM3)) = A(JJ+NFRONT*NSTRUC/2) + A(JJ) = - (A(POSPV1)*A(JJ)+A(OFFDAG)* + + A(JJ+NFRONT*NSTRUC/2)) + A(JJ+NFRONT*NSTRUC/2) = -A(OFFDAG)*A(APOS2) + APOS2 = APOS2 + 1 + 1220 CONTINUE + APOS2 = APOS3 + (K-1)* (NUM2+NUM3) + NUM2 + DO 1230 JJ = APOSI + NASS + NUM1 + NUM2,APOSI + NCOL - 1 + A(APOS2) = ZERO + A(APOS2+ (NSTRUC/2)* (NUM2+NUM3)) = A(JJ+NFRONT*NSTRUC/2) + A(JJ) = - (A(OFFDAG)*A(JJ+NFRONT*NSTRUC/2)) + A(JJ+NFRONT*NSTRUC/2) = ZERO + APOS2 = APOS2 + 1 + 1230 CONTINUE + POSPV1 = POSPV1 + NFRONT + 1 + APOSI = APOSI + NFRONT + OFFDAG = OFFDAG + NFRONT + 1 + 1240 CONTINUE + IF (NPIV.EQ.NSTRUC) THEN + APOS1 = APOS4 + ELSE + APOS1 = APOS4 + NUM1 + END IF + FLOPSB = FLOPSB + 2*NSTRUC*NUM1* (NUM2+NUM3) + IF (NUM1.GE.NBLOC) THEN + CALL DGEMM('N','T',NUM2+NUM3,NUM1,NSTRUC,ONE,A(APOS3), + + NUM2+NUM3,A(APOS+NASS),NFRONT,ZERO,A(APOS1),NSC2) + ELSE + APOSI = APOS + DO 1280 K = 1,NSTRUC/2 + INC = NSC2 + JA1 = APOS1 + J1 = APOSI + NASS + NFRONT*NSTRUC/2 + DO 1270 JJ = 1,NUM1 + AMULT2 = A(J1) + J1 = J1 + 1 + K2 = APOS3 + (K+NSTRUC/2-1)* (NUM2+NUM3) + IF (K.EQ.1) THEN + DO 1250 IROW = JA1,JA1 + NUM2 + NUM3 - 1 + A(IROW) = AMULT2*A(K2) + K2 = K2 + 1 + 1250 CONTINUE + ELSE + DO 1260 IROW = JA1,JA1 + NUM2 + NUM3 - 1 + A(IROW) = A(IROW) + AMULT2*A(K2) + K2 = K2 + 1 + 1260 CONTINUE + END IF + JA1 = JA1 + INC + 1270 CONTINUE + APOSI = APOSI + NFRONT + 1280 CONTINUE + END IF + FLOPSB = FLOPSB + NSTRUC* (2*NUM3+NUM2+1)*NUM2 + FLOPSX = FLOPSX + NSTRUC*NUM2*NUM3 + APOS1 = APOS1 + NUM1*NSC2 + JA1 = APOS1 + KBLK = NUM2/NBLOC + DO 1290 K = 1,KBLK + JA1 = (K-1)*NBLOC + FLOPSX = FLOPSX + NBLOC* (NBLOC-1)*NSTRUC + CALL DGEMM('N','T',NUM2+NUM3-JA1,NBLOC,NSTRUC,ONE, + + A(APOS3+JA1),NUM2+NUM3,A(APOS+NASS+NUM1+JA1), + + NFRONT,ZERO,A(APOS1+JA1* (NSC2+1)),NSC2) + 1290 CONTINUE + APOSI = APOS + APOS1 = APOS1 + KBLK*NBLOC* (NSC2+1) + DO 1350 K = 1,NSTRUC/2 + INC = NSC2 + JA1 = APOS1 + JA2 = JA1 + NUM2 - 1 - KBLK*NBLOC + J1 = APOSI + NASS + NUM1 + KBLK*NBLOC + DO 1340 JJ = 1,NUM2 - KBLK*NBLOC + AMULT1 = A(J1) + AMULT2 = A(J1+NFRONT*NSTRUC/2) + J1 = J1 + 1 + K1 = APOS3 + KBLK*NBLOC + (K-1)* (NUM2+NUM3) + JJ - 1 + K2 = K1 + (NSTRUC/2)* (NUM2+NUM3) + IF (K.EQ.1) THEN + DO 1300 IROW = JA1,JA2 + A(IROW) = AMULT1*A(K1) + AMULT2*A(K2) + K1 = K1 + 1 + K2 = K2 + 1 + 1300 CONTINUE + ELSE + DO 1310 IROW = JA1,JA2 + A(IROW) = A(IROW) + AMULT1*A(K1) + AMULT2*A(K2) + K1 = K1 + 1 + K2 = K2 + 1 + 1310 CONTINUE + END IF + IF (K.EQ.1) THEN + DO 1320 IROW = JA2 + 1,JA2 + NUM3 + A(IROW) = AMULT2*A(K2) + K2 = K2 + 1 + 1320 CONTINUE + ELSE + DO 1330 IROW = JA2 + 1,JA2 + NUM3 + A(IROW) = A(IROW) + AMULT2*A(K2) + K2 = K2 + 1 + 1330 CONTINUE + END IF + JA1 = JA1 + INC + 1 + JA2 = JA2 + INC + 1340 CONTINUE + APOSI = APOSI + NFRONT + 1350 CONTINUE + END IF + IF (NSTRUC.EQ.NPIV) GO TO 1560 + J1 = IWPOS + NSTRUC + LTWO = .FALSE. + POSPV1 = APOS + NFRONT*NSTRUC + NSTRUC + IF (NOSURE) THEN + I = NSTRUC + 2 + APOSI = APOS + NSTRUC*NFRONT + NASS + J2 = APOS + NFRONT*NSTRUC + NCOL - 1 + APOSC = APOS4 + 1 + IF (IW(J1).GT.0) THEN + FLOPSB = FLOPSB + (NCOL-NASS) + (NCOL-NASS)* (NCOL-NASS+1) + DO 1370 JJ = APOSI,J2 + AMULT1 = -A(JJ)*A(POSPV1) + DO 1360 JJJ = JJ,J2 + A(APOSC) = AMULT1*A(JJJ) + APOSC = APOSC + 1 + 1360 CONTINUE + A(JJ) = AMULT1 + 1370 CONTINUE + J1 = J1 + 1 + ELSE + POSPV2 = POSPV1 + NFRONT + 1 + OFFDAG = POSPV1 + 1 + FLOPSB = FLOPSB + 6* (NCOL-NASS) + + + 2* (NCOL-NASS)* (NCOL-NASS+1) + DO 1390 JJ = APOSI,J2 + AMULT1 = - (A(POSPV1)*A(JJ)+A(OFFDAG)*A(JJ+NFRONT)) + AMULT2 = -A(POSPV2)*A(JJ+NFRONT) - A(OFFDAG)*A(JJ) + DO 1380 JJJ = JJ,J2 + A(APOSC) = AMULT1*A(JJJ) + AMULT2*A(JJJ+NFRONT) + APOSC = APOSC + 1 + 1380 CONTINUE + A(JJ) = AMULT1 + A(JJ+NFRONT) = AMULT2 + 1390 CONTINUE + J1 = J1 + 2 + POSPV1 = POSPV2 + I = I + 1 + END IF + POSPV1 = POSPV1 + NFRONT + 1 + DO 1450 I1 = I,NPIV + IF (LTWO) GO TO 1440 + APOSI = APOS + (I1-1)*NFRONT + NASS + J2 = APOS + NFRONT* (I1-1) + NCOL - 1 + APOSC = APOS4 + 1 + IF (IW(J1).GT.0) THEN + FLOPSB = FLOPSB + (NCOL-NASS) + (NCOL-NASS)* (NCOL-NASS+1) + DO 1410 JJ = APOSI,J2 + AMULT1 = -A(JJ)*A(POSPV1) + DO 1400 JJJ = JJ,J2 + A(APOSC) = A(APOSC) + AMULT1*A(JJJ) + APOSC = APOSC + 1 + 1400 CONTINUE + A(JJ) = AMULT1 + 1410 CONTINUE + J1 = J1 + 1 + ELSE + POSPV2 = POSPV1 + NFRONT + 1 + OFFDAG = POSPV1 + 1 + FLOPSB = FLOPSB + 6* (NCOL-NASS) + + + 2* (NCOL-NASS)* (NCOL-NASS+1) + DO 1430 JJ = APOSI,J2 + AMULT1 = - (A(POSPV1)*A(JJ)+A(OFFDAG)*A(JJ+NFRONT)) + AMULT2 = -A(POSPV2)*A(JJ+NFRONT) - A(OFFDAG)*A(JJ) + DO 1420 JJJ = JJ,J2 + A(APOSC) = A(APOSC) + AMULT1*A(JJJ) + + + AMULT2*A(JJJ+NFRONT) + APOSC = APOSC + 1 + 1420 CONTINUE + A(JJ) = AMULT1 + A(JJ+NFRONT) = AMULT2 + 1430 CONTINUE + J1 = J1 + 2 + POSPV1 = POSPV2 + LTWO = .TRUE. + GO TO 1450 + END IF + 1440 LTWO = .FALSE. + POSPV1 = POSPV1 + NFRONT + 1 + 1450 CONTINUE + ELSE + DO 1490 I = NSTRUC + 1,NPIV + IF (LTWO) GO TO 1480 + APOSI = APOS + (I-1)*NFRONT + NASS + POSELT = APOS3 + (I-NSTRUC-1)* (NCOL-NASS) + IF (IW(J1).GT.0) THEN + FLOPSB = FLOPSB + (NCOL-NASS) + DO 1460 JJ = APOSI,APOS + NFRONT* (I-1) + NCOL - 1 + A(POSELT) = A(JJ) + A(JJ) = -A(JJ)*A(POSPV1) + POSELT = POSELT + 1 + 1460 CONTINUE + J1 = J1 + 1 + ELSE + POSPV2 = POSPV1 + NFRONT + 1 + OFFDAG = POSPV1 + 1 + FLOPSB = FLOPSB + 6* (NCOL-NASS) + DO 1470 JJ = APOSI,APOS + NFRONT* (I-1) + NCOL - 1 + A(POSELT) = A(JJ) + A(POSELT+NCOL-NASS) = A(JJ+NFRONT) + A(JJ) = - (A(POSPV1)*A(JJ)+A(OFFDAG)*A(JJ+NFRONT)) + A(JJ+NFRONT) = -A(POSPV2)*A(JJ+NFRONT) - + + A(OFFDAG)*A(POSELT) + POSELT = POSELT + 1 + 1470 CONTINUE + J1 = J1 + 2 + POSPV1 = POSPV2 + LTWO = .TRUE. + GO TO 1490 + END IF + 1480 LTWO = .FALSE. + POSPV1 = POSPV1 + NFRONT + 1 + 1490 CONTINUE + FLOPSB = FLOPSB + NPIV* (NCOL-NASS)**2 + NPIV* (NCOL-NASS) + KBLK = (NCOL-NASS)/NBLOC + IF (NPIV-NSTRUC.LT.NBLOC) KBLK = 0 + APOSH = APOS + NSTRUC*NFRONT + L = NCOL - NASS + DO 1500 KR = 1,KBLK + FLOPSX = FLOPSX + NBLOC* (NBLOC-1)* (NPIV-NSTRUC) + CALL DGEMM('N','T',L- (KR-1)*NBLOC,NBLOC,NPIV-NSTRUC,ONE, + + A(APOSH+NASS+NBLOC* (KR-1)),NFRONT, + + A(APOS3+NBLOC* (KR-1)),L,ZONE, + + A(APOS4+NBLOC* (L+1)* (KR-1)),L) + 1500 CONTINUE + DO 1550 I = 1 + KBLK*NBLOC,L + APOSA = APOS + NSTRUC*NFRONT + NASS + I - 1 + APOSB = APOS3 - 1 + APOSC = APOS4 + (I-1)*L - 1 + IF (ZONE.EQ.ONE) THEN + DO 1510 J = I,L + A(APOSC+J) = A(APOSC+J) + A(APOSA)*A(APOSB+J) + 1510 CONTINUE + ELSE + DO 1520 J = I,L + A(APOSC+J) = A(APOSA)*A(APOSB+J) + 1520 CONTINUE + END IF + DO 1540 K = 2,NPIV - NSTRUC + APOSA = APOSA + NFRONT + APOSB = APOSB + L + DO 1530 J = I,L + A(APOSC+J) = A(APOSC+J) + A(APOSA)*A(APOSB+J) + 1530 CONTINUE + 1540 CONTINUE + 1550 CONTINUE + END IF + 1560 IF (NCOL.LT.NFRONT) THEN + DO 1570 JJ = IWPOS + NCOL,IWPOS + NFRONT - 1 + J = IW(JJ) + PPOS(J) = N + 1 + 1570 CONTINUE + END IF + IF (NPIV.EQ.NSTRUC) THEN + NUMM1 = NUM1 + NUMM2 = NUM2 + ELSE + NUMM1 = 0 + NUMM2 = NCOL - NASS + END IF + NELL = ELEMS(IASS) + IELL = ISTK + 1 + PTRELT = ASTK + 1 + DO 1650 ELT = 1,NELL + IF (NINT(A(PTRELT)).LT.0) PTRELT = PTRELT - NINT(A(PTRELT)) + IF (IW(IELL).LT.0) IELL = IELL - IW(IELL) + IELLN = IELL + IW(IELL) + POSELT = PTRELT + NINT(A(PTRELT)) + JP1 = IELL + 3 + JP2 = JP1 + IW(IELL+1) + JP3 = JP2 + IW(IELL+2) + JP4 = IELL + IW(IELL) - 2 + PPOS(0) = 0 + DO 1580 JJ = JP2,JP3 - 1 + IF (IW(JJ).EQ.0) GO TO 1580 + IF (PPOS(IW(JJ))-NASS.LE.NUMM1 .OR. + + PPOS(IW(JJ))-NASS.GT.NUMM1+NUMM2) GO TO 1640 + 1580 CONTINUE + APOS1 = 0 + DO 1590 JJ = JP1,JP2 - 1 + IF (IW(JJ).EQ.0) GO TO 1590 + IF (PPOS(IW(JJ))-NASS.LE.NUMM1) THEN + IF (APOS1.EQ.2) GO TO 1640 + APOS1 = 1 + END IF + IF (PPOS(IW(JJ))-NASS.GT.NUMM1+NUMM2) THEN + IF (PPOS(IW(JJ)).EQ.N+1) GO TO 1640 + IF (APOS1.EQ.1) GO TO 1640 + APOS1 = 2 + END IF + 1590 CONTINUE + DO 1600 JJ = JP3,JP4 + IF (IW(JJ).EQ.0) GO TO 1600 + IF (PPOS(IW(JJ))-NASS.LE.NUMM1) THEN + IF (APOS1.EQ.1) GO TO 1640 + END IF + IF (PPOS(IW(JJ))-NASS.GT.NUMM1+NUMM2) THEN + IF (PPOS(IW(JJ)).EQ.N+1) GO TO 1640 + IF (APOS1.EQ.2) GO TO 1640 + END IF + 1600 CONTINUE + APOS1 = PTRELT + 1 + JA2 = JP2 + DO 1630 JJ = JP1,JP3 - 1 + J = IW(JJ) + IF (J.EQ.0) THEN + IF (JJ.LE.JP2) THEN + APOS1 = APOS1 + JP4 - JP2 + 1 + ELSE + APOS1 = APOS1 + JP4 - JJ + 1 + END IF + GO TO 1630 + END IF + IF (JJ.GT.JP2) JA2 = JJ + IF (NOSURE) THEN + DO 1610 JJJ = JA2,JP4 + JAY = IW(JJJ) + IF (PPOS(JAY).GE.PPOS(J)) THEN + APOS2 = APOS4 + 1 + ((PPOS(J)-NASS-1)* + + (2*NSC2-PPOS(J)+NASS+2))/2 + PPOS(JAY) - + + PPOS(J) + A(APOS2) = A(APOS2) + A(APOS1) + ELSE IF (JAY.GT.0) THEN + APOS2 = APOS4 + 1 + ((PPOS(JAY)-NASS-1)* + + (2*NSC2-PPOS(JAY)+NASS+2))/2 + PPOS(J) - + + PPOS(JAY) + A(APOS2) = A(APOS2) + A(APOS1) + END IF + APOS1 = APOS1 + 1 + 1610 CONTINUE + ELSE + DO 1620 JJJ = JA2,JP4 + JAY = IW(JJJ) + IF (PPOS(JAY).GE.PPOS(J)) THEN + APOS2 = APOS4 + (PPOS(J)-NASS-1)*NSC2 + PPOS(JAY) - + + NASS - 1 + IF (NSTRUC.EQ.NPIV) APOS2 = APOS2 - NUM1 + A(APOS2) = A(APOS2) + A(APOS1) + ELSE IF (JAY.GT.0) THEN + APOS2 = APOS4 + (PPOS(JAY)-NASS-1)*NSC2 + PPOS(J) - + + NASS - 1 + IF (NSTRUC.EQ.NPIV) APOS2 = APOS2 - NUM1 + A(APOS2) = A(APOS2) + A(APOS1) + END IF + APOS1 = APOS1 + 1 + 1620 CONTINUE + END IF + 1630 CONTINUE + PPOS(0) = N + 1 + NELL = NELL - 1 + NNELL = NNELL - 1 + ELEMS(IASS) = ELEMS(IASS) - 1 + LIELL = IW(IELL) + NSTKAC(2) = NSTKAC(2) - LIELL + J1 = IELL + J2 = IELLN - 1 + IF (IELLN.LT.PTRIRN-IINPUT) THEN + IF (IW(IELLN).LT.0) THEN + LIELL = LIELL - IW(IELLN) + J2 = J2 - IW(IELLN) + END IF + END IF + IF ((IELL-1).EQ.ISTK) THEN + ISTK = ISTK + LIELL + ELSE + IF (IW(IELL-1).LT.0) THEN + LIELL = LIELL - IW(IELL-1) + J1 = IELL + IW(IELL-1) + END IF + IW(J1) = -LIELL + IW(J2) = -LIELL + END IF + LAELL = NINT(A(PTRELT)) + NSTKAC(1) = NSTKAC(1) - LAELL + JA1 = PTRELT + JA2 = POSELT - 1 + IF (POSELT.LT.PTRA-AINPUT) THEN + IF (NINT(A(POSELT)).LT.0) THEN + LAELL = LAELL - NINT(A(POSELT)) + JA2 = JA2 - NINT(A(POSELT)) + END IF + END IF + IF ((PTRELT-1.EQ.ASTK) .AND. (.NOT.NOSURE)) THEN + ASTK = ASTK + LAELL + ELSE + IF (NINT(A(PTRELT-1)).LT.0) THEN + LAELL = LAELL - NINT(A(PTRELT-1)) + JA1 = PTRELT + NINT(A(PTRELT-1)) + END IF + A(JA1) = -LAELL + A(JA2) = -LAELL + END IF + 1640 IELL = IELLN + PTRELT = POSELT + 1650 CONTINUE + PPOS(0) = N + 1 + ELEMS(FATHER(IASS)) = ELEMS(FATHER(IASS)) + 1 + IF (NOSURE) THEN + ASTK = APOS4 - 1 + LAELL = ((NSC1+1)*NSC1)/2 + 2 + ELSE + IF (NSTRUC.EQ.NPIV) THEN + LAELL = NUM1* (NUM2+NUM3) + (NUM2* (NUM2+1))/2 + NUM2*NUM3 + + + 2 + JA1 = APOS4 + (NUM1+NUM2)* (NUM2+NUM3) - 1 + ELSE + LAELL = ((NSC1+1)* (NSC1))/2 + 2 + JA1 = APOS4 + (NSC1)* (NSC1) - 1 + END IF + A(ASTK) = LAELL + NSTKAC(1) = NSTKAC(1) + LAELL + ASTK = ASTK - 1 + IF (NSTRUC.EQ.NPIV) THEN + DO 1670 I = 1,NUM2 + DO 1660 JJ = JA1,JA1 - NUM3 - I + 1,-1 + A(ASTK) = A(JJ) + ASTK = ASTK - 1 + 1660 CONTINUE + JA1 = JA1 - (NUM2+NUM3) + 1670 CONTINUE + DO 1690 I = 1,NUM1 + DO 1680 JJ = 1,NUM2 + NUM3 + A(ASTK) = A(JA1) + ASTK = ASTK - 1 + JA1 = JA1 - 1 + 1680 CONTINUE + 1690 CONTINUE + ELSE + DO 1710 I = 1,NSC1 + DO 1700 JJ = JA1,JA1 - I + 1,-1 + A(ASTK) = A(JJ) + ASTK = ASTK - 1 + 1700 CONTINUE + JA1 = JA1 - NSC1 + 1710 CONTINUE + END IF + A(ASTK) = LAELL + ASTK = ASTK - 1 + END IF + LIELL = NCOL - NASS + 4 + NSTKAC(2) = NSTKAC(2) + LIELL + INTSPA = MAX(INTSPA,IWPOS+2*NFRONT+LIELL+NSTKAC(2)) + IF (IWPOS+2*NFRONT+LIELL.GT.ISTK) THEN + CALL MA47PD(IW,ISTK,PTRIRN,IINPUT,NCMPBI) + IF (IWPOS+2*NFRONT+LIELL.GT.ISTK) THEN + INFO(2) = INTSPA + INFO(1) = -3 + GO TO 2170 + END IF + END IF + IW(ISTK) = LIELL + ISTK = ISTK - 1 + NNELL = NNELL + 1 + DO 1720 I = 1,NCOL - NASS + IW(ISTK) = IW(IWPOS+NCOL-I) + ISTK = ISTK - 1 + 1720 CONTINUE + IF (NSTRUC.EQ.NPIV) THEN + IW(ISTK) = NUM2 + IW(ISTK-1) = NUM1 + ELSE + IW(ISTK) = NCOL - NASS + IW(ISTK-1) = 0 + END IF + IW(ISTK-2) = LIELL + ISTK = ISTK - 3 + 1730 IF (NPIV+NNULL.LT.NASS) THEN + ZCOL = 0 + APOS1 = APOS + NPIV*NFRONT + NASS - 1 + DO 1750 J = NASS + 1,NFRONT + APOS1 = APOS1 + 1 + DO 1740 JA1 = 1,NASS - NPIV + IF (A(APOS1+ (JA1-1)*NFRONT).NE.ZERO) GO TO 1750 + 1740 CONTINUE + IW(IWPOS+J-1) = -IW(IWPOS+J-1) + ZCOL = ZCOL + 1 + 1750 CONTINUE + ELEMS(FATHER(IASS)) = ELEMS(FATHER(IASS)) + 1 + LAELL = (NASS-NPIV)* (NFRONT-NPIV-ZCOL) + 2 + RLSPA = MAX(RLSPA,INFO(2)+APOS+NASS*NFRONT+LAELL+NSTKAC(1)) + IF (APOS+NASS*NFRONT+LAELL.GT.ASTK) THEN + CALL MA47SD(A,ASTK,PTRA,AINPUT,NCMPBR) + IF (APOS+NASS*NFRONT+LAELL.GT.ASTK) THEN + INFO(2) = INFO(2) + APOS - 1 + DO 1760 I = 1,NASS*NFRONT + A(I) = A(APOS+I-1) + 1760 CONTINUE + APOSBB = 1 + APOS = 1 + INFO(1) = -4 + IF (NASS*NFRONT+LAELL.GT.ASTK) THEN + INFO(2) = RLSPA + GO TO 2170 + END IF + END IF + END IF + A(ASTK) = LAELL + NSTKAC(1) = NSTKAC(1) + LAELL + ASTK = ASTK - LAELL + A(ASTK+1) = LAELL + JA1 = ASTK + 2 + JA2 = APOS + NPIV*NFRONT + NPIV + IF (ZCOL.EQ.0) THEN + DO 1780 I = 1,NASS - NPIV + DO 1770 JJ = JA2,JA2 + NFRONT - NPIV - 1 + A(JA1) = A(JJ) + JA1 = JA1 + 1 + 1770 CONTINUE + JA2 = JA2 + NFRONT + 1780 CONTINUE + ELSE + DO 1800 I = 1,NASS - NPIV + DO 1790 JJ = JA2,JA2 + NFRONT - NPIV - 1 + IF (IW(IWPOS+NPIV+JJ-JA2).GT.0) THEN + A(JA1) = A(JJ) + JA1 = JA1 + 1 + END IF + 1790 CONTINUE + JA2 = JA2 + NFRONT + 1800 CONTINUE + END IF + LIELL = NFRONT - NPIV - ZCOL + 4 + INTSPA = MAX(INTSPA,IWPOS+2*NFRONT+2+LIELL+NSTKAC(2)) + IF (IWPOS+2*NFRONT+2+LIELL.GT.ISTK) THEN + CALL MA47PD(IW,ISTK,PTRIRN,IINPUT,NCMPBI) + IF (IWPOS+2*NFRONT+2+LIELL.GT.ISTK) THEN + INFO(2) = INTSPA + INFO(1) = -3 + GO TO 2170 + END IF + END IF + NNELL = NNELL + 1 + IW(ISTK) = LIELL + NSTKAC(2) = NSTKAC(2) + LIELL + ISTK = ISTK - LIELL + IW(ISTK+1) = LIELL + IW(ISTK+2) = -1 + IW(ISTK+3) = NASS - NPIV + J1 = ISTK + 4 + IF (ZCOL.EQ.0) THEN + DO 1810 JJ = IWPOS + NPIV,IWPOS + NFRONT - 1 + IW(J1) = IW(JJ) + J1 = J1 + 1 + 1810 CONTINUE + ELSE + DO 1820 JJ = IWPOS + NPIV,IWPOS + NFRONT - 1 + IF (IW(JJ).LE.0) THEN + IW(JJ) = -IW(JJ) + ELSE + IW(J1) = IW(JJ) + J1 = J1 + 1 + END IF + 1820 CONTINUE + END IF + END IF + 1830 DO 1840 JJ = IWPOS + NPIV,IWPOS + NFRONT - 1 + J = ABS(IW(JJ)) + PPOS(J) = N + 1 + 1840 CONTINUE + IF (FATHER(IASS).LE.NODES) THEN + ELEMS(FATHER(IASS)) = ELEMS(FATHER(IASS)) + NELL + END IF +C******************************** +C******************************** + IF (NPIV.EQ.0) GO TO 2160 + NBLK = NBLK + 1 + ZCOL = 0 + APOS1 = APOS + NPIV + DO 1880 J = 1,NASS - NPIV + DO 1850 JA1 = 1,NPIV + IF (A(APOS1+ (JA1-1)*NFRONT).NE.ZERO) GO TO 1870 + 1850 CONTINUE + ZCOL = ZCOL + 1 + APOS2 = APOS + NASS - ZCOL + DO 1860 JA1 = 1,NPIV + SWOP = A(APOS1+ (JA1-1)*NFRONT) + A(APOS1+ (JA1-1)*NFRONT) = A(APOS2+ (JA1-1)*NFRONT) + A(APOS2+ (JA1-1)*NFRONT) = SWOP + 1860 CONTINUE + ISWOP = IW(IWPOS+NPIV+J-ZCOL) + IW(IWPOS+NPIV+J-ZCOL) = IW(IWPOS+NASS-ZCOL) + IW(IWPOS+NASS-ZCOL) = ISWOP + GO TO 1880 + 1870 APOS1 = APOS1 + 1 + 1880 CONTINUE + IF (ZCOL.GT.0) THEN + APOS1 = APOS + NASS - ZCOL + APOS2 = APOS + NASS + DO 1900 J = 1,NCOL - NASS + DO 1890 JA1 = 1,NPIV + A(APOS1+ (JA1-1)*NFRONT) = A(APOS2+ (JA1-1)*NFRONT) + 1890 CONTINUE + IW(IWPOS+NASS-ZCOL+J-1) = IW(IWPOS+NASS+J-1) + APOS1 = APOS1 + 1 + APOS2 = APOS2 + 1 + 1900 CONTINUE + END IF + NCOL = NCOL - ZCOL + NASS = NASS - ZCOL + IF (NSTRUC.GT.0) THEN + IW(IWPOS-4) = -NCOL + IW(IWPOS-3) = NSTRUC + IF (KIND.EQ.3) IW(IWPOS-3) = -NSTRUC + IW(IWPOS-2) = NUM3 + IF (KIND.EQ.2) THEN + DO 1910 I = 1,NCOL + IW(IWPOS+I-2) = IW(IWPOS+I-1) + 1910 CONTINUE + IWPOS = IWPOS + NCOL + 3 + NUM1 = 0 + ELSE + IW(IWPOS-1) = NUM1 + IWPOS = IWPOS + NCOL + 4 + END IF + IF (NPIV.NE.NSTRUC) THEN + NBLK = NBLK + 1 + J1 = IWPOS - NCOL - 4 + NSTRUC + J2 = IWPOS - 2 + DO 1920 I = NSTRUC + 1,NCOL + IW(J2) = IW(J1) + J2 = J2 + 1 + J1 = J1 + 1 + 1920 CONTINUE + END IF + IF (NSTRUC.LT.NASS) THEN + IF (NUM1.NE.0) THEN + J1 = IWPOS - 4 - NCOL + NSTRUC + J2 = J1 + DO 1930 I = 1,NASS - NSTRUC + PPOS(I) = IW(J2) + J2 = J2 + 1 + 1930 CONTINUE + J2 = J1 + NASS - NSTRUC + DO 1940 I = 1,NUM1 + IW(J1) = IW(J2) + J1 = J1 + 1 + J2 = J2 + 1 + 1940 CONTINUE + DO 1950 I = 1,NASS - NSTRUC + IW(J1) = PPOS(I) + PPOS(I) = N + 1 + J1 = J1 + 1 + 1950 CONTINUE + END IF + END IF + IF (NPIV.EQ.NSTRUC) GO TO 1970 + IWPOS = IWPOS - 2 + ELSE + J1 = IWPOS + J2 = IWPOS - 2 + DO 1960 I = 1,NCOL + IW(J2) = IW(J1) + J2 = J2 + 1 + J1 = J1 + 1 + 1960 CONTINUE + IWPOS = IWPOS - 2 + END IF + IW(IWPOS-2) = NCOL - NSTRUC + IW(IWPOS-1) = NPIV - NSTRUC + IWPOS = IWPOS + NCOL - NSTRUC + 4 + 1970 IF (INFO(1).EQ.-4) THEN + INFO(2) = INFO(2) + ((NPIV-NSTRUC)* (2*NCOL-NPIV+NSTRUC+1))/2 + GO TO 2160 + END IF + APOS2 = APOSBB + DO 1990 I = 1,NSTRUC/2 + JA1 = APOS + (I-1)*NFRONT + NSTRUC/2 + DO 1980 J = 1,NSTRUC/2 + A(APOS2) = A(JA1) + APOS2 = APOS2 + 1 + JA1 = JA1 + 1 + 1980 CONTINUE + 1990 CONTINUE + IF (KIND.EQ.2) THEN + DO 2010 I = 1,NSTRUC/2 + JA1 = APOS + (NSTRUC/2+I-1)* (NFRONT+1) + 1 + DO 2000 J = I + 1,NSTRUC/2 + A(APOS2) = A(JA1) + APOS2 = APOS2 + 1 + JA1 = JA1 + 1 + 2000 CONTINUE + 2010 CONTINUE + JA1 = APOS + DO 2020 I = 1,NSTRUC/2 + A(APOS2) = A(JA1) + JA1 = JA1 + NFRONT + 1 + APOS2 = APOS2 + 1 + 2020 CONTINUE + DO 2030 I = 1,NSTRUC/2 + A(APOS2) = ZERO + APOS2 = APOS2 + 1 + 2030 CONTINUE + ELSE + DO 2040 I = 1,NSTRUC + A(APOS2) = ZERO + APOS2 = APOS2 + 1 + 2040 CONTINUE + END IF + DO 2070 I = 1,NSTRUC/2 + JA1 = APOS + (I-1)*NFRONT + NSTRUC + DO 2050 J = NSTRUC + 1,NASS + A(APOS2) = A(JA1) + APOS2 = APOS2 + 1 + JA1 = JA1 + 1 + 2050 CONTINUE + JA1 = JA1 + NUM1 + DO 2060 J = 1,NCOL - NASS - NUM1 + A(APOS2) = A(JA1) + APOS2 = APOS2 + 1 + JA1 = JA1 + 1 + 2060 CONTINUE + 2070 CONTINUE + DO 2110 I = NSTRUC/2 + 1,NSTRUC + JA1 = APOS + (I-1)*NFRONT + NASS + DO 2080 J = 1,NUM1 + A(APOS2) = A(JA1) + APOS2 = APOS2 + 1 + JA1 = JA1 + 1 + 2080 CONTINUE + JA1 = APOS + (I-1)*NFRONT + NSTRUC + DO 2090 J = 1,NASS - NSTRUC + A(APOS2) = A(JA1) + APOS2 = APOS2 + 1 + JA1 = JA1 + 1 + 2090 CONTINUE + JA1 = APOS + (I-1)*NFRONT + NASS + NUM1 + DO 2100 J = 1,NCOL - NASS - NUM1 - NUM3 + A(APOS2) = A(JA1) + APOS2 = APOS2 + 1 + JA1 = JA1 + 1 + 2100 CONTINUE + 2110 CONTINUE + DO 2130 I = 1,NPIV - NSTRUC + JA1 = APOS + (NSTRUC+I-1)* (NFRONT+1) + DO 2120 J = I,NPIV - NSTRUC + A(APOS2) = A(JA1) + APOS2 = APOS2 + 1 + JA1 = JA1 + 1 + 2120 CONTINUE + 2130 CONTINUE + DO 2150 I = 1,NPIV - NSTRUC + JA1 = APOS + (NSTRUC+I-1)*NFRONT + NPIV + DO 2140 J = 1,NCOL - NPIV + A(APOS2) = A(JA1) + APOS2 = APOS2 + 1 + JA1 = JA1 + 1 + 2140 CONTINUE + 2150 CONTINUE + APOSBB = APOS2 + 2160 CONTINUE + IF (INFO(1).EQ.-4) THEN + INFO(2) = RLSPA + GO TO 2170 + END IF + NRLBDU = APOSBB - 1 + NIRBDU = IWPOS - 5 + IW(1) = NRLBDU + 1 + IW(2) = NRLBDU + NFULLB + IW(3) = NBLK + CALL MA47WD(A,LA,IW,LIW,NRLBDU) + INFO(6) = MAX(2*NE,RLSPA) + INFO(7) = MAX(2*NE,INTSPA) + INFO(15) = MAXFRT + INFO(16) = NRLBDU + INFO(17) = NIRBDU + INFO(18) = NCMPBR + INFO(19) = NCMPBI + INFO(20) = NTILEB + INFO(21) = NOXOB + INFO(22) = NFULLB + INFO(23) = NEIG + INFO(24) = N - NTOTPV + RINFO(3) = FLOPSB + RINFO(4) = FLOPSX + 2170 RETURN + END + SUBROUTINE MA47PD(IW,BOTTOM,TOP,MOVE,NCMP) + INTEGER IW(*) + INTEGER BOTTOM,TOP,MOVE,NCMP + INTEGER IDUMMY,JJ,K,SIZE + NCMP = NCMP + 1 + K = TOP - MOVE - 1 + DO 20 IDUMMY = 1,TOP + IF (K.LE.BOTTOM) GO TO 30 + SIZE = IW(K) + IF (SIZE.LT.0) THEN + MOVE = MOVE - SIZE + K = K + SIZE + ELSE + IF (MOVE.GT.0) THEN + DO 10 JJ = K,K - SIZE + 1,-1 + IW(JJ+MOVE) = IW(JJ) + 10 CONTINUE + END IF + K = K - SIZE + END IF + 20 CONTINUE + 30 BOTTOM = BOTTOM + MOVE + MOVE = 0 + RETURN + END + SUBROUTINE MA47QD(N,A,LA,IW,LIW,W,RHS,IW1,ICNTL) + INTEGER N,LA + DOUBLE PRECISION A(LA) + INTEGER LIW,IW(LIW) + DOUBLE PRECISION W(N),RHS(N) + INTEGER IW1(N),ICNTL(7) + INTRINSIC ABS + EXTERNAL DGEMV,DTPMV,DTPSV,DTRSV + DOUBLE PRECISION ONE + PARAMETER (ONE=1.0D0) + INTEGER APOS,APOSM,APOSO,I,IBLK,IPIV,IRHS,IWPOS,J,J1,J2,K,KIND, + + NCOLS,NROWS,NUM1,NUM3,N2 + DOUBLE PRECISION W1 + APOS = 1 + IWPOS = 4 + DO 270 IBLK = 1,IW(3) + IW1(IBLK) = IWPOS + NCOLS = IW(IWPOS) + NROWS = IW(IWPOS+1) + IWPOS = IWPOS + 2 + NUM1 = 0 + NUM3 = 0 + IF (NCOLS.GT.0) THEN + KIND = 1 + N2 = NROWS + ELSE + NCOLS = -NCOLS + NUM3 = IW(IWPOS) + IWPOS = IWPOS + 1 + IF (NROWS.GT.0) THEN + KIND = 2 + ELSE + NROWS = -NROWS + NUM1 = IW(IWPOS) + IWPOS = IWPOS + 1 + KIND = 3 + END IF + N2 = NROWS/2 + END IF + IF (N2.GT.ICNTL(7)) THEN + DO 10 I = 1,NCOLS + W(I) = RHS(ABS(IW(IWPOS+I-1))) + 10 CONTINUE + IF (KIND.EQ.1) THEN + CALL DTPSV('L','N','U',NROWS,A(APOS),W,1) + APOS = APOS + (NROWS* (NROWS+1))/2 + IF (NCOLS.GT.NROWS) CALL DGEMV('N',NCOLS-NROWS,NROWS,ONE, + + A(APOS),NCOLS-NROWS,W,1,ONE, + + W(NROWS+1),1) + APOS = APOS + NROWS* (NCOLS-NROWS) + DO 35 I = 1,NCOLS + RHS(ABS(IW(IWPOS+I-1))) = W(I) + 35 CONTINUE + ELSE IF (KIND.EQ.2) THEN + CALL DTRSV('U','T','U',N2,A(APOS),N2,W,1) + APOSM = APOS + N2*N2 + APOSO = APOSM + (N2* (N2+1))/2 + N2 + K = NCOLS - NROWS + IF (K.GT.NUM1) CALL DGEMV('N',K-NUM1,N2,ONE,A(APOSO),K-NUM1, + + W,1,ONE,W(NROWS+1+NUM1),1) + DO 40 I = 1,N2 + RHS(ABS(IW(IWPOS+I-1))) = W(I) + 40 CONTINUE + CALL DTPMV('L','N','N',N2-1,A(APOSM),W,1) + DO 50 I = N2 + 2,NROWS + W(I) = W(I) + W(I-N2-1) + 50 CONTINUE + CALL DTRSV('L','N','U',N2,A(APOS),N2,W(N2+1),1) + APOS = APOSO + N2* (K-NUM1) + IF (K.GT.NUM3) CALL DGEMV('N',K-NUM3,N2,ONE,A(APOS),K-NUM3, + + W(N2+1),1,ONE,W(NROWS+1),1) + APOS = APOS + N2* (K-NUM3) + DO 60 I = N2 + 1,NCOLS + RHS(ABS(IW(IWPOS+I-1))) = W(I) + 60 CONTINUE + ELSE + CALL DTRSV('U','T','U',N2,A(APOS),N2,W,1) + CALL DTRSV('L','N','U',N2,A(APOS),N2,W(N2+1),1) + APOS = APOS + N2*N2 + 2*N2 + K = NCOLS - NROWS + IF (K.GT.NUM1) CALL DGEMV('N',K-NUM1,N2,ONE,A(APOS),K-NUM1, + + W,1,ONE,W(NROWS+1+NUM1),1) + APOS = APOS + N2* (K-NUM1) + IF (K.GT.NUM3) CALL DGEMV('N',K-NUM3,N2,ONE,A(APOS),K-NUM3, + + W(N2+1),1,ONE,W(NROWS+1),1) + APOS = APOS + N2* (K-NUM3) + DO 90 I = 1,NCOLS + RHS(ABS(IW(IWPOS+I-1))) = W(I) + 90 CONTINUE + END IF + ELSE + J1 = IWPOS + J2 = IWPOS + NROWS - 1 + IF (KIND.EQ.1) THEN + DO 130 IPIV = 1,NROWS + APOS = APOS + 1 + W1 = RHS(ABS(IW(J1))) + J1 = J1 + 1 + DO 100 J = J1,J2 + IRHS = ABS(IW(J)) + RHS(IRHS) = RHS(IRHS) - A(APOS)*W1 + APOS = APOS + 1 + 100 CONTINUE + 130 CONTINUE + J2 = IWPOS + NCOLS - 1 + DO 136 IPIV = 1,NROWS + W1 = RHS(ABS(IW(IWPOS+IPIV-1))) + DO 133 J = J1,J2 + IRHS = ABS(IW(J)) + RHS(IRHS) = RHS(IRHS) + W1*A(APOS) + APOS = APOS + 1 + 133 CONTINUE + 136 CONTINUE + ELSE + J2 = IWPOS + N2 - 1 + APOSO = APOS + N2*N2 + DO 145 IPIV = 1,N2 - 1 + K = APOS + (IPIV-1)* (N2+1) + W1 = RHS(-IW(J1)) + J1 = J1 + 1 + DO 140 J = J1,J2 + IRHS = ABS(IW(J)) + K = K + N2 + RHS(IRHS) = RHS(IRHS) - W1*A(K) + 140 CONTINUE + 145 CONTINUE + IF (KIND.EQ.2) THEN + K = APOSO + APOSO = APOSO + (N2* (N2+1))/2 + N2 + J1 = IWPOS + DO 155 IPIV = 1,N2 - 1 + W1 = RHS(-IW(J1)) + J1 = J1 + 1 + DO 150 J = J1,J2 + IRHS = ABS(IW(J+N2)) + RHS(IRHS) = RHS(IRHS) + W1*A(K) + K = K + 1 + 150 CONTINUE + 155 CONTINUE + ELSE + APOSO = APOSO + 2*N2 + END IF + J1 = IWPOS + N2 + J2 = J2 + N2 + DO 165 IPIV = 1,N2 - 1 + K = APOS + (IPIV-1)* (N2+1) + W1 = RHS(-IW(J1)) + J1 = J1 + 1 + DO 160 J = J1,J2 + IRHS = ABS(IW(J)) + K = K + 1 + RHS(IRHS) = RHS(IRHS) - W1*A(K) + 160 CONTINUE + 165 CONTINUE + APOS = APOSO + J1 = IWPOS + NROWS + J2 = IWPOS + NCOLS - 1 + DO 195 IPIV = 1,N2 + W1 = RHS(ABS(IW(IWPOS+IPIV-1))) + DO 190 J = J1 + NUM1,J2 + IRHS = ABS(IW(J)) + RHS(IRHS) = RHS(IRHS) + W1*A(APOS) + APOS = APOS + 1 + 190 CONTINUE + 195 CONTINUE + DO 210 IPIV = 1,N2 + W1 = RHS(ABS(IW(IWPOS+IPIV-1+N2))) + DO 200 J = J1,J2 - NUM3 + IRHS = ABS(IW(J)) + RHS(IRHS) = RHS(IRHS) + W1*A(APOS) + APOS = APOS + 1 + 200 CONTINUE + 210 CONTINUE + END IF + END IF + IWPOS = IWPOS + NCOLS + 270 CONTINUE + END + SUBROUTINE MA47RD(N,A,LA,IW,LIW,W,RHS,IW1,ICNTL) + INTEGER N,LA + DOUBLE PRECISION A(LA) + INTEGER LIW,IW(LIW) + DOUBLE PRECISION W(N),RHS(N) + INTEGER IW1(N),ICNTL(7) + INTRINSIC ABS + EXTERNAL DGEMV,DTPMV,DTPSV,DTRSV + DOUBLE PRECISION ONE + PARAMETER (ONE=1.0D0) + INTEGER APOS,APOSD,APOSE,APOSF,APOSM,APOS2,I,IBLK,IPIV,IRHS,IRHS1, + + IRHS2,IWPOS,J,JPIV,J1,J2,K,KIND,LROW,NCOLS,NROWS,NUM1, + + NUM3,N2 + DOUBLE PRECISION W1 + APOS = IW(1) + APOS2 = IW(2) + DO 380 IBLK = IW(3),1,-1 + IWPOS = IW1(IBLK) + NCOLS = ABS(IW(IWPOS)) + NROWS = ABS(IW(IWPOS+1)) + NUM1 = 0 + NUM3 = 0 + IF (IW(IWPOS).GT.0) THEN + KIND = 1 + APOS = APOS - NROWS* (NCOLS-NROWS) + N2 = NROWS + ELSE + N2 = NROWS/2 + APOS = APOS - (NROWS* (NCOLS+NCOLS-NROWS+1))/2 + NUM3 = IW(IWPOS+2) + APOS = APOS + NUM3*N2 + (N2* (N2+1))/2 + IWPOS = IWPOS + 1 + IF (IW(IWPOS).GT.0) THEN + APOS = APOS - N2 + KIND = 2 + ELSE + NUM1 = IW(IWPOS+2) + APOS = APOS + NUM1*N2 + (N2* (N2+1))/2 + APOS = APOS - 2*N2 + IWPOS = IWPOS + 1 + KIND = 3 + END IF + END IF + IWPOS = IWPOS + 2 + IF (N2.GT.ICNTL(7)) THEN + DO 5 I = NROWS + 1,NCOLS + W(I) = RHS(ABS(IW(IWPOS+I-1))) + 5 CONTINUE + IF (KIND.EQ.1) THEN + DO 10 IPIV = NROWS,1,-1 + IRHS = ABS(IW(IWPOS+IPIV-1)) + APOS = APOS - (NROWS+1-IPIV) + W(IPIV) = RHS(IRHS)*A(APOS) + 10 CONTINUE + JPIV = -1 + DO 20 IPIV = NROWS,1,-1 + IRHS = IW(IWPOS+IPIV-1) + IF (IRHS.LT.0) THEN + IRHS1 = -IW(IWPOS+IPIV-1+JPIV) + W(IPIV) = RHS(IRHS1)*A(APOS2) + W(IPIV) + IF (JPIV.EQ.1) APOS2 = APOS2 - 1 + JPIV = -JPIV + END IF + 20 CONTINUE + K = NCOLS - NROWS + IF (K.GT.0) CALL DGEMV('T',K,NROWS,ONE, + + A(APOS+ (NROWS* (NROWS+1))/2),K, + + W(NROWS+1),1,ONE,W,1) + CALL DTPSV('L','T','U',NROWS,A(APOS),W,1) + DO 60 I = 1,NROWS + RHS(ABS(IW(IWPOS+I-1))) = W(I) + 60 CONTINUE + ELSE + APOSD = APOS + APOSM = APOS + N2*N2 + APOSE = APOSM + (N2* (N2-1))/2 + IF (KIND.EQ.3) APOSE = APOSM + APOSF = APOSE + N2 + DO 70 IPIV = 1,N2 + IRHS1 = -IW(IWPOS+IPIV-1) + IRHS2 = -IW(IWPOS+IPIV-1+N2) + W(IPIV) = RHS(IRHS1)*A(APOSE) + RHS(IRHS2)*A(APOSD) + W(IPIV+N2) = RHS(IRHS1)*A(APOSD) + RHS(IRHS2)*A(APOSF) + APOSD = APOSD + N2 + 1 + APOSE = APOSE + 1 + APOSF = APOSF + 1 + 70 CONTINUE + APOSD = APOS + APOS = APOSF + K = NCOLS - NROWS + IF (K.GT.NUM1) CALL DGEMV('T',K-NUM1,N2,ONE,A(APOS),K-NUM1, + + W(NROWS+NUM1+1),1,ONE,W,1) + IF (K.GT.NUM3) CALL DGEMV('T',K-NUM3,N2,ONE, + + A(APOS+N2* (K-NUM1)),K-NUM3, + + W(NROWS+1),1,ONE,W(N2+1),1) + IF (KIND.EQ.2) THEN + APOS = APOSD + CALL DTRSV('L','T','U',N2,A(APOSD),N2,W(N2+1),1) + DO 90 I = N2 + 1,NROWS + RHS(ABS(IW(IWPOS+I-1))) = W(I) + 90 CONTINUE + CALL DTPMV('L','T','N',N2-1,A(APOSM),W(N2+2),1) + DO 100 I = 1,N2 - 1 + W(I) = W(I) + W(I+N2+1) + 100 CONTINUE + CALL DTRSV('U','N','U',N2,A(APOSD),N2,W,1) + DO 110 I = 1,N2 + RHS(ABS(IW(IWPOS+I-1))) = W(I) + 110 CONTINUE + ELSE + APOS = APOSD + CALL DTRSV('L','T','U',N2,A(APOS),N2,W(N2+1),1) + CALL DTRSV('U','N','U',N2,A(APOS),N2,W,1) + DO 180 I = 1,NROWS + RHS(ABS(IW(IWPOS+I-1))) = W(I) + 180 CONTINUE + END IF + END IF + ELSE + J1 = IWPOS + J2 = IWPOS + NCOLS - 1 + K = APOS + IF (KIND.EQ.1) THEN + JPIV = -1 + DO 210 IPIV = NROWS,1,-1 + IRHS = IW(IWPOS+IPIV-1) + LROW = NROWS + 1 - IPIV + IF (IRHS.GT.0) THEN + APOS = APOS - LROW + RHS(IRHS) = RHS(IRHS)*A(APOS) + ELSE + IF (JPIV.EQ.-1) THEN + IRHS1 = -IW(IWPOS+IPIV-2) + IRHS2 = -IRHS + APOS = APOS - LROW - LROW - 1 + W1 = RHS(IRHS1)*A(APOS) + RHS(IRHS2)*A(APOS2) + RHS(IRHS2) = RHS(IRHS1)*A(APOS2) + + + RHS(IRHS2)*A(APOS+LROW+1) + RHS(IRHS1) = W1 + APOS2 = APOS2 - 1 + END IF + JPIV = -JPIV + END IF + 210 CONTINUE + APOS = APOS + (NROWS* (NROWS+1))/2 + K = APOS + J1 = IWPOS + NROWS + DO 220 IPIV = 1,NROWS + IRHS = ABS(IW(IWPOS+IPIV-1)) + W1 = RHS(IRHS) + DO 215 J = J1,J2 + W1 = W1 + A(K)*RHS(ABS(IW(J))) + K = K + 1 + 215 CONTINUE + RHS(IRHS) = W1 + 220 CONTINUE + J2 = IWPOS + NROWS - 1 + DO 260 IPIV = 1,NROWS + IRHS = ABS(IW(J1-1)) + APOS = APOS - IPIV + W1 = RHS(IRHS) + K = APOS + 1 + DO 230 J = J1,J2 + W1 = W1 - A(K)*RHS(ABS(IW(J))) + K = K + 1 + 230 CONTINUE + RHS(IRHS) = W1 + J1 = J1 - 1 + 260 CONTINUE + ELSE + APOSD = APOS + APOSM = APOS + N2*N2 + APOSE = APOSM + (N2* (N2-1))/2 + IF (KIND.EQ.3) APOSE = APOSM + APOSF = APOSE + N2 + DO 270 IPIV = N2,1,-1 + IRHS1 = -IW(J1) + IRHS2 = -IW(J1+N2) + W1 = RHS(IRHS1)*A(APOSE) + RHS(IRHS2)*A(APOSD) + RHS(IRHS2) = RHS(IRHS1)*A(APOSD) + RHS(IRHS2)*A(APOSF) + RHS(IRHS1) = W1 + APOSD = APOSD + N2 + 1 + APOSE = APOSE + 1 + APOSF = APOSF + 1 + J1 = J1 + 1 + 270 CONTINUE + K = APOSF + J1 = IWPOS + NROWS + DO 295 IPIV = 1,N2 + IRHS1 = ABS(IW(IWPOS+IPIV-1)) + W1 = RHS(IRHS1) + DO 290 J = J1 + NUM1,J2 + IRHS = ABS(IW(J)) + W1 = W1 + RHS(IRHS)*A(K) + K = K + 1 + 290 CONTINUE + RHS(IRHS1) = W1 + 295 CONTINUE + DO 310 IPIV = 1,N2 + IRHS2 = ABS(IW(IWPOS+IPIV-1+N2)) + W1 = RHS(IRHS2) + DO 300 J = J1,J2 - NUM3 + IRHS = ABS(IW(J)) + W1 = W1 + RHS(IRHS)*A(K) + K = K + 1 + 300 CONTINUE + RHS(IRHS2) = W1 + 310 CONTINUE + J1 = IWPOS + NROWS - 1 + J2 = J1 + DO 330 IPIV = N2 - 1,1,-1 + IRHS1 = -IW(J1-1) + K = APOS + (IPIV-1)* (N2+1) + DO 320 J = J1,J2 + K = K + 1 + RHS(IRHS1) = RHS(IRHS1) - RHS(ABS(IW(J)))*A(K) + 320 CONTINUE + J1 = J1 - 1 + 330 CONTINUE + IF (KIND.EQ.2) THEN + K = APOSM + DO 350 IPIV = 1,N2 - 1 + J1 = J1 + 1 + IRHS2 = -IW(J1-1-N2) + DO 340 J = J1,J2 + RHS(IRHS2) = RHS(IRHS2) + RHS(ABS(IW(J)))*A(K) + K = K + 1 + 340 CONTINUE + 350 CONTINUE + END IF + J1 = J2 - N2 + J2 = J1 + DO 370 IPIV = N2 - 1,1,-1 + IRHS2 = -IW(J1-1) + K = APOS + (IPIV-1)* (N2+1) + DO 360 J = J1,J2 + K = K + N2 + RHS(IRHS2) = RHS(IRHS2) - RHS(ABS(IW(J)))*A(K) + 360 CONTINUE + J1 = J1 - 1 + 370 CONTINUE + END IF + END IF + 380 CONTINUE + END + SUBROUTINE MA47SD(A,BOTTOM,TOP,MOVE,NCMP) + DOUBLE PRECISION A(*) + INTEGER BOTTOM,TOP,NCMP + INTEGER IDUMMY,JJ,K,MOVE,SIZE + NCMP = NCMP + 1 + K = TOP - MOVE - 1 + DO 20 IDUMMY = 1,TOP + IF (K.LE.BOTTOM) GO TO 30 + SIZE = A(K) + IF (SIZE.LT.0) THEN + MOVE = MOVE - SIZE + K = K + SIZE + ELSE + IF (MOVE.GT.0) THEN + DO 10 JJ = K,K - SIZE + 1,-1 + A(JJ+MOVE) = A(JJ) + 10 CONTINUE + END IF + K = K - SIZE + END IF + 20 CONTINUE + 30 BOTTOM = BOTTOM + MOVE + MOVE = 0 + RETURN + END + SUBROUTINE MA47TD(N,IPE,IW,LW,NV,NEXT,LAST,LEAF,FLAG,VAR,SVAR) + INTEGER N,IPE(N),LW,IW(LW),NV(N),NEXT(N),LAST(N),LEAF(N),FLAG(N), + + VAR(N),SVAR(N) + INTRINSIC SIGN + INTEGER FREE,I,IS,J,JS,K,KK,LS,NS + DO 10 I = 1,N + SVAR(I) = 1 + LAST(I) = I - 1 + NEXT(I) = I + 1 + FLAG(I) = 0 + VAR(I) = I + 1 + 10 CONTINUE + LAST(1) = N + NEXT(N) = 1 + FREE = 2 + DO 30 J = 1,N + KK = IPE(J) + DO 20 K = KK + 1,KK + IW(KK) + I = IW(K) + IS = SVAR(I) + IF (FLAG(IS).NE.J) THEN + FLAG(IS) = J + IF (NEXT(I).EQ.I) THEN + ELSE + JS = FREE + FREE = VAR(JS) + VAR(IS) = I + SVAR(I) = JS + NS = NEXT(I) + LS = LAST(I) + NEXT(LS) = NS + LAST(NS) = LS + NEXT(I) = I + LAST(I) = I + END IF + ELSE + IF (NEXT(I).EQ.I) THEN + NS = VAR(IS) + VAR(IS) = FREE + FREE = IS + ELSE + NS = NEXT(I) + LS = LAST(I) + NEXT(LS) = NS + LAST(NS) = LS + NS = VAR(IS) + END IF + LS = LAST(NS) + NEXT(LS) = I + NEXT(I) = NS + LAST(NS) = I + LAST(I) = LS + SVAR(I) = SVAR(NS) + END IF + 20 CONTINUE + 30 CONTINUE + DO 60 IS = 1,N + LEAF(IS) = IS + IF (LAST(IS).EQ.IS) GO TO 60 + IF (LAST(IS).LT.0) GO TO 60 + LS = LAST(IS) + LEAF(IS) = LS + DO 40 K = 1,N + I = LS + IF (I.EQ.IS) GO TO 50 + IPE(I) = 0 + LS = LAST(I) + NEXT(I) = -LS + LAST(I) = -LS + NV(I) = 0 + 40 CONTINUE + 50 NV(IS) = SIGN(K,NV(IS)) + 60 CONTINUE + END + SUBROUTINE MA47UD(A,LA,IW,LIW,ICNTL) + INTEGER LA + DOUBLE PRECISION A(LA) + INTEGER LIW,IW(LIW),ICNTL(7) + INTRINSIC ABS,INT,MIN,SIGN + CHARACTER*72 LINE + INTEGER APOS,APOSM,APOS2,IBLK,ILINE,IROW,IWPOS,J,JPIV,J1,J2,K, + + KIND,LDIAG,LEN,MP,NBLK,NCOLS,NROWS,NUM1,NUM3,N2 + CHARACTER*1 NZ,SGN,PM(-2:2) + DOUBLE PRECISION AK + DATA PM/'*','-','.','+','.'/ + SGN(K) = PM(SIGN(1,K)) + NZ(AK) = PM(INT(SIGN(2D0,-ABS(AK)))) + MP = ICNTL(2) + LDIAG = ICNTL(3) + APOS2 = IW(1) + NBLK = IW(3) + IF (LDIAG.LE.2) NBLK = 0 + IF (LDIAG.EQ.3) NBLK = MIN(1,NBLK) + LEN = 12 + IF (LDIAG.EQ.5) LEN = 1 + IF (LEN.EQ.12) THEN + IF (NBLK.EQ.IW(3)) THEN + WRITE (MP,'(A)') + + ' For each block, the following information is provided:' + ELSE + WRITE (MP,'(A,A)') ' For the first block only,', + + ' the following information is provided:' + END IF + END IF + IF (LEN.EQ.12) WRITE (MP,'(A)') + + ' 1. Block number, number of rows, number of columns', + + ' 2. Whether the block is full, tile, or oxo', + + ' 3. List of indices for the pivot, each negated if part of' + + ,' a 2x2 pivot', + + ' 4. The factorized block pivot (see below)', + + ' 5. List of indices for the non-pivot columns', + + ' 6. The non-pivot part, with structural zeros printed as', + + ' 0000000000',' A factorized full pivot has the form', + + ' T',' L D L ', + + ' T', + + ' and is printed as D and L packed together.' + IF (LEN.EQ.12) WRITE (MP,'(A)') + + ' A factorized tile or oxo pivot has the form', + + ' T', + + ' ( L ) ( F D ) ( L M )', + + ' ( T T ) ( ) ( )', + + ' ( M U ) ( D E ) ( U )', + + ' where L is unit lower triangular; D, E, and F are diagonal;' + + , + + ' M is zero for an oxo pivot and is upper triangular with zero' + + ,' diagonal for a tile pivot; and U is upper triangular with', + + ' unit diagonal. It is printed as', + + ' a. L,D,U packed together,', + + ' b. M (tile case only) in packed form,',' c. F and E.' + IWPOS = 4 + APOS = 1 + DO 300 IBLK = 1,NBLK + NCOLS = IW(IWPOS) + NROWS = IW(IWPOS+1) + IWPOS = IWPOS + 2 + IF (NCOLS.GT.0) THEN + KIND = 1 + ELSE + NCOLS = -NCOLS + NUM3 = IW(IWPOS) + IWPOS = IWPOS + 1 + IF (NROWS.GT.0) THEN + KIND = 2 + ELSE + NROWS = -NROWS + NUM1 = IW(IWPOS) + IWPOS = IWPOS + 1 + KIND = 3 + END IF + END IF + WRITE (MP,'(4(A,I6))') ' Block',IBLK,' with',NROWS,' rows and', + + NCOLS,' columns' + IF (KIND.EQ.1) WRITE (MP,'(A)') ' Full pivot' + IF (KIND.EQ.2) WRITE (MP,'(A)') ' Tile pivot' + IF (KIND.EQ.3) WRITE (MP,'(A)') ' Oxo pivot' + IF (LEN.EQ.12) WRITE (MP,'(6I12)') (IW(K),K=IWPOS,IWPOS+NROWS-1) + IF (LEN.EQ.1) WRITE (MP,'(72A1)') (SGN(IW(K)),K=IWPOS, + + IWPOS+NROWS-1) + IF (KIND.EQ.1) THEN + JPIV = 0 + DO 30 IROW = 1,NROWS + IF (JPIV.EQ.1) THEN + JPIV = 0 + ELSE + IF (IW(IWPOS+IROW-1).LT.0) JPIV = 1 + END IF + ILINE = 1 + DO 10 J = 1,IROW - 1 + WRITE (LINE(ILINE:ILINE+LEN-1),'(A)') ' ' + ILINE = ILINE + LEN + IF (ILINE.GT.72) THEN + WRITE (MP,'(A)') LINE + ILINE = 1 + END IF + 10 CONTINUE + DO 20 J = IROW,NROWS + IF (LEN.EQ.12) WRITE (LINE(ILINE:ILINE+11), + + '(1P,D12.4)') A(APOS) + IF (LEN.EQ.1) WRITE (LINE(ILINE:ILINE),'(A)') NZ(A(APOS)) + APOS = APOS + 1 + IF (J.EQ.IROW+1) THEN + IF (JPIV.EQ.1) THEN + IF (LEN.EQ.12) WRITE (LINE(ILINE:ILINE+11), + + '(1P,D12.4)') A(APOS2) + IF (LEN.EQ.1) WRITE (LINE(ILINE:ILINE), + + '(A)') NZ(A(APOS2)) + APOS2 = APOS2 + 1 + END IF + END IF + ILINE = ILINE + LEN + IF (ILINE.GT.72) THEN + WRITE (MP,'(A)') LINE + ILINE = 1 + END IF + 20 CONTINUE + IF (ILINE.GT.1) THEN + LINE(ILINE:) = ' ' + WRITE (MP,'(A)') LINE + END IF + 30 CONTINUE + ELSE + N2 = NROWS/2 + DO 50 IROW = 1,N2 + ILINE = 1 + DO 40 J = 1,N2 + IF (LEN.EQ.12) WRITE (LINE(ILINE:ILINE+11), + + '(1P,D12.4)') A(APOS) + IF (LEN.EQ.1) WRITE (LINE(ILINE:ILINE),'(A)') NZ(A(APOS)) + APOS = APOS + 1 + ILINE = ILINE + LEN + IF (ILINE.GT.72) THEN + WRITE (MP,'(A)') LINE + ILINE = 1 + END IF + 40 CONTINUE + IF (ILINE.GT.1) THEN + LINE(ILINE:) = ' ' + WRITE (MP,'(A)') LINE + END IF + 50 CONTINUE + IF (KIND.EQ.2) THEN + DO 80 IROW = 2,N2 + ILINE = 1 + APOSM = APOS + IROW - 2 + DO 60 J = 1,IROW - 1 + IF (LEN.EQ.12) WRITE (LINE(ILINE:ILINE+11), + + '(1P,D12.4)') A(APOSM) + IF (LEN.EQ.1) WRITE (LINE(ILINE:ILINE), + + '(A)') NZ(A(APOSM)) + APOSM = APOSM + N2 - J - 1 + ILINE = ILINE + LEN + IF (ILINE.GT.72) THEN + WRITE (MP,'(A)') LINE + ILINE = 1 + END IF + 60 CONTINUE + DO 70 J = IROW + 1,N2 + WRITE (LINE(ILINE:ILINE+LEN-1),'(A)') ' ' + ILINE = ILINE + LEN + IF (ILINE.GT.72) THEN + WRITE (MP,'(A)') LINE + ILINE = 1 + END IF + 70 CONTINUE + IF (ILINE.GT.1) THEN + LINE(ILINE:) = ' ' + WRITE (MP,'(A)') LINE + END IF + 80 CONTINUE + APOS = APOS + (N2* (N2-1))/2 + END IF + ILINE = 1 + APOS = APOS + N2 + DO 90 J = 1,NROWS + IF (LEN.EQ.12) WRITE (LINE(ILINE:ILINE+11), + + '(1P,D12.4)') A(APOS) + IF (LEN.EQ.1) WRITE (LINE(ILINE:ILINE),'(A)') NZ(A(APOS)) + APOS = APOS + 1 + ILINE = ILINE + LEN + IF (ILINE.GT.72) THEN + WRITE (MP,'(A)') LINE + ILINE = 1 + END IF + IF (J.EQ.N2) APOS = APOS - NROWS + 90 CONTINUE + APOS = APOS + N2 + IF (ILINE.GT.1) THEN + LINE(ILINE:) = ' ' + WRITE (MP,'(A)') LINE + END IF + END IF + IWPOS = IWPOS + NROWS + IF (LEN.EQ.12) WRITE (MP,'(6I12)') (IW(K),K=IWPOS, + + IWPOS+NCOLS-NROWS-1) + IF (LEN.EQ.1) WRITE (MP,'(72A1)') (SGN(IW(K)),K=IWPOS, + + IWPOS+NCOLS-NROWS-1) + IWPOS = IWPOS + NCOLS - NROWS + DO 280 IROW = 1,NROWS + J1 = NROWS + J2 = NCOLS + IF (KIND.GT.1) THEN + IF (IROW.GT.N2) THEN + J2 = NCOLS - NUM3 + ELSE IF (KIND.EQ.3) THEN + J1 = NROWS + NUM1 + END IF + END IF + ILINE = 1 + DO 100 J = NROWS + 1,J1 + IF (LEN.EQ.12) WRITE (LINE(ILINE:ILINE+11), + + '(A)') ' 0000000000' + IF (LEN.EQ.1) WRITE (LINE(ILINE:ILINE),'(A)') '0' + ILINE = ILINE + LEN + IF (ILINE.GT.72) THEN + WRITE (MP,'(A)') LINE + ILINE = 1 + END IF + 100 CONTINUE + DO 110 J = J1 + 1,J2 + IF (LEN.EQ.12) WRITE (LINE(ILINE:ILINE+11), + + '(1P,D12.4)') A(APOS) + IF (LEN.EQ.1) WRITE (LINE(ILINE:ILINE),'(A)') NZ(A(APOS)) + APOS = APOS + 1 + ILINE = ILINE + LEN + IF (ILINE.GT.72) THEN + WRITE (MP,'(A)') LINE + ILINE = 1 + END IF + 110 CONTINUE + DO 120 J = J2 + 1,NCOLS + IF (LEN.EQ.12) WRITE (LINE(ILINE:ILINE+11), + + '(A)') ' 0000000000' + IF (LEN.EQ.1) WRITE (LINE(ILINE:ILINE),'(A)') '0' + ILINE = ILINE + LEN + IF (ILINE.GT.72) THEN + WRITE (MP,'(A)') LINE + ILINE = 1 + END IF + 120 CONTINUE + IF (ILINE.GT.1) THEN + LINE(ILINE:) = ' ' + WRITE (MP,'(A)') LINE + END IF + 280 CONTINUE + 300 CONTINUE + END + SUBROUTINE MA47VD(THRESH,NEWTHR,N,IPE,IW,LW,COUNT,NV,NEXT,LAST, + + IPR,FLAG,NFLG) + INTEGER THRESH,NEWTHR,N,IPE(N),LW,IW(LW),COUNT(N),NV(N),NEXT(N), + + LAST(N),IPR(N),FLAG(N),NFLG + EXTERNAL MA47ZD + INTEGER IR,IS,JP,JP1,JP2,K,KE,KP,KP2,LS,MS,NS,PART + DO 50 MS = 1,N + IF (FLAG(MS).LT.0) GO TO 50 + IF (COUNT(MS).LE.THRESH) GO TO 50 + IF (COUNT(MS).GT.NEWTHR) GO TO 50 + IR = 0 + IF (NFLG.LE.4) CALL MA47ZD(N,FLAG,NFLG) + NFLG = NFLG - 1 + K = IPE(MS) + KP2 = K + IW(K) + DO 30 KP = K + 1,KP2 + PART = (IW(KP)-1)/N + KE = IW(KP) - PART*N + IF (FLAG(KE).EQ.-1) GO TO 30 + IF (FLAG(KE).LE.-2) THEN + JP = IPE(KE) + JP1 = JP + 3 + JP2 = JP + IW(JP) + IF (PART.EQ.0) THEN + ELSE IF (PART.EQ.2) THEN + JP1 = JP1 + IW(JP+1) + ELSE + JP2 = JP2 - IW(JP+2) + END IF + ELSE + JP1 = KP + JP2 = KP2 + END IF + DO 20 JP = JP1,JP2 + IS = IW(JP) + IF (FLAG(IS).GT.NFLG) THEN + FLAG(IS) = NFLG + IR = IR + ABS(NV(IS)) + END IF + 20 CONTINUE + IF (JP2.EQ.KP2 .OR. IR.GT.NEWTHR) GO TO 40 + 30 CONTINUE + 40 IF (IR.NE.COUNT(MS)) THEN + NS = NEXT(MS) + LS = LAST(MS) + NEXT(MS) = 0 + IF (NS.GT.0) LAST(NS) = LS + IF (LS.GT.0) THEN + NEXT(LS) = NS + ELSE + IPR(COUNT(MS)) = NS + END IF + NS = IPR(IR) + IF (NS.GT.0) LAST(NS) = MS + NEXT(MS) = NS + IPR(IR) = MS + LAST(MS) = 0 + COUNT(MS) = IR + END IF + 50 CONTINUE + THRESH = NEWTHR + END + SUBROUTINE MA47WD(A,LA,IW,LIW,NRLBDU) + INTEGER LA,LIW + DOUBLE PRECISION A(LA) + INTEGER IW(LIW) + INTEGER NRLBDU + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D0) + INTEGER APOS,IBLK,IROW,IWPOS,J,JPIV,NCOLS,NROWS,NUM1,NUM3,N2 + APOS = 1 + IWPOS = 6 + DO 40 IBLK = 1,IW(3) + NCOLS = IW(IWPOS-2) + NROWS = IW(IWPOS-1) + N2 = ABS(NROWS)/2 + IF (NCOLS.GT.0) THEN + JPIV = 1 + DO 30 IROW = 1,NROWS + JPIV = JPIV - 1 + IF (JPIV.EQ.1) GO TO 10 + IF (IW(IWPOS+IROW-1).LT.0) THEN + JPIV = 2 + NRLBDU = NRLBDU + 1 + A(NRLBDU) = A(APOS+1) + A(APOS+1) = ZERO + END IF + 10 DO 20 J = APOS + 1,APOS + NROWS - IROW + A(J) = -A(J) + 20 CONTINUE + APOS = APOS + NROWS - IROW + 1 + 30 CONTINUE + APOS = APOS + NROWS* (NCOLS-NROWS) + ELSE + NCOLS = -NCOLS + NUM3 = IW(IWPOS) + APOS = APOS - NUM3*N2 - N2* (N2+1)/2 + N2 + IWPOS = IWPOS + 1 + IF (NROWS.LT.0) THEN + NROWS = -NROWS + NUM1 = IW(IWPOS) + APOS = APOS - NUM1*N2 - N2* (N2+1)/2 + N2 + IWPOS = IWPOS + 1 + END IF + APOS = APOS + NROWS* (NCOLS+NCOLS-NROWS+1)/2 + END IF + IWPOS = IWPOS + ABS(NCOLS) + 2 + 40 CONTINUE + END + SUBROUTINE MA47XD(A,LDA,M,N) + INTEGER LDA,M,N + DOUBLE PRECISION A(LDA,*) + INTEGER I,J + DOUBLE PRECISION ZERO + PARAMETER (ZERO=0.0D0) + DO 20 J = 1,M + DO 10 I = J,N + A(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END + SUBROUTINE MA47YD(A,LDA,M,N,B,LDB,TRIANG,TRANS) + INTEGER LDA,M,N,LDB + LOGICAL TRIANG,TRANS + DOUBLE PRECISION A(LDA,*),B(LDB,*) + INTEGER I,J + IF (.NOT.TRIANG) THEN + IF (.NOT.TRANS) THEN + DO 20 J = 1,M + DO 10 I = 1,N + B(I,J) = A(I,J) + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,M + DO 30 I = 1,N + B(J,I) = A(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE + DO 60 J = 1,M + DO 50 I = J,N + B(I,J) = A(I,J) + 50 CONTINUE + 60 CONTINUE + END IF + RETURN + END + SUBROUTINE MA47ZD(N,FLAG,NFLG) + INTEGER N,FLAG(N),NFLG + INTEGER I,N3 + N3 = N*3 + DO 80 I = 1,N + IF (FLAG(I).GT.2) FLAG(I) = N3 + IF (FLAG(I).LE.-2) FLAG(I) = -N3 + 80 CONTINUE + NFLG = N3 + END diff --git a/deal.II/contrib/hsl/source/ma47dep.f b/deal.II/contrib/hsl/source/ma47dep.f new file mode 100644 index 0000000000..c9ec6f240b --- /dev/null +++ b/deal.II/contrib/hsl/source/ma47dep.f @@ -0,0 +1,1725 @@ + SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, + $ BETA, C, LDC ) +* .. Scalar Arguments .. + CHARACTER*1 TRANSA, TRANSB + INTEGER M, N, K, LDA, LDB, LDC + DOUBLE PRECISION ALPHA, BETA +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) +* .. +* +* Purpose +* ======= +* +* DGEMM performs one of the matrix-matrix operations +* +* C := alpha*op( A )*op( B ) + beta*C, +* +* where op( X ) is one of +* +* op( X ) = X or op( X ) = X', +* +* alpha and beta are scalars, and A, B and C are matrices, with op( A ) +* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. +* +* Parameters +* ========== +* +* TRANSA - CHARACTER*1. +* On entry, TRANSA specifies the form of op( A ) to be used in +* the matrix multiplication as follows: +* +* TRANSA = 'N' or 'n', op( A ) = A. +* +* TRANSA = 'T' or 't', op( A ) = A'. +* +* TRANSA = 'C' or 'c', op( A ) = A'. +* +* Unchanged on exit. +* +* TRANSB - CHARACTER*1. +* On entry, TRANSB specifies the form of op( B ) to be used in +* the matrix multiplication as follows: +* +* TRANSB = 'N' or 'n', op( B ) = B. +* +* TRANSB = 'T' or 't', op( B ) = B'. +* +* TRANSB = 'C' or 'c', op( B ) = B'. +* +* Unchanged on exit. +* +* M - INTEGER. +* On entry, M specifies the number of rows of the matrix +* op( A ) and of the matrix C. M must be at least zero. +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the number of columns of the matrix +* op( B ) and the number of columns of the matrix C. N must be +* at least zero. +* Unchanged on exit. +* +* K - INTEGER. +* On entry, K specifies the number of columns of the matrix +* op( A ) and the number of rows of the matrix op( B ). K must +* be at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is +* k when TRANSA = 'N' or 'n', and is m otherwise. +* Before entry with TRANSA = 'N' or 'n', the leading m by k +* part of the array A must contain the matrix A, otherwise +* the leading k by m part of the array A must contain the +* matrix A. +* Unchanged on exit. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. When TRANSA = 'N' or 'n' then +* LDA must be at least max( 1, m ), otherwise LDA must be at +* least max( 1, k ). +* Unchanged on exit. +* +* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is +* n when TRANSB = 'N' or 'n', and is k otherwise. +* Before entry with TRANSB = 'N' or 'n', the leading k by n +* part of the array B must contain the matrix B, otherwise +* the leading n by k part of the array B must contain the +* matrix B. +* Unchanged on exit. +* +* LDB - INTEGER. +* On entry, LDB specifies the first dimension of B as declared +* in the calling (sub) program. When TRANSB = 'N' or 'n' then +* LDB must be at least max( 1, k ), otherwise LDB must be at +* least max( 1, n ). +* Unchanged on exit. +* +* BETA - DOUBLE PRECISION. +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then C need not be set on input. +* Unchanged on exit. +* +* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). +* Before entry, the leading m by n part of the array C must +* contain the matrix C, except when beta is zero, in which +* case C need not be set on entry. +* On exit, the array C is overwritten by the m by n matrix +* ( alpha*op( A )*op( B ) + beta*C ). +* +* LDC - INTEGER. +* On entry, LDC specifies the first dimension of C as declared +* in the calling (sub) program. LDC must be at least +* max( 1, m ). +* Unchanged on exit. +* +* +* Level 3 Blas routine. +* +* -- Written on 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Local Scalars .. + LOGICAL NOTA, NOTB + INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB + DOUBLE PRECISION TEMP +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Executable Statements .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* transposed and set NROWA, NCOLA and NROWB as the number of rows +* and columns of A and the number of rows of B respectively. +* + NOTA = LSAME( TRANSA, 'N' ) + NOTB = LSAME( TRANSB, 'N' ) + IF( NOTA )THEN + NROWA = M + NCOLA = K + ELSE + NROWA = K + NCOLA = M + END IF + IF( NOTB )THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF( ( .NOT.NOTA ).AND. + $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. + $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.NOTB ).AND. + $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. + $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN + INFO = 2 + ELSE IF( M .LT.0 )THEN + INFO = 3 + ELSE IF( N .LT.0 )THEN + INFO = 4 + ELSE IF( K .LT.0 )THEN + INFO = 5 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 8 + ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN + INFO = 10 + ELSE IF( LDC.LT.MAX( 1, M ) )THEN + INFO = 13 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DGEMM ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* And if alpha.eq.zero. +* + IF( ALPHA.EQ.ZERO )THEN + IF( BETA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, M + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40, J = 1, N + DO 30, I = 1, M + C( I, J ) = BETA*C( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF( NOTB )THEN + IF( NOTA )THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 50, I = 1, M + C( I, J ) = ZERO + 50 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 60, I = 1, M + C( I, J ) = BETA*C( I, J ) + 60 CONTINUE + END IF + DO 80, L = 1, K + IF( B( L, J ).NE.ZERO )THEN + TEMP = ALPHA*B( L, J ) + DO 70, I = 1, M + C( I, J ) = C( I, J ) + TEMP*A( I, L ) + 70 CONTINUE + END IF + 80 CONTINUE + 90 CONTINUE + ELSE +* +* Form C := alpha*A'*B + beta*C +* + DO 120, J = 1, N + DO 110, I = 1, M + TEMP = ZERO + DO 100, L = 1, K + TEMP = TEMP + A( L, I )*B( L, J ) + 100 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP + ELSE + C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) + END IF + 110 CONTINUE + 120 CONTINUE + END IF + ELSE + IF( NOTA )THEN +* +* Form C := alpha*A*B' + beta*C +* + DO 170, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 130, I = 1, M + C( I, J ) = ZERO + 130 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 140, I = 1, M + C( I, J ) = BETA*C( I, J ) + 140 CONTINUE + END IF + DO 160, L = 1, K + IF( B( J, L ).NE.ZERO )THEN + TEMP = ALPHA*B( J, L ) + DO 150, I = 1, M + C( I, J ) = C( I, J ) + TEMP*A( I, L ) + 150 CONTINUE + END IF + 160 CONTINUE + 170 CONTINUE + ELSE +* +* Form C := alpha*A'*B' + beta*C +* + DO 200, J = 1, N + DO 190, I = 1, M + TEMP = ZERO + DO 180, L = 1, K + TEMP = TEMP + A( L, I )*B( J, L ) + 180 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP + ELSE + C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) + END IF + 190 CONTINUE + 200 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGEMM . +* + END + SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, +* +************************************************************************ +* +* File of the DOUBLE PRECISION Level-2 BLAS. +* =========================================== +* +* SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, +* $ BETA, Y, INCY ) +* +* SUBROUTINE DGBMV ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, +* $ BETA, Y, INCY ) +* +* SUBROUTINE DSYMV ( UPLO, N, ALPHA, A, LDA, X, INCX, +* $ BETA, Y, INCY ) +* +* SUBROUTINE DSBMV ( UPLO, N, K, ALPHA, A, LDA, X, INCX, +* $ BETA, Y, INCY ) +* +* SUBROUTINE DSPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) +* +* SUBROUTINE DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) +* +* SUBROUTINE DTBMV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) +* +* SUBROUTINE DTPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX ) +* +* SUBROUTINE DTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) +* +* SUBROUTINE DTBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) +* +* SUBROUTINE DTPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX ) +* +* SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) +* +* SUBROUTINE DSYR ( UPLO, N, ALPHA, X, INCX, A, LDA ) +* +* SUBROUTINE DSPR ( UPLO, N, ALPHA, X, INCX, AP ) +* +* SUBROUTINE DSYR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) +* +* SUBROUTINE DSPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP ) +* +* See: +* +* Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. +* An extended set of Fortran Basic Linear Algebra Subprograms. +* +* Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics +* and Computer Science Division, Argonne National Laboratory, +* 9700 South Cass Avenue, Argonne, Illinois 60439, US. +* +* Or +* +* NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms +* Group Ltd., NAG Central Office, 256 Banbury Road, Oxford +* OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st +* Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. +* +************************************************************************ +* + $ BETA, Y, INCY ) +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, LDA, M, N + CHARACTER*1 TRANS +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* Purpose +* ======= +* +* DGEMV performs one of the matrix-vector operations +* +* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, +* +* where alpha and beta are scalars, x and y are vectors and A is an +* m by n matrix. +* +* Parameters +* ========== +* +* TRANS - CHARACTER*1. +* On entry, TRANS specifies the operation to be performed as +* follows: +* +* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. +* +* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. +* +* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. +* +* Unchanged on exit. +* +* M - INTEGER. +* On entry, M specifies the number of rows of the matrix A. +* M must be at least zero. +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the number of columns of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). +* Before entry, the leading m by n part of the array A must +* contain the matrix of coefficients. +* Unchanged on exit. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, m ). +* Unchanged on exit. +* +* X - DOUBLE PRECISION array of DIMENSION at least +* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +* Before entry, the incremented array X must contain the +* vector x. +* Unchanged on exit. +* +* INCX - INTEGER. +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* BETA - DOUBLE PRECISION. +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then Y need not be set on input. +* Unchanged on exit. +* +* Y - DOUBLE PRECISION array of DIMENSION at least +* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +* Before entry with BETA non-zero, the incremented array Y +* must contain the vector y. On exit, Y is overwritten by the +* updated vector y. +* +* INCY - INTEGER. +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* +* -- Written on 22-October-1986. +* Jack Dongarra, Argonne National Lab. +* Jeremy Du Croz, Nag Central Office. +* Sven Hammarling, Nag Central Office. +* Richard Hanson, Sandia National Labs. +* +* +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( TRANS, 'N' ).AND. + $ .NOT.LSAME( TRANS, 'T' ).AND. + $ .NOT.LSAME( TRANS, 'C' ) )THEN + INFO = 1 + ELSE IF( M.LT.0 )THEN + INFO = 2 + ELSE IF( N.LT.0 )THEN + INFO = 3 + ELSE IF( LDA.LT.MAX( 1, M ) )THEN + INFO = 6 + ELSE IF( INCX.EQ.0 )THEN + INFO = 8 + ELSE IF( INCY.EQ.0 )THEN + INFO = 11 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DGEMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF( LSAME( TRANS, 'N' ) )THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( LENX - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( LENY - 1 )*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* +* First form y := beta*y. +* + IF( BETA.NE.ONE )THEN + IF( INCY.EQ.1 )THEN + IF( BETA.EQ.ZERO )THEN + DO 10, I = 1, LENY + Y( I ) = ZERO + 10 CONTINUE + ELSE + DO 20, I = 1, LENY + Y( I ) = BETA*Y( I ) + 20 CONTINUE + END IF + ELSE + IY = KY + IF( BETA.EQ.ZERO )THEN + DO 30, I = 1, LENY + Y( IY ) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40, I = 1, LENY + Y( IY ) = BETA*Y( IY ) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF( ALPHA.EQ.ZERO ) + $ RETURN + IF( LSAME( TRANS, 'N' ) )THEN +* +* Form y := alpha*A*x + y. +* + JX = KX + IF( INCY.EQ.1 )THEN + DO 60, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*X( JX ) + DO 50, I = 1, M + Y( I ) = Y( I ) + TEMP*A( I, J ) + 50 CONTINUE + END IF + JX = JX + INCX + 60 CONTINUE + ELSE + DO 80, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*X( JX ) + IY = KY + DO 70, I = 1, M + Y( IY ) = Y( IY ) + TEMP*A( I, J ) + IY = IY + INCY + 70 CONTINUE + END IF + JX = JX + INCX + 80 CONTINUE + END IF + ELSE +* +* Form y := alpha*A'*x + y. +* + JY = KY + IF( INCX.EQ.1 )THEN + DO 100, J = 1, N + TEMP = ZERO + DO 90, I = 1, M + TEMP = TEMP + A( I, J )*X( I ) + 90 CONTINUE + Y( JY ) = Y( JY ) + ALPHA*TEMP + JY = JY + INCY + 100 CONTINUE + ELSE + DO 120, J = 1, N + TEMP = ZERO + IX = KX + DO 110, I = 1, M + TEMP = TEMP + A( I, J )*X( IX ) + IX = IX + INCX + 110 CONTINUE + Y( JY ) = Y( JY ) + ALPHA*TEMP + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGEMV . +* + END + LOGICAL FUNCTION LSAME ( CA, CB ) +* .. Scalar Arguments .. + CHARACTER*1 CA, CB +* .. +* +* Purpose +* ======= +* +* LSAME tests if CA is the same letter as CB regardless of case. +* +* N.B. This version of the routine is only correct for ASCII code. +* Installers must modify the routine for other character-codes. +* +* For EBCDIC systems the constant IOFF must be changed to -64. +* For CDC systems using 6-12 bit representations, the system- +* specific code in comments must be activated. +* +* Parameters +* ========== +* +* CA - CHARACTER*1 +* CB - CHARACTER*1 +* On entry, CA and CB specify characters to be compared. +* Unchanged on exit. +* +* +* Auxiliary routine for Level 2 Blas. +* +* -- Written on 11-October-1988. +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, Nag Central Office. +* +* .. Parameters .. + INTEGER IOFF + PARAMETER ( IOFF=32 ) +* .. Intrinsic Functions .. + INTRINSIC ICHAR +* .. Executable Statements .. +* +* Test if the characters are equal +* + LSAME = CA .EQ. CB +* +* Now test for equivalence +* + IF ( .NOT.LSAME ) THEN + LSAME = ICHAR(CA) - IOFF .EQ. ICHAR(CB) + END IF + IF ( .NOT.LSAME ) THEN + LSAME = ICHAR(CA) .EQ. ICHAR(CB) - IOFF + END IF +* + RETURN +* +* The following comments contain code for CDC systems using 6-12 bit +* representations. +* +* .. Parameters .. +* INTEGER ICIRFX +* PARAMETER ( ICIRFX=62 ) +* .. Scalar Arguments .. +* CHARACTER*1 CB +* .. Array Arguments .. +* CHARACTER*1 CA(*) +* .. Local Scalars .. +* INTEGER IVAL +* .. Intrinsic Functions .. +* INTRINSIC ICHAR, CHAR +* .. Executable Statements .. +* +* See if the first character in string CA equals string CB. +* +* LSAME = CA(1) .EQ. CB .AND. CA(1) .NE. CHAR(ICIRFX) +* +* IF (LSAME) RETURN +* +* The characters are not identical. Now check them for equivalence. +* Look for the 'escape' character, circumflex, followed by the +* letter. +* +* IVAL = ICHAR(CA(2)) +* IF (IVAL.GE.ICHAR('A') .AND. IVAL.LE.ICHAR('Z')) THEN +* LSAME = CA(1) .EQ. CHAR(ICIRFX) .AND. CA(2) .EQ. CB +* END IF +* +* RETURN +* +* End of LSAME. +* + END +C A BLAS routine modified for use with HSL +C Toolpack tool decs employed. +C Contained comment lines which caused Decs to fail. +C + SUBROUTINE XERBLA(SRNAME,INFO) +C .. Scalar Arguments .. + INTEGER INFO + CHARACTER SRNAME*6 +C .. +C +C Purpose +C ======= +C +C XERBLA is an error handler for the Level 2 BLAS routines. +C +C It is called by the Level 2 BLAS routines if an input parameter is +C invalid. +C +C Installers should consider modifying the STOP statement in order to +C call system-specific exception-handling facilities. +C +C Parameters +C ========== +C +C SRNAME - CHARACTER*6. +C On entry, SRNAME specifies the name of the routine which +C called XERBLA. +C +C INFO - INTEGER. +C On entry, INFO specifies the position of the invalid +C parameter in the parameter-list of the calling routine. +C +C +C Auxiliary routine for Level 2 Blas. +C +C Written on 20-July-1986. +C +C .. Executable Statements .. +C + WRITE (*,FMT=99999) SRNAME,INFO +C + STOP +C +99999 FORMAT (' ** On entry to ',A6,' parameter number ',I2, + + ' had an illegal value') +C +C End of XERBLA. +C + END +C Toolpack tool decs employed. +C Arg dimension set to *. +C + INTEGER FUNCTION IDAMAX(N,DX,INCX) +C +C FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE. +C JACK DONGARRA, LINPACK, 3/11/78. +C +C .. Scalar Arguments .. + INTEGER INCX,N +C .. +C .. Array Arguments .. + DOUBLE PRECISION DX(*) +C .. +C .. Local Scalars .. + DOUBLE PRECISION DMAX + INTEGER I,IX +C .. +C .. Intrinsic Functions .. + INTRINSIC DABS +C .. +C .. Executable Statements .. +C + IDAMAX = 0 + IF (N.LT.1) RETURN + IDAMAX = 1 + IF (N.EQ.1) RETURN + IF (INCX.EQ.1) GO TO 20 +C +C CODE FOR INCREMENT NOT EQUAL TO 1 +C + IX = 1 + DMAX = DABS(DX(1)) + IX = IX + INCX + DO 10 I = 2,N + IF (DABS(DX(IX)).LE.DMAX) GO TO 5 + IDAMAX = I + DMAX = DABS(DX(IX)) + 5 IX = IX + INCX + 10 CONTINUE + RETURN +C +C CODE FOR INCREMENT EQUAL TO 1 +C + 20 DMAX = DABS(DX(1)) + DO 30 I = 2,N + IF (DABS(DX(I)).LE.DMAX) GO TO 30 + IDAMAX = I + DMAX = DABS(DX(I)) + 30 CONTINUE + RETURN + + END + SUBROUTINE DTPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX ) +* +************************************************************************ +* +* .. Scalar Arguments .. + INTEGER INCX, N + CHARACTER*1 DIAG, TRANS, UPLO +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), X( * ) +* .. +* +* Purpose +* ======= +* +* DTPMV performs one of the matrix-vector operations +* +* x := A*x, or x := A'*x, +* +* where x is an n element vector and A is an n by n unit, or non-unit, +* upper or lower triangular matrix, supplied in packed form. +* +* Parameters +* ========== +* +* UPLO - CHARACTER*1. +* On entry, UPLO specifies whether the matrix is an upper or +* lower triangular matrix as follows: +* +* UPLO = 'U' or 'u' A is an upper triangular matrix. +* +* UPLO = 'L' or 'l' A is a lower triangular matrix. +* +* Unchanged on exit. +* +* TRANS - CHARACTER*1. +* On entry, TRANS specifies the operation to be performed as +* follows: +* +* TRANS = 'N' or 'n' x := A*x. +* +* TRANS = 'T' or 't' x := A'*x. +* +* TRANS = 'C' or 'c' x := A'*x. +* +* Unchanged on exit. +* +* DIAG - CHARACTER*1. +* On entry, DIAG specifies whether or not A is unit +* triangular as follows: +* +* DIAG = 'U' or 'u' A is assumed to be unit triangular. +* +* DIAG = 'N' or 'n' A is not assumed to be unit +* triangular. +* +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the order of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* AP - DOUBLE PRECISION array of DIMENSION at least +* ( ( n*( n + 1 ) )/2 ). +* Before entry with UPLO = 'U' or 'u', the array AP must +* contain the upper triangular matrix packed sequentially, +* column by column, so that AP( 1 ) contains a( 1, 1 ), +* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) +* respectively, and so on. +* Before entry with UPLO = 'L' or 'l', the array AP must +* contain the lower triangular matrix packed sequentially, +* column by column, so that AP( 1 ) contains a( 1, 1 ), +* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) +* respectively, and so on. +* Note that when DIAG = 'U' or 'u', the diagonal elements of +* A are not referenced, but are assumed to be unity. +* Unchanged on exit. +* +* X - DOUBLE PRECISION array of dimension at least +* ( 1 + ( n - 1 )*abs( INCX ) ). +* Before entry, the incremented array X must contain the n +* element vector x. On exit, X is overwritten with the +* tranformed vector x. +* +* INCX - INTEGER. +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* +* -- Written on 22-October-1986. +* Jack Dongarra, Argonne National Lab. +* Jeremy Du Croz, Nag Central Office. +* Sven Hammarling, Nag Central Office. +* Richard Hanson, Sandia National Labs. +* +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, J, JX, K, KK, KX + LOGICAL NOUNIT +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO , 'U' ).AND. + $ .NOT.LSAME( UPLO , 'L' ) )THEN + INFO = 1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. + $ .NOT.LSAME( TRANS, 'T' ).AND. + $ .NOT.LSAME( TRANS, 'C' ) )THEN + INFO = 2 + ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. + $ .NOT.LSAME( DIAG , 'N' ) )THEN + INFO = 3 + ELSE IF( N.LT.0 )THEN + INFO = 4 + ELSE IF( INCX.EQ.0 )THEN + INFO = 7 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DTPMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* + NOUNIT = LSAME( DIAG, 'N' ) +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF( INCX.LE.0 )THEN + KX = 1 - ( N - 1 )*INCX + ELSE IF( INCX.NE.1 )THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of AP are +* accessed sequentially with one pass through AP. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* Form x:= A*x. +* + IF( LSAME( UPLO, 'U' ) )THEN + KK =1 + IF( INCX.EQ.1 )THEN + DO 20, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = X( J ) + K = KK + DO 10, I = 1, J - 1 + X( I ) = X( I ) + TEMP*AP( K ) + K = K + 1 + 10 CONTINUE + IF( NOUNIT ) + $ X( J ) = X( J )*AP( KK + J - 1 ) + END IF + KK = KK + J + 20 CONTINUE + ELSE + JX = KX + DO 40, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = X( JX ) + IX = KX + DO 30, K = KK, KK + J - 2 + X( IX ) = X( IX ) + TEMP*AP( K ) + IX = IX + INCX + 30 CONTINUE + IF( NOUNIT ) + $ X( JX ) = X( JX )*AP( KK + J - 1 ) + END IF + JX = JX + INCX + KK = KK + J + 40 CONTINUE + END IF + ELSE + KK = ( N*( N + 1 ) )/2 + IF( INCX.EQ.1 )THEN + DO 60, J = N, 1, -1 + IF( X( J ).NE.ZERO )THEN + TEMP = X( J ) + K = KK + DO 50, I = N, J + 1, -1 + X( I ) = X( I ) + TEMP*AP( K ) + K = K - 1 + 50 CONTINUE + IF( NOUNIT ) + $ X( J ) = X( J )*AP( KK - N + J ) + END IF + KK = KK - ( N - J + 1 ) + 60 CONTINUE + ELSE + KX = KX + ( N - 1 )*INCX + JX = KX + DO 80, J = N, 1, -1 + IF( X( JX ).NE.ZERO )THEN + TEMP = X( JX ) + IX = KX + DO 70, K = KK, KK - ( N - ( J + 1 ) ), -1 + X( IX ) = X( IX ) + TEMP*AP( K ) + IX = IX - INCX + 70 CONTINUE + IF( NOUNIT ) + $ X( JX ) = X( JX )*AP( KK - N + J ) + END IF + JX = JX - INCX + KK = KK - ( N - J + 1 ) + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A'*x. +* + IF( LSAME( UPLO, 'U' ) )THEN + KK = ( N*( N + 1 ) )/2 + IF( INCX.EQ.1 )THEN + DO 100, J = N, 1, -1 + TEMP = X( J ) + IF( NOUNIT ) + $ TEMP = TEMP*AP( KK ) + K = KK - 1 + DO 90, I = J - 1, 1, -1 + TEMP = TEMP + AP( K )*X( I ) + K = K - 1 + 90 CONTINUE + X( J ) = TEMP + KK = KK - J + 100 CONTINUE + ELSE + JX = KX + ( N - 1 )*INCX + DO 120, J = N, 1, -1 + TEMP = X( JX ) + IX = JX + IF( NOUNIT ) + $ TEMP = TEMP*AP( KK ) + DO 110, K = KK - 1, KK - J + 1, -1 + IX = IX - INCX + TEMP = TEMP + AP( K )*X( IX ) + 110 CONTINUE + X( JX ) = TEMP + JX = JX - INCX + KK = KK - J + 120 CONTINUE + END IF + ELSE + KK = 1 + IF( INCX.EQ.1 )THEN + DO 140, J = 1, N + TEMP = X( J ) + IF( NOUNIT ) + $ TEMP = TEMP*AP( KK ) + K = KK + 1 + DO 130, I = J + 1, N + TEMP = TEMP + AP( K )*X( I ) + K = K + 1 + 130 CONTINUE + X( J ) = TEMP + KK = KK + ( N - J + 1 ) + 140 CONTINUE + ELSE + JX = KX + DO 160, J = 1, N + TEMP = X( JX ) + IX = JX + IF( NOUNIT ) + $ TEMP = TEMP*AP( KK ) + DO 150, K = KK + 1, KK + N - J + IX = IX + INCX + TEMP = TEMP + AP( K )*X( IX ) + 150 CONTINUE + X( JX ) = TEMP + JX = JX + INCX + KK = KK + ( N - J + 1 ) + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTPMV . +* + END + SUBROUTINE DTPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX ) +* +************************************************************************ +* +* .. Scalar Arguments .. + INTEGER INCX, N + CHARACTER*1 DIAG, TRANS, UPLO +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), X( * ) +* .. +* +* Purpose +* ======= +* +* DTPSV solves one of the systems of equations +* +* A*x = b, or A'*x = b, +* +* where b and x are n element vectors and A is an n by n unit, or +* non-unit, upper or lower triangular matrix, supplied in packed form. +* +* No test for singularity or near-singularity is included in this +* routine. Such tests must be performed before calling this routine. +* +* Parameters +* ========== +* +* UPLO - CHARACTER*1. +* On entry, UPLO specifies whether the matrix is an upper or +* lower triangular matrix as follows: +* +* UPLO = 'U' or 'u' A is an upper triangular matrix. +* +* UPLO = 'L' or 'l' A is a lower triangular matrix. +* +* Unchanged on exit. +* +* TRANS - CHARACTER*1. +* On entry, TRANS specifies the equations to be solved as +* follows: +* +* TRANS = 'N' or 'n' A*x = b. +* +* TRANS = 'T' or 't' A'*x = b. +* +* TRANS = 'C' or 'c' A'*x = b. +* +* Unchanged on exit. +* +* DIAG - CHARACTER*1. +* On entry, DIAG specifies whether or not A is unit +* triangular as follows: +* +* DIAG = 'U' or 'u' A is assumed to be unit triangular. +* +* DIAG = 'N' or 'n' A is not assumed to be unit +* triangular. +* +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the order of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* AP - DOUBLE PRECISION array of DIMENSION at least +* ( ( n*( n + 1 ) )/2 ). +* Before entry with UPLO = 'U' or 'u', the array AP must +* contain the upper triangular matrix packed sequentially, +* column by column, so that AP( 1 ) contains a( 1, 1 ), +* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) +* respectively, and so on. +* Before entry with UPLO = 'L' or 'l', the array AP must +* contain the lower triangular matrix packed sequentially, +* column by column, so that AP( 1 ) contains a( 1, 1 ), +* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) +* respectively, and so on. +* Note that when DIAG = 'U' or 'u', the diagonal elements of +* A are not referenced, but are assumed to be unity. +* Unchanged on exit. +* +* X - DOUBLE PRECISION array of dimension at least +* ( 1 + ( n - 1 )*abs( INCX ) ). +* Before entry, the incremented array X must contain the n +* element right-hand side vector b. On exit, X is overwritten +* with the solution vector x. +* +* INCX - INTEGER. +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* +* -- Written on 22-October-1986. +* Jack Dongarra, Argonne National Lab. +* Jeremy Du Croz, Nag Central Office. +* Sven Hammarling, Nag Central Office. +* Richard Hanson, Sandia National Labs. +* +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, J, JX, K, KK, KX + LOGICAL NOUNIT +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO , 'U' ).AND. + $ .NOT.LSAME( UPLO , 'L' ) )THEN + INFO = 1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. + $ .NOT.LSAME( TRANS, 'T' ).AND. + $ .NOT.LSAME( TRANS, 'C' ) )THEN + INFO = 2 + ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. + $ .NOT.LSAME( DIAG , 'N' ) )THEN + INFO = 3 + ELSE IF( N.LT.0 )THEN + INFO = 4 + ELSE IF( INCX.EQ.0 )THEN + INFO = 7 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DTPSV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* + NOUNIT = LSAME( DIAG, 'N' ) +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF( INCX.LE.0 )THEN + KX = 1 - ( N - 1 )*INCX + ELSE IF( INCX.NE.1 )THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of AP are +* accessed sequentially with one pass through AP. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* Form x := inv( A )*x. +* + IF( LSAME( UPLO, 'U' ) )THEN + KK = ( N*( N + 1 ) )/2 + IF( INCX.EQ.1 )THEN + DO 20, J = N, 1, -1 + IF( X( J ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( J ) = X( J )/AP( KK ) + TEMP = X( J ) + K = KK - 1 + DO 10, I = J - 1, 1, -1 + X( I ) = X( I ) - TEMP*AP( K ) + K = K - 1 + 10 CONTINUE + END IF + KK = KK - J + 20 CONTINUE + ELSE + JX = KX + ( N - 1 )*INCX + DO 40, J = N, 1, -1 + IF( X( JX ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( JX ) = X( JX )/AP( KK ) + TEMP = X( JX ) + IX = JX + DO 30, K = KK - 1, KK - J + 1, -1 + IX = IX - INCX + X( IX ) = X( IX ) - TEMP*AP( K ) + 30 CONTINUE + END IF + JX = JX - INCX + KK = KK - J + 40 CONTINUE + END IF + ELSE + KK = 1 + IF( INCX.EQ.1 )THEN + DO 60, J = 1, N + IF( X( J ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( J ) = X( J )/AP( KK ) + TEMP = X( J ) + K = KK + 1 + DO 50, I = J + 1, N + X( I ) = X( I ) - TEMP*AP( K ) + K = K + 1 + 50 CONTINUE + END IF + KK = KK + ( N - J + 1 ) + 60 CONTINUE + ELSE + JX = KX + DO 80, J = 1, N + IF( X( JX ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( JX ) = X( JX )/AP( KK ) + TEMP = X( JX ) + IX = JX + DO 70, K = KK + 1, KK + N - J + IX = IX + INCX + X( IX ) = X( IX ) - TEMP*AP( K ) + 70 CONTINUE + END IF + JX = JX + INCX + KK = KK + ( N - J + 1 ) + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := inv( A' )*x. +* + IF( LSAME( UPLO, 'U' ) )THEN + KK = 1 + IF( INCX.EQ.1 )THEN + DO 100, J = 1, N + TEMP = X( J ) + K = KK + DO 90, I = 1, J - 1 + TEMP = TEMP - AP( K )*X( I ) + K = K + 1 + 90 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/AP( KK + J - 1 ) + X( J ) = TEMP + KK = KK + J + 100 CONTINUE + ELSE + JX = KX + DO 120, J = 1, N + TEMP = X( JX ) + IX = KX + DO 110, K = KK, KK + J - 2 + TEMP = TEMP - AP( K )*X( IX ) + IX = IX + INCX + 110 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/AP( KK + J - 1 ) + X( JX ) = TEMP + JX = JX + INCX + KK = KK + J + 120 CONTINUE + END IF + ELSE + KK = ( N*( N + 1 ) )/2 + IF( INCX.EQ.1 )THEN + DO 140, J = N, 1, -1 + TEMP = X( J ) + K = KK + DO 130, I = N, J + 1, -1 + TEMP = TEMP - AP( K )*X( I ) + K = K - 1 + 130 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/AP( KK - N + J ) + X( J ) = TEMP + KK = KK - ( N - J + 1 ) + 140 CONTINUE + ELSE + KX = KX + ( N - 1 )*INCX + JX = KX + DO 160, J = N, 1, -1 + TEMP = X( JX ) + IX = KX + DO 150, K = KK, KK - ( N - ( J + 1 ) ), -1 + TEMP = TEMP - AP( K )*X( IX ) + IX = IX - INCX + 150 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/AP( KK - N + J ) + X( JX ) = TEMP + JX = JX - INCX + KK = KK - (N - J + 1 ) + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTPSV . +* + END + SUBROUTINE DTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) +* +************************************************************************ +* +* .. Scalar Arguments .. + INTEGER INCX, LDA, N + CHARACTER*1 DIAG, TRANS, UPLO +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ) +* .. +* +* Purpose +* ======= +* +* DTRSV solves one of the systems of equations +* +* A*x = b, or A'*x = b, +* +* where b and x are n element vectors and A is an n by n unit, or +* non-unit, upper or lower triangular matrix. +* +* No test for singularity or near-singularity is included in this +* routine. Such tests must be performed before calling this routine. +* +* Parameters +* ========== +* +* UPLO - CHARACTER*1. +* On entry, UPLO specifies whether the matrix is an upper or +* lower triangular matrix as follows: +* +* UPLO = 'U' or 'u' A is an upper triangular matrix. +* +* UPLO = 'L' or 'l' A is a lower triangular matrix. +* +* Unchanged on exit. +* +* TRANS - CHARACTER*1. +* On entry, TRANS specifies the equations to be solved as +* follows: +* +* TRANS = 'N' or 'n' A*x = b. +* +* TRANS = 'T' or 't' A'*x = b. +* +* TRANS = 'C' or 'c' A'*x = b. +* +* Unchanged on exit. +* +* DIAG - CHARACTER*1. +* On entry, DIAG specifies whether or not A is unit +* triangular as follows: +* +* DIAG = 'U' or 'u' A is assumed to be unit triangular. +* +* DIAG = 'N' or 'n' A is not assumed to be unit +* triangular. +* +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the order of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). +* Before entry with UPLO = 'U' or 'u', the leading n by n +* upper triangular part of the array A must contain the upper +* triangular matrix and the strictly lower triangular part of +* A is not referenced. +* Before entry with UPLO = 'L' or 'l', the leading n by n +* lower triangular part of the array A must contain the lower +* triangular matrix and the strictly upper triangular part of +* A is not referenced. +* Note that when DIAG = 'U' or 'u', the diagonal elements of +* A are not referenced either, but are assumed to be unity. +* Unchanged on exit. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, n ). +* Unchanged on exit. +* +* X - DOUBLE PRECISION array of dimension at least +* ( 1 + ( n - 1 )*abs( INCX ) ). +* Before entry, the incremented array X must contain the n +* element right-hand side vector b. On exit, X is overwritten +* with the solution vector x. +* +* INCX - INTEGER. +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* +* -- Written on 22-October-1986. +* Jack Dongarra, Argonne National Lab. +* Jeremy Du Croz, Nag Central Office. +* Sven Hammarling, Nag Central Office. +* Richard Hanson, Sandia National Labs. +* +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, J, JX, KX + LOGICAL NOUNIT +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO , 'U' ).AND. + $ .NOT.LSAME( UPLO , 'L' ) )THEN + INFO = 1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. + $ .NOT.LSAME( TRANS, 'T' ).AND. + $ .NOT.LSAME( TRANS, 'C' ) )THEN + INFO = 2 + ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. + $ .NOT.LSAME( DIAG , 'N' ) )THEN + INFO = 3 + ELSE IF( N.LT.0 )THEN + INFO = 4 + ELSE IF( LDA.LT.MAX( 1, N ) )THEN + INFO = 6 + ELSE IF( INCX.EQ.0 )THEN + INFO = 8 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DTRSV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* + NOUNIT = LSAME( DIAG, 'N' ) +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF( INCX.LE.0 )THEN + KX = 1 - ( N - 1 )*INCX + ELSE IF( INCX.NE.1 )THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* Form x := inv( A )*x. +* + IF( LSAME( UPLO, 'U' ) )THEN + IF( INCX.EQ.1 )THEN + DO 20, J = N, 1, -1 + IF( X( J ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( J ) = X( J )/A( J, J ) + TEMP = X( J ) + DO 10, I = J - 1, 1, -1 + X( I ) = X( I ) - TEMP*A( I, J ) + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + JX = KX + ( N - 1 )*INCX + DO 40, J = N, 1, -1 + IF( X( JX ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( JX ) = X( JX )/A( J, J ) + TEMP = X( JX ) + IX = JX + DO 30, I = J - 1, 1, -1 + IX = IX - INCX + X( IX ) = X( IX ) - TEMP*A( I, J ) + 30 CONTINUE + END IF + JX = JX - INCX + 40 CONTINUE + END IF + ELSE + IF( INCX.EQ.1 )THEN + DO 60, J = 1, N + IF( X( J ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( J ) = X( J )/A( J, J ) + TEMP = X( J ) + DO 50, I = J + 1, N + X( I ) = X( I ) - TEMP*A( I, J ) + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + JX = KX + DO 80, J = 1, N + IF( X( JX ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( JX ) = X( JX )/A( J, J ) + TEMP = X( JX ) + IX = JX + DO 70, I = J + 1, N + IX = IX + INCX + X( IX ) = X( IX ) - TEMP*A( I, J ) + 70 CONTINUE + END IF + JX = JX + INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := inv( A' )*x. +* + IF( LSAME( UPLO, 'U' ) )THEN + IF( INCX.EQ.1 )THEN + DO 100, J = 1, N + TEMP = X( J ) + DO 90, I = 1, J - 1 + TEMP = TEMP - A( I, J )*X( I ) + 90 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/A( J, J ) + X( J ) = TEMP + 100 CONTINUE + ELSE + JX = KX + DO 120, J = 1, N + TEMP = X( JX ) + IX = KX + DO 110, I = 1, J - 1 + TEMP = TEMP - A( I, J )*X( IX ) + IX = IX + INCX + 110 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/A( J, J ) + X( JX ) = TEMP + JX = JX + INCX + 120 CONTINUE + END IF + ELSE + IF( INCX.EQ.1 )THEN + DO 140, J = N, 1, -1 + TEMP = X( J ) + DO 130, I = N, J + 1, -1 + TEMP = TEMP - A( I, J )*X( I ) + 130 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/A( J, J ) + X( J ) = TEMP + 140 CONTINUE + ELSE + KX = KX + ( N - 1 )*INCX + JX = KX + DO 160, J = N, 1, -1 + TEMP = X( JX ) + IX = KX + DO 150, I = N, J + 1, -1 + TEMP = TEMP - A( I, J )*X( IX ) + IX = IX - INCX + 150 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/A( J, J ) + X( JX ) = TEMP + JX = JX - INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRSV . +* + END