*DECK LA05AD
      SUBROUTINE LA05AD (A, IND, NZ, IA, N, IP, IW, W, G, U)
C***BEGIN PROLOGUE  LA05AD
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (LA05AS-S, LA05AD-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM
C     FROM THE C. 1979 AERE HARWELL LIBRARY.  THE NAME OF THE
C     CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING
C     THE FINAL LETTER =D= IN THE NAMES USED HERE.
C     REVISIONS MADE BY R J HANSON, SNLA, AUGUST, 1979.
C     REVISED SEP. 13, 1979.
C
C     ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES
C     IN THE PACKAGE GIVEN HERE.  ANY PRIMARY USAGE OF THE HARWELL
C     SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN
C     THE USER AND AERE-UK.  ANY USAGE OF THE SANDIA WRITTEN CODES
C     DSPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED.
C
C IP(I,1),IP(I,2) POINT TO THE START OF ROW/COL I.
C IW(I,1),IW(I,2) HOLD THE NUMBER OF NON-ZEROS IN ROW/COL I.
C DURING THE MAIN BODY OF THIS SUBROUTINE THE VECTORS IW(.,3),IW(.,5),
C     IW(.,7) ARE USED TO HOLD DOUBLY LINKED LISTS OF ROWS THAT HAVE
C     NOT BEEN PIVOTAL AND HAVE EQUAL NUMBERS OF NON-ZEROS.
C IW(.,4),IW(.,6),IW(.,8) HOLD SIMILAR LISTS FOR THE COLUMNS.
C IW(I,3),IW(I,4) HOLD FIRST ROW/COLUMN TO HAVE I NON-ZEROS
C     OR ZERO IF THERE ARE NONE.
C IW(I,5), IW(I,6) HOLD ROW/COL NUMBER OF ROW/COL PRIOR TO ROW/COL I
C     IN ITS LIST, OR ZERO IF NONE.
C IW(I,7), IW(I,8) HOLD ROW/COL NUMBER OF ROW/COL AFTER ROW/COL I
C     IN ITS LIST, OR ZERO IF NONE.
C FOR ROWS/COLS THAT HAVE BEEN PIVOTAL IW(I,5),IW(I,6) HOLD NEGATION OF
C     POSITION OF ROW/COL I IN THE PIVOTAL ORDERING.
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  D1MACH, LA05ED, MC20AD, XERMSG, XSETUN
C***COMMON BLOCKS    LA05DD
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890605  Added D1MACH to list of DOUBLE PRECISION variables.
C   890605  Corrected references to XERRWV.  (WRB)
C           (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900402  Added TYPE section.  (WRB)
C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
C***END PROLOGUE  LA05AD
      INTEGER IP(N,2)
      INTEGER IND(IA,2), IW(N,8)
      DOUBLE PRECISION A(*), AMAX, AU, AM, D1MACH, EPS, G, U, SMALL,
     *                 W(*)
      LOGICAL FIRST
      CHARACTER*8 XERN0, XERN1, XERN2
C
      COMMON /LA05DD/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL
C EPS IS THE RELATIVE ACCURACY OF FLOATING-POINT COMPUTATION
      SAVE EPS, FIRST
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  LA05AD
      IF (FIRST) THEN
         EPS = 2.0D0 * D1MACH(4)
      ENDIF
      FIRST = .FALSE.
C
C     SET THE OUTPUT UNIT NUMBER FOR THE ERROR PROCESSOR.
C     THE USAGE OF THIS ERROR PROCESSOR IS DOCUMENTED IN THE
C     SANDIA LABS. TECH. REPT. SAND78-1189, BY R E JONES.
      CALL XSETUN(LP)
      IF (U.GT.1.0D0) U = 1.0D0
      IF (U.LT.EPS) U = EPS
      IF (N.LT.1) GO TO 670
      G = 0.
      DO 50 I=1,N
         W(I) = 0.
         DO 40 J=1,5
            IW(I,J) = 0
   40    CONTINUE
   50 CONTINUE
C
C FLUSH OUT SMALL ENTRIES, COUNT ELEMENTS IN ROWS AND COLUMNS
      L = 1
      LENU = NZ
      DO 80 IDUMMY=1,NZ
         IF (L.GT.LENU) GO TO 90
         DO 60 K=L,LENU
            IF (ABS(A(K)).LE.SMALL) GO TO 70
            I = IND(K,1)
            J = IND(K,2)
            G = MAX(ABS(A(K)),G)
            IF (I.LT.1 .OR. I.GT.N) GO TO 680
            IF (J.LT.1 .OR. J.GT.N) GO TO 680
            IW(I,1) = IW(I,1) + 1
            IW(J,2) = IW(J,2) + 1
   60    CONTINUE
         GO TO 90
   70    L = K
         A(L) = A(LENU)
         IND(L,1) = IND(LENU,1)
         IND(L,2) = IND(LENU,2)
         LENU = LENU - 1
   80 CONTINUE
C
   90 LENL = 0
      LROW = LENU
      LCOL = LROW
C MCP IS THE MAXIMUM NUMBER OF COMPRESSES PERMITTED BEFORE AN
C     ERROR RETURN RESULTS.
      MCP = MAX(N/10,20)
      NCP = 0
C CHECK FOR NULL ROW OR COLUMN AND INITIALIZE IP(I,2) TO POINT
C     JUST BEYOND WHERE THE LAST COMPONENT OF COLUMN I OF A WILL
C     BE STORED.
      K = 1
      DO 110 IR=1,N
         K = K + IW(IR,2)
         IP(IR,2) = K
         DO 100 L=1,2
            IF (IW(IR,L).LE.0) GO TO 700
  100    CONTINUE
  110 CONTINUE
C REORDER BY ROWS
C CHECK FOR DOUBLE ENTRIES WHILE USING THE NEWLY CONSTRUCTED
C     ROW FILE TO CONSTRUCT THE COLUMN FILE. NOTE THAT BY PUTTING
C    THE ENTRIES IN BACKWARDS AND DECREASING IP(J,2) EACH TIME IT
C     IS USED WE AUTOMATICALLY LEAVE IT POINTING TO THE FIRST ELEMENT.
      CALL MC20AD(N, LENU, A, IND(1,2), IP, IND(1,1), 0)
      KL = LENU
      DO 130 II=1,N
         IR = N + 1 - II
         KP = IP(IR,1)
         DO 120 K=KP,KL
            J = IND(K,2)
            IF (IW(J,5).EQ.IR) GO TO 660
            IW(J,5) = IR
            KR = IP(J,2) - 1
            IP(J,2) = KR
            IND(KR,1) = IR
  120    CONTINUE
         KL = KP - 1
  130 CONTINUE
C
C SET UP LINKED LISTS OF ROWS AND COLS WITH EQUAL NUMBERS OF NON-ZEROS.
      DO 150 L=1,2
         DO 140 I=1,N
            NZ = IW(I,L)
            IN = IW(NZ,L+2)
            IW(NZ,L+2) = I
            IW(I,L+6) = IN
            IW(I,L+4) = 0
            IF (IN.NE.0) IW(IN,L+4) = I
  140    CONTINUE
  150 CONTINUE
C
C
C START OF MAIN ELIMINATION LOOP.
      DO 590 IPV=1,N
C FIND PIVOT. JCOST IS MARKOWITZ COST OF CHEAPEST PIVOT FOUND SO FAR,
C     WHICH IS IN ROW IPP AND COLUMN JP.
         JCOST = N*N
C LOOP ON LENGTH OF COLUMN TO BE SEARCHED
         DO 240 NZ=1,N
            IF (JCOST.LE.(NZ-1)**2) GO TO 250
            J = IW(NZ,4)
C SEARCH COLUMNS WITH NZ NON-ZEROS.
            DO 190 IDUMMY=1,N
               IF (J.LE.0) GO TO 200
               KP = IP(J,2)
               KL = KP + IW(J,2) - 1
               DO 180 K=KP,KL
                  I = IND(K,1)
                  KCOST = (NZ-1)*(IW(I,1)-1)
                  IF (KCOST.GE.JCOST) GO TO 180
                  IF (NZ.EQ.1) GO TO 170
C FIND LARGEST ELEMENT IN ROW OF POTENTIAL PIVOT.
                  AMAX = 0.
                  K1 = IP(I,1)
                  K2 = IW(I,1) + K1 - 1
                  DO 160 KK=K1,K2
                     AMAX = MAX(AMAX,ABS(A(KK)))
                     IF (IND(KK,2).EQ.J) KJ = KK
  160             CONTINUE
C PERFORM STABILITY TEST.
                  IF (ABS(A(KJ)).LT.AMAX*U) GO TO 180
  170             JCOST = KCOST
                  IPP = I
                  JP = J
                  IF (JCOST.LE.(NZ-1)**2) GO TO 250
  180          CONTINUE
               J = IW(J,8)
  190       CONTINUE
C SEARCH ROWS WITH NZ NON-ZEROS.
  200       I = IW(NZ,3)
            DO 230 IDUMMY=1,N
               IF (I.LE.0) GO TO 240
               AMAX = 0.
               KP = IP(I,1)
               KL = KP + IW(I,1) - 1
C FIND LARGEST ELEMENT IN THE ROW
               DO 210 K=KP,KL
                  AMAX = MAX(ABS(A(K)),AMAX)
  210          CONTINUE
               AU = AMAX*U
               DO 220 K=KP,KL
C PERFORM STABILITY TEST.
                  IF (ABS(A(K)).LT.AU) GO TO 220
                  J = IND(K,2)
                  KCOST = (NZ-1)*(IW(J,2)-1)
                  IF (KCOST.GE.JCOST) GO TO 220
                  JCOST = KCOST
                  IPP = I
                  JP = J
                  IF (JCOST.LE.(NZ-1)**2) GO TO 250
  220          CONTINUE
               I = IW(I,7)
  230       CONTINUE
  240    CONTINUE
C
C PIVOT FOUND.
C REMOVE ROWS AND COLUMNS INVOLVED IN ELIMINATION FROM ORDERING VECTORS.
  250    KP = IP(JP,2)
         KL = IW(JP,2) + KP - 1
         DO 290 L=1,2
            DO 280 K=KP,KL
               I = IND(K,L)
               IL = IW(I,L+4)
               IN = IW(I,L+6)
               IF (IL.EQ.0) GO TO 260
               IW(IL,L+6) = IN
               GO TO 270
  260          NZ = IW(I,L)
               IW(NZ,L+2) = IN
  270          IF (IN.GT.0) IW(IN,L+4) = IL
  280       CONTINUE
            KP = IP(IPP,1)
            KL = KP + IW(IPP,1) - 1
  290    CONTINUE
C STORE PIVOT
         IW(IPP,5) = -IPV
         IW(JP,6) = -IPV
C ELIMINATE PIVOTAL ROW FROM COLUMN FILE AND FIND PIVOT IN ROW FILE.
         DO 320 K=KP,KL
            J = IND(K,2)
            KPC = IP(J,2)
            IW(J,2) = IW(J,2) - 1
            KLC = KPC + IW(J,2)
            DO 300 KC=KPC,KLC
               IF (IPP.EQ.IND(KC,1)) GO TO 310
  300       CONTINUE
  310       IND(KC,1) = IND(KLC,1)
            IND(KLC,1) = 0
            IF (J.EQ.JP) KR = K
  320    CONTINUE
C BRING PIVOT TO FRONT OF PIVOTAL ROW.
         AU = A(KR)
         A(KR) = A(KP)
         A(KP) = AU
         IND(KR,2) = IND(KP,2)
         IND(KP,2) = JP
C
C PERFORM ELIMINATION ITSELF, LOOPING ON NON-ZEROS IN PIVOT COLUMN.
         NZC = IW(JP,2)
         IF (NZC.EQ.0) GO TO 550
         DO 540 NC=1,NZC
            KC = IP(JP,2) + NC - 1
            IR = IND(KC,1)
C SEARCH NON-PIVOT ROW FOR ELEMENT TO BE ELIMINATED.
            KR = IP(IR,1)
            KRL = KR + IW(IR,1) - 1
            DO 330 KNP=KR,KRL
               IF (JP.EQ.IND(KNP,2)) GO TO 340
  330       CONTINUE
C BRING ELEMENT TO BE ELIMINATED TO FRONT OF ITS ROW.
  340       AM = A(KNP)
            A(KNP) = A(KR)
            A(KR) = AM
            IND(KNP,2) = IND(KR,2)
            IND(KR,2) = JP
            AM = -A(KR)/A(KP)
C COMPRESS ROW FILE UNLESS IT IS CERTAIN THAT THERE IS ROOM FOR NEW ROW.
            IF (LROW+IW(IR,1)+IW(IPP,1)+LENL.LE.IA) GO TO 350
            IF (NCP.GE.MCP .OR. LENU+IW(IR,1)+IW(IPP,1)+LENL.GT.IA) GO
     *       TO 710
            CALL LA05ED(A, IND(1,2), IP, N, IW, IA, .TRUE.)
            KP = IP(IPP,1)
            KR = IP(IR,1)
  350       KRL = KR + IW(IR,1) - 1
            KQ = KP + 1
            KPL = KP + IW(IPP,1) - 1
C PLACE PIVOT ROW (EXCLUDING PIVOT ITSELF) IN W.
            IF (KQ.GT.KPL) GO TO 370
            DO 360 K=KQ,KPL
               J = IND(K,2)
               W(J) = A(K)
  360       CONTINUE
  370       IP(IR,1) = LROW + 1
C
C TRANSFER MODIFIED ELEMENTS.
            IND(KR,2) = 0
            KR = KR + 1
            IF (KR.GT.KRL) GO TO 430
            DO 420 KS=KR,KRL
               J = IND(KS,2)
               AU = A(KS) + AM*W(J)
               IND(KS,2) = 0
C IF ELEMENT IS VERY SMALL REMOVE IT FROM U.
               IF (ABS(AU).LE.SMALL) GO TO 380
               G = MAX(G,ABS(AU))
               LROW = LROW + 1
               A(LROW) = AU
               IND(LROW,2) = J
               GO TO 410
  380          LENU = LENU - 1
C REMOVE ELEMENT FROM COL FILE.
               K = IP(J,2)
               KL = K + IW(J,2) - 1
               IW(J,2) = KL - K
               DO 390 KK=K,KL
                  IF (IND(KK,1).EQ.IR) GO TO 400
  390          CONTINUE
  400          IND(KK,1) = IND(KL,1)
               IND(KL,1) = 0
  410          W(J) = 0.
  420       CONTINUE
C
C SCAN PIVOT ROW FOR FILLS.
  430       IF (KQ.GT.KPL) GO TO 520
            DO 510 KS=KQ,KPL
               J = IND(KS,2)
               AU = AM*W(J)
               IF (ABS(AU).LE.SMALL) GO TO 500
               LROW = LROW + 1
               A(LROW) = AU
               IND(LROW,2) = J
               LENU = LENU + 1
C
C CREATE FILL IN COLUMN FILE.
               NZ = IW(J,2)
               K = IP(J,2)
               KL = K + NZ - 1
               IF (NZ .EQ. 0) GO TO 460
C IF POSSIBLE PLACE NEW ELEMENT AT END OF PRESENT ENTRY.
               IF (KL.NE.LCOL) GO TO 440
               IF (LCOL+LENL.GE.IA) GO TO 460
               LCOL = LCOL + 1
               GO TO 450
  440          IF (IND(KL+1,1).NE.0) GO TO 460
  450          IND(KL+1,1) = IR
               GO TO 490
C NEW ENTRY HAS TO BE CREATED.
  460          IF (LCOL+LENL+NZ+1.LT.IA) GO TO 470
C COMPRESS COLUMN FILE IF THERE IS NOT ROOM FOR NEW ENTRY.
               IF (NCP.GE.MCP .OR. LENU+LENL+NZ+1.GE.IA) GO TO 710
               CALL LA05ED(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.)
               K = IP(J,2)
               KL = K + NZ - 1
C TRANSFER OLD ENTRY INTO NEW.
  470          IP(J,2) = LCOL + 1
               IF (KL .LT. K) GO TO 485
               DO 480 KK=K,KL
                  LCOL = LCOL + 1
                  IND(LCOL,1) = IND(KK,1)
                  IND(KK,1) = 0
  480          CONTINUE
  485          CONTINUE
C ADD NEW ELEMENT.
               LCOL = LCOL + 1
               IND(LCOL,1) = IR
  490          G = MAX(G,ABS(AU))
               IW(J,2) = NZ + 1
  500          W(J) = 0.
  510       CONTINUE
  520       IW(IR,1) = LROW + 1 - IP(IR,1)
C
C STORE MULTIPLIER
            IF (LENL+LCOL+1.LE.IA) GO TO 530
C COMPRESS COL FILE IF NECESSARY.
            IF (NCP.GE.MCP) GO TO 710
            CALL LA05ED(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.)
  530       K = IA - LENL
            LENL = LENL + 1
            A(K) = AM
            IND(K,1) = IPP
            IND(K,2) = IR
            LENU = LENU - 1
  540    CONTINUE
C
C INSERT ROWS AND COLUMNS INVOLVED IN ELIMINATION IN LINKED LISTS
C     OF EQUAL NUMBERS OF NON-ZEROS.
  550    K1 = IP(JP,2)
         K2 = IW(JP,2) + K1 - 1
         IW(JP,2) = 0
         DO 580 L=1,2
            IF (K2.LT.K1) GO TO 570
            DO 560 K=K1,K2
               IR = IND(K,L)
               IF (L.EQ.1) IND(K,L) = 0
               NZ = IW(IR,L)
               IF (NZ.LE.0) GO TO 720
               IN = IW(NZ,L+2)
               IW(IR,L+6) = IN
               IW(IR,L+4) = 0
               IW(NZ,L+2) = IR
               IF (IN.NE.0) IW(IN,L+4) = IR
  560       CONTINUE
  570       K1 = IP(IPP,1) + 1
            K2 = IW(IPP,1) + K1 - 2
  580    CONTINUE
  590 CONTINUE
C
C RESET COLUMN FILE TO REFER TO U AND STORE ROW/COL NUMBERS IN
C     PIVOTAL ORDER IN IW(.,3),IW(.,4)
      DO 600 I=1,N
         J = -IW(I,5)
         IW(J,3) = I
         J = -IW(I,6)
         IW(J,4) = I
         IW(I,2) = 0
  600 CONTINUE
      DO 620 I=1,N
         KP = IP(I,1)
         KL = IW(I,1) + KP - 1
         DO 610 K=KP,KL
            J = IND(K,2)
            IW(J,2) = IW(J,2) + 1
  610    CONTINUE
  620 CONTINUE
      K = 1
      DO 630 I=1,N
         K = K + IW(I,2)
         IP(I,2) = K
  630 CONTINUE
      LCOL = K - 1
      DO 650 II=1,N
         I = IW(II,3)
         KP = IP(I,1)
         KL = IW(I,1) + KP - 1
         DO 640 K=KP,KL
            J = IND(K,2)
            KN = IP(J,2) - 1
            IP(J,2) = KN
            IND(KN,1) = I
  640    CONTINUE
  650 CONTINUE
      RETURN
C
C     THE FOLLOWING INSTRUCTIONS IMPLEMENT THE FAILURE EXITS.
C
  660 IF (LP.GT.0) THEN
         WRITE (XERN1, '(I8)') IR
         WRITE (XERN2, '(I8)') J
         CALL XERMSG ('SLATEC', 'LA05AD', 'MORE THAN ONE MATRIX ' //
     *      'ENTRY.  HERE ROW = ' // XERN1 // ' AND COL = ' // XERN2,
     *      -4, 1)
      ENDIF
      G = -4.
      RETURN
C
  670 IF (LP.GT.0) CALL XERMSG ('SLATEC', 'LA05AD',
     *   'THE ORDER OF THE SYSTEM, N, IS NOT POSITIVE.', -1, 1)
      G = -1.0D0
      RETURN
C
  680 IF (LP.GT.0) THEN
         WRITE (XERN0, '(I8)') K
         WRITE (XERN1, '(I8)') I
         WRITE (XERN2, '(I8)') J
         CALL XERMSG ('SLATEC', 'LA05AD', 'ELEMENT K = ' // XERN0 //
     *      ' IS OUT OF BOUNDS.$$HERE ROW = ' // XERN1 //
     *      ' AND COL = ' // XERN2, -3, 1)
      ENDIF
      G = -3.
      RETURN
C
  700 IF (LP.GT.0) THEN
         WRITE (XERN1, '(I8)') L
         CALL XERMSG ('SLATEC', 'LA05AD', 'ROW OR COLUMN HAS NO ' //
     *      'ELEMENTS.  HERE INDEX = ' // XERN1, -2, 1)
      ENDIF
      G = -2.
      RETURN
C
  710 IF (LP.GT.0) CALL XERMSG ('SLATEC', 'LA05AD',
     *   'LENGTHS OF ARRAYS A(*) AND IND(*,2) ARE TOO SMALL.', -7, 1)
      G = -7.
      RETURN
C
  720 IPV = IPV + 1
      IW(IPV,1) = IR
      DO 730 I=1,N
         II = -IW(I,L+4)
         IF (II.GT.0) IW(II,1) = I
  730 CONTINUE
C
      IF (LP.GT.0) THEN
         XERN1 = 'ROWS'
         IF (L.EQ.2) XERN1 = 'COLUMNS'
         CALL XERMSG ('SLATEC', 'LA05AD', 'DEPENDANT ' // XERN1, -5, 1)
C
  740    WRITE (XERN1, '(I8)') IW(I,1)
         XERN2 = ' '
         IF (I+1.LE.IPV) WRITE (XERN2, '(I8)') IW(I+1,1)
         CALL XERMSG ('SLATEC', 'LA05AD',
     *      'DEPENDENT VECTOR INDICES ARE ' // XERN1 // ' AND ' //
     *      XERN2, -5, 1)
         I = I + 2
         IF (I.LE.IPV) GO TO 740
      ENDIF
      G = -5.
      RETURN
      END
*DECK LA05AS
      SUBROUTINE LA05AS (A, IND, NZ, IA, N, IP, IW, W, G, U)
C***BEGIN PROLOGUE  LA05AS
C***SUBSIDIARY
C***PURPOSE  Subsidiary to SPLP
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (LA05AS-S, LA05AD-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM
C     FROM THE C. 1979 AERE HARWELL LIBRARY.  THE NAME OF THE
C     CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING
C     THE FINAL LETTER =S= IN THE NAMES USED HERE.
C     REVISIONS MADE BY R J HANSON, SNLA, AUGUST, 1979.
C     REVISED SEP. 13, 1979.
C
C     ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES
C     IN THE PACKAGE GIVEN HERE.  ANY PRIMARY USAGE OF THE HARWELL
C     SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN
C     THE USER AND AERE-UK.  ANY USAGE OF THE SANDIA WRITTEN CODES
C     SPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED.
C
C IP(I,1),IP(I,2) POINT TO THE START OF ROW/COL I.
C IW(I,1),IW(I,2) HOLD THE NUMBER OF NON-ZEROS IN ROW/COL I.
C DURING THE MAIN BODY OF THIS SUBROUTINE THE VECTORS IW(.,3),IW(.,5),
C     IW(.,7) ARE USED TO HOLD DOUBLY LINKED LISTS OF ROWS THAT HAVE
C     NOT BEEN PIVOTAL AND HAVE EQUAL NUMBERS OF NON-ZEROS.
C IW(.,4),IW(.,6),IW(.,8) HOLD SIMILAR LISTS FOR THE COLUMNS.
C IW(I,3),IW(I,4) HOLD FIRST ROW/COLUMN TO HAVE I NON-ZEROS
C     OR ZERO IF THERE ARE NONE.
C IW(I,5), IW(I,6) HOLD ROW/COL NUMBER OF ROW/COL PRIOR TO ROW/COL I
C     IN ITS LIST, OR ZERO IF NONE.
C IW(I,7), IW(I,8) HOLD ROW/COL NUMBER OF ROW/COL AFTER ROW/COL I
C     IN ITS LIST, OR ZERO IF NONE.
C FOR ROWS/COLS THAT HAVE BEEN PIVOTAL IW(I,5),IW(I,6) HOLD NEGATION OF
C     POSITION OF ROW/COL I IN THE PIVOTAL ORDERING.
C
C***SEE ALSO  SPLP
C***ROUTINES CALLED  LA05ES, MC20AS, R1MACH, XERMSG, XSETUN
C***COMMON BLOCKS    LA05DS
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890605  Corrected references to XERRWV.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900402  Added TYPE section.  (WRB)
C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
C***END PROLOGUE  LA05AS
      INTEGER IP(N,2)
      INTEGER IND(IA,2), IW(N,8)
      REAL A(*), AMAX, AU, AM, G, U, SMALL, W(*)
      LOGICAL FIRST
      CHARACTER*8 XERN0, XERN1, XERN2
C
      COMMON /LA05DS/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL
C EPS IS THE RELATIVE ACCURACY OF FLOATING-POINT COMPUTATION
      SAVE EPS, FIRST
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  LA05AS
      IF (FIRST) THEN
         EPS = 2.0E0 * R1MACH(4)
      ENDIF
      FIRST = .FALSE.
C
C     SET THE OUTPUT UNIT NUMBER FOR THE ERROR PROCESSOR.
C     THE USAGE OF THIS ERROR PROCESSOR IS DOCUMENTED IN THE
C     SANDIA LABS. TECH. REPT. SAND78-1189, BY R E JONES.
      CALL XSETUN(LP)
      IF (U.GT.1.0E0) U = 1.0E0
      IF (U.LT.EPS) U = EPS
      IF (N.LT.1) GO TO 670
      G = 0.
      DO 50 I=1,N
         W(I) = 0.
         DO 40 J=1,5
            IW(I,J) = 0
   40    CONTINUE
   50 CONTINUE
C
C FLUSH OUT SMALL ENTRIES, COUNT ELEMENTS IN ROWS AND COLUMNS
      L = 1
      LENU = NZ
      DO 80 IDUMMY=1,NZ
         IF (L.GT.LENU) GO TO 90
         DO 60 K=L,LENU
            IF (ABS(A(K)).LE.SMALL) GO TO 70
            I = IND(K,1)
            J = IND(K,2)
            G = MAX(ABS(A(K)),G)
            IF (I.LT.1 .OR. I.GT.N) GO TO 680
            IF (J.LT.1 .OR. J.GT.N) GO TO 680
            IW(I,1) = IW(I,1) + 1
            IW(J,2) = IW(J,2) + 1
   60    CONTINUE
         GO TO 90
   70    L = K
         A(L) = A(LENU)
         IND(L,1) = IND(LENU,1)
         IND(L,2) = IND(LENU,2)
         LENU = LENU - 1
   80 CONTINUE
C
   90 LENL = 0
      LROW = LENU
      LCOL = LROW
C MCP IS THE MAXIMUM NUMBER OF COMPRESSES PERMITTED BEFORE AN
C     ERROR RETURN RESULTS.
      MCP = MAX(N/10,20)
      NCP = 0
C CHECK FOR NULL ROW OR COLUMN AND INITIALIZE IP(I,2) TO POINT
C     JUST BEYOND WHERE THE LAST COMPONENT OF COLUMN I OF A WILL
C     BE STORED.
      K = 1
      DO 110 IR=1,N
         K = K + IW(IR,2)
         IP(IR,2) = K
         DO 100 L=1,2
            IF (IW(IR,L).LE.0) GO TO 700
  100    CONTINUE
  110 CONTINUE
C REORDER BY ROWS
C CHECK FOR DOUBLE ENTRIES WHILE USING THE NEWLY CONSTRUCTED
C     ROW FILE TO CONSTRUCT THE COLUMN FILE. NOTE THAT BY PUTTING
C    THE ENTRIES IN BACKWARDS AND DECREASING IP(J,2) EACH TIME IT
C     IS USED WE AUTOMATICALLY LEAVE IT POINTING TO THE FIRST ELEMENT.
      CALL MC20AS(N, LENU, A, IND(1,2), IP, IND(1,1), 0)
      KL = LENU
      DO 130 II=1,N
         IR = N + 1 - II
         KP = IP(IR,1)
         DO 120 K=KP,KL
            J = IND(K,2)
            IF (IW(J,5).EQ.IR) GO TO 660
            IW(J,5) = IR
            KR = IP(J,2) - 1
            IP(J,2) = KR
            IND(KR,1) = IR
  120    CONTINUE
         KL = KP - 1
  130 CONTINUE
C
C SET UP LINKED LISTS OF ROWS AND COLS WITH EQUAL NUMBERS OF NON-ZEROS.
      DO 150 L=1,2
         DO 140 I=1,N
            NZ = IW(I,L)
            IN = IW(NZ,L+2)
            IW(NZ,L+2) = I
            IW(I,L+6) = IN
            IW(I,L+4) = 0
            IF (IN.NE.0) IW(IN,L+4) = I
  140    CONTINUE
  150 CONTINUE
C
C
C START OF MAIN ELIMINATION LOOP.
      DO 590 IPV=1,N
C FIND PIVOT. JCOST IS MARKOWITZ COST OF CHEAPEST PIVOT FOUND SO FAR,
C     WHICH IS IN ROW IPP AND COLUMN JP.
         JCOST = N*N
C LOOP ON LENGTH OF COLUMN TO BE SEARCHED
         DO 240 NZ=1,N
            IF (JCOST.LE.(NZ-1)**2) GO TO 250
            J = IW(NZ,4)
C SEARCH COLUMNS WITH NZ NON-ZEROS.
            DO 190 IDUMMY=1,N
               IF (J.LE.0) GO TO 200
               KP = IP(J,2)
               KL = KP + IW(J,2) - 1
               DO 180 K=KP,KL
                  I = IND(K,1)
                  KCOST = (NZ-1)*(IW(I,1)-1)
                  IF (KCOST.GE.JCOST) GO TO 180
                  IF (NZ.EQ.1) GO TO 170
C FIND LARGEST ELEMENT IN ROW OF POTENTIAL PIVOT.
                  AMAX = 0.
                  K1 = IP(I,1)
                  K2 = IW(I,1) + K1 - 1
                  DO 160 KK=K1,K2
                     AMAX = MAX(AMAX,ABS(A(KK)))
                     IF (IND(KK,2).EQ.J) KJ = KK
  160             CONTINUE
C PERFORM STABILITY TEST.
                  IF (ABS(A(KJ)).LT.AMAX*U) GO TO 180
  170             JCOST = KCOST
                  IPP = I
                  JP = J
                  IF (JCOST.LE.(NZ-1)**2) GO TO 250
  180          CONTINUE
               J = IW(J,8)
  190       CONTINUE
C SEARCH ROWS WITH NZ NON-ZEROS.
  200       I = IW(NZ,3)
            DO 230 IDUMMY=1,N
               IF (I.LE.0) GO TO 240
               AMAX = 0.
               KP = IP(I,1)
               KL = KP + IW(I,1) - 1
C FIND LARGEST ELEMENT IN THE ROW
               DO 210 K=KP,KL
                  AMAX = MAX(ABS(A(K)),AMAX)
  210          CONTINUE
               AU = AMAX*U
               DO 220 K=KP,KL
C PERFORM STABILITY TEST.
                  IF (ABS(A(K)).LT.AU) GO TO 220
                  J = IND(K,2)
                  KCOST = (NZ-1)*(IW(J,2)-1)
                  IF (KCOST.GE.JCOST) GO TO 220
                  JCOST = KCOST
                  IPP = I
                  JP = J
                  IF (JCOST.LE.(NZ-1)**2) GO TO 250
  220          CONTINUE
               I = IW(I,7)
  230       CONTINUE
  240    CONTINUE
C
C PIVOT FOUND.
C REMOVE ROWS AND COLUMNS INVOLVED IN ELIMINATION FROM ORDERING VECTORS.
  250    KP = IP(JP,2)
         KL = IW(JP,2) + KP - 1
         DO 290 L=1,2
            DO 280 K=KP,KL
               I = IND(K,L)
               IL = IW(I,L+4)
               IN = IW(I,L+6)
               IF (IL.EQ.0) GO TO 260
               IW(IL,L+6) = IN
               GO TO 270
  260          NZ = IW(I,L)
               IW(NZ,L+2) = IN
  270          IF (IN.GT.0) IW(IN,L+4) = IL
  280       CONTINUE
            KP = IP(IPP,1)
            KL = KP + IW(IPP,1) - 1
  290    CONTINUE
C STORE PIVOT
         IW(IPP,5) = -IPV
         IW(JP,6) = -IPV
C ELIMINATE PIVOTAL ROW FROM COLUMN FILE AND FIND PIVOT IN ROW FILE.
         DO 320 K=KP,KL
            J = IND(K,2)
            KPC = IP(J,2)
            IW(J,2) = IW(J,2) - 1
            KLC = KPC + IW(J,2)
            DO 300 KC=KPC,KLC
               IF (IPP.EQ.IND(KC,1)) GO TO 310
  300       CONTINUE
  310       IND(KC,1) = IND(KLC,1)
            IND(KLC,1) = 0
            IF (J.EQ.JP) KR = K
  320    CONTINUE
C BRING PIVOT TO FRONT OF PIVOTAL ROW.
         AU = A(KR)
         A(KR) = A(KP)
         A(KP) = AU
         IND(KR,2) = IND(KP,2)
         IND(KP,2) = JP
C
C PERFORM ELIMINATION ITSELF, LOOPING ON NON-ZEROS IN PIVOT COLUMN.
         NZC = IW(JP,2)
         IF (NZC.EQ.0) GO TO 550
         DO 540 NC=1,NZC
            KC = IP(JP,2) + NC - 1
            IR = IND(KC,1)
C SEARCH NON-PIVOT ROW FOR ELEMENT TO BE ELIMINATED.
            KR = IP(IR,1)
            KRL = KR + IW(IR,1) - 1
            DO 330 KNP=KR,KRL
               IF (JP.EQ.IND(KNP,2)) GO TO 340
  330       CONTINUE
C BRING ELEMENT TO BE ELIMINATED TO FRONT OF ITS ROW.
  340       AM = A(KNP)
            A(KNP) = A(KR)
            A(KR) = AM
            IND(KNP,2) = IND(KR,2)
            IND(KR,2) = JP
            AM = -A(KR)/A(KP)
C COMPRESS ROW FILE UNLESS IT IS CERTAIN THAT THERE IS ROOM FOR NEW ROW.
            IF (LROW+IW(IR,1)+IW(IPP,1)+LENL.LE.IA) GO TO 350
            IF (NCP.GE.MCP .OR. LENU+IW(IR,1)+IW(IPP,1)+LENL.GT.IA) GO
     *       TO 710
            CALL LA05ES(A, IND(1,2), IP, N, IW, IA, .TRUE.)
            KP = IP(IPP,1)
            KR = IP(IR,1)
  350       KRL = KR + IW(IR,1) - 1
            KQ = KP + 1
            KPL = KP + IW(IPP,1) - 1
C PLACE PIVOT ROW (EXCLUDING PIVOT ITSELF) IN W.
            IF (KQ.GT.KPL) GO TO 370
            DO 360 K=KQ,KPL
               J = IND(K,2)
               W(J) = A(K)
  360       CONTINUE
  370       IP(IR,1) = LROW + 1
C
C TRANSFER MODIFIED ELEMENTS.
            IND(KR,2) = 0
            KR = KR + 1
            IF (KR.GT.KRL) GO TO 430
            DO 420 KS=KR,KRL
               J = IND(KS,2)
               AU = A(KS) + AM*W(J)
               IND(KS,2) = 0
C IF ELEMENT IS VERY SMALL REMOVE IT FROM U.
               IF (ABS(AU).LE.SMALL) GO TO 380
               G = MAX(G,ABS(AU))
               LROW = LROW + 1
               A(LROW) = AU
               IND(LROW,2) = J
               GO TO 410
  380          LENU = LENU - 1
C REMOVE ELEMENT FROM COL FILE.
               K = IP(J,2)
               KL = K + IW(J,2) - 1
               IW(J,2) = KL - K
               DO 390 KK=K,KL
                  IF (IND(KK,1).EQ.IR) GO TO 400
  390          CONTINUE
  400          IND(KK,1) = IND(KL,1)
               IND(KL,1) = 0
  410          W(J) = 0.
  420       CONTINUE
C
C SCAN PIVOT ROW FOR FILLS.
  430       IF (KQ.GT.KPL) GO TO 520
            DO 510 KS=KQ,KPL
               J = IND(KS,2)
               AU = AM*W(J)
               IF (ABS(AU).LE.SMALL) GO TO 500
               LROW = LROW + 1
               A(LROW) = AU
               IND(LROW,2) = J
               LENU = LENU + 1
C
C CREATE FILL IN COLUMN FILE.
               NZ = IW(J,2)
               K = IP(J,2)
               KL = K + NZ - 1
               IF (NZ .EQ. 0) GO TO 460
C IF POSSIBLE PLACE NEW ELEMENT AT END OF PRESENT ENTRY.
               IF (KL.NE.LCOL) GO TO 440
               IF (LCOL+LENL.GE.IA) GO TO 460
               LCOL = LCOL + 1
               GO TO 450
  440          IF (IND(KL+1,1).NE.0) GO TO 460
  450          IND(KL+1,1) = IR
               GO TO 490
C NEW ENTRY HAS TO BE CREATED.
  460          IF (LCOL+LENL+NZ+1.LT.IA) GO TO 470
C COMPRESS COLUMN FILE IF THERE IS NOT ROOM FOR NEW ENTRY.
               IF (NCP.GE.MCP .OR. LENU+LENL+NZ+1.GE.IA) GO TO 710
               CALL LA05ES(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.)
               K = IP(J,2)
               KL = K + NZ - 1
C TRANSFER OLD ENTRY INTO NEW.
  470          IP(J,2) = LCOL + 1
               IF (KL .LT. K) GO TO 485
               DO 480 KK=K,KL
                  LCOL = LCOL + 1
                  IND(LCOL,1) = IND(KK,1)
                  IND(KK,1) = 0
  480          CONTINUE
  485          CONTINUE
C ADD NEW ELEMENT.
               LCOL = LCOL + 1
               IND(LCOL,1) = IR
  490          G = MAX(G,ABS(AU))
               IW(J,2) = NZ + 1
  500          W(J) = 0.
  510       CONTINUE
  520       IW(IR,1) = LROW + 1 - IP(IR,1)
C
C STORE MULTIPLIER
            IF (LENL+LCOL+1.LE.IA) GO TO 530
C COMPRESS COL FILE IF NECESSARY.
            IF (NCP.GE.MCP) GO TO 710
            CALL LA05ES(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.)
  530       K = IA - LENL
            LENL = LENL + 1
            A(K) = AM
            IND(K,1) = IPP
            IND(K,2) = IR
            LENU = LENU - 1
  540    CONTINUE
C
C INSERT ROWS AND COLUMNS INVOLVED IN ELIMINATION IN LINKED LISTS
C     OF EQUAL NUMBERS OF NON-ZEROS.
  550    K1 = IP(JP,2)
         K2 = IW(JP,2) + K1 - 1
         IW(JP,2) = 0
         DO 580 L=1,2
            IF (K2.LT.K1) GO TO 570
            DO 560 K=K1,K2
               IR = IND(K,L)
               IF (L.EQ.1) IND(K,L) = 0
               NZ = IW(IR,L)
               IF (NZ.LE.0) GO TO 720
               IN = IW(NZ,L+2)
               IW(IR,L+6) = IN
               IW(IR,L+4) = 0
               IW(NZ,L+2) = IR
               IF (IN.NE.0) IW(IN,L+4) = IR
  560       CONTINUE
  570       K1 = IP(IPP,1) + 1
            K2 = IW(IPP,1) + K1 - 2
  580    CONTINUE
  590 CONTINUE
C
C RESET COLUMN FILE TO REFER TO U AND STORE ROW/COL NUMBERS IN
C     PIVOTAL ORDER IN IW(.,3),IW(.,4)
      DO 600 I=1,N
         J = -IW(I,5)
         IW(J,3) = I
         J = -IW(I,6)
         IW(J,4) = I
         IW(I,2) = 0
  600 CONTINUE
      DO 620 I=1,N
         KP = IP(I,1)
         KL = IW(I,1) + KP - 1
         DO 610 K=KP,KL
            J = IND(K,2)
            IW(J,2) = IW(J,2) + 1
  610    CONTINUE
  620 CONTINUE
      K = 1
      DO 630 I=1,N
         K = K + IW(I,2)
         IP(I,2) = K
  630 CONTINUE
      LCOL = K - 1
      DO 650 II=1,N
         I = IW(II,3)
         KP = IP(I,1)
         KL = IW(I,1) + KP - 1
         DO 640 K=KP,KL
            J = IND(K,2)
            KN = IP(J,2) - 1
            IP(J,2) = KN
            IND(KN,1) = I
  640    CONTINUE
  650 CONTINUE
      RETURN
C
C     THE FOLLOWING INSTRUCTIONS IMPLEMENT THE FAILURE EXITS.
C
  660 IF (LP.GT.0) THEN
         WRITE (XERN1, '(I8)') IR
         WRITE (XERN2, '(I8)') J
         CALL XERMSG ('SLATEC', 'LA05AS', 'MORE THAN ONE MATRIX ' //
     *      'ENTRY.  HERE ROW = ' // XERN1 // ' AND COL = ' // XERN2,
     *      -4, 1)
      ENDIF
      G = -4.
      RETURN
C
  670 IF (LP.GT.0) CALL XERMSG ('SLATEC', 'LA05AS',
     *   'THE ORDER OF THE SYSTEM, N, IS NOT POSITIVE.', -1, 1)
      G = -1.0E0
      RETURN
C
  680 IF (LP.GT.0) THEN
         WRITE (XERN0, '(I8)') K
         WRITE (XERN1, '(I8)') I
         WRITE (XERN2, '(I8)') J
         CALL XERMSG ('SLATEC', 'LA05AS', 'ELEMENT K = ' // XERN0 //
     *      ' IS OUT OF BOUNDS.$$HERE ROW = ' // XERN1 //
     *      ' AND COL = ' // XERN2, -3, 1)
      ENDIF
      G = -3.
      RETURN
C
  700 IF (LP.GT.0) THEN
         WRITE (XERN1, '(I8)') L
         CALL XERMSG ('SLATEC', 'LA05AS', 'ROW OR COLUMN HAS NO ' //
     *      'ELEMENTS.  HERE INDEX = ' // XERN1, -2, 1)
      ENDIF
      G = -2.
      RETURN
C
  710 IF (LP.GT.0) CALL XERMSG ('SLATEC', 'LA05AS',
     *   'LENGTHS OF ARRAYS A(*) AND IND(*,2) ARE TOO SMALL.', -7, 1)
      G = -7.
      RETURN
C
  720 IPV = IPV + 1
      IW(IPV,1) = IR
      DO 730 I=1,N
         II = -IW(I,L+4)
         IF (II.GT.0) IW(II,1) = I
  730 CONTINUE
C
      IF (LP.GT.0) THEN
         XERN1 = 'ROWS'
         IF (L.EQ.2) XERN1 = 'COLUMNS'
         CALL XERMSG ('SLATEC', 'LA05AS', 'DEPENDANT ' // XERN1, -5, 1)
C
  740    WRITE (XERN1, '(I8)') IW(I,1)
         XERN2 = ' '
         IF (I+1.LE.IPV) WRITE (XERN2, '(I8)') IW(I+1,1)
         CALL XERMSG ('SLATEC', 'LA05AS',
     *      'DEPENDENT VECTOR INDICES ARE ' // XERN1 // ' AND ' //
     *      XERN2, -5, 1)
         I = I + 2
         IF (I.LE.IPV) GO TO 740
      ENDIF
      G = -5.
      RETURN
      END
*DECK LA05BD
      SUBROUTINE LA05BD (A, IND, IA, N, IP, IW, W, G, B, TRANS)
C***BEGIN PROLOGUE  LA05BD
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (LA05BS-S, LA05BD-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM
C     FROM THE C. 1979 AERE HARWELL LIBRARY.  THE NAME OF THE
C     CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING
C     THE FINAL LETTER =D= IN THE NAMES USED HERE.
C     REVISED SEP. 13, 1979.
C
C     ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES
C     IN THE PACKAGE GIVEN HERE.  ANY PRIMARY USAGE OF THE HARWELL
C     SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN
C     THE USER AND AERE-UK.  ANY USAGE OF THE SANDIA WRITTEN CODES
C     DSPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED.
C
C IP(I,1),IP(I,2) POINT TO START OF ROW/COLUMN I OF U.
C IW(I,1),IW(I,2) ARE LENGTHS OF ROW/COL I OF U.
C IW(.,3),IW(.,4) HOLD ROW/COL NUMBERS IN PIVOTAL ORDER.
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  XERMSG, XSETUN
C***COMMON BLOCKS    LA05DD
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900402  Added TYPE section.  (WRB)
C   920410  Corrected second dimension on IW declaration.  (WRB)
C***END PROLOGUE  LA05BD
      DOUBLE PRECISION A(*), B(*), AM, W(*), G, SMALL
      LOGICAL TRANS
      INTEGER IND(IA,2), IW(N,8)
      INTEGER IP(N,2)
      COMMON /LA05DD/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL
C***FIRST EXECUTABLE STATEMENT  LA05BD
      IF (G.LT.0.D0) GO TO 130
      KLL = IA - LENL + 1
      IF (TRANS) GO TO 80
C
C     MULTIPLY VECTOR BY INVERSE OF L
      IF (LENL.LE.0) GO TO 20
      L1 = IA + 1
      DO 10 KK=1,LENL
         K = L1 - KK
         I = IND(K,1)
         IF (B(I).EQ.0.D0) GO TO 10
         J = IND(K,2)
         B(J) = B(J) + A(K)*B(I)
   10 CONTINUE
   20 DO 30 I=1,N
         W(I) = B(I)
         B(I) = 0.D0
   30 CONTINUE
C
C     MULTIPLY VECTOR BY INVERSE OF U
      N1 = N + 1
      DO 70 II=1,N
         I = N1 - II
         I = IW(I,3)
         AM = W(I)
         KP = IP(I,1)
         IF (KP.GT.0) GO TO 50
         KP = -KP
         IP(I,1) = KP
         NZ = IW(I,1)
         KL = KP - 1 + NZ
         K2 = KP + 1
         DO 40 K=K2,KL
            J = IND(K,2)
            AM = AM - A(K)*B(J)
   40    CONTINUE
   50    IF (AM.EQ.0.) GO TO 70
         J = IND(KP,2)
         B(J) = AM/A(KP)
         KPC = IP(J,2)
         KL = IW(J,2) + KPC - 1
         IF (KL.EQ.KPC) GO TO 70
         K2 = KPC + 1
         DO 60 K=K2,KL
            I = IND(K,1)
            IP(I,1) = -ABS(IP(I,1))
   60    CONTINUE
   70 CONTINUE
      GO TO 140
C
C     MULTIPLY VECTOR BY INVERSE OF TRANSPOSE OF U
   80 DO 90 I=1,N
         W(I) = B(I)
         B(I) = 0.D0
   90 CONTINUE
      DO 110 II=1,N
         I = IW(II,4)
         AM = W(I)
         IF (AM.EQ.0.D0) GO TO 110
         J = IW(II,3)
         KP = IP(J,1)
         AM = AM/A(KP)
         B(J) = AM
         KL = IW(J,1) + KP - 1
         IF (KP.EQ.KL) GO TO 110
         K2 = KP + 1
         DO 100 K=K2,KL
            I = IND(K,2)
            W(I) = W(I) - AM*A(K)
  100    CONTINUE
  110 CONTINUE
C
C     MULTIPLY VECTOR BY INVERSE OF TRANSPOSE OF L
      IF (KLL.GT.IA) RETURN
      DO 120 K=KLL,IA
         J = IND(K,2)
         IF (B(J).EQ.0.D0) GO TO 120
         I = IND(K,1)
         B(I) = B(I) + A(K)*B(J)
  120 CONTINUE
      GO TO 140
C
  130 CALL XSETUN(LP)
      IF (LP .GT. 0) CALL XERMSG ('SLATEC', 'LA05BD',
     +   'EARLIER ENTRY GAVE ERROR RETURN.', -8, 2)
  140 RETURN
      END
*DECK LA05BS
      SUBROUTINE LA05BS (A, IND, IA, N, IP, IW, W, G, B, TRANS)
C***BEGIN PROLOGUE  LA05BS
C***SUBSIDIARY
C***PURPOSE  Subsidiary to SPLP
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (LA05BS-S, LA05BD-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM
C     FROM THE C. 1979 AERE HARWELL LIBRARY.  THE NAME OF THE
C     CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING
C     THE FINAL LETTER =S= IN THE NAMES USED HERE.
C     REVISED SEP. 13, 1979.
C
C     ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES
C     IN THE PACKAGE GIVEN HERE.  ANY PRIMARY USAGE OF THE HARWELL
C     SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN
C     THE USER AND AERE-UK.  ANY USAGE OF THE SANDIA WRITTEN CODES
C     SPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED.
C
C IP(I,1),IP(I,2) POINT TO START OF ROW/COLUMN I OF U.
C IW(I,1),IW(I,2) ARE LENGTHS OF ROW/COL I OF U.
C IW(.,3),IW(.,4) HOLD ROW/COL NUMBERS IN PIVOTAL ORDER.
C
C***SEE ALSO  SPLP
C***ROUTINES CALLED  XERMSG, XSETUN
C***COMMON BLOCKS    LA05DS
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900402  Added TYPE section.  (WRB)
C   920410  Corrected second dimension on IW declaration.  (WRB)
C***END PROLOGUE  LA05BS
      REAL A(IA), B(*), AM, W(*), G, SMALL
      LOGICAL TRANS
      INTEGER IND(IA,2), IW(N,8)
      INTEGER IP(N,2)
      COMMON /LA05DS/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL
C***FIRST EXECUTABLE STATEMENT  LA05BS
      IF (G.LT.0.) GO TO 130
      KLL = IA - LENL + 1
      IF (TRANS) GO TO 80
C
C     MULTIPLY VECTOR BY INVERSE OF L
      IF (LENL.LE.0) GO TO 20
      L1 = IA + 1
      DO 10 KK=1,LENL
         K = L1 - KK
         I = IND(K,1)
         IF (B(I).EQ.0.) GO TO 10
         J = IND(K,2)
         B(J) = B(J) + A(K)*B(I)
   10 CONTINUE
   20 DO 30 I=1,N
         W(I) = B(I)
         B(I) = 0.
   30 CONTINUE
C
C     MULTIPLY VECTOR BY INVERSE OF U
      N1 = N + 1
      DO 70 II=1,N
         I = N1 - II
         I = IW(I,3)
         AM = W(I)
         KP = IP(I,1)
         IF (KP.GT.0) GO TO 50
         KP = -KP
         IP(I,1) = KP
         NZ = IW(I,1)
         KL = KP - 1 + NZ
         K2 = KP + 1
         DO 40 K=K2,KL
            J = IND(K,2)
            AM = AM - A(K)*B(J)
   40    CONTINUE
   50    IF (AM.EQ.0.) GO TO 70
         J = IND(KP,2)
         B(J) = AM/A(KP)
         KPC = IP(J,2)
         KL = IW(J,2) + KPC - 1
         IF (KL.EQ.KPC) GO TO 70
         K2 = KPC + 1
         DO 60 K=K2,KL
            I = IND(K,1)
            IP(I,1) = -ABS(IP(I,1))
   60    CONTINUE
   70 CONTINUE
      GO TO 140
C
C     MULTIPLY VECTOR BY INVERSE OF TRANSPOSE OF U
   80 DO 90 I=1,N
         W(I) = B(I)
         B(I) = 0.
   90 CONTINUE
      DO 110 II=1,N
         I = IW(II,4)
         AM = W(I)
         IF (AM.EQ.0.) GO TO 110
         J = IW(II,3)
         KP = IP(J,1)
         AM = AM/A(KP)
         B(J) = AM
         KL = IW(J,1) + KP - 1
         IF (KP.EQ.KL) GO TO 110
         K2 = KP + 1
         DO 100 K=K2,KL
            I = IND(K,2)
            W(I) = W(I) - AM*A(K)
  100    CONTINUE
  110 CONTINUE
C
C     MULTIPLY VECTOR BY INVERSE OF TRANSPOSE OF L
      IF (KLL.GT.IA) RETURN
      DO 120 K=KLL,IA
         J = IND(K,2)
         IF (B(J).EQ.0.) GO TO 120
         I = IND(K,1)
         B(I) = B(I) + A(K)*B(J)
  120 CONTINUE
      GO TO 140
C
  130 CALL XSETUN(LP)
      IF (LP .GT. 0) CALL XERMSG ('SLATEC', 'LA05BS',
     +   'EARLIER ENTRY GAVE ERROR RETURN.', -8, 2)
  140 RETURN
      END
*DECK LA05CD
      SUBROUTINE LA05CD (A, IND, IA, N, IP, IW, W, G, U, MM)
C***BEGIN PROLOGUE  LA05CD
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (LA05CS-D, LA05CD-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM
C     FROM THE C. 1979 AERE HARWELL LIBRARY.  THE NAME OF THE
C     CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING
C     THE FINAL LETTER =D= IN THE NAMES USED HERE.
C     REVISED SEP. 13, 1979.
C
C     ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES
C     IN THE PACKAGE GIVEN HERE.  ANY PRIMARY USAGE OF THE HARWELL
C     SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN
C     THE USER AND AERE-UK.  ANY USAGE OF THE SANDIA WRITTEN CODES
C     DSPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED.
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  LA05ED, XERMSG, XSETUN
C***COMMON BLOCKS    LA05DD
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900402  Added TYPE section.  (WRB)
C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
C   920410  Corrected second dimension on IW declaration.  (WRB)
C   920422  Changed upper limit on DO from LAST to LAST-1.  (WRB)
C***END PROLOGUE  LA05CD
      DOUBLE PRECISION A(*), G, U, AM, W(*), SMALL, AU
      INTEGER IND(IA,2), IW(N,8)
      INTEGER IP(N,2)
      CHARACTER*8 XERN1
C
      COMMON /LA05DD/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL
C***FIRST EXECUTABLE STATEMENT  LA05CD
      CALL XSETUN(LP)
      IF (G.LT.0.0D0) GO TO 620
      JM = MM
C MCP LIMITS THE VALUE OF NCP PERMITTED BEFORE AN ERROR RETURN RESULTS.
      MCP = NCP + 20
C REMOVE OLD COLUMN
      LENU = LENU - IW(JM,2)
      KP = IP(JM,2)
      IM = IND(KP,1)
      KL = KP + IW(JM,2) - 1
      IW(JM,2) = 0
      DO 30 K=KP,KL
         I = IND(K,1)
         IND(K,1) = 0
         KR = IP(I,1)
         NZ = IW(I,1) - 1
         IW(I,1) = NZ
         KRL = KR + NZ
         DO 10 KM=KR,KRL
            IF (IND(KM,2).EQ.JM) GO TO 20
   10    CONTINUE
   20    A(KM) = A(KRL)
         IND(KM,2) = IND(KRL,2)
         IND(KRL,2) = 0
   30 CONTINUE
C
C INSERT NEW COLUMN
      DO 110 II=1,N
         I = IW(II,3)
         IF (I.EQ.IM) M = II
         IF (ABS(W(I)).LE.SMALL) GO TO 100
         LENU = LENU + 1
         LAST = II
         IF (LCOL+LENL.LT.IA) GO TO 40
C COMPRESS COLUMN FILE IF NECESSARY.
         IF (NCP.GE.MCP .OR. LENL+LENU.GE.IA) GO TO 610
         CALL LA05ED(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.)
   40    LCOL = LCOL + 1
         NZ = IW(JM,2)
         IF (NZ.EQ.0) IP(JM,2) = LCOL
         IW(JM,2) = NZ + 1
         IND(LCOL,1) = I
         NZ = IW(I,1)
         KPL = IP(I,1) + NZ
         IF (KPL.GT.LROW) GO TO 50
         IF (IND(KPL,2).EQ.0) GO TO 90
C NEW ENTRY HAS TO BE CREATED.
   50    IF (LENL+LROW+NZ.LT.IA) GO TO 60
         IF (NCP.GE.MCP .OR. LENL+LENU+NZ.GE.IA) GO TO 610
C COMPRESS ROW FILE IF NECESSARY.
         CALL LA05ED(A, IND(1,2), IP, N, IW, IA, .TRUE.)
   60    KP = IP(I,1)
         IP(I,1) = LROW + 1
         IF (NZ.EQ.0) GO TO 80
         KPL = KP + NZ - 1
         DO 70 K=KP,KPL
            LROW = LROW + 1
            A(LROW) = A(K)
            IND(LROW,2) = IND(K,2)
            IND(K,2) = 0
   70    CONTINUE
   80    LROW = LROW + 1
         KPL = LROW
C PLACE NEW ELEMENT AT END OF ROW.
   90    IW(I,1) = NZ + 1
         A(KPL) = W(I)
         IND(KPL,2) = JM
  100    W(I) = 0.0D0
  110 CONTINUE
      IF (IW(IM,1).EQ.0 .OR. IW(JM,2).EQ.0 .OR. M.GT.LAST) GO TO 590
C
C FIND COLUMN SINGLETONS, OTHER THAN THE SPIKE. NON-SINGLETONS ARE
C     MARKED WITH W(J)=1. ONLY IW(.,3) IS REVISED AND IW(.,4) IS USED
C     FOR WORKSPACE.
      INS = M
      M1 = M
      W(JM) = 1.0D0
      DO 140 II=M,LAST
         I = IW(II,3)
         J = IW(II,4)
         IF (W(J).EQ.0.) GO TO 130
         KP = IP(I,1)
         KL = KP + IW(I,1) - 1
         DO 120 K=KP,KL
            J = IND(K,2)
            W(J) = 1.0D0
  120    CONTINUE
         IW(INS,4) = I
         INS = INS + 1
         GO TO 140
C PLACE SINGLETONS IN NEW POSITION.
  130    IW(M1,3) = I
         M1 = M1 + 1
  140 CONTINUE
C PLACE NON-SINGLETONS IN NEW POSITION.
      IJ = M + 1
      DO 150 II=M1,LAST-1
         IW(II,3) = IW(IJ,4)
         IJ = IJ + 1
  150 CONTINUE
C PLACE SPIKE AT END.
      IW(LAST,3) = IM
C
C FIND ROW SINGLETONS, APART FROM SPIKE ROW. NON-SINGLETONS ARE MARKED
C     WITH W(I)=2. AGAIN ONLY IW(.,3) IS REVISED AND IW(.,4) IS USED
C     FOR WORKSPACE.
      LAST1 = LAST
      JNS = LAST
      W(IM) = 2.0D0
      J = JM
      DO 180 IJ=M1,LAST
         II = LAST + M1 - IJ
         I = IW(II,3)
         IF (W(I).NE.2.0D0) GO TO 170
         K = IP(I,1)
         IF (II.NE.LAST) J = IND(K,2)
         KP = IP(J,2)
         KL = KP + IW(J,2) - 1
         IW(JNS,4) = I
         JNS = JNS - 1
         DO 160 K=KP,KL
            I = IND(K,1)
            W(I) = 2.0D0
  160    CONTINUE
         GO TO 180
  170    IW(LAST1,3) = I
         LAST1 = LAST1 - 1
  180 CONTINUE
      DO 190 II=M1,LAST1
         JNS = JNS + 1
         I = IW(JNS,4)
         W(I) = 3.0D0
         IW(II,3) = I
  190 CONTINUE
C
C DEAL WITH SINGLETON SPIKE COLUMN. NOTE THAT BUMP ROWS ARE MARKED BY
C    W(I)=3.
      DO 230 II=M1,LAST1
         KP = IP(JM,2)
         KL = KP + IW(JM,2) - 1
         IS = 0
         DO 200 K=KP,KL
            L = IND(K,1)
            IF (W(L).NE.3.0D0) GO TO 200
            IF (IS.NE.0) GO TO 240
            I = L
            KNP = K
            IS = 1
  200    CONTINUE
         IF (IS.EQ.0) GO TO 590
C MAKE A(I,JM) A PIVOT.
         IND(KNP,1) = IND(KP,1)
         IND(KP,1) = I
         KP = IP(I,1)
         DO 210 K=KP,IA
            IF (IND(K,2).EQ.JM) GO TO 220
  210    CONTINUE
  220    AM = A(KP)
         A(KP) = A(K)
         A(K) = AM
         IND(K,2) = IND(KP,2)
         IND(KP,2) = JM
         JM = IND(K,2)
         IW(II,4) = I
         W(I) = 2.0D0
  230 CONTINUE
      II = LAST1
      GO TO 260
  240 IN = M1
      DO 250 IJ=II,LAST1
         IW(IJ,4) = IW(IN,3)
         IN = IN + 1
  250 CONTINUE
  260 LAST2 = LAST1 - 1
      IF (M1.EQ.LAST1) GO TO 570
      DO 270 I=M1,LAST2
         IW(I,3) = IW(I,4)
  270 CONTINUE
      M1 = II
      IF (M1.EQ.LAST1) GO TO 570
C
C CLEAR W
      DO 280 I=1,N
         W(I) = 0.0D0
  280 CONTINUE
C
C PERFORM ELIMINATION
      IR = IW(LAST1,3)
      DO 560 II=M1,LAST1
         IPP = IW(II,3)
         KP = IP(IPP,1)
         KR = IP(IR,1)
         JP = IND(KP,2)
         IF (II.EQ.LAST1) JP = JM
C SEARCH NON-PIVOT ROW FOR ELEMENT TO BE ELIMINATED.
C  AND BRING IT TO FRONT OF ITS ROW
         KRL = KR + IW(IR,1) - 1
         DO 290 KNP=KR,KRL
            IF (JP.EQ.IND(KNP,2)) GO TO 300
  290    CONTINUE
         IF (II-LAST1) 560, 590, 560
C BRING ELEMENT TO BE ELIMINATED TO FRONT OF ITS ROW.
  300    AM = A(KNP)
         A(KNP) = A(KR)
         A(KR) = AM
         IND(KNP,2) = IND(KR,2)
         IND(KR,2) = JP
         IF (II.EQ.LAST1) GO TO 310
         IF (ABS(A(KP)).LT.U*ABS(AM)) GO TO 310
         IF (ABS(AM).LT.U*ABS(A(KP))) GO TO 340
         IF (IW(IPP,1).LE.IW(IR,1)) GO TO 340
C PERFORM INTERCHANGE
  310    IW(LAST1,3) = IPP
         IW(II,3) = IR
         IR = IPP
         IPP = IW(II,3)
         K = KR
         KR = KP
         KP = K
         KJ = IP(JP,2)
         DO 320 K=KJ,IA
            IF (IND(K,1).EQ.IPP) GO TO 330
  320    CONTINUE
  330    IND(K,1) = IND(KJ,1)
         IND(KJ,1) = IPP
  340    IF (A(KP).EQ.0.0D0) GO TO 590
         IF (II.EQ.LAST1) GO TO 560
         AM = -A(KR)/A(KP)
C COMPRESS ROW FILE UNLESS IT IS CERTAIN THAT THERE IS ROOM FOR NEW ROW.
         IF (LROW+IW(IR,1)+IW(IPP,1)+LENL.LE.IA) GO TO 350
         IF (NCP.GE.MCP .OR. LENU+IW(IR,1)+IW(IPP,1)+LENL.GT.IA) GO TO
     *    610
         CALL LA05ED(A, IND(1,2), IP, N, IW, IA, .TRUE.)
         KP = IP(IPP,1)
         KR = IP(IR,1)
  350    KRL = KR + IW(IR,1) - 1
         KQ = KP + 1
         KPL = KP + IW(IPP,1) - 1
C PLACE PIVOT ROW (EXCLUDING PIVOT ITSELF) IN W.
         IF (KQ.GT.KPL) GO TO 370
         DO 360 K=KQ,KPL
            J = IND(K,2)
            W(J) = A(K)
  360    CONTINUE
  370    IP(IR,1) = LROW + 1
C
C TRANSFER MODIFIED ELEMENTS.
         IND(KR,2) = 0
         KR = KR + 1
         IF (KR.GT.KRL) GO TO 430
         DO 420 KS=KR,KRL
            J = IND(KS,2)
            AU = A(KS) + AM*W(J)
            IND(KS,2) = 0
C IF ELEMENT IS VERY SMALL REMOVE IT FROM U.
            IF (ABS(AU).LE.SMALL) GO TO 380
            G = MAX(G,ABS(AU))
            LROW = LROW + 1
            A(LROW) = AU
            IND(LROW,2) = J
            GO TO 410
  380       LENU = LENU - 1
C REMOVE ELEMENT FROM COL FILE.
            K = IP(J,2)
            KL = K + IW(J,2) - 1
            IW(J,2) = KL - K
            DO 390 KK=K,KL
               IF (IND(KK,1).EQ.IR) GO TO 400
  390       CONTINUE
  400       IND(KK,1) = IND(KL,1)
            IND(KL,1) = 0
  410       W(J) = 0.0D0
  420    CONTINUE
C
C SCAN PIVOT ROW FOR FILLS.
  430    IF (KQ.GT.KPL) GO TO 520
         DO 510 KS=KQ,KPL
            J = IND(KS,2)
            AU = AM*W(J)
            IF (ABS(AU).LE.SMALL) GO TO 500
            LROW = LROW + 1
            A(LROW) = AU
            IND(LROW,2) = J
            LENU = LENU + 1
C
C CREATE FILL IN COLUMN FILE.
            NZ = IW(J,2)
            K = IP(J,2)
            KL = K + NZ - 1
C IF POSSIBLE PLACE NEW ELEMENT AT END OF PRESENT ENTRY.
            IF (KL.NE.LCOL) GO TO 440
            IF (LCOL+LENL.GE.IA) GO TO 460
            LCOL = LCOL + 1
            GO TO 450
  440       IF (IND(KL+1,1).NE.0) GO TO 460
  450       IND(KL+1,1) = IR
            GO TO 490
C NEW ENTRY HAS TO BE CREATED.
  460       IF (LCOL+LENL+NZ+1.LT.IA) GO TO 470
C COMPRESS COLUMN FILE IF THERE IS NOT ROOM FOR NEW ENTRY.
            IF (NCP.GE.MCP .OR. LENU+LENL+NZ+1.GE.IA) GO TO 610
            CALL LA05ED(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.)
            K = IP(J,2)
            KL = K + NZ - 1
C TRANSFER OLD ENTRY INTO NEW.
  470       IP(J,2) = LCOL + 1
            DO 480 KK=K,KL
               LCOL = LCOL + 1
               IND(LCOL,1) = IND(KK,1)
               IND(KK,1) = 0
  480       CONTINUE
C ADD NEW ELEMENT.
            LCOL = LCOL + 1
            IND(LCOL,1) = IR
  490       G = MAX(G,ABS(AU))
            IW(J,2) = NZ + 1
  500       W(J) = 0.0D0
  510    CONTINUE
  520    IW(IR,1) = LROW + 1 - IP(IR,1)
C
C STORE MULTIPLIER
         IF (LENL+LCOL+1.LE.IA) GO TO 530
C COMPRESS COL FILE IF NECESSARY.
         IF (NCP.GE.MCP) GO TO 610
         CALL LA05ED(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.)
  530    K = IA - LENL
         LENL = LENL + 1
         A(K) = AM
         IND(K,1) = IPP
         IND(K,2) = IR
C CREATE BLANK IN PIVOTAL COLUMN.
         KP = IP(JP,2)
         NZ = IW(JP,2) - 1
         KL = KP + NZ
         DO 540 K=KP,KL
            IF (IND(K,1).EQ.IR) GO TO 550
  540    CONTINUE
  550    IND(K,1) = IND(KL,1)
         IW(JP,2) = NZ
         IND(KL,1) = 0
         LENU = LENU - 1
  560 CONTINUE
C
C CONSTRUCT COLUMN PERMUTATION AND STORE IT IN IW(.,4)
  570 DO 580 II=M,LAST
         I = IW(II,3)
         K = IP(I,1)
         J = IND(K,2)
         IW(II,4) = J
  580 CONTINUE
      RETURN
C
C     THE FOLLOWING INSTRUCTIONS IMPLEMENT THE FAILURE EXITS.
C
  590 IF (LP.GT.0) THEN
         WRITE (XERN1, '(I8)') MM
         CALL XERMSG ('SLATEC', 'LA05CD', 'SINGULAR MATRIX AFTER ' //
     *      'REPLACEMENT OF COLUMN.  INDEX = ' // XERN1, -6, 1)
      ENDIF
      G = -6.0D0
      RETURN
C
  610 IF (LP.GT.0) CALL XERMSG ('SLATEC', 'LA05CD',
     *   'LENGTHS OF ARRAYS A(*) AND IND(*,2) ARE TOO SMALL.', -7, 1)
      G = -7.0D0
      RETURN
C
  620 IF (LP.GT.0) CALL XERMSG ('SLATEC', 'LA05CD',
     *   'EARLIER ENTRY GAVE ERROR RETURN.', -8, 2)
      G = -8.0D0
      RETURN
      END
*DECK LA05CS
      SUBROUTINE LA05CS (A, IND, IA, N, IP, IW, W, G, U, MM)
C***BEGIN PROLOGUE  LA05CS
C***SUBSIDIARY
C***PURPOSE  Subsidiary to SPLP
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (LA05CS-S, LA05CD-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM
C     FROM THE C. 1979 AERE HARWELL LIBRARY.  THE NAME OF THE
C     CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING
C     THE FINAL LETTER =S= IN THE NAMES USED HERE.
C     REVISED SEP. 13, 1979.
C
C     ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES
C     IN THE PACKAGE GIVEN HERE.  ANY PRIMARY USAGE OF THE HARWELL
C     SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN
C     THE USER AND AERE-UK.  ANY USAGE OF THE SANDIA WRITTEN CODES
C     SPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED.
C
C***SEE ALSO  SPLP
C***ROUTINES CALLED  LA05ES, XERMSG, XSETUN
C***COMMON BLOCKS    LA05DS
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890605  Corrected references to XERRWV.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900402  Added TYPE section.  (WRB)
C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
C   920410  Corrected second dimension on IW declaration.  (WRB)
C   920422  Changed upper limit on DO from LAST to LAST-1.  (WRB)
C***END PROLOGUE  LA05CS
      REAL A(*), G, U, AM, W(*), SMALL, AU
      INTEGER IND(IA,2), IW(N,8)
      INTEGER IP(N,2)
      CHARACTER*8 XERN1
C
      COMMON /LA05DS/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL
C***FIRST EXECUTABLE STATEMENT  LA05CS
      CALL XSETUN(LP)
      IF (G.LT.0.0E0) GO TO 620
      JM = MM
C MCP LIMITS THE VALUE OF NCP PERMITTED BEFORE AN ERROR RETURN RESULTS.
      MCP = NCP + 20
C REMOVE OLD COLUMN
      LENU = LENU - IW(JM,2)
      KP = IP(JM,2)
      IM = IND(KP,1)
      KL = KP + IW(JM,2) - 1
      IW(JM,2) = 0
      DO 30 K=KP,KL
         I = IND(K,1)
         IND(K,1) = 0
         KR = IP(I,1)
         NZ = IW(I,1) - 1
         IW(I,1) = NZ
         KRL = KR + NZ
         DO 10 KM=KR,KRL
            IF (IND(KM,2).EQ.JM) GO TO 20
   10    CONTINUE
   20    A(KM) = A(KRL)
         IND(KM,2) = IND(KRL,2)
         IND(KRL,2) = 0
   30 CONTINUE
C
C INSERT NEW COLUMN
      DO 110 II=1,N
         I = IW(II,3)
         IF (I.EQ.IM) M = II
         IF (ABS(W(I)).LE.SMALL) GO TO 100
         LENU = LENU + 1
         LAST = II
         IF (LCOL+LENL.LT.IA) GO TO 40
C COMPRESS COLUMN FILE IF NECESSARY.
         IF (NCP.GE.MCP .OR. LENL+LENU.GE.IA) GO TO 610
         CALL LA05ES(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.)
   40    LCOL = LCOL + 1
         NZ = IW(JM,2)
         IF (NZ.EQ.0) IP(JM,2) = LCOL
         IW(JM,2) = NZ + 1
         IND(LCOL,1) = I
         NZ = IW(I,1)
         KPL = IP(I,1) + NZ
         IF (KPL.GT.LROW) GO TO 50
         IF (IND(KPL,2).EQ.0) GO TO 90
C NEW ENTRY HAS TO BE CREATED.
   50    IF (LENL+LROW+NZ.LT.IA) GO TO 60
         IF (NCP.GE.MCP .OR. LENL+LENU+NZ.GE.IA) GO TO 610
C COMPRESS ROW FILE IF NECESSARY.
         CALL LA05ES(A, IND(1,2), IP, N, IW, IA, .TRUE.)
   60    KP = IP(I,1)
         IP(I,1) = LROW + 1
         IF (NZ.EQ.0) GO TO 80
         KPL = KP + NZ - 1
         DO 70 K=KP,KPL
            LROW = LROW + 1
            A(LROW) = A(K)
            IND(LROW,2) = IND(K,2)
            IND(K,2) = 0
   70    CONTINUE
   80    LROW = LROW + 1
         KPL = LROW
C PLACE NEW ELEMENT AT END OF ROW.
   90    IW(I,1) = NZ + 1
         A(KPL) = W(I)
         IND(KPL,2) = JM
  100    W(I) = 0.0E0
  110 CONTINUE
      IF (IW(IM,1).EQ.0 .OR. IW(JM,2).EQ.0 .OR. M.GT.LAST) GO TO 590
C
C FIND COLUMN SINGLETONS, OTHER THAN THE SPIKE. NON-SINGLETONS ARE
C     MARKED WITH W(J)=1. ONLY IW(.,3) IS REVISED AND IW(.,4) IS USED
C     FOR WORKSPACE.
      INS = M
      M1 = M
      W(JM) = 1.0E0
      DO 140 II=M,LAST
         I = IW(II,3)
         J = IW(II,4)
         IF (W(J).EQ.0.0E0) GO TO 130
         KP = IP(I,1)
         KL = KP + IW(I,1) - 1
         DO 120 K=KP,KL
            J = IND(K,2)
            W(J) = 1.0E0
  120    CONTINUE
         IW(INS,4) = I
         INS = INS + 1
         GO TO 140
C PLACE SINGLETONS IN NEW POSITION.
  130    IW(M1,3) = I
         M1 = M1 + 1
  140 CONTINUE
C PLACE NON-SINGLETONS IN NEW POSITION.
      IJ = M + 1
      DO 150 II=M1,LAST-1
         IW(II,3) = IW(IJ,4)
         IJ = IJ + 1
  150 CONTINUE
C PLACE SPIKE AT END.
      IW(LAST,3) = IM
C
C FIND ROW SINGLETONS, APART FROM SPIKE ROW. NON-SINGLETONS ARE MARKED
C     WITH W(I)=2. AGAIN ONLY IW(.,3) IS REVISED AND IW(.,4) IS USED
C     FOR WORKSPACE.
      LAST1 = LAST
      JNS = LAST
      W(IM) = 2.0E0
      J = JM
      DO 180 IJ=M1,LAST
         II = LAST + M1 - IJ
         I = IW(II,3)
         IF (W(I).NE.2.0E0) GO TO 170
         K = IP(I,1)
         IF (II.NE.LAST) J = IND(K,2)
         KP = IP(J,2)
         KL = KP + IW(J,2) - 1
         IW(JNS,4) = I
         JNS = JNS - 1
         DO 160 K=KP,KL
            I = IND(K,1)
            W(I) = 2.0E0
  160    CONTINUE
         GO TO 180
  170    IW(LAST1,3) = I
         LAST1 = LAST1 - 1
  180 CONTINUE
      DO 190 II=M1,LAST1
         JNS = JNS + 1
         I = IW(JNS,4)
         W(I) = 3.0E0
         IW(II,3) = I
  190 CONTINUE
C
C DEAL WITH SINGLETON SPIKE COLUMN. NOTE THAT BUMP ROWS ARE MARKED BY
C    W(I)=3.0E0
      DO 230 II=M1,LAST1
         KP = IP(JM,2)
         KL = KP + IW(JM,2) - 1
         IS = 0
         DO 200 K=KP,KL
            L = IND(K,1)
            IF (W(L).NE.3.0E0) GO TO 200
            IF (IS.NE.0) GO TO 240
            I = L
            KNP = K
            IS = 1
  200    CONTINUE
         IF (IS.EQ.0) GO TO 590
C MAKE A(I,JM) A PIVOT.
         IND(KNP,1) = IND(KP,1)
         IND(KP,1) = I
         KP = IP(I,1)
         DO 210 K=KP,IA
            IF (IND(K,2).EQ.JM) GO TO 220
  210    CONTINUE
  220    AM = A(KP)
         A(KP) = A(K)
         A(K) = AM
         IND(K,2) = IND(KP,2)
         IND(KP,2) = JM
         JM = IND(K,2)
         IW(II,4) = I
         W(I) = 2.0E0
  230 CONTINUE
      II = LAST1
      GO TO 260
  240 IN = M1
      DO 250 IJ=II,LAST1
         IW(IJ,4) = IW(IN,3)
         IN = IN + 1
  250 CONTINUE
  260 LAST2 = LAST1 - 1
      IF (M1.EQ.LAST1) GO TO 570
      DO 270 I=M1,LAST2
         IW(I,3) = IW(I,4)
  270 CONTINUE
      M1 = II
      IF (M1.EQ.LAST1) GO TO 570
C
C CLEAR W
      DO 280 I=1,N
         W(I) = 0.0E0
  280 CONTINUE
C
C PERFORM ELIMINATION
      IR = IW(LAST1,3)
      DO 560 II=M1,LAST1
         IPP = IW(II,3)
         KP = IP(IPP,1)
         KR = IP(IR,1)
         JP = IND(KP,2)
         IF (II.EQ.LAST1) JP = JM
C SEARCH NON-PIVOT ROW FOR ELEMENT TO BE ELIMINATED.
C  AND BRING IT TO FRONT OF ITS ROW
         KRL = KR + IW(IR,1) - 1
         DO 290 KNP=KR,KRL
            IF (JP.EQ.IND(KNP,2)) GO TO 300
  290    CONTINUE
         IF (II-LAST1) 560, 590, 560
C BRING ELEMENT TO BE ELIMINATED TO FRONT OF ITS ROW.
  300    AM = A(KNP)
         A(KNP) = A(KR)
         A(KR) = AM
         IND(KNP,2) = IND(KR,2)
         IND(KR,2) = JP
         IF (II.EQ.LAST1) GO TO 310
         IF (ABS(A(KP)).LT.U*ABS(AM)) GO TO 310
         IF (ABS(AM).LT.U*ABS(A(KP))) GO TO 340
         IF (IW(IPP,1).LE.IW(IR,1)) GO TO 340
C PERFORM INTERCHANGE
  310    IW(LAST1,3) = IPP
         IW(II,3) = IR
         IR = IPP
         IPP = IW(II,3)
         K = KR
         KR = KP
         KP = K
         KJ = IP(JP,2)
         DO 320 K=KJ,IA
            IF (IND(K,1).EQ.IPP) GO TO 330
  320    CONTINUE
  330    IND(K,1) = IND(KJ,1)
         IND(KJ,1) = IPP
  340    IF (A(KP).EQ.0.0E0) GO TO 590
         IF (II.EQ.LAST1) GO TO 560
         AM = -A(KR)/A(KP)
C COMPRESS ROW FILE UNLESS IT IS CERTAIN THAT THERE IS ROOM FOR NEW ROW.
         IF (LROW+IW(IR,1)+IW(IPP,1)+LENL.LE.IA) GO TO 350
         IF (NCP.GE.MCP .OR. LENU+IW(IR,1)+IW(IPP,1)+LENL.GT.IA) GO TO
     *    610
         CALL LA05ES(A, IND(1,2), IP, N, IW, IA, .TRUE.)
         KP = IP(IPP,1)
         KR = IP(IR,1)
  350    KRL = KR + IW(IR,1) - 1
         KQ = KP + 1
         KPL = KP + IW(IPP,1) - 1
C PLACE PIVOT ROW (EXCLUDING PIVOT ITSELF) IN W.
         IF (KQ.GT.KPL) GO TO 370
         DO 360 K=KQ,KPL
            J = IND(K,2)
            W(J) = A(K)
  360    CONTINUE
  370    IP(IR,1) = LROW + 1
C
C TRANSFER MODIFIED ELEMENTS.
         IND(KR,2) = 0
         KR = KR + 1
         IF (KR.GT.KRL) GO TO 430
         DO 420 KS=KR,KRL
            J = IND(KS,2)
            AU = A(KS) + AM*W(J)
            IND(KS,2) = 0
C IF ELEMENT IS VERY SMALL REMOVE IT FROM U.
            IF (ABS(AU).LE.SMALL) GO TO 380
            G = MAX(G,ABS(AU))
            LROW = LROW + 1
            A(LROW) = AU
            IND(LROW,2) = J
            GO TO 410
  380       LENU = LENU - 1
C REMOVE ELEMENT FROM COL FILE.
            K = IP(J,2)
            KL = K + IW(J,2) - 1
            IW(J,2) = KL - K
            DO 390 KK=K,KL
               IF (IND(KK,1).EQ.IR) GO TO 400
  390       CONTINUE
  400       IND(KK,1) = IND(KL,1)
            IND(KL,1) = 0
  410       W(J) = 0.0E0
  420    CONTINUE
C
C SCAN PIVOT ROW FOR FILLS.
  430    IF (KQ.GT.KPL) GO TO 520
         DO 510 KS=KQ,KPL
            J = IND(KS,2)
            AU = AM*W(J)
            IF (ABS(AU).LE.SMALL) GO TO 500
            LROW = LROW + 1
            A(LROW) = AU
            IND(LROW,2) = J
            LENU = LENU + 1
C
C CREATE FILL IN COLUMN FILE.
            NZ = IW(J,2)
            K = IP(J,2)
            KL = K + NZ - 1
C IF POSSIBLE PLACE NEW ELEMENT AT END OF PRESENT ENTRY.
            IF (KL.NE.LCOL) GO TO 440
            IF (LCOL+LENL.GE.IA) GO TO 460
            LCOL = LCOL + 1
            GO TO 450
  440       IF (IND(KL+1,1).NE.0) GO TO 460
  450       IND(KL+1,1) = IR
            GO TO 490
C NEW ENTRY HAS TO BE CREATED.
  460       IF (LCOL+LENL+NZ+1.LT.IA) GO TO 470
C COMPRESS COLUMN FILE IF THERE IS NOT ROOM FOR NEW ENTRY.
            IF (NCP.GE.MCP .OR. LENU+LENL+NZ+1.GE.IA) GO TO 610
            CALL LA05ES(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.)
            K = IP(J,2)
            KL = K + NZ - 1
C TRANSFER OLD ENTRY INTO NEW.
  470       IP(J,2) = LCOL + 1
            DO 480 KK=K,KL
               LCOL = LCOL + 1
               IND(LCOL,1) = IND(KK,1)
               IND(KK,1) = 0
  480       CONTINUE
C ADD NEW ELEMENT.
            LCOL = LCOL + 1
            IND(LCOL,1) = IR
  490       G = MAX(G,ABS(AU))
            IW(J,2) = NZ + 1
  500       W(J) = 0.0E0
  510    CONTINUE
  520    IW(IR,1) = LROW + 1 - IP(IR,1)
C
C STORE MULTIPLIER
         IF (LENL+LCOL+1.LE.IA) GO TO 530
C COMPRESS COL FILE IF NECESSARY.
         IF (NCP.GE.MCP) GO TO 610
         CALL LA05ES(A, IND, IP(1,2), N, IW(1,2), IA, .FALSE.)
  530    K = IA - LENL
         LENL = LENL + 1
         A(K) = AM
         IND(K,1) = IPP
         IND(K,2) = IR
C CREATE BLANK IN PIVOTAL COLUMN.
         KP = IP(JP,2)
         NZ = IW(JP,2) - 1
         KL = KP + NZ
         DO 540 K=KP,KL
            IF (IND(K,1).EQ.IR) GO TO 550
  540    CONTINUE
  550    IND(K,1) = IND(KL,1)
         IW(JP,2) = NZ
         IND(KL,1) = 0
         LENU = LENU - 1
  560 CONTINUE
C
C CONSTRUCT COLUMN PERMUTATION AND STORE IT IN IW(.,4)
  570 DO 580 II=M,LAST
         I = IW(II,3)
         K = IP(I,1)
         J = IND(K,2)
         IW(II,4) = J
  580 CONTINUE
      RETURN
C
C     THE FOLLOWING INSTRUCTIONS IMPLEMENT THE FAILURE EXITS.
C
  590 IF (LP.GT.0) THEN
         WRITE (XERN1, '(I8)') MM
         CALL XERMSG ('SLATEC', 'LA05CS', 'SINGULAR MATRIX AFTER ' //
     *      'REPLACEMENT OF COLUMN.  INDEX = ' // XERN1, -6, 1)
      ENDIF
      G = -6.0E0
      RETURN
C
  610 IF (LP.GT.0) CALL XERMSG ('SLATEC', 'LA05CS',
     *   'LENGTHS OF ARRAYS A(*) AND IND(*,2) ARE TOO SMALL.', -7, 1)
      G = -7.0E0
      RETURN
C
  620 IF (LP.GT.0) CALL XERMSG ('SLATEC', 'LA05CS',
     *   'EARLIER ENTRY GAVE ERROR RETURN.', -8, 2)
      G = -8.0E0
      RETURN
      END
*DECK LA05ED
      SUBROUTINE LA05ED (A, IRN, IP, N, IW, IA, REALS)
C***BEGIN PROLOGUE  LA05ED
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (LA05ES-S, LA05ED-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM
C     FROM THE C. 1979 AERE HARWELL LIBRARY.  THE NAME OF THE
C     CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING
C     THE FINAL LETTER =D= IN THE NAMES USED HERE.
C     REVISED SEP. 13, 1979.
C
C     ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES
C     IN THE PACKAGE GIVEN HERE.  ANY PRIMARY USAGE OF THE HARWELL
C     SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN
C     THE USER AND AERE-UK.  ANY USAGE OF THE SANDIA WRITTEN CODES
C     DSPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED.
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  (NONE)
C***COMMON BLOCKS    LA05DD
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  LA05ED
      LOGICAL REALS
      DOUBLE PRECISION A(*),SMALL
      INTEGER IRN(*), IW(*)
      INTEGER IP(*)
      COMMON /LA05DD/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL
C***FIRST EXECUTABLE STATEMENT  LA05ED
      NCP = NCP + 1
C     COMPRESS FILE OF POSITIVE INTEGERS. ENTRY J STARTS AT IRN(IP(J))
C  AND CONTAINS IW(J) INTEGERS,J=1,N. OTHER COMPONENTS OF IRN ARE ZERO.
C  LENGTH OF COMPRESSED FILE PLACED IN LROW IF REALS IS .TRUE. OR LCOL
C  OTHERWISE.
C  IF REALS IS .TRUE. ARRAY A CONTAINS A FILE ASSOCIATED WITH IRN
C  AND THIS IS COMPRESSED TOO.
C  A,IRN,IP,IW,IA ARE INPUT/OUTPUT VARIABLES.
C  N,REALS ARE INPUT/UNCHANGED VARIABLES.
C
      DO 10 J=1,N
C STORE THE LAST ELEMENT OF ENTRY J IN IW(J) THEN OVERWRITE IT BY -J.
         NZ = IW(J)
         IF (NZ.LE.0) GO TO 10
         K = IP(J) + NZ - 1
         IW(J) = IRN(K)
         IRN(K) = -J
   10 CONTINUE
C KN IS THE POSITION OF NEXT ENTRY IN COMPRESSED FILE.
      KN = 0
      IPI = 0
      KL = LCOL
      IF (REALS) KL = LROW
C LOOP THROUGH THE OLD FILE SKIPPING ZERO (DUMMY) ELEMENTS AND
C     MOVING GENUINE ELEMENTS FORWARD. THE ENTRY NUMBER BECOMES
C     KNOWN ONLY WHEN ITS END IS DETECTED BY THE PRESENCE OF A NEGATIVE
C     INTEGER.
      DO 30 K=1,KL
         IF (IRN(K).EQ.0) GO TO 30
         KN = KN + 1
         IF (REALS) A(KN) = A(K)
         IF (IRN(K).GE.0) GO TO 20
C END OF ENTRY. RESTORE IRN(K), SET POINTER TO START OF ENTRY AND
C     STORE CURRENT KN IN IPI READY FOR USE WHEN NEXT LAST ENTRY
C     IS DETECTED.
         J = -IRN(K)
         IRN(K) = IW(J)
         IP(J) = IPI + 1
         IW(J) = KN - IPI
         IPI = KN
   20    IRN(KN) = IRN(K)
   30 CONTINUE
      IF (REALS) LROW = KN
      IF (.NOT.REALS) LCOL = KN
      RETURN
      END
*DECK LA05ES
      SUBROUTINE LA05ES (A, IRN, IP, N, IW, IA, REALS)
C***BEGIN PROLOGUE  LA05ES
C***SUBSIDIARY
C***PURPOSE  Subsidiary to SPLP
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (LA05ES-S, LA05ED-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM
C     FROM THE C. 1979 AERE HARWELL LIBRARY.  THE NAME OF THE
C     CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING
C     THE FINAL LETTER =S= IN THE NAMES USED HERE.
C     REVISED SEP. 13, 1979.
C
C     ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES
C     IN THE PACKAGE GIVEN HERE.  ANY PRIMARY USAGE OF THE HARWELL
C     SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN
C     THE USER AND AERE-UK.  ANY USAGE OF THE SANDIA WRITTEN CODES
C     SPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED.
C
C***SEE ALSO  SPLP
C***ROUTINES CALLED  (NONE)
C***COMMON BLOCKS    LA05DS
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  LA05ES
      LOGICAL REALS
      REAL A(*)
      INTEGER IRN(*), IW(*)
      INTEGER IP(*)
      COMMON /LA05DS/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL
C***FIRST EXECUTABLE STATEMENT  LA05ES
      NCP = NCP + 1
C     COMPRESS FILE OF POSITIVE INTEGERS. ENTRY J STARTS AT IRN(IP(J))
C  AND CONTAINS IW(J) INTEGERS,J=1,N. OTHER COMPONENTS OF IRN ARE ZERO.
C  LENGTH OF COMPRESSED FILE PLACED IN LROW IF REALS IS .TRUE. OR LCOL
C  OTHERWISE.
C  IF REALS IS .TRUE. ARRAY A CONTAINS A REAL FILE ASSOCIATED WITH IRN
C  AND THIS IS COMPRESSED TOO.
C  A,IRN,IP,IW,IA ARE INPUT/OUTPUT VARIABLES.
C  N,REALS ARE INPUT/UNCHANGED VARIABLES.
C
      DO 10 J=1,N
C STORE THE LAST ELEMENT OF ENTRY J IN IW(J) THEN OVERWRITE IT BY -J.
         NZ = IW(J)
         IF (NZ.LE.0) GO TO 10
         K = IP(J) + NZ - 1
         IW(J) = IRN(K)
         IRN(K) = -J
   10 CONTINUE
C KN IS THE POSITION OF NEXT ENTRY IN COMPRESSED FILE.
      KN = 0
      IPI = 0
      KL = LCOL
      IF (REALS) KL = LROW
C LOOP THROUGH THE OLD FILE SKIPPING ZERO (DUMMY) ELEMENTS AND
C     MOVING GENUINE ELEMENTS FORWARD. THE ENTRY NUMBER BECOMES
C     KNOWN ONLY WHEN ITS END IS DETECTED BY THE PRESENCE OF A NEGATIVE
C     INTEGER.
      DO 30 K=1,KL
         IF (IRN(K).EQ.0) GO TO 30
         KN = KN + 1
         IF (REALS) A(KN) = A(K)
         IF (IRN(K).GE.0) GO TO 20
C END OF ENTRY. RESTORE IRN(K), SET POINTER TO START OF ENTRY AND
C     STORE CURRENT KN IN IPI READY FOR USE WHEN NEXT LAST ENTRY
C     IS DETECTED.
         J = -IRN(K)
         IRN(K) = IW(J)
         IP(J) = IPI + 1
         IW(J) = KN - IPI
         IPI = KN
   20    IRN(KN) = IRN(K)
   30 CONTINUE
      IF (REALS) LROW = KN
      IF (.NOT.REALS) LCOL = KN
      RETURN
      END
*DECK LLSIA
      SUBROUTINE LLSIA (A, MDA, M, N, B, MDB, NB, RE, AE, KEY, MODE, NP,
     +   KRANK, KSURE, RNORM, W, LW, IWORK, LIW, INFO)
C***BEGIN PROLOGUE  LLSIA
C***PURPOSE  Solve a linear least squares problems by performing a QR
C            factorization of the matrix using Householder
C            transformations.  Emphasis is put on detecting possible
C            rank deficiency.
C***LIBRARY   SLATEC
C***CATEGORY  D9, D5
C***TYPE      SINGLE PRECISION (LLSIA-S, DLLSIA-D)
C***KEYWORDS  LINEAR LEAST SQUARES, QR FACTORIZATION
C***AUTHOR  Manteuffel, T. A., (LANL)
C***DESCRIPTION
C
C     LLSIA computes the least squares solution(s) to the problem AX=B
C     where A is an M by N matrix with M.GE.N and B is the M by NB
C     matrix of right hand sides.  User input bounds on the uncertainty
C     in the elements of A are used to detect numerical rank deficiency.
C     The algorithm employs a row and column pivot strategy to
C     minimize the growth of uncertainty and round-off errors.
C
C     LLSIA requires (MDA+6)*N + (MDB+1)*NB + M dimensioned space
C
C   ******************************************************************
C   *                                                                *
C   *         WARNING - All input arrays are changed on exit.        *
C   *                                                                *
C   ******************************************************************
C     SUBROUTINE LLSIA(A,MDA,M,N,B,MDB,NB,RE,AE,KEY,MODE,NP,
C    1   KRANK,KSURE,RNORM,W,LW,IWORK,LIW,INFO)
C
C     Input..
C
C     A(,)          Linear coefficient matrix of AX=B, with MDA the
C      MDA,M,N      actual first dimension of A in the calling program.
C                   M is the row dimension (no. of EQUATIONS of the
C                   problem) and N the col dimension (no. of UNKNOWNS).
C                   Must have MDA.GE.M and M.GE.N.
C
C     B(,)          Right hand side(s), with MDB the actual first
C      MDB,NB       dimension of B in the calling program. NB is the
C                   number of M by 1 right hand sides. Must have
C                   MDB.GE.M. If NB = 0, B is never accessed.
C
C   ******************************************************************
C   *                                                                *
C   *         Note - Use of RE and AE are what make this             *
C   *                code significantly different from               *
C   *                other linear least squares solvers.             *
C   *                However, the inexperienced user is              *
C   *                advised to set RE=0.,AE=0.,KEY=0.               *
C   *                                                                *
C   ******************************************************************
C     RE(),AE(),KEY
C     RE()          RE() is a vector of length N such that RE(I) is
C                   the maximum relative uncertainty in column I of
C                   the matrix A. The values of RE() must be between
C                   0 and 1. A minimum of 10*machine precision will
C                   be enforced.
C
C     AE()          AE() is a vector of length N such that AE(I) is
C                   the maximum absolute uncertainty in column I of
C                   the matrix A. The values of AE() must be greater
C                   than or equal to 0.
C
C     KEY           For ease of use, RE and AE may be input as either
C                   vectors or scalars. If a scalar is input, the algo-
C                   rithm will use that value for each column of A.
C                   The parameter key indicates whether scalars or
C                   vectors are being input.
C                        KEY=0     RE scalar  AE scalar
C                        KEY=1     RE vector  AE scalar
C                        KEY=2     RE scalar  AE vector
C                        KEY=3     RE vector  AE vector
C
C     MODE          The integer mode indicates how the routine
C                   is to react if rank deficiency is detected.
C                   If MODE = 0 return immediately, no solution
C                             1 compute truncated solution
C                             2 compute minimal length solution
C                   The inexperienced user is advised to set MODE=0
C
C     NP            The first NP columns of A will not be interchanged
C                   with other columns even though the pivot strategy
C                   would suggest otherwise.
C                   The inexperienced user is advised to set NP=0.
C
C     WORK()        A real work array dimensioned 5*N.  However, if
C                   RE or AE have been specified as vectors, dimension
C                   WORK 4*N. If both RE and AE have been specified
C                   as vectors, dimension WORK 3*N.
C
C     LW            Actual dimension of WORK
C
C     IWORK()       Integer work array dimensioned at least N+M.
C
C     LIW           Actual dimension of IWORK.
C
C     INFO          Is a flag which provides for the efficient
C                   solution of subsequent problems involving the
C                   same A but different B.
C                   If INFO = 0 original call
C                      INFO = 1 subsequent calls
C                   On subsequent calls, the user must supply A, KRANK,
C                   LW, IWORK, LIW, and the first 2*N locations of WORK
C                   as output by the original call to LLSIA. MODE must
C                   be equal to the value of MODE in the original call.
C                   If MODE.LT.2, only the first N locations of WORK
C                   are accessed. AE, RE, KEY, and NP are not accessed.
C
C     Output..
C
C     A(,)          Contains the upper triangular part of the reduced
C                   matrix and the transformation information. It togeth
C                   with the first N elements of WORK (see below)
C                   completely specify the QR factorization of A.
C
C     B(,)          Contains the N by NB solution matrix for X.
C
C     KRANK,KSURE   The numerical rank of A,  based upon the relative
C                   and absolute bounds on uncertainty, is bounded
C                   above by KRANK and below by KSURE. The algorithm
C                   returns a solution based on KRANK. KSURE provides
C                   an indication of the precision of the rank.
C
C     RNORM()       Contains the Euclidean length of the NB residual
C                   vectors  B(I)-AX(I), I=1,NB.
C
C     WORK()        The first N locations of WORK contain values
C                   necessary to reproduce the Householder
C                   transformation.
C
C     IWORK()       The first N locations contain the order in
C                   which the columns of A were used. The next
C                   M locations contain the order in which the
C                   rows of A were used.
C
C     INFO          Flag to indicate status of computation on completion
C                  -1   Parameter error(s)
C                   0 - Rank deficient, no solution
C                   1 - Rank deficient, truncated solution
C                   2 - Rank deficient, minimal length solution
C                   3 - Numerical rank 0, zero solution
C                   4 - Rank .LT. NP
C                   5 - Full rank
C
C***REFERENCES  T. Manteuffel, An interval analysis approach to rank
C                 determination in linear least squares problems,
C                 Report SAND80-0655, Sandia Laboratories, June 1980.
C***ROUTINES CALLED  R1MACH, U11LS, U12LS, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   810801  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   891009  Removed unreferenced variable.  (WRB)
C   891009  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900510  Fixed an error message.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  LLSIA
      DIMENSION A(MDA,*),B(MDB,*),RE(*),AE(*),RNORM(*),W(*)
      INTEGER IWORK(*)
C
C***FIRST EXECUTABLE STATEMENT  LLSIA
      IF(INFO.LT.0 .OR. INFO.GT.1) GO TO 514
      IT=INFO
      INFO=-1
      IF(NB.EQ.0 .AND. IT.EQ.1) GO TO 501
      IF(M.LT.1) GO TO 502
      IF(N.LT.1) GO TO 503
      IF(N.GT.M) GO TO 504
      IF(MDA.LT.M) GO TO 505
      IF(LIW.LT.M+N) GO TO 506
      IF(MODE.LT.0 .OR. MODE.GT.3) GO TO 515
      IF(NB.EQ.0) GO TO 4
      IF(NB.LT.0) GO TO 507
      IF(MDB.LT.M) GO TO 508
      IF(IT.EQ.0) GO TO 4
      GO TO 400
    4 IF(KEY.LT.0.OR.KEY.GT.3) GO TO 509
      IF(KEY.EQ.0 .AND. LW.LT.5*N) GO TO 510
      IF(KEY.EQ.1 .AND. LW.LT.4*N) GO TO 510
      IF(KEY.EQ.2 .AND. LW.LT.4*N) GO TO 510
      IF(KEY.EQ.3 .AND. LW.LT.3*N) GO TO 510
      IF(NP.LT.0 .OR. NP.GT.N) GO TO 516
C
      EPS=10.*R1MACH(4)
      N1=1
      N2=N1+N
      N3=N2+N
      N4=N3+N
      N5=N4+N
C
      IF(KEY.EQ.1) GO TO 100
      IF(KEY.EQ.2) GO TO 200
      IF(KEY.EQ.3) GO TO 300
C
      IF(RE(1).LT.0.0) GO TO 511
      IF(RE(1).GT.1.0) GO TO 512
      IF(RE(1).LT.EPS) RE(1)=EPS
      IF(AE(1).LT.0.0) GO TO 513
      DO 20 I=1,N
      W(N4-1+I)=RE(1)
      W(N5-1+I)=AE(1)
   20 CONTINUE
      CALL U11LS(A,MDA,M,N,W(N4),W(N5),MODE,NP,KRANK,KSURE,
     1            W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2))
      GO TO 400
C
  100 CONTINUE
      IF(AE(1).LT.0.0) GO TO 513
      DO 120 I=1,N
      IF(RE(I).LT.0.0) GO TO 511
      IF(RE(I).GT.1.0) GO TO 512
      IF(RE(I).LT.EPS) RE(I)=EPS
      W(N4-1+I)=AE(1)
  120 CONTINUE
      CALL U11LS(A,MDA,M,N,RE,W(N4),MODE,NP,KRANK,KSURE,
     1            W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2))
      GO TO 400
C
  200 CONTINUE
      IF(RE(1).LT.0.0) GO TO 511
      IF(RE(1).GT.1.0) GO TO 512
      IF(RE(1).LT.EPS) RE(1)=EPS
      DO 220 I=1,N
      W(N4-1+I)=RE(1)
      IF(AE(I).LT.0.0) GO TO 513
  220 CONTINUE
      CALL U11LS(A,MDA,M,N,W(N4),AE,MODE,NP,KRANK,KSURE,
     1            W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2))
      GO TO 400
C
  300 CONTINUE
      DO 320 I=1,N
      IF(RE(I).LT.0.0) GO TO 511
      IF(RE(I).GT.1.0) GO TO 512
      IF(RE(I).LT.EPS) RE(I)=EPS
      IF(AE(I).LT.0.0) GO TO 513
  320 CONTINUE
      CALL U11LS(A,MDA,M,N,RE,AE,MODE,NP,KRANK,KSURE,
     1            W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2))
C
C     DETERMINE INFO
C
  400 IF(KRANK.NE.N) GO TO 402
          INFO=5
          GO TO 410
  402 IF(KRANK.NE.0) GO TO 404
          INFO=3
          GO TO 410
  404 IF(KRANK.GE.NP) GO TO 406
          INFO=4
          RETURN
  406 INFO=MODE
      IF(MODE.EQ.0) RETURN
  410 IF(NB.EQ.0) RETURN
C
C     SOLUTION PHASE
C
      N1=1
      N2=N1+N
      N3=N2+N
      IF(INFO.EQ.2) GO TO 420
      IF(LW.LT.N2-1) GO TO 510
      CALL U12LS(A,MDA,M,N,B,MDB,NB,MODE,KRANK,
     1            RNORM,W(N1),W(N1),IWORK(N1),IWORK(N2))
      RETURN
C
  420 IF(LW.LT.N3-1) GO TO 510
      CALL U12LS(A,MDA,M,N,B,MDB,NB,MODE,KRANK,
     1            RNORM,W(N1),W(N2),IWORK(N1),IWORK(N2))
      RETURN
C
C     ERROR MESSAGES
C
  501 CALL XERMSG ('SLATEC', 'LLSIA',
     +   'SOLUTION ONLY (INFO=1) BUT NO RIGHT HAND SIDE (NB=0)', 1, 0)
      RETURN
  502 CALL XERMSG ('SLATEC', 'LLSIA', 'M.LT.1', 2, 1)
      RETURN
  503 CALL XERMSG ('SLATEC', 'LLSIA', 'N.LT.1', 2, 1)
      RETURN
  504 CALL XERMSG ('SLATEC', 'LLSIA', 'N.GT.M', 2, 1)
      RETURN
  505 CALL XERMSG ('SLATEC', 'LLSIA', 'MDA.LT.M', 2, 1)
      RETURN
  506 CALL XERMSG ('SLATEC', 'LLSIA', 'LIW.LT.M+N', 2, 1)
      RETURN
  507 CALL XERMSG ('SLATEC', 'LLSIA', 'NB.LT.0', 2, 1)
      RETURN
  508 CALL XERMSG ('SLATEC', 'LLSIA', 'MDB.LT.M', 2, 1)
      RETURN
  509 CALL XERMSG ('SLATEC', 'LLSIA', 'KEY OUT OF RANGE', 2, 1)
      RETURN
  510 CALL XERMSG ('SLATEC', 'LLSIA', 'INSUFFICIENT WORK SPACE', 8, 1)
      INFO=-1
      RETURN
  511 CALL XERMSG ('SLATEC', 'LLSIA', 'RE(I) .LT. 0', 2, 1)
      RETURN
  512 CALL XERMSG ('SLATEC', 'LLSIA', 'RE(I) .GT. 1', 2, 1)
      RETURN
  513 CALL XERMSG ('SLATEC', 'LLSIA', 'AE(I) .LT. 0', 2, 1)
      RETURN
  514 CALL XERMSG ('SLATEC', 'LLSIA', 'INFO OUT OF RANGE', 2, 1)
      RETURN
  515 CALL XERMSG ('SLATEC', 'LLSIA', 'MODE OUT OF RANGE', 2, 1)
      RETURN
  516 CALL XERMSG ('SLATEC', 'LLSIA', 'NP OUT OF RANGE', 2, 1)
      RETURN
      END
*DECK LMPAR
      SUBROUTINE LMPAR (N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR, X,
     +   SIGMA, WA1, WA2)
C***BEGIN PROLOGUE  LMPAR
C***SUBSIDIARY
C***PURPOSE  Subsidiary to SNLS1 and SNLS1E
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (LMPAR-S, DMPAR-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     Given an M by N matrix A, an N by N nonsingular DIAGONAL
C     matrix D, an M-vector B, and a positive number DELTA,
C     the problem is to determine a value for the parameter
C     PAR such that if X solves the system
C
C           A*X = B ,     SQRT(PAR)*D*X = 0 ,
C
C     in the least squares sense, and DXNORM is the Euclidean
C     norm of D*X, then either PAR is zero and
C
C           (DXNORM-DELTA) .LE. 0.1*DELTA ,
C
C     or PAR is positive and
C
C           ABS(DXNORM-DELTA) .LE. 0.1*DELTA .
C
C     This subroutine completes the solution of the problem
C     if it is provided with the necessary information from the
C     QR factorization, with column pivoting, of A. That is, if
C     A*P = Q*R, where P is a permutation matrix, Q has orthogonal
C     columns, and R is an upper triangular matrix with diagonal
C     elements of nonincreasing magnitude, then LMPAR expects
C     the full upper triangle of R, the permutation matrix P,
C     and the first N components of (Q TRANSPOSE)*B. On output
C     LMPAR also provides an upper triangular matrix S such that
C
C            T   T                   T
C           P *(A *A + PAR*D*D)*P = S *S .
C
C     S is employed within LMPAR and may be of separate interest.
C
C     Only a few iterations are generally needed for convergence
C     of the algorithm. If, however, the limit of 10 iterations
C     is reached, then the output PAR will contain the best
C     value obtained so far.
C
C     The subroutine statement is
C
C       SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SIGMA,
C                        WA1,WA2)
C
C     where
C
C       N is a positive integer input variable set to the order of R.
C
C       R is an N by N array. On input the full upper triangle
C         must contain the full upper triangle of the matrix R.
C         On output the full upper triangle is unaltered, and the
C         strict lower triangle contains the strict upper triangle
C         (transposed) of the upper triangular matrix S.
C
C       LDR is a positive integer input variable not less than N
C         which specifies the leading dimension of the array R.
C
C       IPVT is an integer input array of length N which defines the
C         permutation matrix P such that A*P = Q*R. Column J of P
C         is column IPVT(J) of the identity matrix.
C
C       DIAG is an input array of length N which must contain the
C         diagonal elements of the matrix D.
C
C       QTB is an input array of length N which must contain the first
C         N elements of the vector (Q TRANSPOSE)*B.
C
C       DELTA is a positive input variable which specifies an upper
C         bound on the Euclidean norm of D*X.
C
C       PAR is a nonnegative variable. On input PAR contains an
C         initial estimate of the Levenberg-Marquardt parameter.
C         On output PAR contains the final estimate.
C
C       X is an output array of length N which contains the least
C         squares solution of the system A*X = B, SQRT(PAR)*D*X = 0,
C         for the output PAR.
C
C       SIGMA is an output array of length N which contains the
C         diagonal elements of the upper triangular matrix S.
C
C       WA1 and WA2 are work arrays of length N.
C
C***SEE ALSO  SNLS1, SNLS1E
C***ROUTINES CALLED  ENORM, QRSOLV, R1MACH
C***REVISION HISTORY  (YYMMDD)
C   800301  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  LMPAR
      INTEGER N,LDR
      INTEGER IPVT(*)
      REAL DELTA,PAR
      REAL R(LDR,*),DIAG(*),QTB(*),X(*),SIGMA(*),WA1(*),WA2(*)
      INTEGER I,ITER,J,JM1,JP1,K,L,NSING
      REAL DXNORM,DWARF,FP,GNORM,PARC,PARL,PARU,P1,P001,SUM,TEMP,ZERO
      REAL R1MACH,ENORM
      SAVE P1, P001, ZERO
      DATA P1,P001,ZERO /1.0E-1,1.0E-3,0.0E0/
C***FIRST EXECUTABLE STATEMENT  LMPAR
      DWARF = R1MACH(1)
C
C     COMPUTE AND STORE IN X THE GAUSS-NEWTON DIRECTION. IF THE
C     JACOBIAN IS RANK-DEFICIENT, OBTAIN A LEAST SQUARES SOLUTION.
C
      NSING = N
      DO 10 J = 1, N
         WA1(J) = QTB(J)
         IF (R(J,J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1
         IF (NSING .LT. N) WA1(J) = ZERO
   10    CONTINUE
      IF (NSING .LT. 1) GO TO 50
      DO 40 K = 1, NSING
         J = NSING - K + 1
         WA1(J) = WA1(J)/R(J,J)
         TEMP = WA1(J)
         JM1 = J - 1
         IF (JM1 .LT. 1) GO TO 30
         DO 20 I = 1, JM1
            WA1(I) = WA1(I) - R(I,J)*TEMP
   20       CONTINUE
   30    CONTINUE
   40    CONTINUE
   50 CONTINUE
      DO 60 J = 1, N
         L = IPVT(J)
         X(L) = WA1(J)
   60    CONTINUE
C
C     INITIALIZE THE ITERATION COUNTER.
C     EVALUATE THE FUNCTION AT THE ORIGIN, AND TEST
C     FOR ACCEPTANCE OF THE GAUSS-NEWTON DIRECTION.
C
      ITER = 0
      DO 70 J = 1, N
         WA2(J) = DIAG(J)*X(J)
   70    CONTINUE
      DXNORM = ENORM(N,WA2)
      FP = DXNORM - DELTA
      IF (FP .LE. P1*DELTA) GO TO 220
C
C     IF THE JACOBIAN IS NOT RANK DEFICIENT, THE NEWTON
C     STEP PROVIDES A LOWER BOUND, PARL, FOR THE ZERO OF
C     THE FUNCTION. OTHERWISE SET THIS BOUND TO ZERO.
C
      PARL = ZERO
      IF (NSING .LT. N) GO TO 120
      DO 80 J = 1, N
         L = IPVT(J)
         WA1(J) = DIAG(L)*(WA2(L)/DXNORM)
   80    CONTINUE
      DO 110 J = 1, N
         SUM = ZERO
         JM1 = J - 1
         IF (JM1 .LT. 1) GO TO 100
         DO 90 I = 1, JM1
            SUM = SUM + R(I,J)*WA1(I)
   90       CONTINUE
  100    CONTINUE
         WA1(J) = (WA1(J) - SUM)/R(J,J)
  110    CONTINUE
      TEMP = ENORM(N,WA1)
      PARL = ((FP/DELTA)/TEMP)/TEMP
  120 CONTINUE
C
C     CALCULATE AN UPPER BOUND, PARU, FOR THE ZERO OF THE FUNCTION.
C
      DO 140 J = 1, N
         SUM = ZERO
         DO 130 I = 1, J
            SUM = SUM + R(I,J)*QTB(I)
  130       CONTINUE
         L = IPVT(J)
         WA1(J) = SUM/DIAG(L)
  140    CONTINUE
      GNORM = ENORM(N,WA1)
      PARU = GNORM/DELTA
      IF (PARU .EQ. ZERO) PARU = DWARF/MIN(DELTA,P1)
C
C     IF THE INPUT PAR LIES OUTSIDE OF THE INTERVAL (PARL,PARU),
C     SET PAR TO THE CLOSER ENDPOINT.
C
      PAR = MAX(PAR,PARL)
      PAR = MIN(PAR,PARU)
      IF (PAR .EQ. ZERO) PAR = GNORM/DXNORM
C
C     BEGINNING OF AN ITERATION.
C
  150 CONTINUE
         ITER = ITER + 1
C
C        EVALUATE THE FUNCTION AT THE CURRENT VALUE OF PAR.
C
         IF (PAR .EQ. ZERO) PAR = MAX(DWARF,P001*PARU)
         TEMP = SQRT(PAR)
         DO 160 J = 1, N
            WA1(J) = TEMP*DIAG(J)
  160       CONTINUE
         CALL QRSOLV(N,R,LDR,IPVT,WA1,QTB,X,SIGMA,WA2)
         DO 170 J = 1, N
            WA2(J) = DIAG(J)*X(J)
  170       CONTINUE
         DXNORM = ENORM(N,WA2)
         TEMP = FP
         FP = DXNORM - DELTA
C
C        IF THE FUNCTION IS SMALL ENOUGH, ACCEPT THE CURRENT VALUE
C        OF PAR. ALSO TEST FOR THE EXCEPTIONAL CASES WHERE PARL
C        IS ZERO OR THE NUMBER OF ITERATIONS HAS REACHED 10.
C
         IF (ABS(FP) .LE. P1*DELTA
     1       .OR. PARL .EQ. ZERO .AND. FP .LE. TEMP
     2            .AND. TEMP .LT. ZERO .OR. ITER .EQ. 10) GO TO 220
C
C        COMPUTE THE NEWTON CORRECTION.
C
         DO 180 J = 1, N
            L = IPVT(J)
            WA1(J) = DIAG(L)*(WA2(L)/DXNORM)
  180       CONTINUE
         DO 210 J = 1, N
            WA1(J) = WA1(J)/SIGMA(J)
            TEMP = WA1(J)
            JP1 = J + 1
            IF (N .LT. JP1) GO TO 200
            DO 190 I = JP1, N
               WA1(I) = WA1(I) - R(I,J)*TEMP
  190          CONTINUE
  200       CONTINUE
  210       CONTINUE
         TEMP = ENORM(N,WA1)
         PARC = ((FP/DELTA)/TEMP)/TEMP
C
C        DEPENDING ON THE SIGN OF THE FUNCTION, UPDATE PARL OR PARU.
C
         IF (FP .GT. ZERO) PARL = MAX(PARL,PAR)
         IF (FP .LT. ZERO) PARU = MIN(PARU,PAR)
C
C        COMPUTE AN IMPROVED ESTIMATE FOR PAR.
C
         PAR = MAX(PARL,PAR+PARC)
C
C        END OF AN ITERATION.
C
         GO TO 150
  220 CONTINUE
C
C     TERMINATION.
C
      IF (ITER .EQ. 0) PAR = ZERO
      RETURN
C
C     LAST CARD OF SUBROUTINE LMPAR.
C
      END
*DECK LPDP
      SUBROUTINE LPDP (A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS,
     +   IS)
C***BEGIN PROLOGUE  LPDP
C***SUBSIDIARY
C***PURPOSE  Subsidiary to LSEI
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (LPDP-S, DLPDP-D)
C***AUTHOR  Hanson, R. J., (SNLA)
C           Haskell, K. H., (SNLA)
C***DESCRIPTION
C
C     DIMENSION A(MDA,N+1),PRGOPT(*),X(N),WS((M+2)*(N+7)),IS(M+N+1),
C     where N=N1+N2.  This is a slight overestimate for WS(*).
C
C     Determine an N1-vector W, and
C               an N2-vector Z
C     which minimizes the Euclidean length of W
C     subject to G*W+H*Z .GE. Y.
C     This is the least projected distance problem, LPDP.
C     The matrices G and H are of respective
C     dimensions M by N1 and M by N2.
C
C     Called by subprogram LSI( ).
C
C     The matrix
C                (G H Y)
C
C     occupies rows 1,...,M and cols 1,...,N1+N2+1 of A(*,*).
C
C     The solution (W) is returned in X(*).
C                  (Z)
C
C     The value of MODE indicates the status of
C     the computation after returning to the user.
C
C          MODE=1  The solution was successfully obtained.
C
C          MODE=2  The inequalities are inconsistent.
C
C***SEE ALSO  LSEI
C***ROUTINES CALLED  SCOPY, SDOT, SNRM2, SSCAL, WNNLS
C***REVISION HISTORY  (YYMMDD)
C   790701  DATE WRITTEN
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910408  Updated the AUTHOR section.  (WRB)
C***END PROLOGUE  LPDP
C
C     SUBROUTINES CALLED
C
C     WNNLS         SOLVES A NONNEGATIVELY CONSTRAINED LINEAR LEAST
C                   SQUARES PROBLEM WITH LINEAR EQUALITY CONSTRAINTS.
C                   PART OF THIS PACKAGE.
C
C++
C     SDOT,         SUBROUTINES FROM THE BLAS PACKAGE.
C     SSCAL,SNRM2,  SEE TRANS. MATH. SOFT., VOL. 5, NO. 3, P. 308.
C     SCOPY
C
      REAL             A(MDA,*), PRGOPT(*), WS(*), WNORM, X(*)
      INTEGER IS(*)
      REAL             FAC, ONE, RNORM, SC, YNORM, ZERO
      REAL             SDOT, SNRM2
      SAVE ZERO, ONE, FAC
      DATA ZERO, ONE /0.E0,1.E0/, FAC /0.1E0/
C***FIRST EXECUTABLE STATEMENT  LPDP
      N = N1 + N2
      MODE = 1
      IF (.NOT.(M.LE.0)) GO TO 20
      IF (.NOT.(N.GT.0)) GO TO 10
      X(1) = ZERO
      CALL SCOPY(N, X, 0, X, 1)
   10 WNORM = ZERO
      RETURN
   20 NP1 = N + 1
C
C     SCALE NONZERO ROWS OF INEQUALITY MATRIX TO HAVE LENGTH ONE.
      DO 40 I=1,M
        SC = SNRM2(N,A(I,1),MDA)
        IF (.NOT.(SC.NE.ZERO)) GO TO 30
        SC = ONE/SC
        CALL SSCAL(NP1, SC, A(I,1), MDA)
   30   CONTINUE
   40 CONTINUE
C
C     SCALE RT.-SIDE VECTOR TO HAVE LENGTH ONE (OR ZERO).
      YNORM = SNRM2(M,A(1,NP1),1)
      IF (.NOT.(YNORM.NE.ZERO)) GO TO 50
      SC = ONE/YNORM
      CALL SSCAL(M, SC, A(1,NP1), 1)
C
C     SCALE COLS OF MATRIX H.
   50 J = N1 + 1
   60 IF (.NOT.(J.LE.N)) GO TO 70
      SC = SNRM2(M,A(1,J),1)
      IF (SC.NE.ZERO) SC = ONE/SC
      CALL SSCAL(M, SC, A(1,J), 1)
      X(J) = SC
      J = J + 1
      GO TO 60
   70 IF (.NOT.(N1.GT.0)) GO TO 130
C
C     COPY TRANSPOSE OF (H G Y) TO WORK ARRAY WS(*).
      IW = 0
      DO 80 I=1,M
C
C     MOVE COL OF TRANSPOSE OF H INTO WORK ARRAY.
        CALL SCOPY(N2, A(I,N1+1), MDA, WS(IW+1), 1)
        IW = IW + N2
C
C     MOVE COL OF TRANSPOSE OF G INTO WORK ARRAY.
        CALL SCOPY(N1, A(I,1), MDA, WS(IW+1), 1)
        IW = IW + N1
C
C     MOVE COMPONENT OF VECTOR Y INTO WORK ARRAY.
        WS(IW+1) = A(I,NP1)
        IW = IW + 1
   80 CONTINUE
      WS(IW+1) = ZERO
      CALL SCOPY(N, WS(IW+1), 0, WS(IW+1), 1)
      IW = IW + N
      WS(IW+1) = ONE
      IW = IW + 1
C
C     SOLVE EU=F SUBJECT TO (TRANSPOSE OF H)U=0, U.GE.0.  THE
C     MATRIX E = TRANSPOSE OF (G Y), AND THE (N+1)-VECTOR
C     F = TRANSPOSE OF (0,...,0,1).
      IX = IW + 1
      IW = IW + M
C
C     DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF WNNLS( ).
      IS(1) = 0
      IS(2) = 0
      CALL WNNLS(WS, NP1, N2, NP1-N2, M, 0, PRGOPT, WS(IX), RNORM,
     1 MODEW, IS, WS(IW+1))
C
C     COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY W.
      SC = ONE - SDOT(M,A(1,NP1),1,WS(IX),1)
      IF (.NOT.(ONE+FAC*ABS(SC).NE.ONE .AND. RNORM.GT.ZERO)) GO TO 110
      SC = ONE/SC
      DO 90 J=1,N1
        X(J) = SC*SDOT(M,A(1,J),1,WS(IX),1)
   90 CONTINUE
C
C     COMPUTE THE VECTOR Q=Y-GW.  OVERWRITE Y WITH THIS VECTOR.
      DO 100 I=1,M
        A(I,NP1) = A(I,NP1) - SDOT(N1,A(I,1),MDA,X,1)
  100 CONTINUE
      GO TO 120
  110 MODE = 2
      RETURN
  120 CONTINUE
  130 IF (.NOT.(N2.GT.0)) GO TO 180
C
C     COPY TRANSPOSE OF (H Q) TO WORK ARRAY WS(*).
      IW = 0
      DO 140 I=1,M
        CALL SCOPY(N2, A(I,N1+1), MDA, WS(IW+1), 1)
        IW = IW + N2
        WS(IW+1) = A(I,NP1)
        IW = IW + 1
  140 CONTINUE
      WS(IW+1) = ZERO
      CALL SCOPY(N2, WS(IW+1), 0, WS(IW+1), 1)
      IW = IW + N2
      WS(IW+1) = ONE
      IW = IW + 1
      IX = IW + 1
      IW = IW + M
C
C     SOLVE RV=S SUBJECT TO V.GE.0.  THE MATRIX R =(TRANSPOSE
C     OF (H Q)), WHERE Q=Y-GW.  THE (N2+1)-VECTOR S =(TRANSPOSE
C     OF (0,...,0,1)).
C
C     DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF WNNLS( ).
      IS(1) = 0
      IS(2) = 0
      CALL WNNLS(WS, N2+1, 0, N2+1, M, 0, PRGOPT, WS(IX), RNORM, MODEW,
     1 IS, WS(IW+1))
C
C     COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY Z.
      SC = ONE - SDOT(M,A(1,NP1),1,WS(IX),1)
      IF (.NOT.(ONE+FAC*ABS(SC).NE.ONE .AND. RNORM.GT.ZERO)) GO TO 160
      SC = ONE/SC
      DO 150 J=1,N2
        L = N1 + J
        X(L) = SC*SDOT(M,A(1,L),1,WS(IX),1)*X(L)
  150 CONTINUE
      GO TO 170
  160 MODE = 2
      RETURN
  170 CONTINUE
C
C     ACCOUNT FOR SCALING OF RT.-SIDE VECTOR IN SOLUTION.
  180 CALL SSCAL(N, YNORM, X, 1)
      WNORM = SNRM2(N1,X,1)
      RETURN
      END
*DECK LSAME
      LOGICAL FUNCTION LSAME (CA, CB)
C***BEGIN PROLOGUE  LSAME
C***SUBSIDIARY
C***PURPOSE  Test two characters to determine if they are the same
C            letter, except for case.
C***LIBRARY   SLATEC
C***CATEGORY  R, N3
C***TYPE      LOGICAL (LSAME-L)
C***KEYWORDS  CHARACTER COMPARISON, LEVEL 2 BLAS, LEVEL 3 BLAS
C***AUTHOR  Hanson, R., (SNLA)
C           Du Croz, J., (NAG)
C***DESCRIPTION
C
C  LSAME  tests if CA is the same letter as CB regardless of case.
C  CB is assumed to be an upper case letter. LSAME returns .TRUE. if
C  CA is either the same as CB or the equivalent lower case letter.
C
C  N.B. This version of the code is correct for both ASCII and EBCDIC
C       systems.  Installers must modify the routine for other
C       character-codes.
C
C       For CDC systems using 6-12 bit representations, the system-
C       specific code in comments must be activated.
C
C  Parameters
C  ==========
C
C  CA     - CHARACTER*1
C  CB     - CHARACTER*1
C           On entry, CA and CB specify characters to be compared.
C           Unchanged on exit.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   860720  DATE WRITTEN
C   910606  Modified to meet SLATEC prologue standards.  Only comment
C           lines were modified.  (BKS)
C   910607  Modified to handle ASCII and EBCDIC codes.  (WRB)
C   930201  Tests for equality and equivalence combined.  (RWC and WRB)
C***END PROLOGUE  LSAME
C     .. Scalar Arguments ..
      CHARACTER CA*1, CB*1
C     .. Local Scalars ..
      INTEGER IOFF
      LOGICAL FIRST
C     .. Intrinsic Functions ..
      INTRINSIC ICHAR
C     .. Save statement ..
      SAVE FIRST, IOFF
C     .. Data statements ..
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  LSAME
      IF (FIRST) IOFF = ICHAR('a') - ICHAR('A')
C
      FIRST = .FALSE.
C
C     Test if the characters are equal or equivalent.
C
      LSAME = (CA.EQ.CB) .OR. (ICHAR(CA)-IOFF.EQ.ICHAR(CB))
C
      RETURN
C
C  The following comments contain code for CDC systems using 6-12 bit
C  representations.
C
C     .. Parameters ..
C     INTEGER                ICIRFX
C     PARAMETER            ( ICIRFX=62 )
C     .. Scalar Arguments ..
C     CHARACTER*1            CB
C     .. Array Arguments ..
C     CHARACTER*1            CA(*)
C     .. Local Scalars ..
C     INTEGER                IVAL
C     .. Intrinsic Functions ..
C     INTRINSIC              ICHAR, CHAR
C     .. Executable Statements ..
C     INTRINSIC              ICHAR, CHAR
C
C     See if the first character in string CA equals string CB.
C
C     LSAME = CA(1) .EQ. CB .AND. CA(1) .NE. CHAR(ICIRFX)
C
C     IF (LSAME) RETURN
C
C     The characters are not identical. Now check them for equivalence.
C     Look for the 'escape' character, circumflex, followed by the
C     letter.
C
C     IVAL = ICHAR(CA(2))
C     IF (IVAL.GE.ICHAR('A') .AND. IVAL.LE.ICHAR('Z')) THEN
C        LSAME = CA(1) .EQ. CHAR(ICIRFX) .AND. CA(2) .EQ. CB
C     ENDIF
C
C     RETURN
C
C     End of LSAME.
C
      END
*DECK LSEI
      SUBROUTINE LSEI (W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, RNORML,
     +   MODE, WS, IP)
C***BEGIN PROLOGUE  LSEI
C***PURPOSE  Solve a linearly constrained least squares problem with
C            equality and inequality constraints, and optionally compute
C            a covariance matrix.
C***LIBRARY   SLATEC
C***CATEGORY  K1A2A, D9
C***TYPE      SINGLE PRECISION (LSEI-S, DLSEI-D)
C***KEYWORDS  CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING,
C             EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS,
C             QUADRATIC PROGRAMMING
C***AUTHOR  Hanson, R. J., (SNLA)
C           Haskell, K. H., (SNLA)
C***DESCRIPTION
C
C     Abstract
C
C     This subprogram solves a linearly constrained least squares
C     problem with both equality and inequality constraints, and, if the
C     user requests, obtains a covariance matrix of the solution
C     parameters.
C
C     Suppose there are given matrices E, A and G of respective
C     dimensions ME by N, MA by N and MG by N, and vectors F, B and H of
C     respective lengths ME, MA and MG.  This subroutine solves the
C     linearly constrained least squares problem
C
C                   EX = F, (E ME by N) (equations to be exactly
C                                       satisfied)
C                   AX = B, (A MA by N) (equations to be
C                                       approximately satisfied,
C                                       least squares sense)
C                   GX .GE. H,(G MG by N) (inequality constraints)
C
C     The inequalities GX .GE. H mean that every component of the
C     product GX must be .GE. the corresponding component of H.
C
C     In case the equality constraints cannot be satisfied, a
C     generalized inverse solution residual vector length is obtained
C     for F-EX.  This is the minimal length possible for F-EX.
C
C     Any values ME .GE. 0, MA .GE. 0, or MG .GE. 0 are permitted.  The
C     rank of the matrix E is estimated during the computation.  We call
C     this value KRANKE.  It is an output parameter in IP(1) defined
C     below.  Using a generalized inverse solution of EX=F, a reduced
C     least squares problem with inequality constraints is obtained.
C     The tolerances used in these tests for determining the rank
C     of E and the rank of the reduced least squares problem are
C     given in Sandia Tech. Rept. SAND-78-1290.  They can be
C     modified by the user if new values are provided in
C     the option list of the array PRGOPT(*).
C
C     The user must dimension all arrays appearing in the call list..
C     W(MDW,N+1),PRGOPT(*),X(N),WS(2*(ME+N)+K+(MG+2)*(N+7)),IP(MG+2*N+2)
C     where K=MAX(MA+MG,N).  This allows for a solution of a range of
C     problems in the given working space.  The dimension of WS(*)
C     given is a necessary overestimate.  Once a particular problem
C     has been run, the output parameter IP(3) gives the actual
C     dimension required for that problem.
C
C     The parameters for LSEI( ) are
C
C     Input..
C
C     W(*,*),MDW,   The array W(*,*) is doubly subscripted with
C     ME,MA,MG,N    first dimensioning parameter equal to MDW.
C                   For this discussion let us call M = ME+MA+MG.  Then
C                   MDW must satisfy MDW .GE. M.  The condition
C                   MDW .LT. M is an error.
C
C                   The array W(*,*) contains the matrices and vectors
C
C                                  (E  F)
C                                  (A  B)
C                                  (G  H)
C
C                   in rows and columns 1,...,M and 1,...,N+1
C                   respectively.
C
C                   The integers ME, MA, and MG are the
C                   respective matrix row dimensions
C                   of E, A and G.  Each matrix has N columns.
C
C     PRGOPT(*)    This real-valued array is the option vector.
C                  If the user is satisfied with the nominal
C                  subprogram features set
C
C                  PRGOPT(1)=1 (or PRGOPT(1)=1.0)
C
C                  Otherwise PRGOPT(*) is a linked list consisting of
C                  groups of data of the following form
C
C                  LINK
C                  KEY
C                  DATA SET
C
C                  The parameters LINK and KEY are each one word.
C                  The DATA SET can be comprised of several words.
C                  The number of items depends on the value of KEY.
C                  The value of LINK points to the first
C                  entry of the next group of data within
C                  PRGOPT(*).  The exception is when there are
C                  no more options to change.  In that
C                  case, LINK=1 and the values KEY and DATA SET
C                  are not referenced.  The general layout of
C                  PRGOPT(*) is as follows.
C
C               ...PRGOPT(1) = LINK1 (link to first entry of next group)
C               .  PRGOPT(2) = KEY1 (key to the option change)
C               .  PRGOPT(3) = data value (data value for this change)
C               .       .
C               .       .
C               .       .
C               ...PRGOPT(LINK1)   = LINK2 (link to the first entry of
C               .                       next group)
C               .  PRGOPT(LINK1+1) = KEY2 (key to the option change)
C               .  PRGOPT(LINK1+2) = data value
C               ...     .
C               .       .
C               .       .
C               ...PRGOPT(LINK) = 1 (no more options to change)
C
C                  Values of LINK that are nonpositive are errors.
C                  A value of LINK .GT. NLINK=100000 is also an error.
C                  This helps prevent using invalid but positive
C                  values of LINK that will probably extend
C                  beyond the program limits of PRGOPT(*).
C                  Unrecognized values of KEY are ignored.  The
C                  order of the options is arbitrary and any number
C                  of options can be changed with the following
C                  restriction.  To prevent cycling in the
C                  processing of the option array, a count of the
C                  number of options changed is maintained.
C                  Whenever this count exceeds NOPT=1000, an error
C                  message is printed and the subprogram returns.
C
C                  Options..
C
C                  KEY=1
C                         Compute in W(*,*) the N by N
C                  covariance matrix of the solution variables
C                  as an output parameter.  Nominally the
C                  covariance matrix will not be computed.
C                  (This requires no user input.)
C                  The data set for this option is a single value.
C                  It must be nonzero when the covariance matrix
C                  is desired.  If it is zero, the covariance
C                  matrix is not computed.  When the covariance matrix
C                  is computed, the first dimensioning parameter
C                  of the array W(*,*) must satisfy MDW .GE. MAX(M,N).
C
C                  KEY=10
C                         Suppress scaling of the inverse of the
C                  normal matrix by the scale factor RNORM**2/
C                  MAX(1, no. of degrees of freedom).  This option
C                  only applies when the option for computing the
C                  covariance matrix (KEY=1) is used.  With KEY=1 and
C                  KEY=10 used as options the unscaled inverse of the
C                  normal matrix is returned in W(*,*).
C                  The data set for this option is a single value.
C                  When it is nonzero no scaling is done.  When it is
C                  zero scaling is done.  The nominal case is to do
C                  scaling so if option (KEY=1) is used alone, the
C                  matrix will be scaled on output.
C
C                  KEY=2
C                         Scale the nonzero columns of the
C                         entire data matrix.
C                  (E)
C                  (A)
C                  (G)
C
C                  to have length one.  The data set for this
C                  option is a single value.  It must be
C                  nonzero if unit length column scaling
C                  is desired.
C
C                  KEY=3
C                         Scale columns of the entire data matrix
C                  (E)
C                  (A)
C                  (G)
C
C                  with a user-provided diagonal matrix.
C                  The data set for this option consists
C                  of the N diagonal scaling factors, one for
C                  each matrix column.
C
C                  KEY=4
C                         Change the rank determination tolerance for
C                  the equality constraint equations from
C                  the nominal value of SQRT(SRELPR).  This quantity can
C                  be no smaller than SRELPR, the arithmetic-
C                  storage precision.  The quantity SRELPR is the
C                  largest positive number such that T=1.+SRELPR
C                  satisfies T .EQ. 1.  The quantity used
C                  here is internally restricted to be at
C                  least SRELPR.  The data set for this option
C                  is the new tolerance.
C
C                  KEY=5
C                         Change the rank determination tolerance for
C                  the reduced least squares equations from
C                  the nominal value of SQRT(SRELPR).  This quantity can
C                  be no smaller than SRELPR, the arithmetic-
C                  storage precision.  The quantity used
C                  here is internally restricted to be at
C                  least SRELPR.  The data set for this option
C                  is the new tolerance.
C
C                  For example, suppose we want to change
C                  the tolerance for the reduced least squares
C                  problem, compute the covariance matrix of
C                  the solution parameters, and provide
C                  column scaling for the data matrix.  For
C                  these options the dimension of PRGOPT(*)
C                  must be at least N+9.  The Fortran statements
C                  defining these options would be as follows:
C
C                  PRGOPT(1)=4 (link to entry 4 in PRGOPT(*))
C                  PRGOPT(2)=1 (covariance matrix key)
C                  PRGOPT(3)=1 (covariance matrix wanted)
C
C                  PRGOPT(4)=7 (link to entry 7 in PRGOPT(*))
C                  PRGOPT(5)=5 (least squares equas.  tolerance key)
C                  PRGOPT(6)=... (new value of the tolerance)
C
C                  PRGOPT(7)=N+9 (link to entry N+9 in PRGOPT(*))
C                  PRGOPT(8)=3 (user-provided column scaling key)
C
C                  CALL SCOPY (N, D, 1, PRGOPT(9), 1)  (Copy the N
C                    scaling factors from the user array D(*)
C                    to PRGOPT(9)-PRGOPT(N+8))
C
C                  PRGOPT(N+9)=1 (no more options to change)
C
C                  The contents of PRGOPT(*) are not modified
C                  by the subprogram.
C                  The options for WNNLS( ) can also be included
C                  in this array.  The values of KEY recognized
C                  by WNNLS( ) are 6, 7 and 8.  Their functions
C                  are documented in the usage instructions for
C                  subroutine WNNLS( ).  Normally these options
C                  do not need to be modified when using LSEI( ).
C
C     IP(1),       The amounts of working storage actually
C     IP(2)        allocated for the working arrays WS(*) and
C                  IP(*), respectively.  These quantities are
C                  compared with the actual amounts of storage
C                  needed by LSEI( ).  Insufficient storage
C                  allocated for either WS(*) or IP(*) is an
C                  error.  This feature was included in LSEI( )
C                  because miscalculating the storage formulas
C                  for WS(*) and IP(*) might very well lead to
C                  subtle and hard-to-find execution errors.
C
C                  The length of WS(*) must be at least
C
C                  LW = 2*(ME+N)+K+(MG+2)*(N+7)
C
C                  where K = max(MA+MG,N)
C                  This test will not be made if IP(1).LE.0.
C
C                  The length of IP(*) must be at least
C
C                  LIP = MG+2*N+2
C                  This test will not be made if IP(2).LE.0.
C
C     Output..
C
C     X(*),RNORME,  The array X(*) contains the solution parameters
C     RNORML        if the integer output flag MODE = 0 or 1.
C                   The definition of MODE is given directly below.
C                   When MODE = 0 or 1, RNORME and RNORML
C                   respectively contain the residual vector
C                   Euclidean lengths of F - EX and B - AX.  When
C                   MODE=1 the equality constraint equations EX=F
C                   are contradictory, so RNORME .NE. 0.  The residual
C                   vector F-EX has minimal Euclidean length.  For
C                   MODE .GE. 2, none of these parameters is defined.
C
C     MODE          Integer flag that indicates the subprogram
C                   status after completion.  If MODE .GE. 2, no
C                   solution has been computed.
C
C                   MODE =
C
C                   0  Both equality and inequality constraints
C                      are compatible and have been satisfied.
C
C                   1  Equality constraints are contradictory.
C                      A generalized inverse solution of EX=F was used
C                      to minimize the residual vector length F-EX.
C                      In this sense, the solution is still meaningful.
C
C                   2  Inequality constraints are contradictory.
C
C                   3  Both equality and inequality constraints
C                      are contradictory.
C
C                   The following interpretation of
C                   MODE=1,2 or 3 must be made.  The
C                   sets consisting of all solutions
C                   of the equality constraints EX=F
C                   and all vectors satisfying GX .GE. H
C                   have no points in common.  (In
C                   particular this does not say that
C                   each individual set has no points
C                   at all, although this could be the
C                   case.)
C
C                   4  Usage error occurred.  The value
C                      of MDW is .LT. ME+MA+MG, MDW is
C                      .LT. N and a covariance matrix is
C                      requested, or the option vector
C                      PRGOPT(*) is not properly defined,
C                      or the lengths of the working arrays
C                      WS(*) and IP(*), when specified in
C                      IP(1) and IP(2) respectively, are not
C                      long enough.
C
C     W(*,*)        The array W(*,*) contains the N by N symmetric
C                   covariance matrix of the solution parameters,
C                   provided this was requested on input with
C                   the option vector PRGOPT(*) and the output
C                   flag is returned with MODE = 0 or 1.
C
C     IP(*)         The integer working array has three entries
C                   that provide rank and working array length
C                   information after completion.
C
C                      IP(1) = rank of equality constraint
C                              matrix.  Define this quantity
C                              as KRANKE.
C
C                      IP(2) = rank of reduced least squares
C                              problem.
C
C                      IP(3) = the amount of storage in the
C                              working array WS(*) that was
C                              actually used by the subprogram.
C                              The formula given above for the length
C                              of WS(*) is a necessary overestimate.
C                              If exactly the same problem matrices
C                              are used in subsequent executions,
C                              the declared dimension of WS(*) can
C                              be reduced to this output value.
C     User Designated
C     Working Arrays..
C
C     WS(*),IP(*)              These are respectively type real
C                              and type integer working arrays.
C                              Their required minimal lengths are
C                              given above.
C
C***REFERENCES  K. H. Haskell and R. J. Hanson, An algorithm for
C                 linear least squares problems with equality and
C                 nonnegativity constraints, Report SAND77-0552, Sandia
C                 Laboratories, June 1978.
C               K. H. Haskell and R. J. Hanson, Selected algorithms for
C                 the linearly constrained least squares problem - a
C                 users guide, Report SAND78-1290, Sandia Laboratories,
C                 August 1979.
C               K. H. Haskell and R. J. Hanson, An algorithm for
C                 linear least squares problems with equality and
C                 nonnegativity constraints, Mathematical Programming
C                 21 (1981), pp. 98-118.
C               R. J. Hanson and K. H. Haskell, Two algorithms for the
C                 linearly constrained least squares problem, ACM
C                 Transactions on Mathematical Software, September 1982.
C***ROUTINES CALLED  H12, LSI, R1MACH, SASUM, SAXPY, SCOPY, SDOT, SNRM2,
C                    SSCAL, SSWAP, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890618  Completely restructured and extensively revised (WRB & RWC)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  LSEI
      INTEGER IP(3), MA, MDW, ME, MG, MODE, N
      REAL             PRGOPT(*), RNORME, RNORML, W(MDW,*), WS(*), X(*)
C
      EXTERNAL H12, LSI, R1MACH, SASUM, SAXPY, SCOPY, SDOT, SNRM2,
     *   SSCAL, SSWAP, XERMSG
      REAL             R1MACH, SASUM, SDOT, SNRM2
C
      REAL             ENORM, FNORM, GAM, RB, RN, RNMAX, SIZE, SN,
     *   SNMAX, SRELPR, T, TAU, UJ, UP, VJ, XNORM, XNRME
      INTEGER I, IMAX, J, JP1, K, KEY, KRANKE, LAST, LCHK, LINK, M,
     *   MAPKE1, MDEQC, MEND, MEP1, N1, N2, NEXT, NLINK, NOPT, NP1,
     *   NTIMES
      LOGICAL COV, FIRST
      CHARACTER*8 XERN1, XERN2, XERN3, XERN4
      SAVE FIRST, SRELPR
C
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  LSEI
C
C     Set the nominal tolerance used in the code for the equality
C     constraint equations.
C
      IF (FIRST) SRELPR = R1MACH(4)
      FIRST = .FALSE.
      TAU = SQRT(SRELPR)
C
C     Check that enough storage was allocated in WS(*) and IP(*).
C
      MODE = 4
      IF (MIN(N,ME,MA,MG) .LT. 0) THEN
         WRITE (XERN1, '(I8)') N
         WRITE (XERN2, '(I8)') ME
         WRITE (XERN3, '(I8)') MA
         WRITE (XERN4, '(I8)') MG
         CALL XERMSG ('SLATEC', 'LSEI', 'ALL OF THE VARIABLES N, ME,' //
     *      ' MA, MG MUST BE .GE. 0$$ENTERED ROUTINE WITH' //
     *      '$$N  = ' // XERN1 //
     *      '$$ME = ' // XERN2 //
     *      '$$MA = ' // XERN3 //
     *      '$$MG = ' // XERN4, 2, 1)
         RETURN
      ENDIF
C
      IF (IP(1).GT.0) THEN
         LCHK = 2*(ME+N) + MAX(MA+MG,N) + (MG+2)*(N+7)
         IF (IP(1).LT.LCHK) THEN
            WRITE (XERN1, '(I8)') LCHK
            CALL XERMSG ('SLATEC', 'LSEI', 'INSUFFICIENT STORAGE ' //
     *         'ALLOCATED FOR WS(*), NEED LW = ' // XERN1, 2, 1)
            RETURN
         ENDIF
      ENDIF
C
      IF (IP(2).GT.0) THEN
         LCHK = MG + 2*N + 2
         IF (IP(2).LT.LCHK) THEN
            WRITE (XERN1, '(I8)') LCHK
            CALL XERMSG ('SLATEC', 'LSEI', 'INSUFFICIENT STORAGE ' //
     *         'ALLOCATED FOR IP(*), NEED LIP = ' // XERN1, 2, 1)
            RETURN
         ENDIF
      ENDIF
C
C     Compute number of possible right multiplying Householder
C     transformations.
C
      M = ME + MA + MG
      IF (N.LE.0 .OR. M.LE.0) THEN
         MODE = 0
         RNORME = 0
         RNORML = 0
         RETURN
      ENDIF
C
      IF (MDW.LT.M) THEN
         CALL XERMSG ('SLATEC', 'LSEI', 'MDW.LT.ME+MA+MG IS AN ERROR',
     +      2, 1)
         RETURN
      ENDIF
C
      NP1 = N + 1
      KRANKE = MIN(ME,N)
      N1 = 2*KRANKE + 1
      N2 = N1 + N
C
C     Set nominal values.
C
C     The nominal column scaling used in the code is
C     the identity scaling.
C
      CALL SCOPY (N, 1.E0, 0, WS(N1), 1)
C
C     No covariance matrix is nominally computed.
C
      COV = .FALSE.
C
C     Process option vector.
C     Define bound for number of options to change.
C
      NOPT = 1000
      NTIMES = 0
C
C     Define bound for positive values of LINK.
C
      NLINK = 100000
      LAST = 1
      LINK = PRGOPT(1)
      IF (LINK.EQ.0 .OR. LINK.GT.NLINK) THEN
         CALL XERMSG ('SLATEC', 'LSEI',
     +      'THE OPTION VECTOR IS UNDEFINED', 2, 1)
         RETURN
      ENDIF
C
  100 IF (LINK.GT.1) THEN
         NTIMES = NTIMES + 1
         IF (NTIMES.GT.NOPT) THEN
            CALL XERMSG ('SLATEC', 'LSEI',
     +         'THE LINKS IN THE OPTION VECTOR ARE CYCLING.', 2, 1)
            RETURN
         ENDIF
C
         KEY = PRGOPT(LAST+1)
         IF (KEY.EQ.1) THEN
            COV = PRGOPT(LAST+2) .NE. 0.E0
         ELSEIF (KEY.EQ.2 .AND. PRGOPT(LAST+2).NE.0.E0) THEN
            DO 110 J = 1,N
               T = SNRM2(M,W(1,J),1)
               IF (T.NE.0.E0) T = 1.E0/T
               WS(J+N1-1) = T
  110       CONTINUE
         ELSEIF (KEY.EQ.3) THEN
            CALL SCOPY (N, PRGOPT(LAST+2), 1, WS(N1), 1)
         ELSEIF (KEY.EQ.4) THEN
            TAU = MAX(SRELPR,PRGOPT(LAST+2))
         ENDIF
C
         NEXT = PRGOPT(LINK)
         IF (NEXT.LE.0 .OR. NEXT.GT.NLINK) THEN
         CALL XERMSG ('SLATEC', 'LSEI',
     +      'THE OPTION VECTOR IS UNDEFINED', 2, 1)
            RETURN
         ENDIF
C
         LAST = LINK
         LINK = NEXT
         GO TO 100
      ENDIF
C
      DO 120 J = 1,N
         CALL SSCAL (M, WS(N1+J-1), W(1,J), 1)
  120 CONTINUE
C
      IF (COV .AND. MDW.LT.N) THEN
         CALL XERMSG ('SLATEC', 'LSEI',
     +      'MDW .LT. N WHEN COV MATRIX NEEDED, IS AN ERROR', 2, 1)
         RETURN
      ENDIF
C
C     Problem definition and option vector OK.
C
      MODE = 0
C
C     Compute norm of equality constraint matrix and right side.
C
      ENORM = 0.E0
      DO 130 J = 1,N
         ENORM = MAX(ENORM,SASUM(ME,W(1,J),1))
  130 CONTINUE
C
      FNORM = SASUM(ME,W(1,NP1),1)
      SNMAX = 0.E0
      RNMAX = 0.E0
      DO 150 I = 1,KRANKE
C
C        Compute maximum ratio of vector lengths. Partition is at
C        column I.
C
         DO 140 K = I,ME
            SN = SDOT(N-I+1,W(K,I),MDW,W(K,I),MDW)
            RN = SDOT(I-1,W(K,1),MDW,W(K,1),MDW)
            IF (RN.EQ.0.E0 .AND. SN.GT.SNMAX) THEN
               SNMAX = SN
               IMAX = K
            ELSEIF (K.EQ.I .OR. SN*RNMAX.GT.RN*SNMAX) THEN
               SNMAX = SN
               RNMAX = RN
               IMAX = K
            ENDIF
  140    CONTINUE
C
C        Interchange rows if necessary.
C
         IF (I.NE.IMAX) CALL SSWAP (NP1, W(I,1), MDW, W(IMAX,1), MDW)
         IF (SNMAX.GT.RNMAX*TAU**2) THEN
C
C        Eliminate elements I+1,...,N in row I.
C
            CALL H12 (1, I, I+1, N, W(I,1), MDW, WS(I), W(I+1,1), MDW,
     +                1, M-I)
         ELSE
            KRANKE = I - 1
            GO TO 160
         ENDIF
  150 CONTINUE
C
C     Save diagonal terms of lower trapezoidal matrix.
C
  160 CALL SCOPY (KRANKE, W, MDW+1, WS(KRANKE+1), 1)
C
C     Use Householder transformation from left to achieve
C     KRANKE by KRANKE upper triangular form.
C
      IF (KRANKE.LT.ME) THEN
         DO 170 K = KRANKE,1,-1
C
C           Apply transformation to matrix cols. 1,...,K-1.
C
            CALL H12 (1, K, KRANKE+1, ME, W(1,K), 1, UP, W, 1, MDW, K-1)
C
C           Apply to rt side vector.
C
            CALL H12 (2, K, KRANKE+1, ME, W(1,K), 1, UP, W(1,NP1), 1, 1,
     +                1)
  170    CONTINUE
      ENDIF
C
C     Solve for variables 1,...,KRANKE in new coordinates.
C
      CALL SCOPY (KRANKE, W(1, NP1), 1, X, 1)
      DO 180 I = 1,KRANKE
         X(I) = (X(I)-SDOT(I-1,W(I,1),MDW,X,1))/W(I,I)
  180 CONTINUE
C
C     Compute residuals for reduced problem.
C
      MEP1 = ME + 1
      RNORML = 0.E0
      DO 190 I = MEP1,M
         W(I,NP1) = W(I,NP1) - SDOT(KRANKE,W(I,1),MDW,X,1)
         SN = SDOT(KRANKE,W(I,1),MDW,W(I,1),MDW)
         RN = SDOT(N-KRANKE,W(I,KRANKE+1),MDW,W(I,KRANKE+1),MDW)
         IF (RN.LE.SN*TAU**2 .AND. KRANKE.LT.N)
     *      CALL SCOPY (N-KRANKE, 0.E0, 0, W(I,KRANKE+1), MDW)
  190 CONTINUE
C
C     Compute equality constraint equations residual length.
C
      RNORME = SNRM2(ME-KRANKE,W(KRANKE+1,NP1),1)
C
C     Move reduced problem data upward if KRANKE.LT.ME.
C
      IF (KRANKE.LT.ME) THEN
         DO 200 J = 1,NP1
            CALL SCOPY (M-ME, W(ME+1,J), 1, W(KRANKE+1,J), 1)
  200    CONTINUE
      ENDIF
C
C     Compute solution of reduced problem.
C
      CALL LSI(W(KRANKE+1, KRANKE+1), MDW, MA, MG, N-KRANKE, PRGOPT,
     +         X(KRANKE+1), RNORML, MODE, WS(N2), IP(2))
C
C     Test for consistency of equality constraints.
C
      IF (ME.GT.0) THEN
         MDEQC = 0
         XNRME = SASUM(KRANKE,W(1,NP1),1)
         IF (RNORME.GT.TAU*(ENORM*XNRME+FNORM)) MDEQC = 1
         MODE = MODE + MDEQC
C
C        Check if solution to equality constraints satisfies inequality
C        constraints when there are no degrees of freedom left.
C
         IF (KRANKE.EQ.N .AND. MG.GT.0) THEN
            XNORM = SASUM(N,X,1)
            MAPKE1 = MA + KRANKE + 1
            MEND = MA + KRANKE + MG
            DO 210 I = MAPKE1,MEND
               SIZE = SASUM(N,W(I,1),MDW)*XNORM + ABS(W(I,NP1))
               IF (W(I,NP1).GT.TAU*SIZE) THEN
                  MODE = MODE + 2
                  GO TO 290
               ENDIF
  210       CONTINUE
         ENDIF
      ENDIF
C
C     Replace diagonal terms of lower trapezoidal matrix.
C
      IF (KRANKE.GT.0) THEN
         CALL SCOPY (KRANKE, WS(KRANKE+1), 1, W, MDW+1)
C
C        Reapply transformation to put solution in original coordinates.
C
         DO 220 I = KRANKE,1,-1
            CALL H12 (2, I, I+1, N, W(I,1), MDW, WS(I), X, 1, 1, 1)
  220    CONTINUE
C
C        Compute covariance matrix of equality constrained problem.
C
         IF (COV) THEN
            DO 270 J = MIN(KRANKE,N-1),1,-1
               RB = WS(J)*W(J,J)
               IF (RB.NE.0.E0) RB = 1.E0/RB
               JP1 = J + 1
               DO 230 I = JP1,N
                  W(I,J) = RB*SDOT(N-J,W(I,JP1),MDW,W(J,JP1),MDW)
  230          CONTINUE
C
               GAM = 0.5E0*RB*SDOT(N-J,W(JP1,J),1,W(J,JP1),MDW)
               CALL SAXPY (N-J, GAM, W(J,JP1), MDW, W(JP1,J), 1)
               DO 250 I = JP1,N
                  DO 240 K = I,N
                     W(I,K) = W(I,K) + W(J,I)*W(K,J) + W(I,J)*W(J,K)
                     W(K,I) = W(I,K)
  240             CONTINUE
  250          CONTINUE
               UJ = WS(J)
               VJ = GAM*UJ
               W(J,J) = UJ*VJ + UJ*VJ
               DO 260 I = JP1,N
                  W(J,I) = UJ*W(I,J) + VJ*W(J,I)
  260          CONTINUE
               CALL SCOPY (N-J, W(J, JP1), MDW, W(JP1,J), 1)
  270       CONTINUE
         ENDIF
      ENDIF
C
C     Apply the scaling to the covariance matrix.
C
      IF (COV) THEN
         DO 280 I = 1,N
            CALL SSCAL (N, WS(I+N1-1), W(I,1), MDW)
            CALL SSCAL (N, WS(I+N1-1), W(1,I), 1)
  280    CONTINUE
      ENDIF
C
C     Rescale solution vector.
C
  290 IF (MODE.LE.1) THEN
         DO 300 J = 1,N
            X(J) = X(J)*WS(N1+J-1)
  300    CONTINUE
      ENDIF
C
      IP(1) = KRANKE
      IP(3) = IP(3) + 2*KRANKE + N
      RETURN
      END
*DECK LSI
      SUBROUTINE LSI (W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, IP)
C***BEGIN PROLOGUE  LSI
C***SUBSIDIARY
C***PURPOSE  Subsidiary to LSEI
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (LSI-S, DLSI-D)
C***AUTHOR  Hanson, R. J., (SNLA)
C***DESCRIPTION
C
C     This is a companion subprogram to LSEI.  The documentation for
C     LSEI has complete usage instructions.
C
C     Solve..
C              AX = B,  A  MA by N  (least squares equations)
C     subject to..
C
C              GX.GE.H, G  MG by N  (inequality constraints)
C
C     Input..
C
C      W(*,*) contains  (A B) in rows 1,...,MA+MG, cols 1,...,N+1.
C                       (G H)
C
C     MDW,MA,MG,N
C              contain (resp) var. dimension of W(*,*),
C              and matrix dimensions.
C
C     PRGOPT(*),
C              Program option vector.
C
C     OUTPUT..
C
C      X(*),RNORM
C
C              Solution vector(unless MODE=2), length of AX-B.
C
C      MODE
C              =0   Inequality constraints are compatible.
C              =2   Inequality constraints contradictory.
C
C      WS(*),
C              Working storage of dimension K+N+(MG+2)*(N+7),
C              where K=MAX(MA+MG,N).
C      IP(MG+2*N+1)
C              Integer working storage
C
C***ROUTINES CALLED  H12, HFTI, LPDP, R1MACH, SASUM, SAXPY, SCOPY, SDOT,
C                    SSCAL, SSWAP
C***REVISION HISTORY  (YYMMDD)
C   790701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890618  Completely restructured and extensively revised (WRB & RWC)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   920422  Changed CALL to HFTI to include variable MA.  (WRB)
C***END PROLOGUE  LSI
      INTEGER IP(*), MA, MDW, MG, MODE, N
      REAL             PRGOPT(*), RNORM, W(MDW,*), WS(*), X(*)
C
      EXTERNAL H12, HFTI, LPDP, R1MACH, SASUM, SAXPY, SCOPY, SDOT,
     *   SSCAL, SSWAP
      REAL             R1MACH, SASUM, SDOT
C
      REAL             ANORM, FAC, GAM, RB, SRELPR, TAU, TOL, XNORM
      INTEGER I, J, K, KEY, KRANK, KRM1, KRP1, L, LAST, LINK, M, MAP1,
     *   MDLPDP, MINMAN, N1, N2, N3, NEXT, NP1
      LOGICAL COV, FIRST, SCLCOV
C
      SAVE SRELPR, FIRST
      DATA FIRST /.TRUE./
C
C***FIRST EXECUTABLE STATEMENT  LSI
C
C     Set the nominal tolerance used in the code.
C
      IF (FIRST) SRELPR = R1MACH(4)
      FIRST = .FALSE.
      TOL = SQRT(SRELPR)
C
      MODE = 0
      RNORM = 0.E0
      M = MA + MG
      NP1 = N + 1
      KRANK = 0
      IF (N.LE.0 .OR. M.LE.0) GO TO 370
C
C     To process option vector.
C
      COV = .FALSE.
      SCLCOV = .TRUE.
      LAST = 1
      LINK = PRGOPT(1)
C
  100 IF (LINK.GT.1) THEN
         KEY = PRGOPT(LAST+1)
         IF (KEY.EQ.1) COV = PRGOPT(LAST+2) .NE. 0.E0
         IF (KEY.EQ.10) SCLCOV = PRGOPT(LAST+2) .EQ. 0.E0
         IF (KEY.EQ.5) TOL = MAX(SRELPR,PRGOPT(LAST+2))
         NEXT = PRGOPT(LINK)
         LAST = LINK
         LINK = NEXT
         GO TO 100
      ENDIF
C
C     Compute matrix norm of least squares equations.
C
      ANORM = 0.E0
      DO 110 J = 1,N
         ANORM = MAX(ANORM,SASUM(MA,W(1,J),1))
  110 CONTINUE
C
C     Set tolerance for HFTI( ) rank test.
C
      TAU = TOL*ANORM
C
C     Compute Householder orthogonal decomposition of matrix.
C
      CALL SCOPY (N, 0.E0, 0, WS, 1)
      CALL SCOPY (MA, W(1, NP1), 1, WS, 1)
      K = MAX(M,N)
      MINMAN = MIN(MA,N)
      N1 = K + 1
      N2 = N1 + N
      CALL HFTI (W, MDW, MA, N, WS, MA, 1, TAU, KRANK, RNORM, WS(N2),
     +           WS(N1), IP)
      FAC = 1.E0
      GAM = MA - KRANK
      IF (KRANK.LT.MA .AND. SCLCOV) FAC = RNORM**2/GAM
C
C     Reduce to LPDP and solve.
C
      MAP1 = MA + 1
C
C     Compute inequality rt-hand side for LPDP.
C
      IF (MA.LT.M) THEN
         IF (MINMAN.GT.0) THEN
            DO 120 I = MAP1,M
               W(I,NP1) = W(I,NP1) - SDOT(N,W(I,1),MDW,WS,1)
  120       CONTINUE
C
C           Apply permutations to col. of inequality constraint matrix.
C
            DO 130 I = 1,MINMAN
               CALL SSWAP (MG, W(MAP1,I), 1, W(MAP1,IP(I)), 1)
  130       CONTINUE
C
C           Apply Householder transformations to constraint matrix.
C
            IF (KRANK.GT.0 .AND. KRANK.LT.N) THEN
               DO 140 I = KRANK,1,-1
                  CALL H12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1),
     +                      W(MAP1,1), MDW, 1, MG)
  140          CONTINUE
            ENDIF
C
C           Compute permuted inequality constraint matrix times r-inv.
C
            DO 160 I = MAP1,M
               DO 150 J = 1,KRANK
                  W(I,J) = (W(I,J)-SDOT(J-1,W(1,J),1,W(I,1),MDW))/W(J,J)
  150          CONTINUE
  160       CONTINUE
         ENDIF
C
C        Solve the reduced problem with LPDP algorithm,
C        the least projected distance problem.
C
         CALL LPDP(W(MAP1,1), MDW, MG, KRANK, N-KRANK, PRGOPT, X,
     +             XNORM, MDLPDP, WS(N2), IP(N+1))
C
C        Compute solution in original coordinates.
C
         IF (MDLPDP.EQ.1) THEN
            DO 170 I = KRANK,1,-1
               X(I) = (X(I)-SDOT(KRANK-I,W(I,I+1),MDW,X(I+1),1))/W(I,I)
  170       CONTINUE
C
C           Apply Householder transformation to solution vector.
C
            IF (KRANK.LT.N) THEN
               DO 180 I = 1,KRANK
                  CALL H12 (2, I, KRANK+1, N, W(I,1), MDW, WS(N1+I-1),
     +                      X, 1, 1, 1)
  180          CONTINUE
            ENDIF
C
C           Repermute variables to their input order.
C
            IF (MINMAN.GT.0) THEN
               DO 190 I = MINMAN,1,-1
                  CALL SSWAP (1, X(I), 1, X(IP(I)), 1)
  190          CONTINUE
C
C              Variables are now in original coordinates.
C              Add solution of unconstrained problem.
C
               DO 200 I = 1,N
                  X(I) = X(I) + WS(I)
  200          CONTINUE
C
C              Compute the residual vector norm.
C
               RNORM = SQRT(RNORM**2+XNORM**2)
            ENDIF
         ELSE
            MODE = 2
         ENDIF
      ELSE
         CALL SCOPY (N, WS, 1, X, 1)
      ENDIF
C
C     Compute covariance matrix based on the orthogonal decomposition
C     from HFTI( ).
C
      IF (.NOT.COV .OR. KRANK.LE.0) GO TO 370
      KRM1 = KRANK - 1
      KRP1 = KRANK + 1
C
C     Copy diagonal terms to working array.
C
      CALL SCOPY (KRANK, W, MDW+1, WS(N2), 1)
C
C     Reciprocate diagonal terms.
C
      DO 210 J = 1,KRANK
         W(J,J) = 1.E0/W(J,J)
  210 CONTINUE
C
C     Invert the upper triangular QR factor on itself.
C
      IF (KRANK.GT.1) THEN
         DO 230 I = 1,KRM1
            DO 220 J = I+1,KRANK
               W(I,J) = -SDOT(J-I,W(I,I),MDW,W(I,J),1)*W(J,J)
  220       CONTINUE
  230    CONTINUE
      ENDIF
C
C     Compute the inverted factor times its transpose.
C
      DO 250 I = 1,KRANK
         DO 240 J = I,KRANK
            W(I,J) = SDOT(KRANK+1-J,W(I,J),MDW,W(J,J),MDW)
  240    CONTINUE
  250 CONTINUE
C
C     Zero out lower trapezoidal part.
C     Copy upper triangular to lower triangular part.
C
      IF (KRANK.LT.N) THEN
         DO 260 J = 1,KRANK
            CALL SCOPY (J, W(1,J), 1, W(J,1), MDW)
  260    CONTINUE
C
         DO 270 I = KRP1,N
            CALL SCOPY (I, 0.E0, 0, W(I,1), MDW)
  270    CONTINUE
C
C        Apply right side transformations to lower triangle.
C
         N3 = N2 + KRP1
         DO 330 I = 1,KRANK
            L = N1 + I
            K = N2 + I
            RB = WS(L-1)*WS(K-1)
C
C           If RB.GE.0.E0, transformation can be regarded as zero.
C
            IF (RB.LT.0.E0) THEN
               RB = 1.E0/RB
C
C              Store unscaled rank one Householder update in work array.
C
               CALL SCOPY (N, 0.E0, 0, WS(N3), 1)
               L = N1 + I
               K = N3 + I
               WS(K-1) = WS(L-1)
C
               DO 280 J = KRP1,N
                  WS(N3+J-1) = W(I,J)
  280          CONTINUE
C
               DO 290 J = 1,N
                  WS(J) = RB*(SDOT(J-I,W(J,I),MDW,WS(N3+I-1),1)+
     +                    SDOT(N-J+1,W(J,J),1,WS(N3+J-1),1))
  290          CONTINUE
C
               L = N3 + I
               GAM = 0.5E0*RB*SDOT(N-I+1,WS(L-1),1,WS(I),1)
               CALL SAXPY (N-I+1, GAM, WS(L-1), 1, WS(I), 1)
               DO 320 J = I,N
                  DO 300 L = 1,I-1
                     W(J,L) = W(J,L) + WS(N3+J-1)*WS(L)
  300             CONTINUE
C
                  DO 310 L = I,J
                     W(J,L) = W(J,L) + WS(J)*WS(N3+L-1)+WS(L)*WS(N3+J-1)
  310             CONTINUE
  320          CONTINUE
            ENDIF
  330    CONTINUE
C
C        Copy lower triangle to upper triangle to symmetrize the
C        covariance matrix.
C
         DO 340 I = 1,N
            CALL SCOPY (I, W(I,1), MDW, W(1,I), 1)
  340    CONTINUE
      ENDIF
C
C     Repermute rows and columns.
C
      DO 350 I = MINMAN,1,-1
         K = IP(I)
         IF (I.NE.K) THEN
            CALL SSWAP (1, W(I,I), 1, W(K,K), 1)
            CALL SSWAP (I-1, W(1,I), 1, W(1,K), 1)
            CALL SSWAP (K-I-1, W(I,I+1), MDW, W(I+1,K), 1)
            CALL SSWAP (N-K, W(I, K+1), MDW, W(K, K+1), MDW)
         ENDIF
  350 CONTINUE
C
C     Put in normalized residual sum of squares scale factor
C     and symmetrize the resulting covariance matrix.
C
      DO 360 J = 1,N
         CALL SSCAL (J, FAC, W(1,J), 1)
         CALL SCOPY (J, W(1,J), 1, W(J,1), MDW)
  360 CONTINUE
C
  370 IP(1) = KRANK
      IP(2) = N + MAX(M,N) + (MG+2)*(N+7)
      RETURN
      END
*DECK LSOD
      SUBROUTINE LSOD (F, NEQ, T, Y, TOUT, RTOL, ATOL, IDID, YPOUT, YH,
     +   YH1, EWT, SAVF, ACOR, WM, IWM, JAC, INTOUT, TSTOP, TOLFAC,
     +   DELSGN, RPAR, IPAR)
C***BEGIN PROLOGUE  LSOD
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DEBDF
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (LSOD-S, DLSOD-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C   DEBDF  merely allocates storage for  LSOD  to relieve the user of
C   the inconvenience of a long call list.  Consequently  LSOD  is used
C   as described in the comments for  DEBDF .
C
C***SEE ALSO  DEBDF
C***ROUTINES CALLED  HSTART, INTYD, R1MACH, STOD, VNWRMS, XERMSG
C***COMMON BLOCKS    DEBDF1
C***REVISION HISTORY  (YYMMDD)
C   800901  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
C***END PROLOGUE  LSOD
C
C
      LOGICAL INTOUT
C
      DIMENSION Y(*),YPOUT(*),YH(NEQ,6),YH1(*),EWT(*),SAVF(*),
     1          ACOR(*),WM(*),IWM(*),RTOL(*),ATOL(*),RPAR(*),IPAR(*)
      CHARACTER*8 XERN1
      CHARACTER*16 XERN3, XERN4
C
      COMMON /DEBDF1/ TOLD, ROWNS(210),
     1   EL0, H, HMIN, HMXI, HU, X, U,
     2   IQUIT, INIT, LYH, LEWT, LACOR, LSAVF, LWM, KSTEPS,
     3   IBEGIN, ITOL, IINTEG, ITSTOP, IJAC, IBAND, IOWNS(6),
     4   IER, JSTART, KFLAG, LDUM, METH, MITER, MAXORD, N, NQ, NST,
     5   NFE, NJE, NQU
C
      EXTERNAL F, JAC
C
C.......................................................................
C
C  THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE
C  NUMBER OF  STEPS ATTEMPTED. WHEN THIS EXCEEDS  MAXNUM, THE COUNTER
C  IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE EXCESSIVE
C  WORK.
C
      SAVE MAXNUM
      DATA MAXNUM/500/
C
C.......................................................................
C
C***FIRST EXECUTABLE STATEMENT  LSOD
      IF (IBEGIN .EQ. 0) THEN
C
C        ON THE FIRST CALL , PERFORM INITIALIZATION --
C        DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY  U  BY CALLING THE
C        FUNCTION ROUTINE R1MACH. THE USER MUST MAKE SURE THAT THE
C        VALUES SET IN R1MACH ARE RELEVANT TO THE COMPUTER BEING USED.
C
         U = R1MACH(4)
C                          -- SET ASSOCIATED MACHINE DEPENDENT PARAMETER
         WM(1) = SQRT(U)
C                          -- SET TERMINATION FLAG
         IQUIT = 0
C                          -- SET INITIALIZATION INDICATOR
         INIT = 0
C                          -- SET COUNTER FOR ATTEMPTED STEPS
         KSTEPS = 0
C                          -- SET INDICATOR FOR INTERMEDIATE-OUTPUT
         INTOUT = .FALSE.
C                          -- SET START INDICATOR FOR STOD CODE
         JSTART = 0
C                          -- SET BDF METHOD INDICATOR
         METH = 2
C                          -- SET MAXIMUM ORDER FOR BDF METHOD
         MAXORD = 5
C                          -- SET ITERATION MATRIX INDICATOR
C
         IF (IJAC .EQ. 0 .AND. IBAND .EQ. 0) MITER = 2
         IF (IJAC .EQ. 1 .AND. IBAND .EQ. 0) MITER = 1
         IF (IJAC .EQ. 0 .AND. IBAND .EQ. 1) MITER = 5
         IF (IJAC .EQ. 1 .AND. IBAND .EQ. 1) MITER = 4
C
C                          -- SET OTHER NECESSARY ITEMS IN COMMON BLOCK
         N = NEQ
         NST = 0
         NJE = 0
         HMXI = 0.
         NQ = 1
         H = 1.
C                          -- RESET IBEGIN FOR SUBSEQUENT CALLS
         IBEGIN=1
      ENDIF
C
C.......................................................................
C
C      CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY
C
      IF (NEQ .LT. 1) THEN
         WRITE (XERN1, '(I8)') NEQ
         CALL XERMSG ('SLATEC', 'LSOD',
     *      'IN DEBDF, THE NUMBER OF EQUATIONS MUST BE A POSITIVE ' //
     *      'INTEGER.$$YOU HAVE CALLED THE CODE WITH NEQ = ' // XERN1,
     *      6, 1)
         IDID=-33
      ENDIF
C
      NRTOLP = 0
      NATOLP = 0
      DO 60 K = 1,NEQ
         IF (NRTOLP .LE. 0) THEN
            IF (RTOL(K) .LT. 0.) THEN
               WRITE (XERN1, '(I8)') K
               WRITE (XERN3, '(1PE15.6)') RTOL(K)
               CALL XERMSG ('SLATEC', 'LSOD',
     *            'IN DEBDF, THE RELATIVE ERROR TOLERANCES MUST ' //
     *            'BE NON-NEGATIVE.$$YOU HAVE CALLED THE CODE WITH ' //
     *            'RTOL(' // XERN1 // ') = ' // XERN3 // '$$IN THE ' //
     *            'CASE OF VECTOR ERROR TOLERANCES, NO FURTHER ' //
     *            'CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1)
               IDID = -33
               IF (NATOLP .GT. 0) GO TO 70
               NRTOLP = 1
            ELSEIF (NATOLP .GT. 0) THEN
               GO TO 50
            ENDIF
         ENDIF
C
         IF (ATOL(K) .LT. 0.) THEN
            WRITE (XERN1, '(I8)') K
            WRITE (XERN3, '(1PE15.6)') ATOL(K)
            CALL XERMSG ('SLATEC', 'LSOD',
     *         'IN DEBDF, THE ABSOLUTE ERROR ' //
     *         'TOLERANCES MUST BE NON-NEGATIVE.$$YOU HAVE CALLED ' //
     *         'THE CODE WITH ATOL(' // XERN1 // ') = ' // XERN3 //
     *         '$$IN THE CASE OF VECTOR ERROR TOLERANCES, NO FURTHER '
     *         // 'CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1)
            IDID=-33
            IF (NRTOLP .GT. 0) GO TO 70
            NATOLP=1
         ENDIF
   50    IF (ITOL .EQ. 0) GO TO 70
   60 CONTINUE
C
   70 IF (ITSTOP .EQ. 1) THEN
         IF (SIGN(1.,TOUT-T) .NE. SIGN(1.,TSTOP-T) .OR.
     1      ABS(TOUT-T) .GT. ABS(TSTOP-T)) THEN
            WRITE (XERN3, '(1PE15.6)') TOUT
            WRITE (XERN4, '(1PE15.6)') TSTOP
            CALL XERMSG ('SLATEC', 'LSOD',
     *         'IN DEBDF, YOU HAVE CALLED THE ' //
     *         'CODE WITH TOUT = ' // XERN3 // '$$BUT YOU HAVE ' //
     *         'ALSO TOLD THE CODE NOT TO INTEGRATE PAST THE POINT ' //
     *         'TSTOP = ' // XERN4 // ' BY SETTING INFO(4) = 1.  ' //
     *         'THESE INSTRUCTIONS CONFLICT.', 14, 1)
            IDID=-33
         ENDIF
      ENDIF
C
C        CHECK SOME CONTINUATION POSSIBILITIES
C
      IF (INIT .NE. 0) THEN
         IF (T .EQ. TOUT) THEN
            WRITE (XERN3, '(1PE15.6)') T
            CALL XERMSG ('SLATEC', 'LSOD',
     *         'IN DEBDF, YOU HAVE CALLED THE CODE WITH T = TOUT = ' //
     *         XERN3 // '  THIS IS NOT ALLOWED ON CONTINUATION CALLS.',
     *         9, 1)
            IDID=-33
         ENDIF
C
         IF (T .NE. TOLD) THEN
            WRITE (XERN3, '(1PE15.6)') TOLD
            WRITE (XERN4, '(1PE15.6)') T
            CALL XERMSG ('SLATEC', 'LSOD',
     *         'IN DEBDF, YOU HAVE CHANGED THE VALUE OF T FROM ' //
     *         XERN3 // ' TO ' // XERN4 //
     *         '  THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 10, 1)
            IDID=-33
         ENDIF
C
         IF (INIT .NE. 1) THEN
            IF (DELSGN*(TOUT-T) .LT. 0.) THEN
               WRITE (XERN3, '(1PE15.6)') TOUT
               CALL XERMSG ('SLATEC', 'LSOD',
     *            'IN DEBDF, BY CALLING THE CODE WITH TOUT = ' //
     *            XERN3 // ' YOU ARE ATTEMPTING TO CHANGE THE ' //
     *            'DIRECTION OF INTEGRATION.$$' //
     *            'THIS IS NOT ALLOWED WITHOUT RESTARTING.', 11, 1)
               IDID=-33
            ENDIF
         ENDIF
      ENDIF
C
      IF (IDID .EQ. (-33)) THEN
         IF (IQUIT .NE. (-33)) THEN
C                       INVALID INPUT DETECTED
            IQUIT=-33
            IBEGIN=-1
         ELSE
            CALL XERMSG ('SLATEC', 'LSOD',
     *         'IN DEBDF, INVALID INPUT WAS ' //
     *         'DETECTED ON SUCCESSIVE ENTRIES.  IT IS IMPOSSIBLE ' //
     *         'TO PROCEED BECAUSE YOU HAVE NOT CORRECTED THE ' //
     *         'PROBLEM, SO EXECUTION IS BEING TERMINATED.', 12, 2)
         ENDIF
         RETURN
      ENDIF
C
C.......................................................................
C
C     RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND INTERPRETED AS
C     ASKING FOR THE MOST ACCURATE SOLUTION POSSIBLE. IN THIS CASE,
C     THE RELATIVE ERROR TOLERANCE RTOL IS RESET TO THE SMALLEST VALUE
C     100*U WHICH IS LIKELY TO BE REASONABLE FOR THIS METHOD AND MACHINE
C
      DO 170 K=1,NEQ
        IF (RTOL(K)+ATOL(K) .GT. 0.) GO TO 160
        RTOL(K)=100.*U
        IDID=-2
  160   IF (ITOL .EQ. 0) GO TO 180
  170   CONTINUE
C
  180 IF (IDID .NE. (-2)) GO TO 190
C                       RTOL=ATOL=0 ON INPUT, SO RTOL IS CHANGED TO A
C                                                SMALL POSITIVE VALUE
      IBEGIN=-1
      RETURN
C
C     BRANCH ON STATUS OF INITIALIZATION INDICATOR
C            INIT=0 MEANS INITIAL DERIVATIVES AND NOMINAL STEP SIZE
C                   AND DIRECTION NOT YET SET
C            INIT=1 MEANS NOMINAL STEP SIZE AND DIRECTION NOT YET SET
C            INIT=2 MEANS NO FURTHER INITIALIZATION REQUIRED
C
  190 IF (INIT .EQ. 0) GO TO 200
      IF (INIT .EQ. 1) GO TO 220
      GO TO 240
C
C.......................................................................
C
C     MORE INITIALIZATION --
C                         -- EVALUATE INITIAL DERIVATIVES
C
  200 INIT=1
      CALL F(T,Y,YH(1,2),RPAR,IPAR)
      NFE=1
      IF (T .NE. TOUT) GO TO 220
      IDID=2
      DO 210 L = 1,NEQ
  210    YPOUT(L) = YH(L,2)
      TOLD=T
      RETURN
C
C                         -- COMPUTE INITIAL STEP SIZE
C                         -- SAVE SIGN OF INTEGRATION DIRECTION
C                         -- SET INDEPENDENT AND DEPENDENT VARIABLES
C                                              X AND YH(*) FOR STOD
C
  220 LTOL = 1
      DO 225 L=1,NEQ
        IF (ITOL .EQ. 1) LTOL = L
        TOL = RTOL(LTOL)*ABS(Y(L)) + ATOL(LTOL)
        IF (TOL .EQ. 0.) GO TO 380
  225   EWT(L) = TOL
C
      BIG = SQRT(R1MACH(2))
      CALL HSTART (F,NEQ,T,TOUT,Y,YH(1,2),EWT,1,U,BIG,
     1             YH(1,3),YH(1,4),YH(1,5),YH(1,6),RPAR,IPAR,H)
C
      DELSGN = SIGN(1.0,TOUT-T)
      X = T
      DO 230 L = 1,NEQ
        YH(L,1) = Y(L)
  230   YH(L,2) = H*YH(L,2)
      INIT = 2
C
C.......................................................................
C
C   ON EACH CALL SET INFORMATION WHICH DETERMINES THE ALLOWED INTERVAL
C   OF INTEGRATION BEFORE RETURNING WITH AN ANSWER AT TOUT
C
  240 DEL = TOUT - T
      ABSDEL = ABS(DEL)
C
C.......................................................................
C
C   IF ALREADY PAST OUTPUT POINT, INTERPOLATE AND RETURN
C
  250 IF (ABS(X-T) .LT. ABSDEL) GO TO 270
      CALL INTYD(TOUT,0,YH,NEQ,Y,INTFLG)
      CALL INTYD(TOUT,1,YH,NEQ,YPOUT,INTFLG)
      IDID = 3
      IF (X .NE. TOUT) GO TO 260
      IDID = 2
      INTOUT = .FALSE.
  260 T = TOUT
      TOLD = T
      RETURN
C
C   IF CANNOT GO PAST TSTOP AND SUFFICIENTLY CLOSE,
C   EXTRAPOLATE AND RETURN
C
  270 IF (ITSTOP .NE. 1) GO TO 290
      IF (ABS(TSTOP-X) .GE. 100.*U*ABS(X)) GO TO 290
      DT = TOUT - X
      DO 280 L = 1,NEQ
  280   Y(L) = YH(L,1) + (DT/H)*YH(L,2)
      CALL F(TOUT,Y,YPOUT,RPAR,IPAR)
      NFE = NFE + 1
      IDID = 3
      T = TOUT
      TOLD = T
      RETURN
C
  290 IF (IINTEG .EQ. 0  .OR.  .NOT.INTOUT) GO TO 300
C
C   INTERMEDIATE-OUTPUT MODE
C
      IDID = 1
      GO TO 500
C
C.......................................................................
C
C     MONITOR NUMBER OF STEPS ATTEMPTED
C
  300 IF (KSTEPS .LE. MAXNUM) GO TO 330
C
C                       A SIGNIFICANT AMOUNT OF WORK HAS BEEN EXPENDED
      IDID=-1
      KSTEPS=0
      IBEGIN = -1
      GO TO 500
C
C.......................................................................
C
C   LIMIT STEP SIZE AND SET WEIGHT VECTOR
C
  330 HMIN = 100.*U*ABS(X)
      HA = MAX(ABS(H),HMIN)
      IF (ITSTOP .NE. 1) GO TO 340
      HA = MIN(HA,ABS(TSTOP-X))
  340 H = SIGN(HA,H)
      LTOL = 1
      DO 350 L = 1,NEQ
        IF (ITOL .EQ. 1) LTOL = L
        EWT(L) = RTOL(LTOL)*ABS(YH(L,1)) + ATOL(LTOL)
        IF (EWT(L) .LE. 0.0) GO TO 380
  350   CONTINUE
      TOLFAC = U*VNWRMS(NEQ,YH,EWT)
      IF (TOLFAC .LE. 1.) GO TO 400
C
C                       TOLERANCES TOO SMALL
      IDID = -2
      TOLFAC = 2.*TOLFAC
      RTOL(1) = TOLFAC*RTOL(1)
      ATOL(1) = TOLFAC*ATOL(1)
      IF (ITOL .EQ. 0) GO TO 370
      DO 360 L = 2,NEQ
        RTOL(L) = TOLFAC*RTOL(L)
  360   ATOL(L) = TOLFAC*ATOL(L)
  370 IBEGIN = -1
      GO TO 500
C
C                       RELATIVE ERROR CRITERION INAPPROPRIATE
  380 IDID = -3
      IBEGIN = -1
      GO TO 500
C
C.......................................................................
C
C     TAKE A STEP
C
  400 CALL STOD(NEQ,Y,YH,NEQ,YH1,EWT,SAVF,ACOR,WM,IWM,F,JAC,RPAR,IPAR)
C
      JSTART = -2
      INTOUT = .TRUE.
      IF (KFLAG .EQ. 0) GO TO 250
C
C.......................................................................
C
      IF (KFLAG .EQ. -1) GO TO 450
C
C                       REPEATED CORRECTOR CONVERGENCE FAILURES
      IDID = -6
      IBEGIN = -1
      GO TO 500
C
C                       REPEATED ERROR TEST FAILURES
  450 IDID = -7
      IBEGIN = -1
C
C.......................................................................
C
C                       STORE VALUES BEFORE RETURNING TO DEBDF
  500 DO 555 L = 1,NEQ
        Y(L) = YH(L,1)
  555   YPOUT(L) = YH(L,2)/H
      T = X
      TOLD = T
      INTOUT = .FALSE.
      RETURN
      END
*DECK LSSODS
      SUBROUTINE LSSODS (A, X, B, M, N, NRDA, IFLAG, IRANK, ISCALE, Q,
     +   DIAG, KPIVOT, ITER, RESNRM, XNORM, Z, R, DIV, TD, SCALES)
C***BEGIN PROLOGUE  LSSODS
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BVSUP
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (LSSODS-S)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     LSSODS solves the same problem as SODS (in fact, it is called by
C     SODS) but is somewhat more flexible in its use. In particular,
C     LSSODS allows for iterative refinement of the solution, makes the
C     transformation and triangular reduction information more
C     accessible, and enables the user to avoid destruction of the
C     original matrix A.
C
C     Modeled after the ALGOL codes in the articles in the REFERENCES
C     section.
C
C **********************************************************************
C   INPUT
C **********************************************************************
C
C     A -- Contains the matrix of M equations in N unknowns and must
C          be dimensioned NRDA by N. A remains unchanged
C     X -- Solution array of length at least N
C     B -- Given constant vector of length M, B remains unchanged
C     M -- Number of equations, M greater or equal to 1
C     N -- Number of unknowns, N not larger than M
C  NRDA -- Row dimension of A, NRDA greater or equal to M
C IFLAG -- Status indicator
C         = 0 for the first call (and for each new problem defined by
C             a new matrix A) when the matrix data is treated as exact
C         =-K for the first call (and for each new problem defined by
C             a new matrix A) when the matrix data is assumed to be
C             accurate to about K digits
C         = 1 for subsequent calls whenever the matrix A has already
C             been decomposed (problems with new vectors B but
C             same matrix a can be handled efficiently)
C ISCALE -- Scaling indicator
C         =-1 if the matrix A is to be pre-scaled by
C             columns when appropriate
C             If the scaling indicator is not equal to -1
C             no scaling will be attempted
C             For most problems scaling will probably not be necessary
C   ITER -- Maximum number of iterative improvement steps to be
C           performed,  0 .LE. ITER .LE. 10   (SODS uses ITER=0)
C      Q -- Matrix used for the transformation, must be dimensioned
C           NRDA by N  (SODS puts A in the Q location which conserves
C           storage but destroys A)
C           When iterative improvement of the solution is requested,
C           ITER .GT. 0, this additional storage for Q must be
C           made available
C DIAG,KPIVOT,Z,R, -- Arrays of length N (except for R which is M)
C   DIV,TD,SCALES     used for internal storage
C
C **********************************************************************
C   OUTPUT
C **********************************************************************
C
C  IFLAG -- Status indicator
C            =1 if solution was obtained
C            =2 if improper input is detected
C            =3 if rank of matrix is less than N
C               if the minimal length least squares solution is
C               desired, simply reset IFLAG=1 and call the code again
C
C       The next three IFLAG values can occur only when
C        the iterative improvement mode is being used.
C            =4 if the problem is ill-conditioned and maximal
C               machine accuracy is not achievable
C            =5 if the problem is very ill-conditioned and the solution
C               IS likely to have no correct digits
C            =6 if the allowable number of iterative improvement steps
C               has been completed without getting convergence
C      X -- Least squares solution of  A X = B
C  IRANK -- Contains the numerically determined matrix rank
C           the user must not alter this value on succeeding calls
C           with input values of IFLAG=1
C      Q -- Contains the strictly upper triangular part of the reduced
C           matrix and the transformation information in the lower
C           triangular part
C   DIAG -- Contains the diagonal elements of the triangular reduced
C           matrix
C KPIVOT -- Contains the pivotal information.  The column interchanges
C           performed on the original matrix are recorded here
C   ITER -- The actual number of iterative corrections used
C RESNRM -- The Euclidean norm of the residual vector  B - A X
C  XNORM -- The Euclidean norm of the solution vector
C DIV,TD -- Contains transformation information for rank
C           deficient problems
C SCALES -- Contains the column scaling parameters
C
C **********************************************************************
C
C***SEE ALSO  BVSUP
C***REFERENCES  G. Golub, Numerical methods for solving linear least
C                 squares problems, Numerische Mathematik 7, (1965),
C                 pp. 206-216.
C               P. Businger and G. Golub, Linear least squares
C                 solutions by Householder transformations, Numerische
C                 Mathematik  7, (1965), pp. 269-276.
C***ROUTINES CALLED  J4SAVE, OHTROR, ORTHOL, R1MACH, SDOT, SDSDOT,
C                    XERMAX, XERMSG, XGETF, XSETF
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900402  Added TYPE section.  (WRB)
C   910408  Updated the REFERENCES section.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  LSSODS
      DIMENSION A(NRDA,*),X(*),B(*),Q(NRDA,*),DIAG(*),
     1          Z(*),KPIVOT(*),R(*),DIV(*),TD(*),SCALES(*)
C
C **********************************************************************
C
C     MACHINE PRECISION (COMPUTER UNIT ROUNDOFF VALUE) IS DEFINED
C     THE FUNCTION R1MACH.
C
C***FIRST EXECUTABLE STATEMENT  LSSODS
      URO = R1MACH(3)
C
C **********************************************************************
C
      IF (N .LT. 1  .OR.  M .LT. N  .OR.  NRDA .LT. M) GO TO 1
      IF (ITER .LT. 0) GO TO 1
      IF (IFLAG .LE. 0) GO TO 5
      IF (IFLAG .EQ. 1) GO TO 15
C
C     INVALID INPUT FOR LSSODS
    1 IFLAG=2
      CALL XERMSG ('SLATEC', 'LSSODS', 'INVALID INPUT PARAMETERS.', 2,
     +   1)
      RETURN
C
    5 CALL XGETF (NFATAL)
      MAXMES = J4SAVE (4,0,.FALSE.)
      IF (IFLAG .EQ. 0) GO TO 7
      NFAT = -1
      IF(NFATAL .EQ. 0) NFAT=0
      CALL XSETF (NFAT)
      CALL XERMAX (1)
C
C     COPY MATRIX A INTO MATRIX Q
C
    7 DO 10 J=1,N
         DO 10 K=1,M
   10       Q(K,J)=A(K,J)
C
C     USE ORTHOGONAL TRANSFORMATIONS TO REDUCE Q TO
C     UPPER TRIANGULAR FORM
C
      CALL ORTHOL(Q,M,N,NRDA,IFLAG,IRANK,ISCALE,DIAG,KPIVOT,SCALES,Z,TD)
C
      CALL XSETF (NFATAL)
      CALL XERMAX (MAXMES)
      IF (IRANK .EQ. N) GO TO 12
C
C     FOR RANK DEFICIENT PROBLEMS USE ADDITIONAL ORTHOGONAL
C     TRANSFORMATIONS TO FURTHER REDUCE Q
C
      IF (IRANK .NE. 0) CALL OHTROR(Q,N,NRDA,DIAG,IRANK,DIV,TD)
      RETURN
C
C     STORE DIVISORS FOR THE TRIANGULAR SOLUTION
C
   12 DO 13 K=1,N
   13    DIV(K)=DIAG(K)
C
   15 IRM=IRANK-1
      IRP=IRANK+1
      ITERP=MIN(ITER+1,11)
      ACC=10.*URO
C
C     ZERO OUT SOLUTION ARRAY
C
      DO 20 K=1,N
   20    X(K)=0.
C
      IF (IRANK .GT. 0) GO TO 25
C
C     SPECIAL CASE FOR THE NULL MATRIX
      ITER=0
      XNORM=0.
      RESNRM=SQRT(SDOT(M,B(1),1,B(1),1))
      RETURN
C
C     COPY CONSTANT VECTOR INTO R
C
   25 DO 30 K=1,M
   30    R(K)=B(K)
C
C **********************************************************************
C     SOLUTION SECTION
C     ITERATIVE REFINEMENT OF THE RESIDUAL VECTOR
C **********************************************************************
C
      DO 100 IT=1,ITERP
         ITER=IT-1
C
C        APPLY ORTHOGONAL TRANSFORMATION TO R
C
         DO 35 J=1,IRANK
            MJ=M-J+1
            GAMMA=SDOT(MJ,Q(J,J),1,R(J),1)/(DIAG(J)*Q(J,J))
            DO 35 K=J,M
   35          R(K)=R(K)+GAMMA*Q(K,J)
C
C        BACKWARD SUBSTITUTION FOR TRIANGULAR SYSTEM SOLUTION
C
         Z(IRANK)=R(IRANK)/DIV(IRANK)
         IF (IRM .EQ. 0) GO TO 45
         DO 40 L=1,IRM
            K=IRANK-L
            KP=K+1
   40       Z(K)=(R(K)-SDOT(L,Q(K,KP),NRDA,Z(KP),1))/DIV(K)
C
   45    IF (IRANK .EQ. N) GO TO 60
C
C        FOR RANK DEFICIENT PROBLEMS OBTAIN THE
C        MINIMAL LENGTH SOLUTION
C
         NMIR=N-IRANK
         DO 50 K=IRP,N
   50       Z(K)=0.
         DO 55 K=1,IRANK
            GAM=((TD(K)*Z(K))+SDOT(NMIR,Q(K,IRP),NRDA,Z(IRP),1))/
     1                (TD(K)*DIV(K))
            Z(K)=Z(K)+GAM*TD(K)
            DO 55 J=IRP,N
   55          Z(J)=Z(J)+GAM*Q(K,J)
C
C        REORDER SOLUTION COMPONENTS ACCORDING TO PIVOTAL POINTS
C        AND RESCALE ANSWERS AS DICTATED
C
   60    DO 65 K=1,N
            Z(K)=Z(K)*SCALES(K)
            L=KPIVOT(K)
   65       X(L)=X(L)+Z(K)
C
C        COMPUTE CORRECTION VECTOR NORM (SOLUTION NORM)
C
         ZNORM=SQRT(SDOT(N,Z(1),1,Z(1),1))
         IF (IT .EQ. 1) XNORM=ZNORM
         IF (ITERP .GT. 1) GO TO 80
C
C        NO ITERATIVE CORRECTIONS TO BE PERFORMED, SO COMPUTE
C        THE APPROXIMATE RESIDUAL NORM DEFINED BY THE EQUATIONS
C        WHICH ARE NOT SATISFIED BY THE SOLUTION
C        THEN WE ARE DONE
C
         MMIR=M-IRANK
         IF (MMIR .EQ. 0) GO TO 70
         RESNRM=SQRT(SDOT(MMIR,R(IRP),1,R(IRP),1))
         RETURN
   70    RESNRM=0.
         RETURN
C
C        COMPUTE RESIDUAL VECTOR FOR THE ITERATIVE IMPROVEMENT PROCESS
C
   80    DO 85 K=1,M
   85       R(K)=-SDSDOT(N,-B(K),A(K,1),NRDA,X(1),1)
         RESNRM=SQRT(SDOT(M,R(1),1,R(1),1))
         IF (IT .EQ. 1) GO TO 100
C
C        TEST FOR CONVERGENCE
C
         IF (ZNORM .LE. ACC*XNORM) RETURN
C
C        COMPARE SUCCESSIVE REFINEMENT VECTOR NORMS
C        FOR LOOP TERMINATION CRITERIA
C
         IF (ZNORM .LE. 0.25*ZNRM0) GO TO 100
         IF (IT .EQ. 2) GO TO 90
C
         IFLAG=4
         CALL XERMSG ('SLATEC', 'LSSODS',
     +   'PROBLEM MAY BE ILL-CONDITIONED.  MAXIMAL MACHINE ACCURACY ' //
     +   'IS NOT ACHIEVABLE.', 3, 1)
         RETURN
C
   90    IFLAG=5
         CALL XERMSG ('SLATEC', 'LSSODS',
     +      'PROBLEM IS VERY ILL-CONDITIONED.  ITERATIVE ' //
     +      'IMPROVEMENT IS INEFFECTIVE.', 8, 1)
         RETURN
C
  100    ZNRM0=ZNORM
C **********************************************************************
C
C **********************************************************************
      IFLAG=6
         CALL XERMSG ('SLATEC', 'LSSODS',
     +      'CONVERGENCE HAS NOT BEEN OBTAINED WITH ALLOWABLE ' //
     +      'NUMBER OF ITERATIVE IMPROVEMENT STEPS.', 8, 1)
C
      RETURN
      END
*DECK LSSUDS
      SUBROUTINE LSSUDS (A, X, B, N, M, NRDA, U, NRDU, IFLAG, MLSO,
     +   IRANK, ISCALE, Q, DIAG, KPIVOT, S, DIV, TD, ISFLG, SCALES)
C***BEGIN PROLOGUE  LSSUDS
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BVSUP
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (LSSUDS-S, DLSSUD-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C    LSSUDS solves the underdetermined system of equations  A Z = B,
C    where A is N by M and N .LE. M.  In particular, if rank A equals
C    IRA, a vector X and a matrix U are determined such that X is the
C    UNIQUE solution of smallest length, satisfying A X = B, and the
C    columns of U form an orthonormal basis for the null space of A,
C    satisfying A U = 0 .  Then all solutions Z are given by
C              Z = X + C(1)*U(1) + ..... + C(M-IRA)*U(M-IRA)
C    where U(J) represents the J-th column of U and the C(J) are
C    arbitrary constants.
C    If the system of equations are not compatible, only the least
C    squares solution of minimal length is computed.
C
C *********************************************************************
C   INPUT
C *********************************************************************
C
C     A -- Contains the matrix of N equations in M unknowns, A remains
C          unchanged, must be dimensioned NRDA by M.
C     X -- Solution array of length at least M.
C     B -- Given constant vector of length N, B remains unchanged.
C     N -- Number of equations, N greater or equal to 1.
C     M -- Number of unknowns, M greater or equal to N.
C     NRDA -- Row dimension of A, NRDA greater or equal to N.
C     U -- Matrix used for solution, must be dimensioned NRDU by
C          (M - rank of A).
C          (storage for U may be ignored when only the minimal length
C           solution X is desired)
C     NRDU -- Row dimension of U, NRDU greater or equal to M.
C             (if only the minimal length solution is wanted,
C              NRDU=0 is acceptable)
C     IFLAG -- Status indicator
C           =0  for the first call (and for each new problem defined by
C               a new matrix A) when the matrix data is treated as exact
C           =-K for the first call (and for each new problem defined by
C               a new matrix A) when the matrix data is assumed to be
C               accurate to about K digits.
C           =1  for subsequent calls whenever the matrix A has already
C               been decomposed (problems with new vectors B but
C               same matrix A can be handled efficiently).
C     MLSO -- =0 if only the minimal length solution is wanted.
C             =1 if the complete solution is wanted, includes the
C                linear space defined by the matrix U.
C     IRANK -- Variable used for the rank of A, set by the code.
C     ISCALE -- Scaling indicator
C               =-1 if the matrix A is to be pre-scaled by
C               columns when appropriate.
C               If the scaling indicator is not equal to -1
C               no scaling will be attempted.
C            For most problems scaling will probably not be necessary.
C     Q -- Matrix used for the transformation, must be dimensioned
C            NRDA by M.
C     DIAG,KPIVOT,S, -- Arrays of length at least N used for internal
C      DIV,TD,SCALES    storage (except for SCALES which is M).
C     ISFLG -- Storage for an internal variable.
C
C *********************************************************************
C   OUTPUT
C *********************************************************************
C
C     IFLAG -- Status indicator
C            =1 if solution was obtained.
C            =2 if improper input is detected.
C            =3 if rank of matrix is less than N.
C               To continue, simply reset IFLAG=1 and call LSSUDS again.
C            =4 if the system of equations appears to be inconsistent.
C               However, the least squares solution of minimal length
C               was obtained.
C     X -- Minimal length least squares solution of A Z = B
C     IRANK -- Numerically determined rank of A, must not be altered
C              on succeeding calls with input values of IFLAG=1.
C     U -- Matrix whose M-IRANK columns are mutually orthogonal unit
C          vectors which span the null space of A. This is to be ignored
C          when MLSO was set to zero or IFLAG=4 on output.
C     Q -- Contains the strictly upper triangular part of the reduced
C           matrix and transformation information.
C     DIAG -- Contains the diagonal elements of the triangular reduced
C             matrix.
C     KPIVOT -- Contains the pivotal information.  The row interchanges
C               performed on the original matrix are recorded here.
C     S -- Contains the solution of the lower triangular system.
C     DIV,TD -- Contains transformation information for rank
C               deficient problems.
C     SCALES -- Contains the column scaling parameters.
C
C *********************************************************************
C
C***SEE ALSO  BVSUP
C***REFERENCES  H. A. Watts, Solving linear least squares problems
C                 using SODS/SUDS/CODS, Sandia Report SAND77-0683,
C                 Sandia Laboratories, 1977.
C***ROUTINES CALLED  J4SAVE, OHTROL, ORTHOR, R1MACH, SDOT, XERMAX,
C                    XERMSG, XGETF, XSETF
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900328  Added TYPE section.  (WRB)
C   900510  Fixed an error message.  (RWC)
C   910408  Updated the AUTHOR and REFERENCES sections.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  LSSUDS
      DIMENSION A(NRDA,*),X(*),B(*),U(NRDU,*),Q(NRDA,*),
     1          DIAG(*),KPIVOT(*),S(*),DIV(*),TD(*),SCALES(*)
C
C **********************************************************************
C
C     MACHINE PRECISION (COMPUTER UNIT ROUNDOFF VALUE) IS DEFINED
C     BY THE FUNCTION R1MACH.
C
C***FIRST EXECUTABLE STATEMENT  LSSUDS
      URO = R1MACH(4)
C
C **********************************************************************
C
      IF (N .LT. 1  .OR.  M .LT. N  .OR.  NRDA .LT. N) GO TO 1
      IF (NRDU .NE. 0  .AND.  NRDU .LT. M) GO TO 1
      IF (IFLAG .LE. 0) GO TO 5
      IF (IFLAG .EQ. 1) GO TO 25
C
C     INVALID INPUT FOR LSSUDS
    1 IFLAG=2
      CALL XERMSG ('SLATEC', 'LSSUDS', 'INVALID INPUT PARAMETERS.', 2,
     +   1)
      RETURN
C
    5 CALL XGETF(NFATAL)
      MAXMES = J4SAVE (4,0,.FALSE.)
      ISFLG=-15
      IF (IFLAG .EQ. 0) GO TO 7
      ISFLG=IFLAG
      NFAT = -1
      IF (NFATAL .EQ. 0) NFAT=0
      CALL XSETF(NFAT)
      CALL XERMAX(1)
C
C     COPY MATRIX A INTO MATRIX Q
C
    7 DO 10 K=1,M
         DO 10 J=1,N
   10       Q(J,K)=A(J,K)
C
C     USE ORTHOGONAL TRANSFORMATIONS TO REDUCE Q TO LOWER
C     TRIANGULAR FORM
C
      CALL ORTHOR(Q,N,M,NRDA,IFLAG,IRANK,ISCALE,DIAG,KPIVOT,SCALES,
     1            DIV,TD)
C
      CALL XSETF(NFATAL)
      CALL XERMAX(MAXMES)
      IF (IRANK .EQ. N) GO TO 15
C
C     FOR RANK DEFICIENT PROBLEMS USE ADDITIONAL ORTHOGONAL
C     TRANSFORMATIONS TO FURTHER REDUCE Q
C
      IF (IRANK .NE. 0) CALL OHTROL(Q,N,NRDA,DIAG,IRANK,DIV,TD)
      RETURN
C
C     STORE DIVISORS FOR THE TRIANGULAR SOLUTION
C
   15 DO 20 K=1,N
   20    DIV(K)=DIAG(K)
C
C
   25 IF (IRANK .GT. 0) GO TO 40
C
C     SPECIAL CASE FOR THE NULL MATRIX
      DO 35 K=1,M
         X(K)=0.
         IF (MLSO .EQ. 0) GO TO 35
         U(K,K)=1.
         DO 30 J=1,M
            IF (J .EQ. K) GO TO 30
            U(J,K)=0.
   30    CONTINUE
   35 CONTINUE
      DO 37 K=1,N
         IF (B(K) .GT. 0.) IFLAG=4
   37 CONTINUE
      RETURN
C
C     COPY CONSTANT VECTOR INTO S AFTER FIRST INTERCHANGING
C     THE ELEMENTS ACCORDING TO THE PIVOTAL SEQUENCE
C
   40 DO 45 K=1,N
         KP=KPIVOT(K)
   45    X(K)=B(KP)
      DO 50 K=1,N
   50    S(K)=X(K)
C
      IRP=IRANK+1
      NU=1
      IF (MLSO .EQ. 0) NU=0
      IF (IRANK .EQ. N) GO TO 60
C
C     FOR RANK DEFICIENT PROBLEMS WE MUST APPLY THE
C     ORTHOGONAL TRANSFORMATION TO S
C     WE ALSO CHECK TO SEE IF THE SYSTEM APPEARS TO BE INCONSISTENT
C
      NMIR=N-IRANK
      SS=SDOT(N,S(1),1,S(1),1)
      DO 55 L=1,IRANK
         K=IRP-L
         GAM=((TD(K)*S(K))+SDOT(NMIR,Q(IRP,K),1,S(IRP),1))/
     1             (TD(K)*DIV(K))
         S(K)=S(K)+GAM*TD(K)
         DO 55 J=IRP,N
   55       S(J)=S(J)+GAM*Q(J,K)
      RES=SDOT(NMIR,S(IRP),1,S(IRP),1)
      IF (RES .LE. SS*(10.*MAX(10.**ISFLG,10.*URO))**2) GO TO 60
C
C     INCONSISTENT SYSTEM
      IFLAG=4
      NU=0
C
C     APPLY FORWARD SUBSTITUTION TO SOLVE LOWER TRIANGULAR SYSTEM
C
   60 S(1)=S(1)/DIV(1)
      IF (IRANK .EQ. 1) GO TO 70
      DO 65 K=2,IRANK
   65    S(K)=(S(K)-SDOT(K-1,Q(K,1),NRDA,S(1),1))/DIV(K)
C
C     INITIALIZE X VECTOR AND THEN APPLY ORTHOGONAL TRANSFORMATION
C
   70 DO 75 K=1,M
         X(K)=0.
         IF (K .LE. IRANK) X(K)=S(K)
   75 CONTINUE
C
      DO 80 JR=1,IRANK
         J=IRP-JR
         MJ=M-J+1
         GAMMA=SDOT(MJ,Q(J,J),NRDA,X(J),1)/(DIAG(J)*Q(J,J))
         DO 80 K=J,M
   80       X(K)=X(K)+GAMMA*Q(J,K)
C
C     RESCALE ANSWERS AS DICTATED
C
      DO 85 K=1,M
   85    X(K)=X(K)*SCALES(K)
C
      IF ((NU .EQ. 0) .OR. (M .EQ. IRANK)) RETURN
C
C     INITIALIZE U MATRIX AND THEN APPLY ORTHOGONAL TRANSFORMATION
C
      L=M-IRANK
      DO 100 K=1,L
         DO 90 I=1,M
            U(I,K)=0.
            IF (I .EQ. IRANK+K) U(I,K)=1.
   90    CONTINUE
C
         DO 100 JR=1,IRANK
            J=IRP-JR
            MJ=M-J+1
            GAMMA=SDOT(MJ,Q(J,J),NRDA,U(J,K),1)/(DIAG(J)*Q(J,J))
            DO 100 I=J,M
  100          U(I,K)=U(I,K)+GAMMA*Q(J,I)
C
      RETURN
      END
