From: wolf Date: Fri, 7 Jun 2002 08:02:14 +0000 (+0000) Subject: . X-Git-Url: https://gitweb.dealii.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=520b94891fd20bb1b751b1a523e4168484bdd817;p=dealii-svn.git . git-svn-id: https://svn.dealii.org/trunk@6022 0785d39b-7218-0410-832d-ea1e28bc413d --- diff --git a/deal.II/contrib/hsl/source/ma27.f b/deal.II/contrib/hsl/source/ma27.f deleted file mode 100644 index 19b0ab4104..0000000000 --- a/deal.II/contrib/hsl/source/ma27.f +++ /dev/null @@ -1,2053 +0,0 @@ -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 deleted file mode 100644 index ebe3a41921..0000000000 --- a/deal.II/contrib/hsl/source/ma47.f +++ /dev/null @@ -1,5075 +0,0 @@ -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 deleted file mode 100644 index c9ec6f240b..0000000000 --- a/deal.II/contrib/hsl/source/ma47dep.f +++ /dev/null @@ -1,1725 +0,0 @@ - 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