*DECK U11LS
      SUBROUTINE U11LS (A, MDA, M, N, UB, DB, MODE, NP, KRANK, KSURE, H,
     +   W, EB, IC, IR)
C***BEGIN PROLOGUE  U11LS
C***SUBSIDIARY
C***PURPOSE  Subsidiary to LLSIA
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (U11LS-S, DU11LS-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C       This routine performs a QR factorization of A
C       using Householder transformations. Row and
C       column pivots are chosen to reduce the growth
C       of round-off and to help detect possible rank
C       deficiency.
C
C***SEE ALSO  LLSIA
C***ROUTINES CALLED  ISAMAX, ISWAP, SAXPY, SDOT, SNRM2, SSCAL, SSWAP,
C                    XERMSG
C***REVISION HISTORY  (YYMMDD)
C   810801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891009  Removed unreferenced variable.  (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***END PROLOGUE  U11LS
      DIMENSION A(MDA,*),UB(*),DB(*),H(*),W(*),EB(*)
      INTEGER IC(*),IR(*)
C
C        INITIALIZATION
C
C***FIRST EXECUTABLE STATEMENT  U11LS
      J=0
      KRANK=N
      DO 10 I=1,N
      IC(I)=I
   10 CONTINUE
      DO 12 I=1,M
      IR(I)=I
   12 CONTINUE
C
C        DETERMINE REL AND ABS ERROR VECTORS
C
C
C
C        CALCULATE COL LENGTH
C
      DO 30 I=1,N
      H(I)=SNRM2(M,A(1,I),1)
      W(I)=H(I)
   30 CONTINUE
C
C         INITIALIZE ERROR BOUNDS
C
      DO  40 I=1,N
      EB(I)=MAX(DB(I),UB(I)*H(I))
      UB(I)=EB(I)
      DB(I)=0.0
   40 CONTINUE
C
C          DISCARD SELF DEPENDENT COLUMNS
C
      I=1
   50 IF(EB(I).GE.H(I)) GO TO 60
      IF(I.EQ.KRANK) GO TO 70
      I=I+1
      GO TO 50
C
C          MATRIX REDUCTION
C
   60 CONTINUE
      KK=KRANK
      KRANK=KRANK-1
      IF(MODE.EQ.0) RETURN
      IF(I.GT.NP) GO TO  64
      CALL XERMSG ('SLATEC', 'U11LS',
     +   'FIRST NP COLUMNS ARE LINEARLY DEPENDENT', 8, 0)
      KRANK=I-1
      RETURN
   64 CONTINUE
      IF(I.GT.KRANK) GO TO 70
      CALL SSWAP(1,EB(I),1,EB(KK),1)
      CALL SSWAP(1,UB(I),1,UB(KK),1)
      CALL SSWAP(1,W(I),1,W(KK),1)
      CALL SSWAP(1,H(I),1,H(KK),1)
      CALL ISWAP(1,IC(I),1,IC(KK),1)
      CALL SSWAP(M,A(1,I),1,A(1,KK),1)
      GO TO 50
C
C           TEST FOR ZERO RANK
C
   70 IF(KRANK.GT.0) GO TO 80
      KRANK=0
      KSURE=0
      RETURN
   80 CONTINUE
C
C        M A I N    L O O P
C
  110 CONTINUE
      J=J+1
      JP1=J+1
      JM1=J-1
      KZ=KRANK
      IF(J.LE.NP) KZ=J
C
C        EACH COL HAS MM=M-J+1 COMPONENTS
C
      MM=M-J+1
C
C         UB DETERMINES COLUMN PIVOT
C
  115 IMIN=J
      IF(H(J).EQ.0.) GO TO 170
      RMIN=UB(J)/H(J)
      DO 120 I=J,KZ
      IF(UB(I).GE.H(I)*RMIN) GO TO 120
      RMIN=UB(I)/H(I)
      IMIN=I
  120 CONTINUE
C
C     TEST FOR RANK DEFICIENCY
C
      IF(RMIN.LT.1.0) GO TO 200
      TT=(EB(IMIN)+ABS(DB(IMIN)))/H(IMIN)
      IF(TT.GE.1.0) GO TO 170
C     COMPUTE EXACT UB
      DO 125 I=1,JM1
      W(I)=A(I,IMIN)
  125 CONTINUE
      L=JM1
  130 W(L)=W(L)/A(L,L)
      IF(L.EQ.1) GO TO 150
      LM1=L-1
      DO 140 I=L,JM1
      W(LM1)=W(LM1)-A(LM1,I)*W(I)
  140 CONTINUE
      L=LM1
      GO TO 130
  150 TT=EB(IMIN)
      DO 160 I=1,JM1
      TT=TT+ABS(W(I))*EB(I)
  160 CONTINUE
      UB(IMIN)=TT
      IF(UB(IMIN)/H(IMIN).GE.1.0) GO TO 170
      GO TO 200
C
C        MATRIX REDUCTION
C
  170 CONTINUE
      KK=KRANK
      KRANK=KRANK-1
      KZ=KRANK
      IF(MODE.EQ.0) RETURN
      IF(J.GT.NP) GO TO 172
      CALL XERMSG ('SLATEC', 'U11LS',
     +   'FIRST NP COLUMNS ARE LINEARLY DEPENDENT', 8, 0)
      KRANK=J-1
      RETURN
  172 CONTINUE
      IF(IMIN.GT.KRANK) GO TO 180
      CALL ISWAP(1,IC(IMIN),1,IC(KK),1)
      CALL SSWAP(M,A(1,IMIN),1,A(1,KK),1)
      CALL SSWAP(1,EB(IMIN),1,EB(KK),1)
      CALL SSWAP(1,UB(IMIN),1,UB(KK),1)
      CALL SSWAP(1,DB(IMIN),1,DB(KK),1)
      CALL SSWAP(1,W(IMIN),1,W(KK),1)
      CALL SSWAP(1,H(IMIN),1,H(KK),1)
  180 IF(J.GT.KRANK) GO TO 300
      GO TO 115
C
C        COLUMN PIVOT
C
  200 IF(IMIN.EQ.J) GO TO 230
      CALL SSWAP(1,H(J),1,H(IMIN),1)
      CALL SSWAP(M,A(1,J),1,A(1,IMIN),1)
      CALL SSWAP(1,EB(J),1,EB(IMIN),1)
      CALL SSWAP(1,UB(J),1,UB(IMIN),1)
      CALL SSWAP(1,DB(J),1,DB(IMIN),1)
      CALL SSWAP(1,W(J),1,W(IMIN),1)
      CALL ISWAP(1,IC(J),1,IC(IMIN),1)
C
C        ROW PIVOT
C
  230 CONTINUE
      JMAX=ISAMAX(MM,A(J,J),1)
      JMAX=JMAX+J-1
      IF(JMAX.EQ.J) GO TO 240
      CALL SSWAP(N,A(J,1),MDA,A(JMAX,1),MDA)
      CALL ISWAP(1,IR(J),1,IR(JMAX),1)
  240 CONTINUE
C
C     APPLY HOUSEHOLDER TRANSFORMATION
C
      TN=SNRM2(MM,A(J,J),1)
      IF(TN.EQ.0.0) GO TO 170
      IF(A(J,J).NE.0.0) TN=SIGN(TN,A(J,J))
      CALL SSCAL(MM,1.0/TN,A(J,J),1)
      A(J,J)=A(J,J)+1.0
      IF(J.EQ.N) GO TO 250
      DO 248 I=JP1,N
      BB=-SDOT(MM,A(J,J),1,A(J,I),1)/A(J,J)
      CALL SAXPY(MM,BB,A(J,J),1,A(J,I),1)
      IF(I.LE.NP) GO TO 248
      IF(H(I).EQ.0.0) GO TO 248
      TT=1.0-(ABS(A(J,I))/H(I))**2
      TT=MAX(TT,0.0)
      T=TT
      TT=1.0+.05*TT*(H(I)/W(I))**2
      IF(TT.EQ.1.0) GO TO 244
      H(I)=H(I)*SQRT(T)
      GO TO 246
  244 CONTINUE
      H(I)=SNRM2(M-J,A(J+1,I),1)
      W(I)=H(I)
  246 CONTINUE
  248 CONTINUE
  250 CONTINUE
      H(J)=A(J,J)
      A(J,J)=-TN
C
C
C          UPDATE UB, DB
C
      UB(J)=UB(J)/ABS(A(J,J))
      DB(J)=(SIGN(EB(J),DB(J))+DB(J))/A(J,J)
      IF(J.EQ.KRANK) GO TO 300
      DO 260 I=JP1,KRANK
      UB(I)=UB(I)+ABS(A(J,I))*UB(J)
      DB(I)=DB(I)-A(J,I)*DB(J)
  260 CONTINUE
      GO TO 110
C
C        E N D    M A I N    L O O P
C
  300 CONTINUE
C
C        COMPUTE KSURE
C
      KM1=KRANK-1
      DO 318 I=1,KM1
      IS=0
      KMI=KRANK-I
      DO 315 II=1,KMI
      IF(UB(II).LE.UB(II+1)) GO TO 315
      IS=1
      TEMP=UB(II)
      UB(II)=UB(II+1)
      UB(II+1)=TEMP
  315 CONTINUE
      IF(IS.EQ.0) GO TO 320
  318 CONTINUE
  320 CONTINUE
      KSURE=0
      SUM=0.0
      DO 328 I=1,KRANK
      R2=UB(I)*UB(I)
      IF(R2+SUM.GE.1.0) GO TO 330
      SUM=SUM+R2
      KSURE=KSURE+1
  328 CONTINUE
  330 CONTINUE
C
C     IF SYSTEM IS OF REDUCED RANK AND MODE = 2
C     COMPLETE THE DECOMPOSITION FOR SHORTEST LEAST SQUARES SOLUTION
C
      IF(KRANK.EQ.N .OR. MODE.LT.2) GO TO 360
      NMK=N-KRANK
      KP1=KRANK+1
      I=KRANK
  340 TN=SNRM2(NMK,A(I,KP1),MDA)/A(I,I)
      TN=A(I,I)*SQRT(1.0+TN*TN)
      CALL SSCAL(NMK,1.0/TN,A(I,KP1),MDA)
      W(I)=A(I,I)/TN+1.0
      A(I,I)=-TN
      IF(I.EQ.1) GO TO 350
      IM1=I-1
      DO 345 II=1,IM1
      TT=-SDOT(NMK,A(II,KP1),MDA,A(I,KP1),MDA)/W(I)
      TT=TT-A(II,I)
      CALL SAXPY(NMK,TT,A(I,KP1),MDA,A(II,KP1),MDA)
      A(II,I)=A(II,I)+TT*W(I)
  345 CONTINUE
      I=I-1
      GO TO 340
  350 CONTINUE
  360 CONTINUE
      RETURN
      END
*DECK U11US
      SUBROUTINE U11US (A, MDA, M, N, UB, DB, MODE, NP, KRANK, KSURE, H,
     +   W, EB, IR, IC)
C***BEGIN PROLOGUE  U11US
C***SUBSIDIARY
C***PURPOSE  Subsidiary to ULSIA
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (U11US-S, DU11US-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C       This routine performs an LQ factorization of the
C       matrix A using Householder transformations. Row
C       and column pivots are chosen to reduce the growth
C       of round-off and to help detect possible rank
C       deficiency.
C
C***SEE ALSO  ULSIA
C***ROUTINES CALLED  ISAMAX, ISWAP, SAXPY, SDOT, SNRM2, SSCAL, SSWAP,
C                    XERMSG
C***REVISION HISTORY  (YYMMDD)
C   810801  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***END PROLOGUE  U11US
      DIMENSION A(MDA,*),UB(*),DB(*),H(*),W(*),EB(*)
      INTEGER IC(*),IR(*)
C
C        INITIALIZATION
C
C***FIRST EXECUTABLE STATEMENT  U11US
      J=0
      KRANK=M
      DO 10 I=1,N
      IC(I)=I
   10 CONTINUE
      DO 12 I=1,M
      IR(I)=I
   12 CONTINUE
C
C        DETERMINE REL AND ABS ERROR VECTORS
C
C
C
C        CALCULATE ROW LENGTH
C
      DO 30 I=1,M
      H(I)=SNRM2(N,A(I,1),MDA)
      W(I)=H(I)
   30 CONTINUE
C
C         INITIALIZE ERROR BOUNDS
C
      DO  40 I=1,M
      EB(I)=MAX(DB(I),UB(I)*H(I))
      UB(I)=EB(I)
      DB(I)=0.0
   40 CONTINUE
C
C          DISCARD SELF DEPENDENT ROWS
C
      I=1
   50 IF(EB(I).GE.H(I)) GO TO 60
      IF(I.EQ.KRANK) GO TO 70
      I=I+1
      GO TO 50
C
C          MATRIX REDUCTION
C
   60 CONTINUE
      KK=KRANK
      KRANK=KRANK-1
      IF(MODE.EQ.0) RETURN
      IF(I.GT.NP) GO TO  64
      CALL XERMSG ('SLATEC', 'U11US',
     +   'FIRST NP ROWS ARE LINEARLY DEPENDENT', 8, 0)
      KRANK=I-1
      RETURN
   64 CONTINUE
      IF(I.GT.KRANK) GO TO 70
      CALL SSWAP(1,EB(I),1,EB(KK),1)
      CALL SSWAP(1,UB(I),1,UB(KK),1)
      CALL SSWAP(1,W(I),1,W(KK),1)
      CALL SSWAP(1,H(I),1,H(KK),1)
      CALL ISWAP(1,IR(I),1,IR(KK),1)
      CALL SSWAP(N,A(I,1),MDA,A(KK,1),MDA)
      GO TO 50
C
C           TEST FOR ZERO RANK
C
   70 IF(KRANK.GT.0) GO TO 80
      KRANK=0
      KSURE=0
      RETURN
   80 CONTINUE
C
C        M A I N    L O O P
C
  110 CONTINUE
      J=J+1
      JP1=J+1
      JM1=J-1
      KZ=KRANK
      IF(J.LE.NP) KZ=J
C
C        EACH ROW HAS NN=N-J+1 COMPONENTS
C
      NN=N-J+1
C
C         UB DETERMINES ROW PIVOT
C
  115 IMIN=J
      IF(H(J).EQ.0.) GO TO 170
      RMIN=UB(J)/H(J)
      DO 120 I=J,KZ
      IF(UB(I).GE.H(I)*RMIN) GO TO 120
      RMIN=UB(I)/H(I)
      IMIN=I
  120 CONTINUE
C
C     TEST FOR RANK DEFICIENCY
C
      IF(RMIN.LT.1.0) GO TO 200
      TT=(EB(IMIN)+ABS(DB(IMIN)))/H(IMIN)
      IF(TT.GE.1.0) GO TO 170
C     COMPUTE EXACT UB
      DO 125 I=1,JM1
      W(I)=A(IMIN,I)
  125 CONTINUE
      L=JM1
  130 W(L)=W(L)/A(L,L)
      IF(L.EQ.1) GO TO 150
      LM1=L-1
      DO 140 I=L,JM1
      W(LM1)=W(LM1)-A(I,LM1)*W(I)
  140 CONTINUE
      L=LM1
      GO TO 130
  150 TT=EB(IMIN)
      DO 160 I=1,JM1
      TT=TT+ABS(W(I))*EB(I)
  160 CONTINUE
      UB(IMIN)=TT
      IF(UB(IMIN)/H(IMIN).GE.1.0) GO TO 170
      GO TO 200
C
C        MATRIX REDUCTION
C
  170 CONTINUE
      KK=KRANK
      KRANK=KRANK-1
      KZ=KRANK
      IF(MODE.EQ.0) RETURN
      IF(J.GT.NP) GO TO 172
      CALL XERMSG ('SLATEC', 'U11US',
     +   'FIRST NP ROWS ARE LINEARLY DEPENDENT', 8, 0)
      KRANK=J-1
      RETURN
  172 CONTINUE
      IF(IMIN.GT.KRANK) GO TO 180
      CALL ISWAP(1,IR(IMIN),1,IR(KK),1)
      CALL SSWAP(N,A(IMIN,1),MDA,A(KK,1),MDA)
      CALL SSWAP(1,EB(IMIN),1,EB(KK),1)
      CALL SSWAP(1,UB(IMIN),1,UB(KK),1)
      CALL SSWAP(1,DB(IMIN),1,DB(KK),1)
      CALL SSWAP(1,W(IMIN),1,W(KK),1)
      CALL SSWAP(1,H(IMIN),1,H(KK),1)
  180 IF(J.GT.KRANK) GO TO 300
      GO TO 115
C
C        ROW PIVOT
C
  200 IF(IMIN.EQ.J) GO TO 230
      CALL SSWAP(1,H(J),1,H(IMIN),1)
      CALL SSWAP(N,A(J,1),MDA,A(IMIN,1),MDA)
      CALL SSWAP(1,EB(J),1,EB(IMIN),1)
      CALL SSWAP(1,UB(J),1,UB(IMIN),1)
      CALL SSWAP(1,DB(J),1,DB(IMIN),1)
      CALL SSWAP(1,W(J),1,W(IMIN),1)
      CALL ISWAP(1,IR(J),1,IR(IMIN),1)
C
C        COLUMN PIVOT
C
  230 CONTINUE
      JMAX=ISAMAX(NN,A(J,J),MDA)
      JMAX=JMAX+J-1
      IF(JMAX.EQ.J) GO TO 240
      CALL SSWAP(M,A(1,J),1,A(1,JMAX),1)
      CALL ISWAP(1,IC(J),1,IC(JMAX),1)
  240 CONTINUE
C
C     APPLY HOUSEHOLDER TRANSFORMATION
C
      TN=SNRM2(NN,A(J,J),MDA)
      IF(TN.EQ.0.0) GO TO 170
      IF(A(J,J).NE.0.0) TN=SIGN(TN,A(J,J))
      CALL SSCAL(NN,1.0/TN,A(J,J),MDA)
      A(J,J)=A(J,J)+1.0
      IF(J.EQ.M) GO TO 250
      DO 248 I=JP1,M
      BB=-SDOT(NN,A(J,J),MDA,A(I,J),MDA)/A(J,J)
      CALL SAXPY(NN,BB,A(J,J),MDA,A(I,J),MDA)
      IF(I.LE.NP) GO TO 248
      IF(H(I).EQ.0.0) GO TO 248
      TT=1.0-(ABS(A(I,J))/H(I))**2
      TT=MAX(TT,0.0)
      T=TT
      TT=1.0+.05*TT*(H(I)/W(I))**2
      IF(TT.EQ.1.0) GO TO 244
      H(I)=H(I)*SQRT(T)
      GO TO 246
  244 CONTINUE
      H(I)=SNRM2(N-J,A(I,J+1),MDA)
      W(I)=H(I)
  246 CONTINUE
  248 CONTINUE
  250 CONTINUE
      H(J)=A(J,J)
      A(J,J)=-TN
C
C
C          UPDATE UB, DB
C
      UB(J)=UB(J)/ABS(A(J,J))
      DB(J)=(SIGN(EB(J),DB(J))+DB(J))/A(J,J)
      IF(J.EQ.KRANK) GO TO 300
      DO 260 I=JP1,KRANK
      UB(I)=UB(I)+ABS(A(I,J))*UB(J)
      DB(I)=DB(I)-A(I,J)*DB(J)
  260 CONTINUE
      GO TO 110
C
C        E N D    M A I N    L O O P
C
  300 CONTINUE
C
C        COMPUTE KSURE
C
      KM1=KRANK-1
      DO 318 I=1,KM1
      IS=0
      KMI=KRANK-I
      DO 315 II=1,KMI
      IF(UB(II).LE.UB(II+1)) GO TO 315
      IS=1
      TEMP=UB(II)
      UB(II)=UB(II+1)
      UB(II+1)=TEMP
  315 CONTINUE
      IF(IS.EQ.0) GO TO 320
  318 CONTINUE
  320 CONTINUE
      KSURE=0
      SUM=0.0
      DO 328 I=1,KRANK
      R2=UB(I)*UB(I)
      IF(R2+SUM.GE.1.0) GO TO 330
      SUM=SUM+R2
      KSURE=KSURE+1
  328 CONTINUE
  330 CONTINUE
C
C     IF SYSTEM IS OF REDUCED RANK AND MODE = 2
C     COMPLETE THE DECOMPOSITION FOR SHORTEST LEAST SQUARES SOLUTION
C
      IF(KRANK.EQ.M .OR. MODE.LT.2) GO TO 360
      MMK=M-KRANK
      KP1=KRANK+1
      I=KRANK
  340 TN=SNRM2(MMK,A(KP1,I),1)/A(I,I)
      TN=A(I,I)*SQRT(1.0+TN*TN)
      CALL SSCAL(MMK,1.0/TN,A(KP1,I),1)
      W(I)=A(I,I)/TN+1.0
      A(I,I)=-TN
      IF(I.EQ.1) GO TO 350
      IM1=I-1
      DO 345 II=1,IM1
      TT=-SDOT(MMK,A(KP1,II),1,A(KP1,I),1)/W(I)
      TT=TT-A(I,II)
      CALL SAXPY(MMK,TT,A(KP1,I),1,A(KP1,II),1)
      A(I,II)=A(I,II)+TT*W(I)
  345 CONTINUE
      I=I-1
      GO TO 340
  350 CONTINUE
  360 CONTINUE
      RETURN
      END
*DECK U12LS
      SUBROUTINE U12LS (A, MDA, M, N, B, MDB, NB, MODE, KRANK, RNORM, H,
     +   W, IC, IR)
C***BEGIN PROLOGUE  U12LS
C***SUBSIDIARY
C***PURPOSE  Subsidiary to LLSIA
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (U12LS-S, DU12LS-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C        Given the Householder QR factorization of A, this
C        subroutine solves the system AX=B. If the system
C        is of reduced rank, this routine returns a solution
C        according to the selected mode.
C
C       Note - If MODE.NE.2, W is never accessed.
C
C***SEE ALSO  LLSIA
C***ROUTINES CALLED  SAXPY, SDOT, SNRM2, SSWAP
C***REVISION HISTORY  (YYMMDD)
C   810801  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***END PROLOGUE  U12LS
      DIMENSION A(MDA,*),B(MDB,*),RNORM(*),H(*),W(*)
      INTEGER IC(*),IR(*)
C***FIRST EXECUTABLE STATEMENT  U12LS
      K=KRANK
      KP1=K+1
C
C        RANK=0
C
      IF(K.GT.0) GO TO 410
      DO 404 JB=1,NB
      RNORM(JB)=SNRM2(M,B(1,JB),1)
  404 CONTINUE
      DO 406 JB=1,NB
      DO 406 I=1,N
      B(I,JB)=0.0
  406 CONTINUE
      RETURN
C
C     REORDER B TO REFLECT ROW INTERCHANGES
C
  410 CONTINUE
      I=0
  412 I=I+1
      IF(I.EQ.M) GO TO 418
      J=IR(I)
      IF(J.EQ.I) GO TO 412
      IF(J.LT.0) GO TO 412
      IR(I)=-IR(I)
      DO 413 JB=1,NB
      RNORM(JB)=B(I,JB)
  413 CONTINUE
      IJ=I
  414 DO 415 JB=1,NB
      B(IJ,JB)=B(J,JB)
  415 CONTINUE
      IJ=J
      J=IR(IJ)
      IR(IJ)=-IR(IJ)
      IF(J.NE.I) GO TO 414
      DO 416 JB=1,NB
      B(IJ,JB)=RNORM(JB)
  416 CONTINUE
      GO TO 412
  418 CONTINUE
      DO 420 I=1,M
      IR(I)=ABS(IR(I))
  420 CONTINUE
C
C     APPLY HOUSEHOLDER TRANSFORMATIONS TO B
C
      DO 430 J=1,K
      TT=A(J,J)
      A(J,J)=H(J)
      DO 425 I=1,NB
      BB=-SDOT(M-J+1,A(J,J),1,B(J,I),1)/H(J)
      CALL SAXPY(M-J+1,BB,A(J,J),1,B(J,I),1)
  425 CONTINUE
      A(J,J)=TT
  430 CONTINUE
C
C        FIND NORMS OF RESIDUAL VECTOR(S)..(BEFORE OVERWRITE B)
C
      DO 440 JB=1,NB
      RNORM(JB)=SNRM2((M-K),B(KP1,JB),1)
  440 CONTINUE
C
C     BACK SOLVE UPPER TRIANGULAR R
C
      I=K
  442 DO 444 JB=1,NB
      B(I,JB)=B(I,JB)/A(I,I)
  444 CONTINUE
      IF(I.EQ.1) GO TO 450
      IM1=I-1
      DO 448 JB=1,NB
      CALL SAXPY(IM1,-B(I,JB),A(1,I),1,B(1,JB),1)
  448 CONTINUE
      I=IM1
      GO TO 442
  450 CONTINUE
C
C     RANK LT N
C
C      TRUNCATED SOLUTION
C
      IF(K.EQ.N) GO TO 480
      DO 460 JB=1,NB
      DO 460 I=KP1,N
      B(I,JB)=0.0
  460 CONTINUE
      IF(MODE.EQ.1) GO TO 480
C
C      MINIMAL LENGTH SOLUTION
C
      NMK=N-K
      DO 470 JB=1,NB
      DO 465 I=1,K
      TT=-SDOT(NMK,A(I,KP1),MDA,B(KP1,JB),1)/W(I)
      TT=TT-B(I,JB)
      CALL SAXPY(NMK,TT,A(I,KP1),MDA,B(KP1,JB),1)
      B(I,JB)=B(I,JB)+TT*W(I)
  465 CONTINUE
  470 CONTINUE
C
C
C     REORDER B TO REFLECT COLUMN INTERCHANGES
C
  480 CONTINUE
      I=0
  482 I=I+1
      IF(I.EQ.N) GO TO 488
      J=IC(I)
      IF(J.EQ.I) GO TO 482
      IF(J.LT.0) GO TO 482
      IC(I)=-IC(I)
  484 CALL SSWAP(NB,B(J,1),MDB,B(I,1),MDB)
      IJ=IC(J)
      IC(J)=-IC(J)
      J=IJ
      IF(J.EQ.I) GO TO 482
      GO TO 484
  488 CONTINUE
      DO 490 I=1,N
      IC(I)=ABS(IC(I))
  490 CONTINUE
C
C        SOLUTION VECTORS ARE IN FIRST N ROWS OF B(,)
C
      RETURN
      END
*DECK U12US
      SUBROUTINE U12US (A, MDA, M, N, B, MDB, NB, MODE, KRANK, RNORM, H,
     +   W, IR, IC)
C***BEGIN PROLOGUE  U12US
C***SUBSIDIARY
C***PURPOSE  Subsidiary to ULSIA
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (U12US-S, DU12US-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C        Given the Householder LQ factorization of A, this
C        subroutine solves the system AX=B. If the system
C        is of reduced rank, this routine returns a solution
C        according to the selected mode.
C
C       Note - If MODE.NE.2, W is never accessed.
C
C***SEE ALSO  ULSIA
C***ROUTINES CALLED  SAXPY, SDOT, SNRM2, SSWAP
C***REVISION HISTORY  (YYMMDD)
C   810801  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***END PROLOGUE  U12US
      DIMENSION A(MDA,*),B(MDB,*),RNORM(*),H(*),W(*)
      INTEGER IC(*),IR(*)
C***FIRST EXECUTABLE STATEMENT  U12US
      K=KRANK
      KP1=K+1
C
C        RANK=0
C
      IF(K.GT.0) GO TO 410
      DO 404 JB=1,NB
      RNORM(JB)=SNRM2(M,B(1,JB),1)
  404 CONTINUE
      DO 406 JB=1,NB
      DO 406 I=1,N
      B(I,JB)=0.0
  406 CONTINUE
      RETURN
C
C     REORDER B TO REFLECT ROW INTERCHANGES
C
  410 CONTINUE
      I=0
  412 I=I+1
      IF(I.EQ.M) GO TO 418
      J=IR(I)
      IF(J.EQ.I) GO TO 412
      IF(J.LT.0) GO TO 412
      IR(I)=-IR(I)
      DO 413 JB=1,NB
      RNORM(JB)=B(I,JB)
  413 CONTINUE
      IJ=I
  414 DO 415 JB=1,NB
      B(IJ,JB)=B(J,JB)
  415 CONTINUE
      IJ=J
      J=IR(IJ)
      IR(IJ)=-IR(IJ)
      IF(J.NE.I) GO TO 414
      DO 416 JB=1,NB
      B(IJ,JB)=RNORM(JB)
  416 CONTINUE
      GO TO 412
  418 CONTINUE
      DO 420 I=1,M
      IR(I)=ABS(IR(I))
  420 CONTINUE
C
C     IF A IS OF REDUCED RANK AND MODE=2,
C     APPLY HOUSEHOLDER TRANSFORMATIONS TO B
C
      IF(MODE.LT.2 .OR. K.EQ.M) GO TO 440
      MMK=M-K
      DO 430 JB=1,NB
      DO 425 J=1,K
      I=KP1-J
      TT=-SDOT(MMK,A(KP1,I),1,B(KP1,JB),1)/W(I)
      TT=TT-B(I,JB)
      CALL SAXPY(MMK,TT,A(KP1,I),1,B(KP1,JB),1)
      B(I,JB)=B(I,JB)+TT*W(I)
  425 CONTINUE
  430 CONTINUE
C
C     FIND NORMS OF RESIDUAL VECTOR(S)..(BEFORE OVERWRITE B)
C
  440 DO 442 JB=1,NB
      RNORM(JB)=SNRM2((M-K),B(KP1,JB),1)
  442 CONTINUE
C
C     BACK SOLVE LOWER TRIANGULAR L
C
      DO 450 JB=1,NB
      DO 448 I=1,K
      B(I,JB)=B(I,JB)/A(I,I)
      IF(I.EQ.K) GO TO 450
      IP1=I+1
      CALL SAXPY(K-I,-B(I,JB),A(IP1,I),1,B(IP1,JB),1)
  448 CONTINUE
  450 CONTINUE
C
C
C      TRUNCATED SOLUTION
C
      IF(K.EQ.N) GO TO 462
      DO 460 JB=1,NB
      DO 460 I=KP1,N
      B(I,JB)=0.0
  460 CONTINUE
C
C     APPLY HOUSEHOLDER TRANSFORMATIONS TO B
C
  462 DO 470 I=1,K
      J=KP1-I
      TT=A(J,J)
      A(J,J)=H(J)
      DO 465 JB=1,NB
      BB=-SDOT(N-J+1,A(J,J),MDA,B(J,JB),1)/H(J)
      CALL SAXPY(N-J+1,BB,A(J,J),MDA,B(J,JB),1)
  465 CONTINUE
      A(J,J)=TT
  470 CONTINUE
C
C
C     REORDER B TO REFLECT COLUMN INTERCHANGES
C
      I=0
  482 I=I+1
      IF(I.EQ.N) GO TO 488
      J=IC(I)
      IF(J.EQ.I) GO TO 482
      IF(J.LT.0) GO TO 482
      IC(I)=-IC(I)
  484 CALL SSWAP(NB,B(J,1),MDB,B(I,1),MDB)
      IJ=IC(J)
      IC(J)=-IC(J)
      J=IJ
      IF(J.EQ.I) GO TO 482
      GO TO 484
  488 CONTINUE
      DO 490 I=1,N
      IC(I)=ABS(IC(I))
  490 CONTINUE
C
C        SOLUTION VECTORS ARE IN FIRST N ROWS OF B(,)
C
      RETURN
      END
*DECK ULSIA
      SUBROUTINE ULSIA (A, MDA, M, N, B, MDB, NB, RE, AE, KEY, MODE, NP,
     +   KRANK, KSURE, RNORM, W, LW, IWORK, LIW, INFO)
C***BEGIN PROLOGUE  ULSIA
C***PURPOSE  Solve an underdetermined linear system of equations by
C            performing an LQ factorization of the matrix using
C            Householder transformations.  Emphasis is put on detecting
C            possible rank deficiency.
C***LIBRARY   SLATEC
C***CATEGORY  D9
C***TYPE      SINGLE PRECISION (ULSIA-S, DULSIA-D)
C***KEYWORDS  LINEAR LEAST SQUARES, LQ FACTORIZATION,
C             UNDERDETERMINED LINEAR SYSTEM
C***AUTHOR  Manteuffel, T. A., (LANL)
C***DESCRIPTION
C
C     ULSIA computes the minimal length solution(s) to the problem AX=B
C     where A is an M by N matrix with M.LE.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     ULSIA requires (MDA+1)*N + (MDB+1)*NB + 6*M dimensioned space
C
C   ******************************************************************
C   *                                                                *
C   *         WARNING - All input arrays are changed on exit.        *
C   *                                                                *
C   ******************************************************************
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.LE.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.  Since the
C                   solution is returned in B, must have MDB.GE.N. If
C                   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
C     RE(),AE(),KEY
C     RE()          RE() is a vector of length N such that RE(I) is
C                   the maximum relative uncertainty in row 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 row 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
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 least squares sol
C                   The inexperienced user is advised to set MODE=0
C
C     NP            The first NP rows of A will not be interchanged
C                   with other rows 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*M.  However, if
C                   RE or AE have been specified as vectors, dimension
C                   WORK 4*M. If both RE and AE have been specified
C                   as vectors, dimension WORK 3*M.
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
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*M locations of WORK
C                   as output by the original call to ULSIA. 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
C
C
C     Output..
C
C     A(,)          Contains the lower triangular part of the reduced
C                   matrix and the transformation information. It togeth
C                   with the first M elements of WORK (see below)
C                   completely specify the LQ 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. If the matrix A is of
C                   full rank, then RNORM=0.0.
C
C     WORK()        The first M 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 least squares sol
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, U11US, U12US, 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  ULSIA
      DIMENSION A(MDA,*),B(MDB,*),RE(*),AE(*),RNORM(*),W(*)
      INTEGER IWORK(*)
C
C***FIRST EXECUTABLE STATEMENT  ULSIA
      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.LT.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.N) 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*M) GO TO 510
      IF(KEY.EQ.1 .AND. LW.LT.4*M) GO TO 510
      IF(KEY.EQ.2 .AND. LW.LT.4*M) GO TO 510
      IF(KEY.EQ.3 .AND. LW.LT.3*M) GO TO 510
      IF(NP.LT.0 .OR. NP.GT.M) GO TO 516
C
      EPS=10.*R1MACH(4)
      M1=1
      M2=M1+M
      M3=M2+M
      M4=M3+M
      M5=M4+M
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,M
      W(M4-1+I)=RE(1)
      W(M5-1+I)=AE(1)
   20 CONTINUE
      CALL U11US(A,MDA,M,N,W(M4),W(M5),MODE,NP,KRANK,KSURE,
     1            W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2))
      GO TO 400
C
  100 CONTINUE
      IF(AE(1).LT.0.0) GO TO 513
      DO 120 I=1,M
      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(M4-1+I)=AE(1)
  120 CONTINUE
      CALL U11US(A,MDA,M,N,RE,W(M4),MODE,NP,KRANK,KSURE,
     1            W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2))
      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,M
      W(M4-1+I)=RE(1)
      IF(AE(I).LT.0.0) GO TO 513
  220 CONTINUE
      CALL U11US(A,MDA,M,N,W(M4),AE,MODE,NP,KRANK,KSURE,
     1            W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2))
      GO TO 400
C
  300 CONTINUE
      DO 320 I=1,M
      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 U11US(A,MDA,M,N,RE,AE,MODE,NP,KRANK,KSURE,
     1            W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2))
C
C     DETERMINE INFO
C
  400 IF(KRANK.NE.M) 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
C     SOLUTION PHASE
C
      M1=1
      M2=M1+M
      M3=M2+M
      IF(INFO.EQ.2) GO TO 420
      IF(LW.LT.M2-1) GO TO 510
      CALL U12US(A,MDA,M,N,B,MDB,NB,MODE,KRANK,
     1            RNORM,W(M1),W(M1),IWORK(M1),IWORK(M2))
      RETURN
C
  420 IF(LW.LT.M3-1) GO TO 510
      CALL U12US(A,MDA,M,N,B,MDB,NB,MODE,KRANK,
     1            RNORM,W(M1),W(M2),IWORK(M1),IWORK(M2))
      RETURN
C
C     ERROR MESSAGES
C
  501 CALL XERMSG ('SLATEC', 'ULSIA',
     +   'SOLUTION ONLY (INFO=1) BUT NO RIGHT HAND SIDE (NB=0)', 1, 0)
      RETURN
  502 CALL XERMSG ('SLATEC', 'ULSIA', 'M.LT.1', 2, 1)
      RETURN
  503 CALL XERMSG ('SLATEC', 'ULSIA', 'N.LT.1', 2, 1)
      RETURN
  504 CALL XERMSG ('SLATEC', 'ULSIA', 'N.LT.M', 2, 1)
      RETURN
  505 CALL XERMSG ('SLATEC', 'ULSIA', 'MDA.LT.M', 2, 1)
      RETURN
  506 CALL XERMSG ('SLATEC', 'ULSIA', 'LIW.LT.M+N', 2, 1)
      RETURN
  507 CALL XERMSG ('SLATEC', 'ULSIA', 'NB.LT.0', 2, 1)
      RETURN
  508 CALL XERMSG ('SLATEC', 'ULSIA', 'MDB.LT.N', 2, 1)
      RETURN
  509 CALL XERMSG ('SLATEC', 'ULSIA', 'KEY OUT OF RANGE', 2, 1)
      RETURN
  510 CALL XERMSG ('SLATEC', 'ULSIA', 'INSUFFICIENT WORK SPACE', 8, 1)
      INFO=-1
      RETURN
  511 CALL XERMSG ('SLATEC', 'ULSIA', 'RE(I) .LT. 0', 2, 1)
      RETURN
  512 CALL XERMSG ('SLATEC', 'ULSIA', 'RE(I) .GT. 1', 2, 1)
      RETURN
  513 CALL XERMSG ('SLATEC', 'ULSIA', 'AE(I) .LT. 0', 2, 1)
      RETURN
  514 CALL XERMSG ('SLATEC', 'ULSIA', 'INFO OUT OF RANGE', 2, 1)
      RETURN
  515 CALL XERMSG ('SLATEC', 'ULSIA', 'MODE OUT OF RANGE', 2, 1)
      RETURN
  516 CALL XERMSG ('SLATEC', 'ULSIA', 'NP OUT OF RANGE', 2, 1)
      RETURN
      END
*DECK USRMAT
      SUBROUTINE USRMAT (I, J, AIJ, INDCAT, PRGOPT, DATTRV, IFLAG)
C***BEGIN PROLOGUE  USRMAT
C***SUBSIDIARY
C***PURPOSE  Subsidiary to SPLP
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (USRMAT-S, DUSRMT-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C   The user may supply this code
C
C***SEE ALSO  SPLP
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  USRMAT
      DIMENSION PRGOPT(*),DATTRV(*),IFLAG(10)
C
C***FIRST EXECUTABLE STATEMENT  USRMAT
      IF(IFLAG(1).EQ.1) THEN
C
C     THIS IS THE INITIALIZATION STEP.  THE VALUES OF IFLAG(K),K=2,3,4,
C     ARE RESPECTIVELY THE COLUMN INDEX, THE ROW INDEX (OR THE NEXT COL.
C     INDEX), AND THE POINTER TO THE MATRIX ENTRY'S VALUE WITHIN
C     DATTRV(*).  ALSO CHECK (DATTRV(1)=0.) SIGNIFYING NO DATA.
           IF(DATTRV(1).EQ.0.) THEN
           I = 0
           J = 0
           IFLAG(1) = 3
           ELSE
           IFLAG(2)=-DATTRV(1)
           IFLAG(3)= DATTRV(2)
           IFLAG(4)= 3
           ENDIF
C
           RETURN
      ELSE
           J=IFLAG(2)
           I=IFLAG(3)
           L=IFLAG(4)
           IF(I.EQ.0) THEN
C
C     SIGNAL THAT ALL OF THE NONZERO ENTRIES HAVE BEEN DEFINED.
                IFLAG(1)=3
                RETURN
           ELSE IF(I.LT.0) THEN
C
C     SIGNAL THAT A SWITCH IS MADE TO A NEW COLUMN.
                J=-I
                I=DATTRV(L)
                L=L+1
           ENDIF
C
           AIJ=DATTRV(L)
C
C     UPDATE THE INDICES AND POINTERS FOR THE NEXT ENTRY.
           IFLAG(2)=J
           IFLAG(3)=DATTRV(L+1)
           IFLAG(4)=L+2
C
C     INDCAT=0 DENOTES THAT ENTRIES OF THE MATRIX ARE ASSIGNED THE
C     VALUES FROM DATTRV(*).  NO ACCUMULATION IS PERFORMED.
           INDCAT=0
           RETURN
      ENDIF
      END
