--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+ 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