*DECK DMACON
      SUBROUTINE DMACON
C***BEGIN PROLOGUE  DMACON
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DBVSUP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (MACON-S, DMACON-D)
C***AUTHOR  (UNKNOWN)
C***SEE ALSO  DBVSUP
C***ROUTINES CALLED  D1MACH
C***COMMON BLOCKS    DML5MC
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890921  Realigned order of variables in certain COMMON blocks.
C           (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  DMACON
      DOUBLE PRECISION D1MACH
      INTEGER KE, LPAR
      DOUBLE PRECISION DD, EPS, FOURU, SQOVFL, SRU, TWOU, URO
      COMMON /DML5MC/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR
C***FIRST EXECUTABLE STATEMENT  DMACON
      URO = D1MACH(4)
      SRU = SQRT(URO)
      DD = -LOG10(URO)
      LPAR = 0.5D0*DD
      KE = 0.5D0 + 0.75D0*DD
      EPS = 10.0D0**(-2*KE)
      SQOVFL = SQRT(D1MACH(2))
      TWOU = 2.0D0*URO
      FOURU = 4.0D0*URO
      RETURN
      END
*DECK DMGSBV
      SUBROUTINE DMGSBV (M, N, A, IA, NIV, IFLAG, S, P, IP, INHOMO, V,
     +   W, WCND)
C***BEGIN PROLOGUE  DMGSBV
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DBVSUP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (MGSBV-S, DMGSBV-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C **********************************************************************
C Orthogonalize a set of N double precision vectors and determine their
C rank.
C
C **********************************************************************
C INPUT
C **********************************************************************
C   M = dimension of vectors.
C   N = no. of vectors.
C   A = array whose first N cols contain the vectors.
C   IA = first dimension of array A (col length).
C   NIV = number of independent vectors needed.
C   INHOMO = 1 corresponds to having a non-zero particular solution.
C   V = particular solution vector (not included in the pivoting).
C   INDPVT = 1 means pivoting will not be used.
C
C **********************************************************************
C OUTPUT
C **********************************************************************
C   NIV = no. of linear independent vectors in input set.
C     A = matrix whose first NIV cols. contain NIV orthogonal vectors
C         which span the vector space determined by the input vectors.
C   IFLAG
C          = 0 success
C          = 1 incorrect input
C          = 2 rank of new vectors less than N
C   P = decomposition matrix.  P is upper triangular and
C             (old vectors) = (new vectors) * P.
C         The old vectors will be reordered due to pivoting.
C         The dimension of P must be .GE. N*(N+1)/2.
C             (  N*(2*N+1) when N .NE. NFCC )
C   IP = pivoting vector. The dimension of IP must be .GE. N.
C             (  2*N when N .NE. NFCC )
C   S = square of norms of incoming vectors.
C   V = vector which is orthogonal to the vectors of A.
C   W = orthogonalization information for the vector V.
C   WCND = worst case (smallest) norm decrement value of the
C          vectors being orthogonalized  (represents a test
C          for linear dependence of the vectors).
C **********************************************************************
C
C***SEE ALSO  DBVSUP
C***ROUTINES CALLED  DDOT, DPRVEC
C***COMMON BLOCKS    DML18J, DML5MC
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890921  Realigned order of variables in certain COMMON blocks.
C           (WRB)
C   890921  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C***END PROLOGUE  DMGSBV
C
      DOUBLE PRECISION DDOT, DPRVEC
      INTEGER I, IA, ICOCO, IFLAG, INDPVT, INHOMO, INTEG, IP(*), IP1,
     1     IX, IZ, J, JK, JP, JQ, JY, JZ, K, KD, KJ, KP, L, LIX, LPAR,
     2     LR, M, M2, MXNON, N, NDISK, NEQ, NEQIVP, NFCC, NIC, NIV,
     3     NIVN, NMNR, NN, NOPG, NP1, NPS, NR, NRM1, NTAPE, NTP,
     4     NUMORT, NXPTS
      DOUBLE PRECISION A(IA,*), AE, DOT, EPS, FOURU, P(*), PJP, PSAVE,
     1     RE, RY, S(*), SQOVFL, SRU, SV, T, TOL, TWOU, URO, V(*), VL,
     2     VNORM, W(*), WCND, Y
C
C
      COMMON /DML18J/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ,
     1                INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,NFCC,
     2                ICOCO
C
      COMMON /DML5MC/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR
C
C***FIRST EXECUTABLE STATEMENT  DMGSBV
      IF (M .GT. 0 .AND. N .GT. 0 .AND. IA .GE. M) GO TO 10
         IFLAG = 1
      GO TO 280
   10 CONTINUE
C        BEGIN BLOCK PERMITTING ...EXITS TO 270
C           BEGIN BLOCK PERMITTING ...EXITS TO 260
C
               JP = 0
               IFLAG = 0
               NP1 = N + 1
               Y = 0.0D0
               M2 = M/2
C
C              CALCULATE SQUARE OF NORMS OF INCOMING VECTORS AND SEARCH
C              FOR VECTOR WITH LARGEST MAGNITUDE
C
               J = 0
               DO 40 I = 1, N
                  VL = DDOT(M,A(1,I),1,A(1,I),1)
                  S(I) = VL
                  IF (N .EQ. NFCC) GO TO 20
                     J = 2*I - 1
                     P(J) = VL
                     IP(J) = J
   20             CONTINUE
                  J = J + 1
                  P(J) = VL
                  IP(J) = J
                  IF (VL .LE. Y) GO TO 30
                     Y = VL
                     IX = I
   30             CONTINUE
   40          CONTINUE
               IF (INDPVT .NE. 1) GO TO 50
                  IX = 1
                  Y = P(1)
   50          CONTINUE
               LIX = IX
               IF (N .NE. NFCC) LIX = 2*IX - 1
               P(LIX) = P(1)
               S(NP1) = 0.0D0
               IF (INHOMO .EQ. 1) S(NP1) = DDOT(M,V,1,V,1)
               WCND = 1.0D0
               NIVN = NIV
               NIV = 0
C
C           ...EXIT
               IF (Y .EQ. 0.0D0) GO TO 260
C              *********************************************************
               DO 240 NR = 1, N
C                 BEGIN BLOCK PERMITTING ...EXITS TO 230
C              ......EXIT
                     IF (NIVN .EQ. NIV) GO TO 250
                     NIV = NR
                     IF (IX .EQ. NR) GO TO 130
C
C                       PIVOTING OF COLUMNS OF P MATRIX
C
                        NN = N
                        LIX = IX
                        LR = NR
                        IF (N .EQ. NFCC) GO TO 60
                           NN = NFCC
                           LIX = 2*IX - 1
                           LR = 2*NR - 1
   60                   CONTINUE
                        IF (NR .EQ. 1) GO TO 80
                           KD = LIX - LR
                           KJ = LR
                           NRM1 = LR - 1
                           DO 70 J = 1, NRM1
                              PSAVE = P(KJ)
                              JK = KJ + KD
                              P(KJ) = P(JK)
                              P(JK) = PSAVE
                              KJ = KJ + NN - J
   70                      CONTINUE
                           JY = JK + NMNR
                           JZ = JY - KD
                           P(JY) = P(JZ)
   80                   CONTINUE
                        IZ = IP(LIX)
                        IP(LIX) = IP(LR)
                        IP(LR) = IZ
                        SV = S(IX)
                        S(IX) = S(NR)
                        S(NR) = SV
                        IF (N .EQ. NFCC) GO TO 110
                           IF (NR .EQ. 1) GO TO 100
                              KJ = LR + 1
                              DO 90 K = 1, NRM1
                                 PSAVE = P(KJ)
                                 JK = KJ + KD
                                 P(KJ) = P(JK)
                                 P(JK) = PSAVE
                                 KJ = KJ + NFCC - K
   90                         CONTINUE
  100                      CONTINUE
                           IZ = IP(LIX+1)
                           IP(LIX+1) = IP(LR+1)
                           IP(LR+1) = IZ
  110                   CONTINUE
C
C                       PIVOTING OF COLUMNS OF VECTORS
C
                        DO 120 L = 1, M
                           T = A(L,IX)
                           A(L,IX) = A(L,NR)
                           A(L,NR) = T
  120                   CONTINUE
  130                CONTINUE
C
C                    CALCULATE P(NR,NR) AS NORM SQUARED OF PIVOTAL
C                    VECTOR
C
                     JP = JP + 1
                     P(JP) = Y
                     RY = 1.0D0/Y
                     NMNR = N - NR
                     IF (N .EQ. NFCC) GO TO 140
                        NMNR = NFCC - (2*NR - 1)
                        JP = JP + 1
                        P(JP) = 0.0D0
                        KP = JP + NMNR
                        P(KP) = Y
  140                CONTINUE
                     IF (NR .EQ. N .OR. NIVN .EQ. NIV) GO TO 200
C
C                       CALCULATE ORTHOGONAL PROJECTION VECTORS AND
C                       SEARCH FOR LARGEST NORM
C
                        Y = 0.0D0
                        IP1 = NR + 1
                        IX = IP1
C                       ************************************************
                        DO 190 J = IP1, N
                           DOT = DDOT(M,A(1,NR),1,A(1,J),1)
                           JP = JP + 1
                           JQ = JP + NMNR
                           IF (N .NE. NFCC) JQ = JQ + NMNR - 1
                           P(JQ) = P(JP) - DOT*(DOT*RY)
                           P(JP) = DOT*RY
                           DO 150 I = 1, M
                              A(I,J) = A(I,J) - P(JP)*A(I,NR)
  150                      CONTINUE
                           IF (N .EQ. NFCC) GO TO 170
                              KP = JP + NMNR
                              JP = JP + 1
                              PJP = RY*DPRVEC(M,A(1,NR),A(1,J))
                              P(JP) = PJP
                              P(KP) = -PJP
                              KP = KP + 1
                              P(KP) = RY*DOT
                              DO 160 K = 1, M2
                                 L = M2 + K
                                 A(K,J) = A(K,J) - PJP*A(L,NR)
                                 A(L,J) = A(L,J) + PJP*A(K,NR)
  160                         CONTINUE
                              P(JQ) = P(JQ) - PJP*(PJP/RY)
  170                      CONTINUE
C
C                          TEST FOR CANCELLATION IN RECURRENCE RELATION
C
                           IF (P(JQ) .LE. S(J)*SRU)
     1                        P(JQ) = DDOT(M,A(1,J),1,A(1,J),1)
                           IF (P(JQ) .LE. Y) GO TO 180
                              Y = P(JQ)
                              IX = J
  180                      CONTINUE
  190                   CONTINUE
                        IF (N .NE. NFCC) JP = KP
C                       ************************************************
                        IF (INDPVT .EQ. 1) IX = IP1
C
C                       RECOMPUTE NORM SQUARED OF PIVOTAL VECTOR WITH
C                       SCALAR PRODUCT
C
                        Y = DDOT(M,A(1,IX),1,A(1,IX),1)
C           ............EXIT
                        IF (Y .LE. EPS*S(IX)) GO TO 260
                        WCND = MIN(WCND,Y/S(IX))
  200                CONTINUE
C
C                    COMPUTE ORTHOGONAL PROJECTION OF PARTICULAR
C                    SOLUTION
C
C                 ...EXIT
                     IF (INHOMO .NE. 1) GO TO 230
                     LR = NR
                     IF (N .NE. NFCC) LR = 2*NR - 1
                     W(LR) = DDOT(M,A(1,NR),1,V,1)*RY
                     DO 210 I = 1, M
                        V(I) = V(I) - W(LR)*A(I,NR)
  210                CONTINUE
C                 ...EXIT
                     IF (N .EQ. NFCC) GO TO 230
                     LR = 2*NR
                     W(LR) = RY*DPRVEC(M,V,A(1,NR))
                     DO 220 K = 1, M2
                        L = M2 + K
                        V(K) = V(K) + W(LR)*A(L,NR)
                        V(L) = V(L) - W(LR)*A(K,NR)
  220                CONTINUE
  230             CONTINUE
  240          CONTINUE
  250          CONTINUE
C              *********************************************************
C
C                  TEST FOR LINEAR DEPENDENCE OF PARTICULAR SOLUTION
C
C        ......EXIT
               IF (INHOMO .NE. 1) GO TO 270
               IF ((N .GT. 1) .AND. (S(NP1) .LT. 1.0)) GO TO 270
               VNORM = DDOT(M,V,1,V,1)
               IF (S(NP1) .NE. 0.0D0) WCND = MIN(WCND,VNORM/S(NP1))
C        ......EXIT
               IF (VNORM .GE. EPS*S(NP1)) GO TO 270
  260       CONTINUE
            IFLAG = 2
            WCND = EPS
  270    CONTINUE
  280 CONTINUE
      RETURN
      END
*DECK DMOUT
      SUBROUTINE DMOUT (M, N, LDA, A, IFMT, IDIGIT)
C***BEGIN PROLOGUE  DMOUT
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DBOCLS and DFC
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (SMOUT-S, DMOUT-D)
C***AUTHOR  Hanson, R. J., (SNLA)
C           Wisniewski, J. A., (SNLA)
C***DESCRIPTION
C
C     DOUBLE PRECISION MATRIX OUTPUT ROUTINE.
C
C  INPUT..
C
C  M,N,LDA,A(*,*) PRINT THE DOUBLE PRECISION ARRAY A(I,J),I = 1,...,M,
C                 J=1,...,N, ON OUTPUT UNIT LOUT=6. LDA IS THE DECLARED
C                 FIRST DIMENSION OF A(*,*) AS SPECIFIED IN THE CALLING
C                 PROGRAM. THE HEADING IN THE FORTRAN FORMAT STATEMENT
C                 IFMT(*), DESCRIBED BELOW, IS PRINTED AS A FIRST STEP.
C                 THE COMPONENTS A(I,J) ARE INDEXED, ON OUTPUT, IN A
C                 PLEASANT FORMAT.
C  IFMT(*)        A FORTRAN FORMAT STATEMENT. THIS IS PRINTED ON
C                 OUTPUT UNIT LOUT=6 WITH THE VARIABLE FORMAT FORTRAN
C                 STATEMENT
C                       WRITE(LOUT,IFMT).
C  IDIGIT         PRINT AT LEAST ABS(IDIGIT) DECIMAL DIGITS PER NUMBER.
C                 THE SUBPROGRAM WILL CHOOSE THAT INTEGER 4,6,14,20 OR
C                 28 WHICH WILL PRINT AT LEAST ABS(IDIGIT) NUMBER OF
C                 PLACES.  IF IDIGIT.LT.0, 72 PRINTING COLUMNS ARE
C                 UTILIZED TO WRITE EACH LINE OF OUTPUT OF THE ARRAY
C                 A(*,*). (THIS CAN BE USED ON MOST TIME-SHARING
C                 TERMINALS).  IF IDIGIT.GE.0, 133 PRINTING COLUMNS ARE
C                 UTILIZED. (THIS CAN BE USED ON MOST LINE PRINTERS).
C
C  EXAMPLE..
C
C  PRINT AN ARRAY CALLED (SIMPLEX TABLEAU   ) OF SIZE 10 BY 20 SHOWING
C  6 DECIMAL DIGITS PER NUMBER. THE USER IS RUNNING ON A TIME-SHARING
C  SYSTEM WITH A 72 COLUMN OUTPUT DEVICE.
C
C     DOUBLE PRECISION TABLEU(20,20)
C     M = 10
C     N = 20
C     LDTABL = 20
C     IDIGIT = -6
C     CALL DMOUT(M,N,LDTABL,TABLEU,21H(16H1SIMPLEX TABLEAU),IDIGIT)
C
C***SEE ALSO  DBOCLS, DFC
C***ROUTINES CALLED  I1MACH
C***REVISION HISTORY  (YYMMDD)
C   821220  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891107  Added comma after 1P edit descriptor in FORMAT
C           statements.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910403  Updated AUTHOR section.  (WRB)
C***END PROLOGUE  DMOUT
      DOUBLE PRECISION A(LDA,*)
      CHARACTER IFMT*(*),ICOL*3
      SAVE ICOL
      DATA ICOL /'COL'/
C***FIRST EXECUTABLE STATEMENT  DMOUT
      LOUT=I1MACH(2)
      WRITE(LOUT,IFMT)
      IF(M.LE.0.OR.N.LE.0.OR.LDA.LE.0) RETURN
      NDIGIT = IDIGIT
      IF(IDIGIT.EQ.0) NDIGIT = 4
      IF(IDIGIT.GE.0) GO TO 80
C
      NDIGIT = -IDIGIT
      IF(NDIGIT.GT.4) GO TO 9
C
      DO 5 K1=1,N,5
      K2 = MIN(N,K1+4)
      WRITE(LOUT,1010) (ICOL,I,I = K1, K2)
      DO 5 I = 1, M
      WRITE(LOUT,1009) I,(A(I,J),J = K1, K2)
   5  CONTINUE
      RETURN
C
   9  CONTINUE
      IF(NDIGIT.GT.6) GO TO 20
C
      DO 10 K1=1,N,4
      K2 = MIN(N,K1+3)
      WRITE(LOUT,1000) (ICOL,I,I = K1, K2)
      DO 10 I = 1, M
      WRITE(LOUT,1004) I,(A(I,J),J = K1, K2)
   10 CONTINUE
      RETURN
C
   20 CONTINUE
      IF(NDIGIT.GT.14) GO TO 40
C
      DO 30 K1=1,N,2
      K2 = MIN(N,K1+1)
      WRITE(LOUT,1001) (ICOL,I,I = K1, K2)
      DO 30 I = 1, M
      WRITE(LOUT,1005) I,(A(I,J),J = K1, K2)
   30 CONTINUE
      RETURN
C
   40 CONTINUE
      IF(NDIGIT.GT.20) GO TO 60
C
      DO 50 K1=1,N,2
      K2=MIN(N,K1+1)
      WRITE(LOUT,1002) (ICOL,I,I = K1, K2)
      DO 50 I = 1, M
      WRITE(LOUT,1006) I,(A(I,J),J = K1, K2)
   50 CONTINUE
      RETURN
C
   60 CONTINUE
      DO 70 K1=1,N
      K2 = K1
      WRITE(LOUT,1003) (ICOL,I,I = K1, K2)
      DO 70 I = 1, M
      WRITE(LOUT,1007) I,(A(I,J),J = K1, K2)
   70 CONTINUE
      RETURN
C
   80 CONTINUE
      IF(NDIGIT.GT.4) GO TO 86
C
      DO 85 K1=1,N,10
      K2 = MIN(N,K1+9)
      WRITE(LOUT,1000) (ICOL,I,I = K1, K2)
      DO 85 I = 1, M
      WRITE(LOUT,1009) I,(A(I,J),J = K1, K2)
   85 CONTINUE
C
86    IF (NDIGIT.GT.6) GO TO 100
C
      DO 90 K1=1,N,8
      K2 = MIN(N,K1+7)
      WRITE(LOUT,1000) (ICOL,I,I = K1, K2)
      DO 90 I = 1, M
      WRITE(LOUT,1004) I,(A(I,J),J = K1, K2)
   90 CONTINUE
      RETURN
C
  100 CONTINUE
      IF(NDIGIT.GT.14) GO TO 120
C
      DO 110 K1=1,N,5
      K2 = MIN(N,K1+4)
      WRITE(LOUT,1001) (ICOL,I,I = K1, K2)
      DO 110 I = 1, M
      WRITE(LOUT,1005) I,(A(I,J),J = K1, K2)
  110 CONTINUE
      RETURN
C
  120 CONTINUE
      IF(NDIGIT.GT.20) GO TO 140
C
      DO 130 K1=1,N,4
      K2 = MIN(N,K1+3)
      WRITE(LOUT,1002) (ICOL,I,I = K1, K2)
      DO 130 I = 1, M
      WRITE(LOUT,1006) I,(A(I,J),J = K1, K2)
  130 CONTINUE
      RETURN
C
  140 CONTINUE
      DO 150 K1=1,N,3
      K2 = MIN(N,K1+2)
      WRITE(LOUT,1003) (ICOL,I,I = K1, K2)
      DO 150 I = 1, M
      WRITE(LOUT,1007) I,(A(I,J),J = K1, K2)
  150 CONTINUE
      RETURN
 1000 FORMAT(10X,8(5X,A,I4,2X))
 1001 FORMAT(10X,5(9X,A,I4,6X))
 1002 FORMAT(10X,4(12X,A,I4,9X))
 1003 FORMAT(10X,3(16X,A,I4,13X))
 1004 FORMAT(1X,'ROW',I4,2X,1P,8D14.5)
 1005 FORMAT(1X,'ROW',I4,2X,1P,5D22.13)
 1006 FORMAT(1X,'ROW',I4,2X,1P,4D28.19)
 1007 FORMAT(1X,'ROW',I4,2X,1P,3D36.27)
 1009 FORMAT(1X,'ROW',I4,2X,1P,10D12.3)
 1010 FORMAT(10X,10(4X,A,I4,1X))
      END
*DECK DMPAR
      SUBROUTINE DMPAR (N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR, X,
     +   SIGMA, WA1, WA2)
C***BEGIN PROLOGUE  DMPAR
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DNLS1 and DNLS1E
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (LMPAR-S, DMPAR-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C   **** Double Precision version of LMPAR ****
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 DMPAR 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     DMPAR 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 DMPAR 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 DMPAR(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  DNLS1, DNLS1E
C***ROUTINES CALLED  D1MACH, DENORM, DQRSLV
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  DMPAR
      INTEGER N,LDR
      INTEGER IPVT(*)
      DOUBLE PRECISION DELTA,PAR
      DOUBLE PRECISION R(LDR,*),DIAG(*),QTB(*),X(*),SIGMA(*),WA1(*),
     1 WA2(*)
      INTEGER I,ITER,J,JM1,JP1,K,L,NSING
      DOUBLE PRECISION DXNORM,DWARF,FP,GNORM,PARC,PARL,PARU,P1,P001,
     1 SUM,TEMP,ZERO
      DOUBLE PRECISION D1MACH,DENORM
      SAVE P1, P001, ZERO
      DATA P1,P001,ZERO /1.0D-1,1.0D-3,0.0D0/
C***FIRST EXECUTABLE STATEMENT  DMPAR
      DWARF = D1MACH(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 = DENORM(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 = DENORM(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 = DENORM(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 DQRSLV(N,R,LDR,IPVT,WA1,QTB,X,SIGMA,WA2)
         DO 170 J = 1, N
            WA2(J) = DIAG(J)*X(J)
  170       CONTINUE
         DXNORM = DENORM(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 = DENORM(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 DMPAR.
C
      END
