]> https://gitweb.dealii.org/ - dealii-svn.git/commitdiff
Move into repository, so that it is possible to get these files via CVS. Have to...
authorwolf <wolf@0785d39b-7218-0410-832d-ea1e28bc413d>
Fri, 7 Jun 2002 08:01:48 +0000 (08:01 +0000)
committerwolf <wolf@0785d39b-7218-0410-832d-ea1e28bc413d>
Fri, 7 Jun 2002 08:01:48 +0000 (08:01 +0000)
git-svn-id: https://svn.dealii.org/trunk@6021 0785d39b-7218-0410-832d-ea1e28bc413d

deal.II/contrib/hsl/source/ma27.f [new file with mode: 0644]
deal.II/contrib/hsl/source/ma47.f [new file with mode: 0644]
deal.II/contrib/hsl/source/ma47dep.f [new file with mode: 0644]

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

In the beginning the Universe was created. This has made a lot of people very angry and has been widely regarded as a bad move.

Douglas Adams


Typeset in Trocchi and Trocchi Bold Sans Serif.