*  SELECTED ROUTINES FROM STARPAC LIBRARY (FOR DIGITAL FILTERING
*  AND ARIMA MODELING).  MODIFIED FOR DATAPLOT BY ALAN HECKERT
*  FEBRUARY, 1999.  MODIFICATIONS ARE TO INCORPORATE I/O INTO
*  DATAPLOT SCHEME, NOT NUMERICAL MODIFICATIONS.
*ABSCOM
      SUBROUTINE ABSCOM(N, V, W, ABSTOL, NFAIL)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE COMPUTES THE NUMBER OF TIMES THE
C     ABSOLUTE DIFFERENCE BETWEEN V(I) AND W(I), I = 1, 2, ..., N,
C     IS GREATER THAN   ABSTOL  .
C
C     WRITTEN BY  -  ROBERT B. SCHNABEL (CODED BY JANET R. DONALDSON)
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  APRIL 2, 1981
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   ABSTOL
      INTEGER
     +   N,NFAIL
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   V(*),W(*)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION ABSTOL
C        THE ABSOLUTE TOLERANCE USED IN THE COMPARISON.
C     INTEGER I
C        AN INDEXING VARIABLE.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NFAIL
C        THE TOTAL NUMBER OF FAILURES.
C     DOUBLE PRECISION V(N), W(N)
C        THE VALUES BEING COMPARED.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      NFAIL = 0
C
      DO 10 I = 1, N
         IF (ABS(V(I) - W(I)) .GT. ABSTOL) NFAIL = NFAIL + 1
   10 CONTINUE
C
      RETURN
C
      END
*AMFMN
      SUBROUTINE AMFMN (PAR, PV, Y, NPAR, N, NFAC, MSPECT,
     +  PARDF, NPARDF, T, TEMP, PARAR, PARMA, MBO, MBOL, N1, N2, NPRT,
     +  SAVE, NFCST, NFCSTO, IFCSTO, FCST, IFCST, FCSTSD, F,
     +  FSD, NPARAR, NPARMA)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE MAIN ROUTINE FOR COMPUTING AND PRINTING THE ARIMA
C     FORECASTS
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 2, 1985
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IFCST,MBO,MBOL,N,N1,N2,NFAC,NFCST,NFCSTO,NPAR,NPARAR,
     +   NPARDF,NPARMA,NPRT
      LOGICAL
     +   SAVE
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   F(*),FCST(IFCST,*),FCSTSD(*),FSD(*),PAR(*),PARAR(*),PARDF(*),
     +   PARMA(*),PV(N1:N2),T(*),TEMP(*),Y(*)
      INTEGER
     +   IFCSTO(*),MSPECT(NFAC,4)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   CONST,PMU,RSD,RSS,T975,WSUM,WSUMT
      INTEGER
     +   I,I1,IDF,IF,IFC,IFLAG,IFO,IFOMIN,J,K,NT
      LOGICAL
     +   PAGE
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   PPFT,DDOT
      EXTERNAL PPFT,DDOT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMFHDR,AMFOUT,AMLST,DCOEF,MDLTS2,MODSUM,MULTBP
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION CONST
C        THE CONSTANT TERM IN THE MODEL, MODELING EITHER THE SERIES
C        MEAN OR A DETERMINISTIC TREND.
C     DOUBLE PRECISION F(NFCST)
C        THE FORECASTS.
C     DOUBLE PRECISION FCST(IFCST,NFCSTO)
C        THE STORAGE ARRAY FOR THE FORECASTS.
C     DOUBLE PRECISION FCSTSD(NFCST)
C        THE STORAGE ARRAY FOR THE STANDARD DEVIATIONS OF THE FORECASTS.
C     DOUBLE PRECISION FSD(NFCST)
C        THE STANDARD DEVIATIONS OF THE FORECASTS.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IF
C        AN INDEX VARIABLE.
C     INTEGER IFCST
C        THE FIRST DIMENSION OF THE ARRAY FCST.
C     INTEGER IFCSTO(NFCSTO)
C        THE INDICES OF THE ORIGINS FOR THE FORECASTS.
C     INTEGER IFLAG
C        AN INDICATOR VARIABLE DESIGNATING WHETHER THE BACK FORECASTS
C        WERE ESSENTIALLY ZERO (IFLAG=0) OR NOT (IFLAG=1).
C     INTEGER IFO
C        THE INDEX OF THE ORIGIN BEING USED.
C     INTEGER IFOMIN
C        THE SMALLEST ORIGIN USED.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER I1
C        AN INDEX VALUE.
C     INTEGER J
C        AN INDEX VARIABLE.
C     INTEGER K
C        AN INDEX VARIABLE.
C     INTEGER MBO
C        THE MAXIMUM BACK ORDER OPERATOR.
C     INTEGER MBOL
C        THE MAXIMUM BACK ORDER ON THE LEFT
C     INTEGER MSPECT(NFAC,4)
C        THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NFAC
C        THE NUMBER OF FACTORS IN THE MODEL
C     INTEGER NFCST
C        THE NUMBER OF FORECASTS.
C     INTEGER NFCSTO
C        THE NUMBER OF THE ORIGINS.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     INTEGER NPARAR
C        THE NUMBER OF AUTOREGRESSIVE PARAMETERS
C     INTEGER NPARDF
C        THE ORDER OF THE EXPANDED DIFFERENCE FILTER.
C     INTEGER NPARMA
C        THE LENGTH OF THE VECTOR PARMA
C     INTEGER NPRT
C        THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS
C        TO BE PROVIDED.
C     INTEGER NT
C        THE NUMBER OF PARAMETERS IN T, WHERE NT = MBOL
C     INTEGER N1
C        THE LOWER BOUND FOR PV.
C     INTEGER N2
C        THE UPPER BOUND FOR PV.
C     LOGICAL PAGE
C        THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF
C        THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     DOUBLE PRECISION PARAR(MBO)
C        THE AUTOREGRESSIVE PARAMETERS
C     DOUBLE PRECISION PARDF(NPARDF)
C        THE VECTOR CONTAINING THE DIFFERENCE FILTER PARAMETERS.
C     DOUBLE PRECISION PARMA(MBO)
C        THE MOVING AVERAGE PARAMETERS
C     DOUBLE PRECISION PMU
C        THE VALUE OF MU, I.E., THE TREND OR MEAN.
C     DOUBLE PRECISION PV(N1:N2)
C        THE PREDICTED VALUE OF THE FIT.
C     DOUBLE PRECISION RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     DOUBLE PRECISION RSS
C        THE RESIDUAL SUM OF SQUARES.
C     LOGICAL SAVE
C        THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN
C        THE RESIDUALS AND PARAMETERS ARE TO BE SAVED (TRUE) OR NOT
C        (FALSE).
C     DOUBLE PRECISION T(2*MBO)
C        A TEMPORARY WORK VECTOR.
C     DOUBLE PRECISION TEMP(MBO)
C        A TEMPORARY WORK VECTOR
C     DOUBLE PRECISION T975
C        THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE
C        T DISTRIBUTION.
C     DOUBLE PRECISION WSUM
C        THE SUM OF THE WEIGHTS SQUARED, USED TO COMPUTE THE
C        STANDARD DEVIATION OF THE FORECAST.
C     DOUBLE PRECISION WSUMT
C        A TEMPORARY STORAGE LOCATION FOR WSUM.
C     DOUBLE PRECISION Y(N)
C        THE DEPENDENT VARIABLE.
C
C
      COMMON/ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC CALL IPRINT (IPRT)
C
C     COMPUTE DIFFERENCING PARAMETERS
C
      CALL DCOEF (NFAC, MSPECT(1,2), MSPECT(1,4), NPARDF, PARDF, MBO, T)
C
C     COMPUTE RESIDUALS, GIVEN VALUES OF PARAMETERS
C
      CALL MDLTS2 (PAR, PV, Y, NPAR, N, NFAC, MSPECT, PMU,
     +  PARDF, NPARDF, T, TEMP, PARAR, PARMA, MBO, N1, N2, IFLAG)
      IDF = N - NPARDF - NPAR
      RSS = DDOT(N, PV(1), 1, PV(1), 1)
      RSD = SQRT(RSS / IDF)
C
C     PRINT INITIAL SUMMARY
C
      PAGE = .FALSE.
      IF (NPRT.EQ.0) GO TO 10
      CALL AMFHDR(PAGE, .TRUE., 2)
      CALL MODSUM(NFAC, MSPECT)
      CALL AMLST(2, PAR, NPAR, NFAC, MSPECT, N, PAR, NPAR, PAR,
     +  NPAR, PAR, NPAR, PAR, RSS, RSD, NPARDF, NPAR, IDF)
      PAGE = .TRUE.
C
   10 CONTINUE
C
C     COMBINE PARDF AND PARAR INTO T
C
      NT = NPARAR + NPARDF
      CALL MULTBP(PARAR, NPARAR, PARDF, NPARDF, T, NT, MBO)
C
C     COMPUTE CONSTANT
C
      CONST = 0.0D0
      IF (PMU.NE.0.0D0) THEN
        IF (NPARAR.GE.1) THEN
          DO 20 J = 1, NPARAR
            CONST = CONST - PARAR(J)
   20     CONTINUE
        END IF
        CONST = (1.0D0 + CONST) * PMU
      END IF
C
C     FIND LOWEST ORIGIN
C
      IFOMIN = IFCSTO(1)
      DO 30 IFO = 1, NFCSTO
        IFOMIN = MIN(IFOMIN, IFCSTO(IFO))
   30 CONTINUE
C
C     SET TEMP TO BACKFORECAST OF Y IF NECESSARY
C
      IF ((MBOL.GE.1) .AND. (IFOMIN.LT.MBOL)) THEN
        I1 = IFOMIN-MBOL+1
        DO 60 I = 0, I1, -1
          K = 1-I
          TEMP(K) = CONST
          DO 40 J = 1, MBOL
            IF (I+J.LE.N) THEN
              IF (I+J.GE.1) THEN
                TEMP(K) = TEMP(K) + T(J)*Y(I+J)
              ELSE
                TEMP(K) = TEMP(K) + T(J)*TEMP(MBOL-I-J)
              END IF
            END IF
   40     CONTINUE
          IF (NPARMA.GE.1) THEN
            DO 50 J =1, NPARMA
              IF (I+J.LE.N) TEMP(K) = TEMP(K) - PARMA(J)*PV(I+J)
   50       CONTINUE
          END IF
   60   CONTINUE
      END IF
C
C      COMPUTE WEIGHTS FOR COMPUTING STANDARD DEVIATIONS OF THE FORECAST
C
      DO 65 J = 1, NFCST
        FSD(J) = 0.0D0
        IF (MBOL.GE.1) THEN
          DO 64 I = 1, MBOL
            IF (J-I.GE.1) THEN
              FSD(J) = FSD(J) + T(I)*FSD(J-I)
            ELSE
              IF (J-I.EQ.0) FSD(J) = FSD(J) + T(I)
            END IF
   64     CONTINUE
        END IF
        IF (J.LE.NPARMA) FSD(J) = FSD(J) - PARMA(J)
   65 CONTINUE
C
C     COMPUTE STANDARD DEVIATIONS OF FORECASTS
C
      WSUM = 1.0D0
      DO 66 I = 1, NFCST
        WSUMT =WSUM
        WSUM = WSUM + FSD(I)*FSD(I)
        FSD(I) = SQRT(WSUMT)*RSD
   66 CONTINUE
C
C     SET PERCENT POINT VALUE FOR 95 PERCENT CONFIDENCE LIMITS
C
      T975 = PPFT(0.975D0, N-NPAR)
C
C     COMPUTE FORECASTS FOR EACH ORIGIN
C
      DO 100 IFO = 1, NFCSTO
        IFC = IFCSTO(IFO)
        IF ((IFC.LT.1) .OR. (IFC.GT.N)) IFC = N
        DO 90 IF = 1, NFCST
          F(IF) = CONST
          IF (MBOL.GE.1) THEN
            DO 70 J = 1, MBOL
              K = IF + IFC-J
              IF (K.LE.0) THEN
                F(IF) = F(IF) + T(J)*TEMP(1-K)
              ELSE
                IF (K.LE.IFC) THEN
                  F(IF) = F(IF) + T(J)*Y(K)
                ELSE
                  F(IF) = F(IF) + T(J)*F(IF-J)
                END IF
              END IF
   70       CONTINUE
          END IF
          IF (NPARMA.GE.1) THEN
            DO 80 J = 1, NPARMA
              K = IF + IFC - J
              IF (K.LE.IFC) F(IF) = F(IF) - PARMA(J)*PV(K)
   80       CONTINUE
          END IF
          IF (SAVE) FCST(IF,IFO) = F(IF)
   90   CONTINUE
C
C     PRINT RESULTS FROM THIS ORIGIN
C
C
C     WRITE INDEX, FORECAST, SD FORECAST, 95% CONFIDENCE INTERVAL TO
C     FILE.
C
      DO2000I=1,NFCST
        NTEMP=N+I
        FLOW=F(I)-T975*FSD(I)
        FHIGH=F(I)+T975*FSD(I)
        WRITE(IOUNI5,2001)NTEMP,F(I),FSD(I),FLOW,FHIGH
 2001   FORMAT(I5,1X,4E17.8)
 2000 CONTINUE
C
        IF (NPRT.NE.0)
     +    CALL AMFOUT(F, FSD, N, NFCST, IFCSTO, IFO, NFCSTO, Y, T975,
     +    PAGE)
C
  100 CONTINUE
C
      RETURN
C
      END
*EIAGEP
      SUBROUTINE EIAGEP (NMSUB, NMVAR, YMMN, NVMX, HEAD, MSGTYP, NV,
     +   NMMIN)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRINTS THE ERROR MESSAGES FOR ERAGT AND ERAGTM.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JUNE 10, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   MSGTYP,NV,NVMX,YMMN
      LOGICAL
     +   HEAD
C
C  ARRAY ARGUMENTS
      CHARACTER
     +   NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL HEAD
C        A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED
C        (TRUE) OR NOT (FALSE).  IF A HEADING IS PRINTED, THE VALUE
C        OF HEAD WILL BE CHANGED TO FALSE.
C     INTEGER I
C        AN INDEX ARGUMENT.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER MSGTYP
C        THE INDICATOR ARGUMENT FOR THE TYPE OF MESSAGE.
C        IF (MSGTYP.GE.3) THE MESSAGE PRINTED WILL USE NMMIN
C        OTHERWISE IT WILL USE YMMN.
C        IF (MSGTYP = 1 OR 3) NO VIOLATIONS ARE ALLOWED.
C        IF (MSGTYP = 2 OR 4) THE NUMBER OF VIOLATIONS MUST
C                             BE LESS THAN   NVMX   .
C     CHARACTER*1 NMMIN(8)
C        THE NAME OF THE ARGUMENT SPECIFYING THE MINIMUM.
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     CHARACTER*1 NMVAR(8)
C        THE CHARACTERS OF THE PARAMETERS NAME.
C     INTEGER NV
C        THE NUMBER OF VIOLATIONS FOUND.
C     INTEGER NVMX
C        THE LARGEST NUMBER OF VIOLATIONS ALLOWED.
C     INTEGER YMMN
C        THE MINIMUM ACCEPTABLE VALUE.
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
CCCCC CALL IPRINT(IPRT)
      CALL EHDR(NMSUB, HEAD)
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
C
      IF (MSGTYP.LE.2)
     +   WRITE (ICOUT, 1000) (NMVAR(I),I=1,6), YMMN, NV
      IF (MSGTYP.GE.3) THEN
         WRITE (ICOUT, 1005) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), NV
         CALL DPWRST('XXX','BUG ')
      ENDIF
C
      GO TO (10, 20, 30, 40), MSGTYP
C
   10 WRITE(ICOUT, 1010) (NMVAR(I),I=1,6), YMMN
      CALL DPWRST('XXX','BUG ')
      RETURN
C
   20 WRITE(ICOUT, 1020) (NMVAR(I),I=1,6), YMMN
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT, 1021) NVMX
      CALL DPWRST('XXX','BUG ')
      RETURN
C
   30 WRITE(ICOUT, 1030) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
   40 WRITE(ICOUT, 1040) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT, 1041) NVMX
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     FORMAT STATEMENTS
C
  999 FORMAT(1X)
 1000 FORMAT (
     +   ' THE NUMBER OF VALUES IN ARRAY ', 6A1,
     +   ' LESS THAN ', I5, ' IS ', I6, '.')
 1005 FORMAT (
     +   ' THE NUMBER OF VALUES IN ARRAY ', 6A1,
     +   ' LESS THAN ', 8A1, ' IS ', I6, '.')
 1010 FORMAT(
     +   ' THE VALUES IN THE ARRAY ', 6A1,
     +   ' MUST ALL BE GREATER THAN OR EQUAL TO ', I5, '.')
 1020 FORMAT(
     +   ' THE NUMBER OF VALUES IN THE ARRAY ', 6A1,
     +   ' LESS THAN ', I5)
 1021 FORMAT(
     +   ' MUST BE LESS THAN ', I5, '.')
 1030 FORMAT(
     +   ' THE VALUES IN THE ARRAY ', 6A1,
     +   ' MUST ALL BE GREATER THAN OR EQUAL TO ', I5, '.')
 1040 FORMAT(
     +   ' THE NUMBER OF VALUES IN THE ARRAY ', 6A1,
     +   ' LESS THAN ',8A1)
 1041 FORMAT(
     +   ' MUST BE LESS THAN ', I5, '.')
C
      END
*HPFLT
      SUBROUTINE HPFLT (HLP, K, HHP)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE HIPASS FILTER COEFFICIENTS
C     CORRESPONDING TO THE INPUT LOW PASS FILTER.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  NOVEMBER 26, 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   K
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   HHP(K),HLP(K)
C
C  LOCAL SCALARS
      INTEGER
     +   I,KMID
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION HHP(K)
C        THE ARRAY IN WHICH THE HIGH PASS FILTER COEFFICIENTS
C        WILL BE RETURNED.
C     DOUBLE PRECISION HLP(K)
C        THE ARRAY IN WHICH THE INPUT LOW PASS FILTER COEFFICIENTS
C        ARE STORED.
C     INTEGER I
C       AN INDEX VARIABLE.
C     INTEGER K
C        THE NUMBER OF FILTER TERMS TO BE COMPUTED.
C     INTEGER KMID
C        THE MIDPOINT OF THE FILTER.
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DO 20 I = 1, K
         HHP(I) = -HLP(I)
   20 CONTINUE
C
      KMID = (K + 1) / 2
C
      HHP(KMID) = HHP(KMID) + 1.0D0
C
      RETURN
      END
*MADJ
      SUBROUTINE MADJ(N, P, X, NF, J, UIPARM, URPARM, UFPARM)
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N,NF,P
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   J(N,P),URPARM(*),X(P)
      INTEGER
     +   UIPARM(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL UFPARM
C
C  INTRINSIC FUNCTIONS
      INTRINSIC COS,SIN
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      J(1,1) = 2.0D0*X(1) + X(2)
      J(1,2) = 2.0D0*X(2) + X(1)
      J(2,1) = COS(X(1))
      J(2,2) = 0.0D0
      J(3,1) = 0.0D0
      J(3,2) = -SIN(X(2))
      RETURN
      END
*NLSUPK
      SUBROUTINE NLSUPK(PARE, NPARE, PAR, MASK, NPAR)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE UNPACKS A VECTOR PARE INTO A VECTOR PAR, BY
C     PLACING SUCCEDING ELEMENTS OF PARE INTO ELEMENTS OF PAR
C     WHICH CORRESPOND TO ELEMENTS OF MASK WITH THE VALUE 1.
C     OTHER ELEMENTS OF MASK SHOULD BE 0.  THE NUMBER OF ELEMENTS
C     NPARE IN PARE SHOULD EQUAL THE NUMBER OF ELEMENTS OF
C     MASK WHICH ARE 1.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  OCTOBER 3, 1983
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   NPAR,NPARE
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   PAR(NPAR),PARE(NPAR)
      INTEGER
     +   MASK(NPAR)
C
C  LOCAL SCALARS
      INTEGER
     +   I,JPK
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER JPK
C        AN INDEX VARIABLE.
C     INTEGER MASK(NPAR)
C        INPUT PARAMETER.  THE MASK GOVERNING THE PACKING OF PAR.
C        ELEMENTS OF MASK ARE 1 IF THE CORRESPONDING ELEMENT OF PAR
C        WAS ELIMINATED IN PARE, 0 IF IT WAS INCLUDED.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     INTEGER NPARE
C        THE NUMBER OF PARAMETERS TO BE OPTIMIZED.
C     DOUBLE PRECISION PARE(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS BEING OPTIMIZED,
C        NOT INCLUDING THOSE WHOSE VALUES ARE FIXED.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     COMMENCE BODY OF ROUTINE
C
      JPK = 0
      DO 20 I=1,NPAR
         IF (MASK(I).NE.0) GO TO 20
         JPK = JPK + 1
         PAR(I) = PARE(JPK)
   20 CONTINUE
      RETURN
      END
*STKCLR
      SUBROUTINE STKCLR (NALL0)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE IS AN ADDITION TO THE FRAMEWORK AREA MANIPULATION
C     ROUTINES.  IT CLEARS ALL ALLOCATIONS MADE SINCE THE FIRST NALL0.
C     IT IS INTENDED FOR USE DURING ERROR OR FINAL EXITS FROM STARPAC
C     ROUTINES WHICH MAKE ALLOCATIONS, TO RELEASE ALL ALLOCATIONS
C     MADE SINCE THE NALL0 EXISTING ON ENTRY TO THE STARPAC ROUTINE,
C     WITHOUT KNOWING HOW MANY ALLOCATIONS MUST BE RELEASED.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 7, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   NALL0
C
C  LOCAL SCALARS
      INTEGER
     +   NALLN
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKST
      EXTERNAL STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL STKREL
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER NALL0
C        INPUT PARAMETER.  THE NUMBER OF ALLOCATIONS TO BE PRESERVED
C        WHEN ALL LATER ONES ARE RELEASED.
C     INTEGER NALLN
C        THE TOTAL NUMBER OF ALLOCATIONS EXISTING BEFORE ANY ARE
C        RELEASED.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     COMMENCE BODY OF ROUTINE
C
      NALLN = STKST(1)
      CALL STKREL (NALLN - NALL0)
      RETURN
      END
*AIMES
      SUBROUTINE AIMES(Y, N, MSPEC, NFAC, PAR, NPAR, RES, LDSTAK,
     +   IFIXED, STP, MIT, STOPSS, STOPP, SCALE, DELTA, IVAPRX, NPRT,
     +   NPARE, RSD, PV, SDPV, SDRES, VCV, IVCV)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE SUBROUTINE FOR ARIMA ESTIMATION
C     (LONG CALL).
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 2, 1985
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   DELTA,RSD,STOPP,STOPSS
      INTEGER
     +   IVAPRX,IVCV,LDSTAK,MIT,N,NFAC,NPAR,NPARE,NPRT
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   PAR(*),PV(*),RES(*),SCALE(*),SDPV(*),SDRES(*),STP(*),VCV(*),
     +   Y(*)
      INTEGER
     +   IFIXED(1),MSPEC(4,*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP
      LOGICAL
     +   SAVE
C
C  LOCAL ARRAYS
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMEDRV
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION DELTA
C        THE MAXIMUM CHANGE ALLOWED IN THE MODEL PARAMETERS AT THE
C        FIRST ITERATION.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER IERR
C        THE VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .GE. 1, ERRORS WERE DETECTED.
C     INTEGER IFIXED(1)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE
C        PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED.
C        IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED.
C        IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED.
C        IF IFIXED(1).LT.0, THEN IFIXED(I)=DEFAULT,I=1,...,NPAR, AND THE
C                           DIMENSION OF IFIXED WILL BE ASSUMED TO BE 1.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IVAPRX
C        AN INDICATOR VALUE USED TO DESIGNATE WHICH OPTION IS TO BE USED
C        TO COMPUTE THE VARIANCE COVARIANCE MATRIX (VCV), WHERE FOR
C        IVAPRX LE 0, VCV = THE DEFAULT OPTION
C        IVAPRX EQ 1, VCV = INVERSE(TRANSPOSE(J)*J)
C                     USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED
C                     DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE
C        IVAPRX EQ 2, VCV = INVERSE(H)
C                     USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED
C                     DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE
C        IVAPRX EQ 3, VCV = INVERSE(H)*TRANSPOSE(J)*JACOBIAN*INVERSE(H)
C                     USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED
C                     DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE
C        IVAPRX EQ 4, VCV = INVERSE(TRANSPOSE(J)*J)
C                     USING ONLY THE MODEL SUBROUTINE
C        IVAPRX EQ 5, VCV = INVERSE(H)
C                     USING ONLY THE MODEL SUBROUTINE
C        IVAPRX EQ 6, VCV = INVERSE(H)*TRANSPOSE(J)*JACOBIAN*INVERSE(H)
C                     USING ONLY THE MODEL SUBROUTINE
C        IVAPRX GE 7, VCV = THE DEFAULT OPTION
C        WITH J REPRESENTING THE JACOBIAN AND H THE HESSIAN.
C     INTEGER IVCV
C        THE FIRST DIMENSION OF MATRIX VCV.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER LIFIXD
C        THE DIMENSION OF VECTOR IFIXED.
C     INTEGER LPV
C        THE DIMENSION OF VECTOR PV.
C     INTEGER LSCALE
C        THE DIMENSION OF VECTOR SCALE.
C     INTEGER LSDPV
C        THE DIMENSION OF VECTOR SDPV.
C     INTEGER LSDRES
C        THE DIMENSION OF VECTOR SDRES.
C     INTEGER LSTP
C        THE DIMENSION OF VECTOR STP.
C     INTEGER MIT
C        THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C     INTEGER MSPEC(4,NFAC)
C        THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NFAC
C        THE NUMBER OF FACTORS IN THE MODEL
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE ROUTINE CALLING THE ERROR CHECKING ROUTINE
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     INTEGER NPARE
C        THE NUMBER OF PARAMETERS TO BE OPTIMIZED.
C     INTEGER NPRT
C        THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS
C        TO BE PROVIDED.
C     DOUBLE PRECISION PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     DOUBLE PRECISION PV(N)
C        THE PREDICTED VALUE OF THE FIT.
C     DOUBLE PRECISION RES(N)
C        THE RESIDUALS FROM THE FIT.
C     DOUBLE PRECISION RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     LOGICAL SAVE
C        THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN
C        THE RESIDUALS AND PARAMETERS ARE TO BE SAVED (TRUE) OR NOT
C        (FALSE).
C     DOUBLE PRECISION SCALE(NPAR)
C        THE TYPICAL SIZE OF THE PARAMETERS.
C        IF SCALE(1).LE.0, THEN SCALE(I)=DEFAULT,I=1,...,NPAR, AND THE
C                          DIMENSION OF SCALE WILL BE ASSUMED TO BE 1.
C     DOUBLE PRECISION SDPV(N)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     DOUBLE PRECISION SDRES(N)
C        THE STANDARDIZED RESIDUALS.
C     DOUBLE PRECISION STOPP
C        THE STOPPING CRITERION FOR THE TEST BASED ON THE MAXIMUM SCALED
C        RELATIVE CHANGE IN THE ELEMENTS OF THE MODEL PARAMETER VECTOR
C     DOUBLE PRECISION STOPSS
C        THE STOPPING CRITERION FOR THE TEST BASED ON THE RATIO OF THE
C        PREDICTED DECREASE IN THE RESIDUAL SUM OF SQUARES (COMPUTED
C        BY STARPAC) TO THE CURRENT RESIDUAL SUM OF SQUARES ESTIMATE.
C     DOUBLE PRECISION STP(NPAR)
C        THE STEP SIZE ARRAY.
C        IF STP(1).LE.0, THEN STP(I)=DEFAULT,I=1,...,NPAR, AND THE
C                        DIMENSION OF STP WILL BE ASSUMED TO BE 1.
C     DOUBLE PRECISION VCV(IVCV,NPAR)
C        THE VARIANCE-COVARIANCE MATRIX.
C     DOUBLE PRECISION Y(N)
C        THE DEPENDENT VARIABLE.
C
C     SET UP NAME ARRAYS
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'A','I','M','E','S',' '/
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      SAVE = .TRUE.
C
      LIFIXD = NPAR
      IF (IFIXED(1).LE.-1) LIFIXD = 1
      LSCALE = NPAR
      IF (SCALE(1).LE.0.0D0) LSCALE = 1
      LSTP = NPAR
      IF (STP(1).LE.0.0D0) LSTP = 1
C
      CALL AMEDRV(Y, N, MSPEC, NFAC, PAR, NPAR, RES,
     +   LDSTAK, IFIXED, LIFIXD, STP, LSTP, MIT, STOPSS, STOPP, SCALE,
     +   LSCALE, DELTA, IVAPRX, NPRT, RSD, PV, LPV, SDPV, LSDPV, SDRES,
     +   LSDRES, VCV, IVCV, NMSUB, SAVE, NPARE)
C
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
CCCCC CALL IPRINT(IPRT)
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1000)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1001)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1002)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1003)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1004)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     FORMAT STATEMENTS
C
  999 FORMAT(1X)
 1000 FORMAT (' THE CORRECT FORM OF THE CALL STATEMENT IS')
 1001 FORMAT (
     +  '       CALL AIMES(Y, N, MSPEC, NFAC, PAR, NPAR, RES, LDSTAK,')
 1002 FORMAT (
     +  '      +           IFIXED, STP, MIT, STOPSS, STOPP, SCALE,')
 1003 FORMAT (
     +  '      +           DELTA, IVAPRX, NPRT,')
 1004 FORMAT (
     +  '      +           NPARE, RSD, PV, SDPV, SDRES, VCV, IVCV)')
      END
*AMFOUT
      SUBROUTINE AMFOUT(F, FSD, N, NFCST, IFCSTO, IFO, NFCSTO, Y,
     +  T975, PAGE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRODUCES ARIMA FORECASTING OUTPUT
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 2, 1985
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   T975
      INTEGER
     +   IFO,N,NFCST,NFCSTO
      LOGICAL
     +   PAGE
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   F(*),FSD(*),Y(*)
      INTEGER
     +   IFCSTO(*)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   FL,FU,SCALE,YMN,YMX
      INTEGER
CCCCC+   I,IEND,IF,ILIM,INTER,IPF,IPFL,IPFU,IPRT,IPY,IY,J
     +   I,IEND,IF,ILIM,INTER,IPF,IPFL,IPFU,IPY,IY,J
C
C  LOCAL ARRAYS
      DOUBLE PRECISION
     +   YLIM(4)
      CHARACTER
     +   LINE(53)*1
C
C  EXTERNAL SUBROUTINES
CCCCC EXTERNAL AMFHDR,IPRINT
      EXTERNAL AMFHDR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC INT,MAX,MIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION F(NFCST)
C        THE FORECASTS.
C     DOUBLE PRECISION FL
C        THE LOWER 95 PERCENT CONFIDENCE LIMIT FOR THE FORECAST
C     DOUBLE PRECISION FSD(NFCST)
C        THE STANDARD DEVIATIONS OF THE FORECASTS.
C     DOUBLE PRECISION FU
C        THE UPPER 95 PERCENT CONFIDENCE LIMIT FOR THE FORECAST
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IEND
C        THE LAST LOCATION IN THE PLOT STRING.
C     INTEGER IF
C        AN INDEX VARIABLE.
C     INTEGER IFCSTO(NFCSTO)
C        THE INDICES OF THE ORIGINS FOR THE FORECASTS.
C     INTEGER IFO
C        THE INDEX OF THE ORIGIN BEING USED.
C     INTEGER ILIM
C        THE NUMBER OF LOCATIONS IN YLIM.
C     INTEGER INTER
C        THE NUMBER OF PLOT INTERVALS.
C     INTEGER IPF
C        THE LOCATION IN THE PLOT STRING OF THE FORECAST.
C     INTEGER IPFL
C        THE LOCATION IN THE PLOT STRING OF THE FORECAST LOWER
C        CONFIDENCE LIMIT.
C     INTEGER IPFU
C        THE LOCATION IN THE PLOT STRING OF THE FORECAST UPPER
C        CONFIDENCE LIMIT.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IPY
C        THE LOCATION IN THE PLOT STRING OF THE OBSERVED VALUE.
C     INTEGER IY
C        AN INDEX VARIABLE.
C     INTEGER J
C        AN INDEX VARIABLE.
C     CHARACTER*1 LINE(53)
C        THE ARRAY OF SYMBOLS TO BE PLOTTED.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NFCST
C        THE NUMBER OF FORECASTS.
C     INTEGER NFCSTO
C        THE NUMBER OF THE ORIGINS.
C     LOGICAL PAGE
C        THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF
C        THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION SCALE
C        THE PLOT SCALE.
C     DOUBLE PRECISION T975
C        THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE
C        T DISTRIBUTION.
C     DOUBLE PRECISION Y(N)
C        THE DEPENDENT VARIABLE.
C     DOUBLE PRECISION YLIM(4)
C        THE VALUES OF THE AXIS LABELS.
C     DOUBLE PRECISION YMN
C        THE MINIMUM VALUE TO BE PLOTTED.
C     DOUBLE PRECISION YMX
C        THE MAXIMUM VALUE TO BE PLOTTED.
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     SET VARIABLES FOR PLOTS
C
CCCCC CALL IPRINT(IPRT)
      INTER = 50
      IEND = INTER + 1
      ILIM = 4
C
C     COMPUTE SCALE FOR PLOT
C
      YMN = F(NFCST)-T975*FSD(NFCST)
      YMX = F(NFCST)+T975*FSD(NFCST)
      IY = IFCSTO(IFO)
      DO 10 I = 1, NFCST
        YMN = MIN(YMN, F(I)-T975*FSD(I))
        YMX = MAX(YMX, F(I)+T975*FSD(I))
        IF ((IY.GE.1) .AND. (IY.LE.N)) THEN
          YMN = MIN(YMN, Y(IY))
          YMX = MAX(YMX, Y(IY))
          IY = IY + 1
        END IF
   10 CONTINUE
      IF (IFCSTO(IFO).GE.2) THEN
        DO 20 IY = MAX(IFCSTO(IFO)-4, 1), IFCSTO(IFO)-1
          YMN = MIN(YMN, Y(IY))
          YMX = MAX(YMX, Y(IY))
   20   CONTINUE
      END IF
C
      SCALE = (YMX-YMN) / INTER
C
C     PRINT PLOT HEADINGS
C
      DO 30 I = 1, ILIM
        YLIM(I) = YMN + SCALE*I*10.0D0
   30 CONTINUE
C
      CALL AMFHDR(PAGE, .TRUE., 0)
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1030) IFO
 1030 FORMAT (' FORECASTS FOR ORIGIN ', I2)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1000)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1001) YMN, YLIM(2), YLIM(4)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1002) YLIM(1), YLIM(4), YMX
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1003)
      CALL DPWRST('XXX','BUG ')
 1000 FORMAT (
     +  82X, ' --------------------95  PERCENT')
 1001 FORMAT (
     +  1X, 3(G15.8, 5X), 21X,
     +  ' --------------CONFIDENCE LIMITS',
     +  ' ---------ACTUAL')
 1002 FORMAT (
     +  11X, 2(G15.8, 5X), G15.8,
     +  ' ------FORECASTS ----------LOWER',
     +  ' ----------UPPER -------IF KNOWN')
 1003 FORMAT (
     +  9X, 5('I---------'), 'I', 6X,
     +  ' ------------[X] ------------[(]',
     +  ' ------------[)] ------------[*]')
C
C     BEGIN PLOTTING
C
      DO 80 I=MAX(IFCSTO(IFO)-4,1), IFCSTO(IFO)+NFCST
         IF (I.NE.IFCSTO(IFO)) THEN
           DO 40 J = 1, IEND
             LINE(J) = ' '
   40      CONTINUE
         ELSE
           DO 50 J = 1, IEND
             LINE(J) = '.'
   50      CONTINUE
         END IF
         IF (I.LE.IFCSTO(IFO)) THEN
           IPY = INT(((Y(I)-YMN) / SCALE) + 1.5D0)
           LINE(IPY) = '*'
           WRITE (ICOUT, 1020) I, (LINE(J),J=1,IEND), I, Y(I)
 1020 FORMAT (2X, I5, 1X, 'I', 51A1, 'I', I5, 49X, G15.8)
           CALL DPWRST('XXX','BUG ')
         ELSE
           IF = I-IFCSTO(IFO)
           FL = F(IF) - T975*FSD(IF)
           FU = F(IF) + T975*FSD(IF)
           IF (I.LE.N) THEN
             IPFL = INT(((FL-YMN) / SCALE) + 1.5D0)
             IPFU = INT(((FU-YMN) / SCALE) + 1.5D0)
             DO 60 J = IPFL, IPFU
               LINE(J) = '-'
   60        CONTINUE
             LINE(IPFL) = '('
             LINE(IPFU) = ')'
             IPY = INT(((Y(I)-YMN) / SCALE) + 1.5D0)
             LINE(IPY) = '*'
             IPF = INT(((F(IF)-YMN) / SCALE) + 1.5D0)
             IF (IPF.NE.IPY) THEN
               LINE(IPF) = 'X'
             ELSE
               LINE(IPF) = '2'
             END IF
             WRITE (ICOUT, 1010) I, (LINE(J),J=1,IEND), I,
     +         F(IF), FL, FU, Y(I)
             CALL DPWRST('XXX','BUG ')
           ELSE
             IPFL = INT(((FL-YMN) / SCALE) + 1.5D0)
             IPFU = INT(((FU-YMN) / SCALE) + 1.5D0)
             DO 70 J = IPFL, IPFU
               LINE(J) = '-'
   70        CONTINUE
             LINE(IPFL) = '('
             LINE(IPFU) = ')'
             IPF = INT(((F(IF)-YMN) / SCALE) + 1.5D0)
             LINE(IPF) = 'X'
             WRITE (ICOUT, 1010) I, (LINE(J),J=1,IEND), I,
     +         F(IF), FL, FU
 1010 FORMAT (2X, I5, 1X, 'I', 51A1, 'I', I5, 4(1X, G15.8))
             CALL DPWRST('XXX','BUG ')
           END IF
         END IF
   80 CONTINUE
C
      RETURN
C
C     FORMAT STATEMENTS
C
C
      END
*EISEQ
      SUBROUTINE EISEQ(NMSUB, NMVAR1, NVAL, NEQ, MSGTYP, HEAD, ERROR,
     +   NMVAR2)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE CHECKS WHETHER THE VALUE   NVAL   IS
C     OQUAL TO   NEQ  AND PRINTS A DIAGNOSTIC IF IT IS NOT.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 2, 1985
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   MSGTYP,NEQ,NVAL
      LOGICAL
     +   ERROR,HEAD
C
C  ARRAY ARGUMENTS
      CHARACTER
     +   NMSUB(6)*1,NMVAR1(8)*1,NMVAR2(8)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERROR
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     LOGICAL HEAD
C        A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED
C        (TRUE) OR NOT (FALSE).  IF A HEADING IS PRINTED, THE VALUE
C        OF HEAD WILL BE CHANGED TO FALSE.
C     INTEGER I
C        AN INDEX ARGUMENT.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER MSGTYP
C        AN ARGUMENT USED TO INDICATE THE TYPE OF MESSAGE TO BE
C        PRINTED, WHERE IF ERROR IS TRUE AND
C        MSGTYP = 1 THE INPUT VALUE WAS NOT EQUAL TO THE NUMBER OF PARAM
C                   SPECIFIED BY MSPEC (ARIMA ESTIMATION AND FORECASTING
C     INTEGER NEQ
C        THE ACCEPTABLE VALUE FOR THE ARGUMENT BEING TESTED.
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING SUBROUTINES NAME.
C     CHARACTER*1 NMVAR1(8)
C        THE CHARACTERS OF THE NAME OF THE ARGUMENT BEING CHECKED.
C     CHARACTER*1 NMVAR2(8)
C        THE CHARACTERS OF THE NAME OF THE ARGUMENT BEING CHECKED
C        AGAINST.
C     INTEGER NVAL
C        THE INPUT VALUE OF THE ARGUMENT BEING CHECKED.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      ERROR = .FALSE.
C
      IF (NVAL .EQ. NEQ) RETURN
C
      ERROR = .TRUE.
C
CCCCC CALL IPRINT (IPRT)
C
      CALL EHDR(NMSUB, HEAD)
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
C
      WRITE (ICOUT, 1000) (NMVAR1(I), I=1,6), NVAL
      CALL DPWRST('XXX','BUG ')
C
C     PRINT MESSAGE FOR ARIMA ROUTINES
C
      WRITE (ICOUT, 1010) (NMVAR1(I), I=1,6)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1011) NEQ
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1012)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1013)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     FORMAT STATEMENTS
C
  999 FORMAT(1X)
 1000 FORMAT (' THE INPUT VALUE OF ', 6A1, ' IS ', I5, '.')
 1010 FORMAT(
     +   ' THE VALUE OF THE ARGUMENT ', 6A1,
     +   ' MUST BE GREATER THAN OR EQUAL TO')
 1011 FORMAT(
     +   1X, I5, ' = ONE PLUS THE SUM OF MSPEC(1,J)+MSPEC(3,J) FOR',
     +   ' J = 1, ..., NFAC,')
 1012 FORMAT(
     +   6X,' = ONE PLUS THE NUMBER OF AUTOREGRESSIVE PARAMETERS PLUS')
 1013 FORMAT(
     +   9X, ' THE NUMBER OF MOVING AVERAGE PARAMETERS.')
C
      END
*ICNTI
      INTEGER FUNCTION ICNTI (IV, NIV, I)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COUNTS THE NUMBER OF OCCURENCES OF I IN IV.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING LAB/BOULDER
C                  NATIONAL BUREAU OF STANDARDS
C
C     CREATION DATE  -  APRIL 20, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   I,NIV
C
C  ARRAY ARGUMENTS
      INTEGER
     +   IV(NIV)
C
C  LOCAL SCALARS
      INTEGER
     +   J
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        INPUT PARAMETER.  THE INTEGER TO COUNT OCCURENCES OF.
C     INTEGER IV(NIV)
C        INPUT PARAMETER.  THE VECTOR IN WHICH TO COUNT.
C     INTEGER J
C        LOOP PARAMETER.
C     INTEGER NIV
C        INPUT PARAMETER.  THE LENGTH OF IV.
C
C     COMMENCE BODY OF ROUTINE
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      ICNTI = 0
      DO 10 J = 1, NIV
         IF (IV(J) .EQ. I) ICNTI = ICNTI + 1
   10 CONTINUE
      RETURN
      END
*MADR
      SUBROUTINE MADR(N, P, X, NF, R, UIPARM, URPARM, UFPARM)
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N,NF,P
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   R(N),URPARM(*),X(P)
      INTEGER
     +   UIPARM(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL UFPARM
C
C  INTRINSIC FUNCTIONS
      INTRINSIC COS,SIN
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      R(1) = X(1)**2 + X(2)**2 + X(1)*X(2)
      R(2) = SIN(X(1))
      R(3) = COS(X(2))
      RETURN
      END
*OBSSM2
      SUBROUTINE OBSSM2(N, Y, PVT, SDPVT, RES, SDREST, IFIRST, ILAST)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBOUTINE LISTS THE DATA SUMMARY FOR THE ARIMA ESTIMATION
C     SUBROUTINES.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 2, 1985
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IFIRST,ILAST,N
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   PVT(N),RES(N),SDPVT(N),SDREST(N),Y(N)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   FPLM
      INTEGER
     +   I
C
C  EXTERNAL FUNCTIONS
CCCCC DOUBLE PRECISION
CCCCC+   D1MACH
CCCCC EXTERNAL D1MACH
C
C  EXTERNAL SUBROUTINES
CCCCC EXTERNAL IPRINT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IERR
C        THE VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .GE. 1, ERRORS WERE DETECTED.
C     INTEGER IFIRST, ILAST
C        THE FIRST AND LAST INDICES TO BE LISTED.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     DOUBLE PRECISION PVT(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES.
C     DOUBLE PRECISION RES(N)
C        THE RESIDUALS FROM THE FIT.
C     DOUBLE PRECISION SDPVT(N)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     DOUBLE PRECISION SDREST(N)
C        THE STANDARDIZED RESIDUALS.
C     DOUBLE PRECISION Y(N)
C        THE DEPENDENT VARIABLE.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      FPLM = D1MACH(2)
C
CCCCC CALL IPRINT(IPRT)
C
      DO 140 I=IFIRST,ILAST
C
C     PRINT DATA SUMMARY.
C
         IF ((SDPVT(I).NE.FPLM) .AND. (SDREST(I).NE.FPLM)) THEN
            WRITE (IOUNI2, 1060) I, Y(I), PVT(I), SDPVT(I), RES(I),
     +      SDREST(I)
         ENDIF
         IF ((SDPVT(I).NE.FPLM) .AND. (SDREST(I).EQ.FPLM)) THEN
            WRITE (IOUNI2, 1050) I, Y(I), PVT(I), SDPVT(I), RES(I)
         ENDIF
         IF ((SDPVT(I).EQ.FPLM) .AND. (SDREST(I).EQ.FPLM)) THEN
            WRITE (IOUNI2, 1080) I, Y(I), PVT(I), RES(I)
         ENDIF
C
  140 CONTINUE
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1050 FORMAT (I4, 4E16.8, 4X, 'NC *')
 1060 FORMAT (I4, 4E16.8, 1X, F7.2)
 1080 FORMAT (I4, 2E16.8, 7X, 'NC *', 4X, E15.8, 4X, 'NC *')
      END
*STKGET
      INTEGER FUNCTION STKGET(NITEMS, ITYPE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C  ALLOCATES SPACE OUT OF THE INTEGER ARRAY ISTAK (IN COMMON
C  BLOCK CSTAK) FOR AN ARRAY OF LENGTH NITEMS AND OF TYPE
C  DETERMINED BY ITYPE AS FOLLOWS
C
C    1 - LOGICAL
C    2 - INTEGER
C    3 - REAL
C    4 - DOUBLE PRECISION
C    5 - COMPLEX
C
C  ON RETURN, THE ARRAY WILL OCCUPY
C
C    STAK(STKGET), STAK(STKGET+1), ..., STAK(STKGET-NITEMS+1)
C
C  WHERE STAK IS AN ARRAY OF TYPE ITYPE EQUIVALENCED TO ISTAK.
C
C  (FOR THOSE WANTING TO MAKE MACHINE DEPENDENT MODIFICATIONS
C  TO SUPPORT OTHER TYPES, CODES 6, 7, 8, 9, 10, 11 AND 12 HAVE
C  BEEN RESERVED FOR 1/4 LOGICAL, 1/2 LOGICAL, 1/4 INTEGER,
C  1/2 INTEGER, QUAD PRECISION, DOUBLE COMPLEX AND QUAD
C  COMPLEX, RESPECTIVELY.)
C
C  THE USE OF THE FIRST FIVE WORDS IS DESCRIBED BELOW.
C
C    ISTAK( 1) - LOUT,  THE NUMBER OF CURRENT ALLOCATIONS.
C    ISTAK( 2) - LNOW,  THE CURRENT ACTIVE LENGTH OF THE STACK.
C    ISTAK( 3) - LUSED, THE MAXIMUM VALUE OF ISTAK(2) ACHIEVED.
C    ISTAK( 4) - LMAX,  THE MAXIMUM LENGTH THE STACK.
C    ISTAK( 5) - LBOOK, THE NUMBER OF WORDS USED FOR BOOKEEPING.
C
C  THE NEXT FIVE WORDS CONTAIN INTEGERS DESCRIBING THE AMOUNT
C  OF STORAGE ALLOCATED BY THE FORTRAN SYSTEM TO THE VARIOUS
C  DATA TYPES.  THE UNIT OF MEASUREMENT IS ARBITRARY AND MAY
C  BE WORDS, BYTES OR BITS OR WHATEVER IS CONVENIENT.  THE
C  VALUES CURRENTLY ASSUMED CORRESPOND TO AN ANS FORTRAN
C  ENVIRONMENT.  FOR SOME MINI-COMPUTER SYSTEMS THE VALUES MAY
C  HAVE TO BE CHANGED (SEE I0TK00).
C
C    ISTAK( 6) - THE NUMBER OF UNITS ALLOCATED TO LOGICAL
C    ISTAK( 7) - THE NUMBER OF UNITS ALLOCATED TO INTEGER
C    ISTAK( 8) - THE NUMBER OF UNITS ALLOCATED TO REAL
C    ISTAK( 9) - THE NUMBER OF UNITS ALLOCATED TO DOUBLE PRECISION
C    ISTAK(10) - THE NUMBER OF UNITS ALLOCATED TO COMPLEX
C
C     THIS FUNCTION WAS ADAPTED FROM THE FRAMEWORK FUNCTION ISTKGT
C
C     ADAPTED BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  NOVEMBER 26, 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   ITYPE,NITEMS
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   I,LBOOK,LMAX,LNOW,LOUT,LUSED
C
C  LOCAL ARRAYS
      INTEGER
     +   ISIZE(5),ISTAK(12)
C
C  EXTERNAL SUBROUTINES
CCCCC EXTERNAL IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),ISTAK(1))
      EQUIVALENCE (ISTAK(1),LOUT)
      EQUIVALENCE (ISTAK(2),LNOW)
      EQUIVALENCE (ISTAK(3),LUSED)
      EQUIVALENCE (ISTAK(4),LMAX)
      EQUIVALENCE (ISTAK(5),LBOOK)
      EQUIVALENCE (ISTAK(6),ISIZE(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER I
C        THE LOCATION OF A POINTER TO THE END OF THE PREVIOUS ALLOCATION
C     INTEGER IERR
C        THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED
C        IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER ISIZE(5)
C        THE NUMBER OF WORDS IN EACH OF THE VARIOUS DATA TYPES.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ITYPE
C        THE TYPE OF ARRAY OF LENGTH NITEMS TO BE ALLOCATED.
C     INTEGER LBOOK
C        THE NUMBER OF WORDS USED FOR BOOKEEPING.
C     INTEGER LMAX
C        THE MAXIMUM LENGTH OF THE STACK.
C     INTEGER LNOW
C        THE CURRENT ACTIVE LENGTH OF THE STACK.
C     INTEGER LOUT
C        THE NUMBER OF CURRENT ALLOCATIONS.
C     INTEGER LUSED
C        THE MAXIMUM VALUE OF ISTAK(2) ACHEIVED.
C     INTEGER NITEMS
C        THE LENGTH OF THE ARRAY OF ITYPE TO BE ALLOCATED.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      STKGET = (LNOW*ISIZE(2)-1)/ISIZE(ITYPE) + 2
      I = ( (STKGET-1+NITEMS)*ISIZE(ITYPE) - 1 )/ISIZE(2) + 3
C
C  STACK OVERFLOW IS AN UNRECOVERABLE ERROR.
C
      IF (I .LE. LMAX) GO TO 10
C
      IERR = 1
CCCCC CALL IPRINT(IPRT)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
C
      WRITE(ICOUT, 1000)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
   10 CONTINUE
C
C  ISTAK(I-1) CONTAINS THE TYPE FOR THIS ALLOCATION.
C  ISTAK(I  ) CONTAINS A POINTER TO THE END OF THE PREVIOUS
C             ALLOCATION.
C
      ISTAK(I-1) = ITYPE
      ISTAK(I  ) = LNOW
      LOUT = LOUT+1
      LNOW = I
      LUSED = MAX(LUSED, LNOW)
C
      RETURN
C
C     FORMAT STATEMENTS
C
  999 FORMAT(1X)
 1000 FORMAT(' DSTAK IS TOO SHORT.')
C
      END
*AIMFS
      SUBROUTINE AIMFS(Y, N, MSPEC, NFAC, PAR, NPAR, LDSTAK,
     +   NFCST, NFCSTO, IFCSTO, NPRT, FCST, IFCST, FCSTSD)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE SUBROUTINE FOR ARIMA ESTIMATION
C     (CONTROL CALL).
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 2, 1985
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IFCST,LDSTAK,N,NFAC,NFCST,NFCSTO,NPAR,NPRT
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   FCST(*),FCSTSD(*),PAR(*),Y(*)
      INTEGER
     +   IFCSTO(*),MSPEC(4,*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   NFCSTU
      LOGICAL
     +   SAVE
C
C  LOCAL ARRAYS
      CHARACTER
     +   NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMFCNT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     DOUBLE PRECISION FCST(IFCST,NFCSTO)
C        THE STORAGE ARRAY FOR THE FORECASTS.
C     DOUBLE PRECISION FCSTSD(NFCST)
C        THE STORAGE ARRAY FOR THE STANDARD DEVIATIONS OF THE FORECASTS.
C     INTEGER IERR
C        THE VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .GE. 1, ERRORS WERE DETECTED.
C     INTEGER IFCST
C        THE FIRST DIMENSION OF THE ARRAY FCST.
C     INTEGER IFCSTO(NFCSTO)
C        THE INDICES OF THE ORIGINS FOR THE FORECASTS.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER MSPEC(4,NFAC)
C        THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NFAC
C        THE NUMBER OF FACTORS IN THE MODEL
C     INTEGER NFCST
C        THE NUMBER OF FORECASTS.
C     INTEGER NFCSTO
C        THE NUMBER OF THE ORIGINS.
C     INTEGER NFCSTU
C        THE NUMBER OF FORCASTES ACTUALLY USED.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE ROUTINE CALLING THE ERROR CHECKING ROUTINE
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     INTEGER NPRT
C        THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS
C        TO BE PROVIDED.
C     DOUBLE PRECISION PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     LOGICAL SAVE
C        THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN
C        THE RESIDUALS AND PARAMETERS ARE TO BE SAVED (TRUE) OR NOT
C        (FALSE).
C     DOUBLE PRECISION Y(N)
C        THE DEPENDENT VARIABLE.
C
C
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     SET UP NAME ARRAYS
C
      DATA NMSUB(1), NMSUB(2), NMSUB(3), NMSUB(4), NMSUB(5), NMSUB(6) /
     +   'A','I','M','F','S',' '/
C
C     SET VARIOUS PROGRAM PARAMETERS
C
      ISUBRO='AMES'
      IBUGA3='OFF'
      IFOUND='NO'
      IERROR='OFF'
      CALL DPFLSH(IPR,IBUGA3,ISUBRO,IFOUND,IERROR)
      SAVE = .TRUE.
C
      IF ((NFCST.GE.1) .AND. (NFCST.LE.N)) THEN
         NFCSTU = NFCST
      ELSE
         NFCSTU = (N/10)+1
      END IF
C
      CALL AMFCNT(Y, N, MSPEC, NFAC, PAR, NPAR, LDSTAK, NFCSTU,
     +   MAX(1,NFCSTO), IFCSTO, NPRT, FCST, IFCST, FCSTSD, NMSUB, SAVE)
C
      ISUBRO='AMES'
      IBUGA3='OFF'
      IFOUND='NO'
      IERROR='OFF'
      CALL DPFLSH(IPR,IBUGA3,ISUBRO,IFOUND,IERROR)
      IF (IERR.NE.1) RETURN
C
C     PRINT PROPER CALL SEQUENCE
C
CCCCC CALL IPRINT(IPRT)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1000)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1001)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1001)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     FORMAT STATEMENTS
C
  999 FORMAT(1X)
 1000 FORMAT (
     +  ' THE CORRECT FORM OF THE CALL STATEMENT IS')
 1001 FORMAT (
     +  '       CALL AIMFS (Y, N, MSPEC, NFAC, PAR, NPAR, LDSTAK,')
 1002 FORMAT (
     +  '      +            NFCST, NFCSTO, IFCSTO, NPRT, FCST, IFCST,',
     +  ' FCSTSD)')
      END
*AMLST
      SUBROUTINE AMLST (IAMHD, PAR, NPAR, NFAC, MSPECT, N, VCVL,
     +   LVCVL, SCALE, LSCALE, STPT, LSTPT, IFIXD, RSS, RSD, NPARDF,
     +   NPARE, IDF)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRINTS THE PARAMETER SUMMARY OUTPUT FROM THE
C     ARIMA FORECASTING SUBROUTINES.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 4, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   RSD,RSS
      INTEGER
     +   IAMHD,IDF,LSCALE,LSTPT,LVCVL,N,NFAC,NPAR,NPARDF,NPARE
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   PAR(*),SCALE(*),STPT(*),VCVL(*)
      INTEGER
     +   IFIXD(*),MSPECT(NFAC,4)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   FPLM,T975
      INTEGER
CCCCC+   IPARMN,IPARMX,IPRT,LBLTYP
     +   IPARMN,IPARMX,LBLTYP
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   PPFT
      EXTERNAL PPFT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMLST1
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     INTEGER IAMHD
C        THE INDICATOR VALUE USED TO DESIGNATE THE TYPE OF LIST
C        TO BE GENERATED
C        IF IAMHD=1, THE LIST IS FOR THE INITIAL SUMMARY OF THE
C                    ESTIMATION ROUTINES.
C        IF IAMHD=2, THE LIST IS FOR THE INITIAL REPORT OF THE
C                    FORECASTING ROUTINES.
C        IF IAMHD=3, THE LIST IS FOR THE FINAL REPORT OF THE
C                    ESTIMATION ROUTINES.
C     INTEGER IDF
C        THE DEGREES OF FREEDOM IN THE FIT.
C     INTEGER IFIXD(NPAR)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE
C        PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED.
C        IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED.
C        IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED.
C     INTEGER IPARMN
C        THE SMALLEST PARAMETER INDEX INCLUDED IN THIS TERM.
C     INTEGER IPARMX
C        THE LARGEST PARAMETER INDEX INCLUDED IN THIS TERM.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER LSCALE
C        THE DIMENSION OF VECTOR SCALE.
C     INTEGER LSTPT
C        THE DIMENSION OF VECTOR STPT.
C     INTEGER LVCVL
C        THE DIMENSION OF VECTOR VCVL.
C     INTEGER MSPECT(NFAC,4)
C        THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NPARDF
C        THE ORDER OF THE EXPANDED DIFFERENCE FILTER.
C     INTEGER NFAC
C        THE NUMBER OF FACTORS IN THE MODEL
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     INTEGER NPARE
C        THE NUMBER OF PARAMETERS TO BE OPTIMIZED.
C     DOUBLE PRECISION PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     DOUBLE PRECISION RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     DOUBLE PRECISION RSS
C        THE RESIDUAL SUM OF SQUARES.
C     DOUBLE PRECISION SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     DOUBLE PRECISION STPT(LSTPT)
C        THE STEP SIZE ARRAY.
C     DOUBLE PRECISION T975
C        THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE
C        T DISTRIBUTION.
C     DOUBLE PRECISION VCVL(LVCVL)
C        THE LOWER HALF OF THE VARIANCE-COVARIANCE MATRIX, STORED
C        ROW WISE.
C
C
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
      COMMON/STARPC/IRESDF
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      FPLM = D1MACH(2)
C
CCCCC CALL IPRINT(IPRT)
C
C     PRINT HEADING FOR INFORMATION ABOUT PARAMETERS
C
      WRITE(ICOUT, 1001)
      CALL DPWRST('XXX','BUG ')
C
      IF (IAMHD .EQ. 1) THEN
        WRITE(ICOUT, 1001)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT, 1001)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT, 1003)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT, 1001)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT, 1004)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT, 1104)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT, 1204)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT, 1304)
        CALL DPWRST('XXX','BUG ')
      ENDIF
 1003 FORMAT(
     +  'DEFAULT SCALING USED FOR ALL PARAMETERS.')
 1004 FORMAT (
     +  56X, '  ##STEP SIZE FOR')
 1104 FORMAT (
     +  39X, '  ######PARAMETER', '  ##APPROXIMATING')
 1204 FORMAT (
     +  ' #################PARAMETER DESCRIPTION  STARTING VALUES',
     +  '  #####DERIVATIVE')
 1304 FORMAT (
     +  ' INDEX  #########TYPE  ##ORDER  ##FIXED  ##########(PAR)',
     +  '  ##########(STP)')
      IF (IAMHD .EQ. 2) THEN
        WRITE(ICOUT, 1005)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT, 1105)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT, 1205)
        CALL DPWRST('XXX','BUG ')
      ENDIF
 1005 FORMAT(
     +  30X, '  ######PARAMETER')
 1105 FORMAT(
     +  ' ########PARAMETER DESCRIPTION  ######ESTIMATES')
 1205 FORMAT(
     +  ' INDEX  #########TYPE  ##ORDER  ##########(PAR)')
      IF (IAMHD .EQ. 3) THEN
        WRITE(ICOUT, 1006)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT, 1106)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT, 1206)
        CALL DPWRST('XXX','BUG ')
      ENDIF
 1006 FORMAT(
     +  15X,'PARAMETER     STD DEV OF',' ###PAR/',3X,
     +  '##################APPROXIMATE')
 1106 FORMAT(
     +  15X,'ESTIMATES',
     +  '  ####PARAMETER ####(SD',
     +  '    95 PERCENT CONFIDENCE LIMITS')
 1206 FORMAT(
     +  ' TYPE ORD    ###(OF PAR)',
     +  '  ####ESTIMATES',
     +  ' ##(PAR)    #######LOWER     ######UPPER')
      WRITE(ICOUT, 1001)
      CALL DPWRST('XXX','BUG ')
      ISUBRO='AMES'
      IBUGA3='OFF'
      IFOUND='NO'
      IERROR='OFF'
      CALL DPFLSH(IPR,IBUGA3,ISUBRO,IFOUND,IERROR)
C
C     PRINT MODEL SUMMARY INFORMATION
C
      IPARMN = 1
      IPARMX = 0
      T975 = PPFT(0.95D0, N-NPAR)
C
C     PRINT AUTOREGRESSIVE TERMS
C
      LBLTYP = 1
      CALL AMLST1 (IAMHD, PAR, NPAR, MSPECT, NFAC, VCVL, LVCVL,
     +  SCALE, LSCALE, STPT, LSTPT, IPARMN, IPARMX, LBLTYP, T975, IFIXD)
C
C     PRINT MEAN OR TREND TERM
C
      LBLTYP = 2
      CALL AMLST1 (IAMHD, PAR, NPAR, MSPECT, 1, VCVL, LVCVL,
     +  SCALE, LSCALE, STPT, LSTPT, IPARMN, IPARMX, LBLTYP, T975, IFIXD)
C
C     PRINT MOVING AVERAGE TERMS
C
      LBLTYP = 3
      CALL AMLST1 (IAMHD, PAR, NPAR, MSPECT, NFAC, VCVL, LVCVL,
     +  SCALE, LSCALE, STPT, LSTPT, IPARMN, IPARMX, LBLTYP, T975, IFIXD)
C
      WRITE(ICOUT, 1001)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1160) N
      CALL DPWRST('XXX','BUG ')
      IF (IAMHD.GE.2) THEN
        WRITE (ICOUT, 1040) RSS
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT, 2040)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT, 1041) RSD
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT, 1042) N, NPARDF, NPARE, IDF
        CALL DPWRST('XXX','BUG ')
        AIC=REAL(N)*LOG(REAL(RSD)**2) + 2.0*REAL(NPAR)
        WRITE (ICOUT, 1045) AIC
        CALL DPWRST('XXX','BUG ')
        IORDAR=MSPECT(1,1)
        IORDMA=MSPECT(3,1)
        AN=REAL(N)
        AP=REAL(IORDAR)
        AQ=REAL(IORDMA)
        AFACT=2.0*(AP + AQ + 1.0)*AN/(AN - AP - AQ - 2.0)
        AICC=REAL(N)*LOG(REAL(RSD)**2) + AFACT
        WRITE (ICOUT, 1046) AICC
        CALL DPWRST('XXX','BUG ')
        IRESDF=IDF
      ENDIF
      ISUBRO='AMES'
      IBUGA3='OFF'
      IFOUND='NO'
      IERROR='OFF'
      CALL DPFLSH(IPR,IBUGA3,ISUBRO,IFOUND,IERROR)
      RETURN
C
C     FORMAT STATEMENTS
C
 1001 FORMAT(1X)
 1040 FORMAT (
     +  ' RESIDUAL SUM OF SQUARES             ', 8X, G15.7)
 2040 FORMAT (
     +  '     (BACKFORECASTS INCLUDED)')
 1041 FORMAT (
     +  ' RESIDUAL STANDARD DEVIATION         ', 8X, G15.7)
 1042 FORMAT (
     +  ' BASED ON DEGREES OF FREEDOM', 
     +  1X, I4, ' - ', I3, ' - ', I3, ' = ', I4)
 1045 FORMAT (
     +  ' AKAIKE INFORMATION CRITERION (AIC)  ', 8X, G15.7)
 1046 FORMAT (
     +  ' AKAIKE INFORMATION CRITERION (AICC) ', 8X, G15.7)
 1160 FORMAT (' NUMBER OF OBSERVATIONS', 18X, '(N)', 1X, I5)
      END
*EISGE
      SUBROUTINE EISGE(NMSUB, NMVAR1, NVAL, NMIN, MSGTYP, HEAD, ERROR,
     +   NMVAR2)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE CHECKS WHETHER THE VALUE   NVAL   IS GREATER THAN
C     OR EQUAL TO   NMIN   AND PRINTS A DIAGNOSTIC IF IT IS NOT.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 29, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   MSGTYP,NMIN,NVAL
      LOGICAL
     +   ERROR,HEAD
C
C  ARRAY ARGUMENTS
      CHARACTER
     +   NMSUB(6)*1,NMVAR1(8)*1,NMVAR2(8)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERROR
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     LOGICAL HEAD
C        A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED
C        (TRUE) OR NOT (FALSE).  IF A HEADING IS PRINTED, THE VALUE
C        OF HEAD WILL BE CHANGED TO FALSE.
C     INTEGER I
C        AN INDEX ARGUMENT.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER MSGTYP
C        AN ARGUMENT USED TO INDICATE THE TYPE OF MESSAGE TO BE
C        PRINTED, WHERE IF ERROR IS TRUE AND
C        MSGTYP = 1 THE INPUT VALUE WAS TOO SMALL BASED
C                   ON LIMITS IMPOSED BY STARPAC
C        MSGTYP = 2 THE INPUT VALUE WAS TOO SMALL BASED ON OTHER INPUT
C                   ARGUMENTS.
C        MSGTYP = 3 THE INPUT VALUE WAS TOO SMALL BASED ON OTHER INPUT
C                   ARGUMENTS, WHERE THE VALUE INDICATES THE FIRST
C                   DIMENSION OF A DIMENSIONED ARRAY
C                   N.B.  IT IS ASSUMED THAT THE DIMENSION NAME IS THE
C                         ARRAY NAME PRECEDED BY THE LETTER I.  IF THE
C                         ARRAY NAME IS 6 LETTERS, THE DIMENSION NAME
C                         SHOULD OMIT THE LAST LETTER.  THE DIMENSION
C                         NAME WILL BE PRINTED USING (NMVAR(I),I=1,6),
C                         AND THE ARRAY NAME USING (NMVAR(I),I=2,7).
C        MSGTYP = 4 THE INPUT VALUE WAS TOO SMALL BASED ON OTHER INPUT
C                   ARGUMENTS, WHERE THE VALUE INDICATES THE SECOND
C                   DIMENSION OF A DIMENSIONED ARRAY
C                   N.B.  IT IS ASSUMED THAT THE DIMENSION NAME IS THE
C                         ARRAY NAME PRECEDED BY THE LETTER J.  IF THE
C                         ARRAY NAME IS 6 LETTERS, THE DIMENSION NAME
C                         SHOULD OMIT THE LAST LETTER.  THE DIMENSION
C                         NAME WILL BE PRINTED USING (NMVAR(I),I=1,6),
C                         AND THE ARRAY NAME USING (NMVAR(I),I=2,7).
C        MSGTYP = 5 THE ARGUMENT BEING CHECKED IS LDSTAK.
C                   NO LONGER USED.
C        MSGTYP = 6 THE ARGUMENT INDICATES THE FIRST DIMENSION OF
C                   AN ARRAY BEING CHECKED AGAINST THE NUMBER OF
C                   UNFIXED PARAMETERS.
C        MSGTYP = 7 THE INPUT VALUE WAS TOO SMALL BASED ON OTHER INPUT
C                   ARGUMENTS, WHERE THE VALUE INDICATES THE
C                   DIMENSION OF A VECTOR.
C                   N.B.  IT IS ASSUMED THAT THE DIMENSION NAME IS THE
C                         ARRAY NAME PRECEDED BY THE LETTER L.  IF THE
C                         ARRAY NAME IS 6 LETTERS, THE DIMENSION NAME
C                         SHOULD OMIT THE LAST LETTER.  THE DIMENSION
C                         NAME WILL BE PRINTED USING (NMVAR(I),I=1,6),
C                         AND THE ARRAY NAME USING (NMVAR(I),I=2,7).
C        MSGTYP = 8 THE INPUT VALUE WAS TOO SMALL BASED ON OTHER INPUT
C                   ARGUMENTS, WHERE THE VALUE INDICATES THE
C                   DIMENSION OF THE VECTORS ACOV AND NLPPA.
C        MSGTYP = 9 THE INPUT VALUE WAS TOO SMALL BASED ON LIMITS
C                   IMPOSED BY STARPAC, WHERE THE VALUE INDICATES THE
C                   DIMENSION OF A VECTOR.
C                   N.B.  IT IS ASSUMED THAT THE DIMENSION NAME IS THE
C                         ARRAY NAME PRECEDED BY THE LETTER L.  IF THE
C                         ARRAY NAME IS 6 LETTERS, THE DIMENSION NAME
C                         SHOULD OMIT THE LAST LETTER.  THE DIMENSION
C                         NAME WILL BE PRINTED USING (NMVAR(I),I=1,6),
C                         AND THE ARRAY NAME USING (NMVAR(I),I=2,7).
C     INTEGER NMIN
C        THE MINIMUM ACCEPTABLE VALUE FOR THE ARGUMENT BEING TESTED.
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING SUBROUTINES NAME.
C     CHARACTER*1 NMVAR1(8)
C        THE CHARACTERS OF THE NAME OF THE ARGUMENT BEING CHECKED.
C     CHARACTER*1 NMVAR2(8)
C        THE CHARACTERS OF THE NAME OF THE ARGUMENT BEING CHECKED
C        AGAINST.
C     INTEGER NVAL
C        THE INPUT VALUE OF THE ARGUMENT BEING CHECKED.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      ERROR = .FALSE.
C
      IF (NVAL .GE. NMIN) RETURN
C
      ERROR = .TRUE.
C
CCCCC CALL IPRNT (IPRT)
C
      CALL EHDR(NMSUB, HEAD)
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1000) (NMVAR1(I), I=1,6), NVAL
      CALL DPWRST('XXX','BUG ')
C
      GO TO (20, 30, 40, 50, 60, 70, 80, 90, 100), MSGTYP
C
C     PRINT MESSAGE FOR VALUE TOO SMALL BASED ON LIMITS IMPOSED
C     BY STARPAC.
C
   20 WRITE (ICOUT, 1010) (NMVAR1(I), I=1,6), NMIN
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     PRINT MESSAGE FOR VALUE TOO SMALL BASED ON OTHER INPUT
C     ARGUMENTS.
C
   30 WRITE (ICOUT, 1020) (NMVAR1(I), I=1,6), (NMVAR2(I), I=1,8)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     PRINT MESSAGE FOR VALUE TOO SMALL, WHERE VALUE INDICATED THE
C     FIRST DIMENSION OF A DIMENSIONED ARRAY.
C
   40 WRITE (ICOUT, 1030) (NMVAR1(I), I=2,7)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1031) (NMVAR1(I), I=1,6), (NMVAR2(I), I=1,8)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     PRINT MESSAGE FOR VALUE TOO SMALL, WHERE VALUE INDICATED THE
C     SECOND DIMENSION OF A DIMENSIONED ARRAY.
C
   50 WRITE (ICOUT, 1040) (NMVAR1(I), I=2,7)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1041) (NMVAR1(I), I=1,6),
     +   (NMVAR2(I), I=1,8)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     PRINT MESSAGE FOR VALUE TOO SMALL, WHEN ARGUMENT IS LDSTAK.
C
   60 WRITE(ICOUT, 1050)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT, 1051) NMIN
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     PRINT MESSAGE FOR VALUE TOO SMALL, WHERE VALUE INDICATED THE
C     FIRST DIMENSION OF A DIMENSIONED ARRAY CHECK AGAINST THE NUMBER OF
C     UNFIXED PARAMETERS.
C
   70 WRITE (ICOUT, 1060) (NMVAR1(I), I=2,7)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1061) (NMVAR1(I), I=1,6)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     PRINT MESSAGE FOR VALUE TOO SMALL, WHERE VALUE INDICATED THE
C     DIMENSION OF A VECTOR.
C
   80 WRITE (ICOUT, 1070) (NMVAR1(I), I=2,7)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1071) (NMVAR1(I), I=1,6),(NMVAR2(I), I=1,8)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     PRINT MESSAGE FOR VALUE TOO SMALL, WHERE VALUE INDICATED THE
C     DIMENSION OF THE VECTORS ACOV AND NLPPA.
C
   90 WRITE (ICOUT, 1080)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1081) (NMVAR1(I), I=1,6), (NMVAR2(I), I=1,8)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     PRINT MESSAGE FOR VALUE TOO SMALL, WHERE VALUE INDICATED THE
C     DIMENSION OF A VECTOR.
C
  100 WRITE (ICOUT, 1090) (NMVAR1(I), I=2,7)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1091) (NMVAR1(I), I=1,6),NMIN
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     FORMAT STATEMENTS
C
  999 FORMAT(1X)
 1000 FORMAT (' THE INPUT VALUE OF ',6A1,' IS ',I5,'.')
 1010 FORMAT(
     +   ' THE VALUE OF THE ARGUMENT ', 6A1,
     +   ' MUST BE GREATER THAN OR EQUAL TO ', I5, '.')
 1020 FORMAT(
     +   ' THE VALUE OF THE ARGUMENT ',6A1,
     +   ' MUST BE GREATER THAN OR EQUAL TO ', 8A1, '.')
 1030 FORMAT(
     +   ' THE FIRST DIMENSION OF ', 6A1,
     +   ', AS INDICATED BY THE ARGUMENT')
 1031 FORMAT(
     +    1X, 6A1, ', MUST BE GREATER THAN OR EQUAL TO ', 8A1, '.')
 1040 FORMAT(
     +   ' THE SECOND DIMENSION OF ', 6A1,
     +   ', AS INDICATED BY THE ARGUMENT')
 1041 FORMAT(
     +    1X, 6A1, ', MUST BE GREATER THAN OR EQUAL TO ', 8A1, '.')
 1050 FORMAT(
     +   ' THE DIMENSION OF THE DOUBLE PRECISION VECTOR DSTAK, AS',
     +   ' INDICATED BY')
 1051 FORMAT(
     +   ' THE ARGUMENT LDSTAK, MUST BE GREATER THAN OR EQUAL TO ',
     +   I5, '.')
 1060 FORMAT(
     +   ' THE FIRST DIMENSION OF ', 6A1,
     +   ', AS INDICATED BY THE ARGUMENT')
 1061 FORMAT(
     +    1X, 6A1, ', MUST BE GREATER THAN OR EQUAL TO ',
     +    'THE NUMBER OF UNFIXED PARAMETERS.')
 1070 FORMAT(
     +   ' THE LENGTH OF ', 6A1,
     +   ', AS INDICATED BY THE ARGUMENT')
 1071 FORMAT(
     +    1X, 6A1, ', MUST BE GREATER THAN OR EQUAL TO ', 8A1, '.')
 1080 FORMAT(
     +   ' THE LENGTH OF ACOV AND NLPPA',
     +   ', AS INDICATED BY THE ARGUMENT')
 1081 FORMAT(
     +    1X, 6A1, ', MUST BE GREATER THAN OR EQUAL TO ', 8A1, '.')
 1090 FORMAT(
     +   ' THE LENGTH OF ', 6A1,
     +   ', AS INDICATED BY THE ARGUMENT')
 1091 FORMAT(
     +    1X, 6A1, ', MUST BE GREATER THAN OR EQUAL TO ', I6, '.')
C
      END
*ICOPY
      SUBROUTINE ICOPY(N,ISX,INCX,ISY,INCY)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE IS A ADAPTATION OF THE BLAS SUBROUTINE DCOPY,
C     MODIFIED TO HANDLE INTEGER ARRAYS.
C
C     COPY INTEGER ISX TO INTEGER ISY.
C     FOR I = 0 TO N-1, COPY  ISX(LX+I*INCX) TO ISY(LY+I*INCY),
C     WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS
C     DEFINED IN A SIMILAR WAY USING INCY.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  APRIL 2, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   INCX,INCY,N
C
C  ARRAY ARGUMENTS
      INTEGER
     +   ISX(N),ISY(N)
C
C  LOCAL SCALARS
      INTEGER
     +   I,IX,IY,M,MP1,NS
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MOD
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        AN INDEXING VARIABLE.
C     INTEGER INCX, INCY
C        THE INCREMENT USED FOR THE COPY FROM ONE VARIABLE TO THE OTHER.
C     INTEGER ISX(N)
C        THE ARRAY TO BE COPIED FROM.
C     INTEGER ISY(N)
C        THE ARRAY TO BE COPIED TO.
C     INTEGER IX, IY
C        INDEX VARIABLES.
C     INTEGER M
C        THE VALUE OF N MODULO 7.
C     INTEGER MP1
C        THE VALUE OF M + 1.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS IN THE ARRAYS ISX AND ISY.
C     INTEGER NS
C        THE VALUE OF N * INCX.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60
    5 CONTINUE
C
C        CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS.
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        ISY(IY) = ISX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 7.
C
   20 M = MOD(N,7)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        ISY(I) = ISX(I)
   30 CONTINUE
      IF( N .LT. 7 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,7
        ISY(I) = ISX(I)
        ISY(I + 1) = ISX(I + 1)
        ISY(I + 2) = ISX(I + 2)
        ISY(I + 3) = ISX(I + 3)
        ISY(I + 4) = ISX(I + 4)
        ISY(I + 5) = ISX(I + 5)
        ISY(I + 6) = ISX(I + 6)
   50 CONTINUE
      RETURN
C
C        CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS.
C
   60 CONTINUE
      NS = N*INCX
      DO 70 I=1,NS,INCX
          ISY(I) = ISX(I)
   70 CONTINUE
      RETURN
      END
*MATPRF
      SUBROUTINE MATPRF(X, Y, NC, MODE, CODE, LENGTH, MASK, LMASK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRINTS A SQUARE MATRIX STORED IN SYMMETRIC
C     FORM.
C
C     WRITTEN BY - JOHN E. KOONTZ
C        STATISTICAL ENGINEERING DIVISION
C        NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  OCTOBER 3, 1983
C        BASED ON THE JULY 1982 VERSION OF MATPRT, BY LINDA L. MITCHELL.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   CODE,LENGTH,LMASK,MODE,NC
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   X(LENGTH),Y(LENGTH)
      INTEGER
     +   MASK(LMASK)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   SQXII,SQYII
      INTEGER
     +   I,I0,II,IK,IMASK,J,JMASK,K,KI,KK,KM,KMAX,KN,L,NF,
     +   NLINE
C
C  LOCAL ARRAYS
      DOUBLE PRECISION
     +   XLINE(10),YLINE(10)
      INTEGER
     +   INDW(10)
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   INPERL
      EXTERNAL INPERL
C
C  EXTERNAL SUBROUTINES
CCCCC EXTERNAL IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER CODE
C        IF 1 -SINGLE PRINTED, X ONLY (Y IS DUMMY ARG)
C           2 -DOUBLE PRINTED LINE, BOTH X AND Y
C     INTEGER I
C        ROW NUMBER
C     INTEGER II
C        THE INDEX OF THE (I,I)TH ELEMENT OF THE VCV MATRIX
C     INTEGER IK
C        THE INDEX OF THE (I,K)TH ELEMENT OF THE VCV MATRIX
C     INTEGER I0
C        THE INDEX OF THE ((I,I)-1)TH ELEMENT OF THE VCV MATRIX
C     INTEGER IMASK
C        INDEX IN MASK FOR LABELLING OF THE ROW DIMENSION.
C     INTEGER INDW(10)
C        A WORK VECTOR FOR THE INDICES TO BE PRINTED FOR THE
C        MATRIX.
C     INTEGER IPRT
C        THE OUTPUT UNIT NUMBER
C     INTEGER J
C        FIRST COLUMN IN THE SET TO BE PRINTED
C     INTEGER JMASK
C        INDEX IN MASK FOR LABELLING OF THE COLUMN DIMENSION.
C     INTEGER K
C        COLUMN NUMBER IN THE POSSIBLE SET OF NF
C     INTEGER KI
C        THE INDEX OF THE (K,I)TH ELEMENT OF THE VCV MATRIX
C     INTEGER KK
C        THE INDEX OF THE (K,K)TH ELEMENT OF THE VCV MATRIX
C     INTEGER KM
C        LAST COLUMN IN THE SET
C        LIMITED TO VALUES OF J-1 PLUS A NUMBER BETWEEN 1 AND
C        NF (INCLUSIVE)
C     INTEGER KMAX
C        INDEX IN INDW OF THE LARGEST INDEX TO BE PRINTED FOR
C        MATRIX.
C     INTEGER KN
C        LAST COLUMN TO PRINT WHEN PRINTING LOWER TRIANGLE
C     INTEGER L
C        FIRST ROW TO PRINT FOR THIS SET
C     INTEGER LMASK
C        LENGTH OF MASK.
C     INTEGER LENGTH
C        LENGTH OF X AND Y
C     INTEGER MASK(LMASK)
C        MASK VECTOR FOR VCV.  THE INDEX OF THE ITH ELEMENT OF
C        MASK EQUAL TO ZERO IS THE LABEL IN THE OUTPUT OF VCV
C        IN OF THE ITH ROW AND ITH COLUMN.
C     INTEGER MODE
C        IF 0, LOWER TRIANGULAR PART PRINTED
C           1, LOWER TRIANGULAR PART IS PRINTED WITH
C              SQUARE ROOTS OF THE DIAGONAL
C           2, LOWER TRIANGLE PRINTED AS CORRELATION MATRIX
C              WITH SQUARE ROOTS ON THE DIAGONAL
C           3, FULL MATRIX PRINTED
C           4, FULL MATRIX PRINTED WITH CORRELATION MATRIX
C              PRINTED BELOW THE DIAGONAL
C     INTEGER NC
C        ROW AND COLUMN DIMENSION OF X
C     INTEGER NF
C        THE NUMBER OF COLUMNS THAT CAN BE PRINTED, GIVEN
C        THE WIDTH IWIDTH OF THE OUTPUT DEVICE.
C     INTEGER NLINE
C        THE NUMBER OF VALUES TO BE PRINTED EACH LINE.
C     DOUBLE PRECISION SQXII, SQYII
C        THE SQUARE ROOT OF THE (I,I)TH ELEMENT OF X AND Y.
C     DOUBLE PRECISION X(LENGTH)
C        INPUT SYMMETRIC ARRAY STORED ROW WISE
C     DOUBLE PRECISION XLINE(10)
C        THE CURRENT VALUES BEING PRINTED FROM ARRAY X.
C     DOUBLE PRECISION Y(LENGTH)
C        ARRAY TO BE PRINTED ON THE SECOND LEVEL IF CODE=2
C     DOUBLE PRECISION YLINE(10)
C        THE CURRENT VALUES BEING PRINTED FROM ARRAY Y.
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
C     BODY OF ROUTINE
C
CCCCC CALL IPRINT(IPRT)
C
      NF = INPERL(0)
C
      L = 1
      JMASK = 0
C
C     SELECT INITIAL COLUMN TO PRINT THIS PASS OF THE REPORT
C
      DO 90 J=1,NC,NF
         KN = MIN(NC,J+NF-1)
         KMAX = MIN(NC-J+1,NF)
C
C     GENERATE VECTOR OF COLUMN HEAD LABELS
C
         DO 20 K=1,KMAX
   10       IF (JMASK.GE.LMASK) GO TO 100
            JMASK = JMASK + 1
            IF (MASK(JMASK).NE.0) GO TO 10
            INDW(K) = JMASK
   20    CONTINUE
C
C     PRINT VECTOR OF COLUMN HEAD LABELS
C
         WRITE(IOUNI4,999)
CCCCC    CALL DPWRST('XXX','BUG ')
         WRITE (IOUNI4,1000) (INDW(K),K=1,KMAX)
CCCCC    CALL DPWRST('XXX','BUG ')
         WRITE (IOUNI4,1030)
CCCCC    CALL DPWRST('XXX','BUG ')
         IF (MODE.LE.2) L = INDW(1)
C
C     PRINT ALL ROWS IN COLUMN RANGE FOR THIS PASS
C
         IMASK = L - 1
         DO 80 I=L,NC
            KM = KN
            IF (MODE.LE.2) KM = J + MIN(I-L,NF-1)
            NLINE = 0
            I0 = I*(I-1)/2
            II = I0 + I
            SQXII = SQRT(X(II))
            IF (CODE.EQ.2) THEN
               SQYII = SQRT(Y(II))
            ELSE
               SQYII = 1.0D0
            END IF
            DO 60 K=J,KM
               NLINE = NLINE + 1
               IF (K.GT.I) GO TO 30
               IK = I0 + K
               XLINE(NLINE) = X(IK)
               IF (CODE.EQ.2) YLINE(NLINE) = Y(IK)
               GO TO 40
   30          KI = K*(K-1)/2 + I
               XLINE(NLINE) = X(KI)
               IF (CODE.EQ.2) YLINE(NLINE) = Y(KI)
   40          IF (((MODE.NE.1) .AND. (MODE.NE.2)) .OR. (I.NE.K)) GO TO
     +            50
               XLINE(NLINE) = SQXII
               IF (CODE.EQ.2) YLINE(NLINE) = SQXII
   50          IF (((MODE.NE.2) .AND. (MODE.NE.4)) .OR. (K.GE.I)) GO TO
     +            60
               KK = K*(K-1)/2 + K
               XLINE(NLINE) = XLINE(NLINE)/(SQXII*SQRT(X(KK)))
               IF (CODE.EQ.2)
     +            YLINE(NLINE) = YLINE(NLINE)/(SQYII*SQRT(Y(KK)))
   60       CONTINUE
   70       IF (IMASK.GE.LMASK) GO TO 100
            IMASK = IMASK + 1
            IF (MASK(IMASK).NE.0) GO TO 70
            WRITE (IOUNI4,1010) IMASK, (XLINE(K),K=1,NLINE)
CCCCC       CALL DPWRST('XXX','BUG ')
            IF (CODE.EQ.2) THEN
              WRITE (IOUNI4,1020) (YLINE(K),K=1,NLINE)
CCCCC         CALL DPWRST('XXX','BUG ')
            ENDIF
            IF (CODE.EQ.2) THEN
              WRITE (IOUNI4,1030)
CCCCC         CALL DPWRST('XXX','BUG ')
            ENDIF
   80    CONTINUE
   90 CONTINUE
      RETURN
C
  100 CONTINUE
      WRITE(IOUNI4,999)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE (IOUNI4,1040)
CCCCC CALL DPWRST('XXX','BUG ')
      RETURN
C
C     FORMAT STATEMENTS
C
C
  999 FORMAT(1X)
 1000 FORMAT (' ', 'COLUMN ', 7(I9, 8X))
 1010 FORMAT (' ', I6, 1X, 7(3X, G14.7))
 1020 FORMAT (' ', 5X, 7(3X, G14.7))
 1030 FORMAT (' ')
 1040 FORMAT (' ERROR IN STARPAC.  MATPRF TRIES TO ACCESS MORE',
     +   ' ELEMENTS THAN EXIST IN MASK.')
      END
*PARCHK
      SUBROUTINE PARCHK(IV, N, NN, P, V)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C
C  ***  CHECK NL2SOL (VERSION 2.2) PARAMETERS, PRINT CHANGED VALUES  ***
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N,NN,P
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   V(33)
      INTEGER
     +   IV(21)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   BIG,MACHEP,TINY,VK,ZERO
      INTEGER
     +   D0INIT,DTYPE,DTYPE0,EPSLON,I,ICH,INITS,IV1,JTINIT,JTOL0,
     +   JTOL1,JTOLP,K,L,M,NVDFLT,OLDN,OLDNN,OLDP,PARPRT,PARSV1,
     +   PRUNIT,PU
C
C  LOCAL ARRAYS
      DOUBLE PRECISION
     +   VM(27),VX(27)
      CHARACTER
     +   CNGD(12)*1,DFLT(12)*1,VN(8,27)*1,WHICH(12)*1
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   RMDCON
      EXTERNAL RMDCON
C
C  EXTERNAL SUBROUTINES
      EXTERNAL DFAULT,VCOPY
C
C     INTEGER IV(21), N, NN, P
C     DOUBLE PRECISION V(33)
C     DIMENSION IV(*), V(*)
C
C     EXTERNAL DFAULT, RMDCON, VCOPY
C     DOUBLE PRECISION RMDCON
C DFAULT -- SUPPLIES DFAULT PARAMETER VALUES.
C RMDCON -- RETURNS MACHINE-DEPENDENT CONSTANTS.
C VCOPY  -- COPIES ONE VECTOR TO ANOTHER.
C
C  ***  LOCAL VARIABLES  ***
C
C     INTEGER I, IV1, JTOLP, K, L, M, NVDFLT, PU
C     CHARACTER*1 CNGD(12), WHICH(12)
C     CHARACTER*1 DFLT(12), VN(8,27)
C     DOUBLE PRECISION BIG, MACHEP, TINY, VK, VM(27), VX(27), ZERO
C
C  ***  IV AND V SUBSCRIPTS  ***
C
C     INTEGER DTYPE, DTYPE0, D0INIT, EPSLON, INITS, JTINIT, JTOL0,
C    1        JTOL1, OLDN, OLDNN, OLDP, PARPRT, PARSV1, PRUNIT
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA BIG/0.0D0/, NVDFLT/27/, TINY/1.0D0/, ZERO/0.0D0/
C
      DATA DTYPE/16/, DTYPE0/29/, D0INIT/37/, EPSLON/19/,
     +     INITS/25/, JTINIT/39/, JTOL0/86/, JTOL1/87/,
     +     OLDN/45/, OLDNN/46/, OLDP/47/, PARPRT/20/,
     +     PARSV1/51/, PRUNIT/21/
C
      DATA
     + VN(1,1),VN(2,1),VN(3,1),VN(4,1),VN(5,1),VN(6,1),VN(7,1),VN(8,1)
     +   /'E',    'P',    'S',    'L',    'O',    'N',    '.',    '.'/
      DATA
     + VN(1,2),VN(2,2),VN(3,2),VN(4,2),VN(5,2),VN(6,2),VN(7,2),VN(8,2)
     +   /'P',    'H',    'M',    'N',    'F',    'C',    '.',    '.'/
      DATA
     + VN(1,3),VN(2,3),VN(3,3),VN(4,3),VN(5,3),VN(6,3),VN(7,3),VN(8,3)
     +   /'P',    'H',    'M',    'X',    'F',    'C',    '.',    '.'/
      DATA
     + VN(1,4),VN(2,4),VN(3,4),VN(4,4),VN(5,4),VN(6,4),VN(7,4),VN(8,4)
     +   /'D',    'E',    'C',    'F',    'A',    'C',    '.',    '.'/
      DATA
     + VN(1,5),VN(2,5),VN(3,5),VN(4,5),VN(5,5),VN(6,5),VN(7,5),VN(8,5)
     +   /'I',    'N',    'C',    'F',    'A',    'C',    '.',    '.'/
      DATA
     + VN(1,6),VN(2,6),VN(3,6),VN(4,6),VN(5,6),VN(6,6),VN(7,6),VN(8,6)
     +   /'R',    'D',    'F',    'C',    'M',    'N',    '.',    '.'/
      DATA
     + VN(1,7),VN(2,7),VN(3,7),VN(4,7),VN(5,7),VN(6,7),VN(7,7),VN(8,7)
     +   /'R',    'D',    'F',    'C',    'M',    'X',    '.',    '.'/
      DATA
     + VN(1,8),VN(2,8),VN(3,8),VN(4,8),VN(5,8),VN(6,8),VN(7,8),VN(8,8)
     +   /'T',    'U',    'N',    'E',    'R',    '1',    '.',    '.'/
      DATA
     + VN(1,9),VN(2,9),VN(3,9),VN(4,9),VN(5,9),VN(6,9),VN(7,9),VN(8,9)
     +   /'T',    'U',    'N',    'E',    'R',    '2',    '.',    '.'/
      DATA
     + VN(1,10),VN(2,10),VN(3,10),VN(4,10),VN(5,10),VN(6,10),VN(7,10),
     + VN(8,10)
     +   /'T',    'U',    'N',    'E',    'R',    '3',    '.',    '.'/
      DATA
     + VN(1,11),VN(2,11),VN(3,11),VN(4,11),VN(5,11),VN(6,11),VN(7,11),
     + VN(8,11)
     +   /'T',    'U',    'N',    'E',    'R',    '4',    '.',    '.'/
      DATA
     + VN(1,12),VN(2,12),VN(3,12),VN(4,12),VN(5,12),VN(6,12),VN(7,12),
     + VN(8,12)
     +   /'T',    'U',    'N',    'E',    'R',    '5',    '.',    '.'/
      DATA
     + VN(1,13),VN(2,13),VN(3,13),VN(4,13),VN(5,13),VN(6,13),VN(7,13),
     + VN(8,13)
     +   /'A',    'F',    'C',    'T',    'O',    'L',    '.',    '.'/
      DATA
     + VN(1,14),VN(2,14),VN(3,14),VN(4,14),VN(5,14),VN(6,14),VN(7,14),
     + VN(8,14)
     +   /'R',    'F',    'C',    'T',    'O',    'L',    '.',    '.'/
      DATA
     + VN(1,15),VN(2,15),VN(3,15),VN(4,15),VN(5,15),VN(6,15),VN(7,15),
     + VN(8,15)
     +   /'X',    'C',    'T',    'O',    'L',    '.',    '.',    '.'/
      DATA
     + VN(1,16),VN(2,16),VN(3,16),VN(4,16),VN(5,16),VN(6,16),VN(7,16),
     + VN(8,16)
     +   /'X',    'F',    'T',    'O',    'L',    '.',    '.',    '.'/
      DATA
     + VN(1,17),VN(2,17),VN(3,17),VN(4,17),VN(5,17),VN(6,17),VN(7,17),
     + VN(8,17)
     +   /'L',    'M',    'A',    'X',    '0',    '.',    '.',    '.'/
      DATA
     + VN(1,18),VN(2,18),VN(3,18),VN(4,18),VN(5,18),VN(6,18),VN(7,18),
     + VN(8,18)
     +   /'D',    'L',    'T',    'F',    'D',    'J',    '.',    '.'/
      DATA
     + VN(1,19),VN(2,19),VN(3,19),VN(4,19),VN(5,19),VN(6,19),VN(7,19),
     + VN(8,19)
     +   /'D',    '0',    'I',    'N',    'I',    'T',    '.',    '.'/
      DATA
     + VN(1,20),VN(2,20),VN(3,20),VN(4,20),VN(5,20),VN(6,20),VN(7,20),
     + VN(8,20)
     +   /'D',    'I',    'N',    'I',    'T',    '.',    '.',    '.'/
      DATA
     + VN(1,21),VN(2,21),VN(3,21),VN(4,21),VN(5,21),VN(6,21),VN(7,21),
     + VN(8,21)
     +   /'J',    'T',    'I',    'N',    'I',    'T',    '.',    '.'/
      DATA
     + VN(1,22),VN(2,22),VN(3,22),VN(4,22),VN(5,22),VN(6,22),VN(7,22),
     + VN(8,22)
     +   /'D',    'L',    'T',    'F',    'D',    'C',    '.',    '.'/
      DATA
     + VN(1,23),VN(2,23),VN(3,23),VN(4,23),VN(5,23),VN(6,23),VN(7,23),
     + VN(8,23)
     +   /'D',    'F',    'A',    'C',    '.',    '.',    '.',    '.'/
      DATA
     + VN(1,24),VN(2,24),VN(3,24),VN(4,24),VN(5,24),VN(6,24),VN(7,24),
     + VN(8,24)
     +   /'R',    'L',    'I',    'M',    'I',    'T',    '.',    '.'/
      DATA
     + VN(1,25),VN(2,25),VN(3,25),VN(4,25),VN(5,25),VN(6,25),VN(7,25),
     + VN(8,25)
     +   /'C',    'O',    'S',    'M',    'I',    'N',    '.',    '.'/
      DATA
     + VN(1,26),VN(2,26),VN(3,26),VN(4,26),VN(5,26),VN(6,26),VN(7,26),
     + VN(8,26)
     +   /'D',    'E',    'L',    'T',    'A',    '0',    '.',    '.'/
      DATA
     + VN(1,27),VN(2,27),VN(3,27),VN(4,27),VN(5,27),VN(6,27),VN(7,27),
     + VN(8,27)
     +   /'F',    'U',    'Z',    'Z',    '.',    '.',    '.',    '.'/
C
      DATA VM(1)/1.0D-3/, VM(2)/-0.99D0/, VM(3)/1.0D-3/, VM(4)/1.0D-2/,
     +     VM(5)/1.2D0/, VM(6)/1.0D-2/, VM(7)/1.2D0/, VM(8)/0.0D0/,
     +     VM(9)/0.0D0/, VM(10)/1.0D-3/, VM(11)/-1.0D0/, VM(15)/0.0D0/,
     +     VM(16)/0.0D0/, VM(19)/0.0D0/, VM(20)/-10.0D0/, VM(21)/0.0D0/,
     +     VM(23)/0.0D0/, VM(24)/1.0D10/, VM(27)/1.01D0/
      DATA VX(1)/0.9D0/, VX(2)/-1.0D-3/, VX(3)/1.0D1/, VX(4)/0.8D0/,
     +     VX(5)/1.0D2/, VX(6)/0.8D0/, VX(7)/1.0D2/, VX(8)/0.5D0/,
     +     VX(9)/0.5D0/, VX(10)/1.0D0/, VX(11)/1.0D0/, VX(14)/0.1D0/,
     +     VX(15)/1.0D0/, VX(16)/1.0D0/, VX(18)/1.0D0/, VX(22)/1.0D0/,
     +     VX(23)/1.0D0/, VX(25)/1.0D0/, VX(26)/1.0D0/, VX(27)/1.0D2/
C
      DATA CNGD(1), CNGD(2), CNGD(3), CNGD(4), CNGD(5), CNGD(6)
     +   /     '-',     '-',     '-',     'C',     'H',     'A'/
      DATA CNGD(7), CNGD(8), CNGD(9), CNGD(10), CNGD(11), CNGD(12)
     +   /     'N',     'G',     'E',     'D',     ' ',     'V'/
      DATA DFLT(1), DFLT(2), DFLT(3), DFLT(4), DFLT(5), DFLT(6)
     +   /     'N',     'O',     'N',     'D',     'E',     'F'/
      DATA DFLT(7), DFLT(8), DFLT(9), DFLT(10), DFLT(11), DFLT(12)
     +   /     'A',     'U',     'L',     'T',     ' ',     'V'/
C
C.......................................................................
C
      IF (IV(1) .EQ. 0) CALL DFAULT(IV, V)
CCCCC PU = IV(PRUNIT)
      PU=6
      IV1 = IV(1)
      IF (IV1 .NE. 12) GO TO 30
         IF (NN .GE. N .AND. N .GE. P .AND. P .GE. 1) GO TO 20
              IV(1) = 16
              IF (PU .NE. 0) THEN
                 WRITE(ICOUT,9999)
                 CALL DPWRST('XXX','BUG ')
 9999            FORMAT(1X)
                 WRITE(ICOUT,10) NN, N, P
 10           FORMAT('***** BAD NN, N, OR P... NN =',I5,5H, N =,I5,
     +               5H, P =,I5)
                 CALL DPWRST('XXX','BUG ')
              ENDIF
              GO TO 999
 20      K = IV(21)
         CALL DFAULT(IV(21), V(33))
         IV(21) = K
         IV(DTYPE0) = IV(DTYPE+20)
         IV(OLDN) = N
         IV(OLDNN) = NN
         IV(OLDP) = P
         DO 25 ICH = 1, 12
            WHICH(ICH) = DFLT(ICH)
 25      CONTINUE
         GO TO 80
 30   IF (N .EQ. IV(OLDN) .AND. NN .EQ. IV(OLDNN) .AND. P .EQ. IV(OLDP))
     +                       GO TO 50
         IV(1) = 17
         IF (PU .NE. 0) THEN
            WRITE(ICOUT,40) IV(OLDNN), IV(OLDN), IV(OLDP), NN,
     +                               N, P
 40      FORMAT(' ///// (NN,N,P) CHANGED FROM (',I5,',',I5,',',I3,
     +          ') TO (',I5,',',I5,',',I3,').')
             CALL DPWRST('XXX','BUG ')
         ENDIF
         GO TO 999
C
 50   IF (IV1 .LE. 11 .AND. IV1 .GE. 1) GO TO 70
         IV(1) = 50
         IF (PU .NE. 0) THEN
             WRITE(ICOUT,60) IV1
 60      FORMAT('******  IV(1) =',I5,' SHOULD BE BETWEEN 0 AND 12.')
             CALL DPWRST('XXX','BUG ')
         ENDIF
         GO TO 999
C
 70   DO 75 ICH = 1, 12
         WHICH(ICH) = CNGD(ICH)
 75   CONTINUE
C
 80   IF (BIG .GT. TINY) GO TO 90
         TINY = RMDCON(1)
         MACHEP = RMDCON(3)
         BIG = RMDCON(6)
         VM(12) = MACHEP
         VX(12) = BIG
         VM(13) = TINY
         VX(13) = BIG
         VM(14) = MACHEP
         VM(17) = TINY
         VX(17) = BIG
         VM(18) = MACHEP
         VX(19) = BIG
         VX(20) = BIG
         VX(21) = BIG
         VM(22) = MACHEP
         VX(24) = RMDCON(5)
         VM(25) = MACHEP
         VM(26) = MACHEP
 90   M = 0
      IF (IV(INITS) .GE. 0 .AND. IV(INITS) .LE. 2) GO TO 110
         M = 18
         IF (PU .NE. 0) THEN
            WRITE(ICOUT,100) IV(INITS)
 100     FORMAT(25H******  INITS... IV(25) =,I4,20H SHOULD BE BETWEEN 0,
     +          7H AND 2.)
             CALL DPWRST('XXX','BUG ')
         ENDIF
 110  K = EPSLON
      DO 140 I = 1, NVDFLT
         VK = V(K)
         IF (VK .GE. VM(I) .AND. VK .LE. VX(I)) GO TO 130
              M = K
           IF (PU .NE. 0) THEN
              WRITE(ICOUT,120) (VN(ICH, I), ICH=1, 8),
     +                                  (VN(ICH, I), ICH=1, 8),
     +                                  K, VK, VM(I), VX(I)
 120          FORMAT(8H******  ,8A1,5H.. V(,I2,3H) =,D11.3,7H SHOULD,
     +               ' BE BETWEEN',D11.3,4H AND,D11.3)
             CALL DPWRST('XXX','BUG ')
         ENDIF
 130     K = K + 1
 140     CONTINUE
C
      IF (IV1 .EQ. 12 .AND. V(JTINIT) .GT. ZERO) GO TO 170
C
C  ***  CHECK JTOL VALUES  ***
C
      JTOLP = JTOL0 + P
      DO 160 I = JTOL1, JTOLP
         IF (V(I) .GT. ZERO) GO TO 160
         K = I - JTOL0
         IF (PU .NE. 0) THEN
            WRITE(ICOUT,150) K, I, V(I)
 150     FORMAT(12H****** JTOL(,I3,6H) = V(,I3,3H) =,D11.3,
     +          20H SHOULD BE POSITIVE.)
             CALL DPWRST('XXX','BUG ')
         ENDIF
         M = I
 160     CONTINUE
C
 170  IF (M .EQ. 0) GO TO 180
         IV(1) = M
         GO TO 999
C
 180  IF (PU .EQ. 0 .OR. IV(PARPRT) .EQ. 0) GO TO 999
      IF (IV1 .NE. 12 .OR. IV(INITS) .EQ. 0) GO TO 200
         M = 1
         WRITE(ICOUT,190)
 190     FORMAT(' NONDEFAULT VALUES....')
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,191) IV(INITS)
 191     FORMAT(20H INITS..... IV(25) =,I3)
         CALL DPWRST('XXX','BUG ')
 200  IF (IV(DTYPE) .EQ. IV(DTYPE0)) GO TO  210
         IF (M .EQ. 0) THEN
            WRITE(ICOUT,215) (WHICH(ICH), ICH=1, 12)
            CALL DPWRST('XXX','BUG ')
         ENDIF
         M = 1
         WRITE(ICOUT,205) IV(DTYPE)
 205     FORMAT(20H DTYPE..... IV(16) =,I3)
         CALL DPWRST('XXX','BUG ')
 210  K = EPSLON
      L = PARSV1
      DO 240 I = 1, NVDFLT
         IF (V(K) .EQ. V(L)) GO TO 230
              IF (M .EQ. 0) THEN
                 WRITE(ICOUT,215) (WHICH(ICH), ICH = 1, 12)
 215             FORMAT (' ',12A1,'ALUES....')
                 CALL DPWRST('XXX','BUG ')
                 WRITE(ICOUT,9999)
                 CALL DPWRST('XXX','BUG ')
              ENDIF
              M = 1
              WRITE (ICOUT,220) (VN(ICH, I), ICH = 1, 8), K, V(K)
 220          FORMAT (1X, 8A1, 5H.. V(, I2, 3H) =, D15.7)
              CALL DPWRST('XXX','BUG ')
 230     K = K + 1
         L = L + 1
 240     CONTINUE
      IV(DTYPE0) = IV(DTYPE)
      CALL VCOPY(NVDFLT, V(PARSV1), V(EPSLON))
      IF (IV1 .NE. 12) GO TO 999
         IF (V(JTINIT) .GT. ZERO) GO TO 260
              JTOLP = JTOL0 + P
              WRITE(ICOUT,250)
 250          FORMAT(24H (INITIAL) JTOL ARRAY...)
              CALL DPWRST('XXX','BUG ')
              WRITE(ICOUT,251) (V(I), I = JTOL1, JTOLP)
 251          FORMAT((1X,6D12.3))
              CALL DPWRST('XXX','BUG ')
 260     IF (V(D0INIT) .GT. ZERO) GO TO 999
              K = JTOL1 + P
              L = K + P - 1
              WRITE(ICOUT,270)
 270          FORMAT(22H (INITIAL) D0 ARRAY...)
              CALL DPWRST('XXX','BUG ')
              WRITE(ICOUT,271) (V(I), I = K, L)
 271          FORMAT(1X,6D12.3)
              CALL DPWRST('XXX','BUG ')
C
 999  RETURN
C  ***  LAST CARD OF PARCHK FOLLOWS  ***
      END
*STKREL
      SUBROUTINE STKREL(NUMBER)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C  DE-ALLOCATES THE LAST (NUMBER) ALLOCATIONS MADE IN THE STACK
C  BY STKGET.
C
C  ERROR STATES -
C
C    1 - NUMBER .LT. 0
C    2 - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN
C    3 - ATTEMPT TO DE-ALLOCATE NON-EXISTENT ALLOCATION
C    4 - THE POINTER AT ISTAK(LNOW) OVERWRITTEN
C
C     THIS FUNCTION WAS ADAPTED FROM THE FRAMEWORK FUNCTION ISTKGT
C
C     ADAPTED BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  NOVEMBER 26, 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   NUMBER
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
CCCCC+   IN,IPRT,LBOOK,LMAX,LNOW,LOUT,LUSED
     +   IN,LBOOK,LMAX,LNOW,LOUT,LUSED
C
C  LOCAL ARRAYS
      INTEGER
     +   ISTAK(12)
C
C  EXTERNAL SUBROUTINES
CCCCC EXTERNAL IPRINT
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),ISTAK(1))
      EQUIVALENCE (ISTAK(1),LOUT)
      EQUIVALENCE (ISTAK(2),LNOW)
      EQUIVALENCE (ISTAK(3),LUSED)
      EQUIVALENCE (ISTAK(4),LMAX)
      EQUIVALENCE (ISTAK(5),LBOOK)
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER IERR
C        THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED
C        IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED
C     INTEGER IN
C        ...
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER LBOOK
C        THE NUMBER OF WORDS USED FOR BOOKEEPING.
C     INTEGER LMAX
C        THE MAXIMUM LENGTH OF THE STACK.
C     INTEGER LNOW
C        THE CURRENT ACTIVE LENGTH OF THE STACK.
C     INTEGER LOUT
C        THE NUMBER OF CURRENT ALLOCATIONS.
C     INTEGER LUSED
C        THE MAXIMUM VALUE OF ISTAK(2) ACHEIVED.
C     INTEGER NUMBER
C        THE NUMBER OF ALLOCATIONS TO BE FREED FROM THE STACK.
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      IF (LNOW.LT.LBOOK.OR.LNOW.GT.LUSED.OR.LUSED.GT.LMAX) GO TO 20
C
      IN = NUMBER
 10      IF (IN.EQ.0) RETURN
C
         IF (LNOW.LE.LBOOK) GO TO 30
C
C     CHECK TO MAKE SURE THE BACK POINTERS ARE MONOTONE.
C
         IF (ISTAK(LNOW).LT.LBOOK.OR.ISTAK(LNOW).GE.LNOW-1) GO TO 40
C
         LOUT = LOUT-1
         LNOW = ISTAK(LNOW)
         IN = IN-1
         GO TO 10
C
C     PRINT ERROR MESSAGES
C
   20 IERR = 1
CCCCC CALL IPRINT(IPRT)
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1000)
 1000 FORMAT (' ***** ERROR *****')
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1002)
 1002 FORMAT (' DSTAK BOOKKEEPING ELEMENTS HAVE BEEN OVERWRITTEN.')
      CALL DPWRST('XXX','BUG ')
      RETURN
C
   30 IERR = 1
CCCCC CALL IPRINT(IPRT)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1010)
 1010 FORMAT (' ***** ERROR *****')
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1012)
 1012 FORMAT (
     +   ' ATTEMPT HAS BEEN MADE TO DE-ALLOCATE A NON-EXISTANT,',
     +   ' ALLOCATION IN DSTAK.')
      CALL DPWRST('XXX','BUG ')
      RETURN
C
   40 IERR = 1
CCCCC CALL IPRINT(IPRT)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1020) LOUT
 1020 FORMAT (' ***** ERROR *****')
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1022) LOUT
 1022 FORMAT(
     +   ' THE POINTER FOR ALLOCATION NUMBER ', I3, ' HAS BEEN',
     +   ' OVERWRITTEN.')
      CALL DPWRST('XXX','BUG ')
C
      RETURN
      END
*AMDRV
      SUBROUTINE AMDRV (MDLTS3, DRV, DONE, IFIXD, PAR, NPAR, XM, N, M,
     +   IXM, NRESTS, RESTS, D, WEIGHT, WT, LWT, STPT, LSTPT, SCL, LSCL)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE NUMERICAL APPROXIMATIONS TO THE
C     DERIVATIVE MATRIX (JACOBIAN).
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 2, 1985
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IXM,LSCL,LSTPT,LWT,M,N,NPAR,NRESTS
      LOGICAL
     +   DONE,WEIGHT
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   D(NRESTS,*),PAR(*),RESTS(*),SCL(*),STPT(*),WT(*),XM(IXM,*)
      INTEGER
     +   IFIXD(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL DRV,MDLTS3
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   PJ,STPJ
      INTEGER
     +   I,J,JPK
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MAX,SIGN
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION D(NRESTS,NPAR)
C        THE FIRST DERIVATIVE OF THE MODEL (JACOBIAN).
C     EXTERNAL DRV
C        THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE
C        DERIVATIVE (JACOBIAN) MATRIX OF THE MODEL.
C     LOGICAL DONE
C        THE VARIABLE USED TO INDICATE WHETHER THIS IS THE FINAL
C        COMPUTATION OF THE JACOBIAN OR NOT.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IERR
C        THE VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .GE. 1, ERRORS WERE DETECTED.
C     INTEGER IFIXD(NPAR)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE
C        PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED.
C        IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED.
C        IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED.
C     INTEGER IXM
C        THE FIRST DIMENSION OF MATRIX XM.
C     INTEGER J
C        AN INDEX VARIABLE.
C     INTEGER JPK
C        AN INDEX VARIABLE.
C     INTEGER LSCL
C        THE DIMENSION OF VECTOR SCL.
C     INTEGER LSTPT
C        THE DIMENSION OF VECTOR STPT.
C     INTEGER LWT
C        THE DIMENSION OF VECTOR WT.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     EXTERNAL MDLTS3
C        THE STARPAC FORMAT SUBROUTINE FOR COMPUTING THE ARIMA MODEL
C        RESIDUALS.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     INTEGER NRESTS
C        THE MAXIMUM NUMBER OF RESIDUALS TO BE COMPUTED.
C     DOUBLE PRECISION PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     DOUBLE PRECISION PJ
C        A TEMPORARY LOCATION FOR STORAGE OF THE JTH PARAMETER.
C     DOUBLE PRECISION RESTS(NRESTS)
C        THE RESIDUALS FROM THE ARIMA MODEL.
C     DOUBLE PRECISION SCL(LSCL)
C        THE SCALE VALUES.
C     DOUBLE PRECISION STPT(LSTPT)
C        THE STEP SIZE ARRAY.
C     DOUBLE PRECISION STPJ
C        THE JTH STEP SIZE.
C     LOGICAL WEIGHT
C        THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO
C        BE PERFORMED (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION WT(LWT)
C        THE USER SUPPLIED WEIGHTS.
C     DOUBLE PRECISION XM(IXM,M)
C        THE INDEPENDENT VARIABLE.
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     COMPUTE FINITE-DIFFERENCE JACOBIAN OF THE OPTIMIZED PARAMETERS
C
      JPK = 0
C
      DO 20 J=1,NPAR
C
         IF (IFIXD(J).NE.0) GO TO 20
C
         JPK = JPK + 1
C
         PJ = PAR(J)
         IF (SCL(JPK).NE.0.0D0) THEN
            STPJ = STPT(J)*SIGN(1.0D0,PAR(J))*MAX(ABS(PAR(J)),1.0D0/
     +             ABS(SCL(JPK)))
         ELSE
            IF (PAR(J).NE.0.0D0) THEN
               STPJ = STPT(J)*SIGN(1.0D0,PAR(J))*ABS(PAR(J))
            ELSE
               STPJ = STPT(J)
            END IF
         END IF
C
         STPJ = STPJ + PAR(J)
         STPJ = STPJ - PAR(J)
C
         PAR(J) = PJ + STPJ
         CALL MDLTS3(PAR, NPAR, XM, N, M, IXM, D(1,J))
C
         DO 10 I=1,NRESTS
            D(I,JPK) = (-RESTS(I)+D(I,J))/STPJ
   10    CONTINUE
C
         PAR(J) = PJ
C
   20 CONTINUE
C
      RETURN
C
      END
*AMLST1
      SUBROUTINE AMLST1 (IAMHD, PAR, NPAR, MSPECT, NFAC, VCVL, LVCVL,
     +  SCALE, LSCALE, STPT, LSTPT, IPARMN, IPARMX, LBLTYP, T975, IFIXD)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRINTS THE PARAMETERS FOR THE ARIMA ROUTINES.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 2, 1985
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   T975
      INTEGER
     +   IAMHD,IPARMN,IPARMX,LBLTYP,LSCALE,LSTPT,LVCVL,NFAC,NPAR
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   PAR(*),SCALE(*),STPT(*),VCVL(*)
      INTEGER
     +   IFIXD(*),MSPECT(NFAC,4)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   FPLM,PLL,PUL,RATIO,SDPAR
      INTEGER
CCCCC+   IPRT,J,K,L,LL,LPAR,ORDER
     +   J,K,L,LL,LPAR,ORDER
C
C  LOCAL ARRAYS
      CHARACTER
     +   FIXED(3)*1
C
C  EXTERNAL FUNCTIONS
CCCCC DOUBLE PRECISION
CCCCC+   D1MACH
CCCCC EXTERNAL D1MACH
C
C  EXTERNAL SUBROUTINES
CCCCC EXTERNAL FIXPRT,IPRINT
      EXTERNAL FIXPRT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     CHARACTER*1 FIXED(3)
C        THE CHARACTERS USED TO LABEL THE PARAMETERS FIXED OR NOT.
C     DOUBLE PRECISION FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     INTEGER IAMHD
C        THE INDICATOR VALUE USED TO DESIGNATE THE TYPE OF LIST
C        TO BE GENERATED
C        IF IAMHD=1, THE LIST IS FOR THE INITIAL SUMMARY OF THE
C                    ESTIMATION ROUTINES.
C        IF IAMHD=2, THE LIST IS FOR THE INITIAL REPORT OF THE
C                    FORECASTING ROUTINES.
C        IF IAMHD=3, THE LIST IS FOR THE FINAL REPORT OF THE
C                    ESTIMATION ROUTINES.
C     INTEGER IFIXD(NPAR)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE
C        PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED.
C        IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED.
C        IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED.
C     INTEGER IPARMN
C        THE SMALLEST PARAMETER INDEX INCLUDED IN THIS TERM.
C     INTEGER IPARMX
C        THE LARGEST PARAMETER INDEX INCLUDED IN THIS TERM.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER LVCVL
C        THE DIMENSION OF VECTOR VCVL.
C     INTEGER J
C        AN INDEX VARIABLE.
C     INTEGER L
C        AN INDEX VARIABLE.
C     INTEGER LBLTYP
C        THE TYPE OF LABLE TO BE PRINTED, WHERE
C        1 INDICATES THE TERM IS AUTOREGRESSIVE AND
C        2 INDICATES THE TERM IS MOVING AVERAGE
C     INTEGER LL
C        AN INDEX VARIABLE.
C     INTEGER LPAR
C        AN INDEX VARIABLE.
C     INTEGER LSCALE
C        THE DIMENSION OF VECTOR SCALE.
C     INTEGER LSTPT
C        THE DIMENSION OF VECTOR STPT.
C     INTEGER MSPECT(NFAC,4)
C        THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT
C     INTEGER NFAC
C        THE NUMBER OF FACTORS IN THE MODEL
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     INTEGER ORDER
C        THE ORDER OF B FOR THE PARAMETER BEING PRINTED
C     DOUBLE PRECISION PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     DOUBLE PRECISION PLL
C        THE LOWER CONFIDENCE LIMIT FOR A GIVEN PARAMETER.
C     DOUBLE PRECISION PUL
C        THE UPPER CONFIDENCE LIMIT FOR A GIVEN PARAMETER.
C     DOUBLE PRECISION RATIO
C        THE RATIO OF A GIVEN PARAMETER VALUE TO ITS STANDARD ERROR.
C     DOUBLE PRECISION SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     DOUBLE PRECISION SDPAR
C        THE STANDARD DEVIATION OF A GIVEN PARAMETER VALUE.
C     DOUBLE PRECISION STPT(LSTPT)
C        THE STEP SIZE ARRAY.
C     DOUBLE PRECISION T975
C        THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE
C        T DISTRIBUTION.
C     DOUBLE PRECISION VCVL(LVCVL)
C        THE LOWER HALF OF THE VARIANCE-COVARIANCE MATRIX, STORED
C        ROW WISE.
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      FPLM = D1MACH(2)
C
CCCCC CALL IPRINT(ICOUT)
C
C     PRINT NEXT SET OF TERMS
C
      LPAR = 0
      DO 1 J=1,IPARMX
         IF (IFIXD(J).EQ.0) LPAR = LPAR + 1
    1 CONTINUE

      DO 40 J=1,NFAC
        IF (IAMHD.EQ.3.AND.LBLTYP.EQ.1)THEN
           WRITE(ICOUT,601) J
           CALL DPWRST('XXX','BUG ')
  601      FORMAT(' FACTOR ',I1)
        ENDIF
        IF ((MSPECT(J,LBLTYP).EQ.0) .AND. (LBLTYP.NE.2)) GO TO 40
        IF (LBLTYP.NE.2) IPARMX = IPARMX + MSPECT(J,LBLTYP)
        IF (LBLTYP.EQ.2) IPARMX = IPARMX + 1
        ORDER = 0
        DO 30 L = IPARMN, IPARMX
          ORDER = ORDER + MSPECT(J,4)
          IF (IAMHD.EQ.2) THEN
             IF (LBLTYP.EQ.1) THEN
                WRITE(ICOUT, 1010) L, J, ORDER, PAR(L)
                CALL DPWRST('XXX','BUG ')
 1010        FORMAT(1X, I5, 2X, 'AR (FACTOR', I2, ')',4X,I5,E17.8)
             ELSEIF (LBLTYP.EQ.2) THEN
               WRITE(ICOUT, 1014) L, PAR(L)
               CALL DPWRST('XXX','BUG ')
 1014        FORMAT(1X, I5, 13X, 'MU', 4X, '  ###' ,E17.8)
             ELSEIF (LBLTYP.EQ.3) THEN
               WRITE(ICOUT, 1015) L, J, ORDER, PAR(L)
               CALL DPWRST('XXX','BUG ')
 1015        FORMAT(1X, I5, 2X, 'MA (FACTOR', I2, ')',4X,I5,E17.8)
             ENDIF
             GOTO30
          ENDIF
          CALL FIXPRT(IFIXD(L), FIXED)
          IF (IAMHD.EQ.1) THEN
            IF (IFIXD(L).EQ.0) THEN
              IF (LBLTYP.EQ.1) THEN
                 WRITE(ICOUT, 1000) L,J,ORDER,(FIXED(K),K=1,3),PAR(L),
     +                              STPT(L)
                 CALL DPWRST('XXX','BUG ')
 1000         FORMAT(1X,I5,2X,'AR (FACTOR',I2,')',4X,I5,6X,3A1,2E17.8)
              ELSEIF (LBLTYP.EQ.2) THEN
                 WRITE(ICOUT, 1004) L, (FIXED(K),K=1,3), PAR(L),STPT(L)
                 CALL DPWRST('XXX','BUG ')
 1004         FORMAT(1X, I5, 13X, 'MU', 4X, '  ###' ,6X,3A1,2E17.8)
              ELSEIF (LBLTYP.EQ.3) THEN
                 WRITE(ICOUT, 1005) L,J,ORDER,(FIXED(K),K=1,3),PAR(L),
     +                              STPT(L)
                 CALL DPWRST('XXX','BUG ')
 1005         FORMAT(1X,I5,2X,'MA (FACTOR',I2,')',4X,I5,6X,3A1,2E17.8)
              ENDIF
            ELSE
              IF (LBLTYP.EQ.1) THEN
                 WRITE(ICOUT, 1000) L,J,ORDER,(FIXED(K),K=1,3),PAR(L)
                 CALL DPWRST('XXX','BUG ')
              ELSEIF (LBLTYP.EQ.2) THEN
                 WRITE(ICOUT, 1004) L, (FIXED(K),K=1,3), PAR(L)
                 CALL DPWRST('XXX','BUG ')
              ELSEIF (LBLTYP.EQ.3) THEN
                 WRITE(ICOUT, 1005) L,J,ORDER,(FIXED(K),K=1,3),PAR(L)
                 CALL DPWRST('XXX','BUG ')
              ENDIF
            ENDIF
          ELSEIF (IAMHD.EQ.3) THEN
            IF (IFIXD(L).NE.0) THEN
               IF (LBLTYP.EQ.1) THEN
                 WRITE(ICOUT, 3000) ORDER,PAR(L)
                 CALL DPWRST('XXX','BUG ')
 3000            FORMAT(2X,'*AR',1X,I2,1X,2E15.8,F8.2,2E15.8)
               ELSEIF (LBLTYP.EQ.2) THEN
                 WRITE(ICOUT, 3004) PAR(L)
                 CALL DPWRST('XXX','BUG ')
 3004            FORMAT(2X,'*MU',' ### ' ,2E15.8,F8.2,
     +             2E16.8)
               ELSEIF (LBLTYP.EQ.3) THEN
                 WRITE(ICOUT, 3005) ORDER,(FIXED(K),K=1,3),PAR(L)
                 CALL DPWRST('XXX','BUG ')
 3005            FORMAT(2X,'*MA',1X,I2,1X,2E15.8,F8.2,2E16.8)
              ENDIF
            ELSE
C
               LPAR = LPAR + 1
               RATIO = FPLM
               LL = LPAR*(LPAR-1)/2 + LPAR
               IF (VCVL(LL).GT.0.0D0) RATIO = PAR(L)/SQRT(VCVL(LL))
               SDPAR = SQRT(VCVL(LL))
               PLL = PAR(L) - T975*SDPAR
               PUL = PAR(L) + T975*SDPAR
CCCCC          WRITE(ICOUT, 1003) SDPAR, RATIO, PLL, PUL
CCCCC          CALL DPWRST('XXX','BUG ')
C1003          FORMAT ('+', 55X, 4(2X, E15.8))
               WRITE(IOUNI1, 1013) PAR(L), SDPAR, RATIO, PLL, PUL
 1013          FORMAT (5(1X, E16.8))
               IF (LBLTYP.EQ.1) THEN
                 WRITE(ICOUT, 2000) ORDER,PAR(L),
     +                              SDPAR, RATIO, PLL, PUL
                 CALL DPWRST('XXX','BUG ')
 2000            FORMAT(3X,'AR',1X,I2,1X,2E15.8,F8.2,2E16.8)
               ELSEIF (LBLTYP.EQ.2) THEN
                 WRITE(ICOUT, 2004) PAR(L), SDPAR, RATIO, PLL, PUL
                 CALL DPWRST('XXX','BUG ')
 2004            FORMAT(3X,'MU',' ## ' ,2E15.8,F8.2,2E16.8)
               ELSEIF (LBLTYP.EQ.3) THEN
                 WRITE(ICOUT, 2005) ORDER,PAR(L),SDPAR,RATIO,PLL,PUL
                 CALL DPWRST('XXX','BUG ')
 2005            FORMAT(3X,'MA',1X,I2,1X,2E15.8,F8.2,2E16.8)
              ENDIF
            ENDIF
          ENDIF
   30   CONTINUE
        IPARMN = IPARMX + 1
   40 CONTINUE
C
      RETURN
      END
*EISII
      SUBROUTINE EISII(NMSUB, NMVAR, IVAL, IVALMN, IVALMX, MSGTYP,
     +   HEAD, ERROR, NMMIN, NMMAX)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THE ROUTINE CHECKS WHETHER THE VALUE   IVAL   IS WITHIN THE
C     THE RANGE IVALMN (INCLUSIVE) TO IVALMX (INCLUSIVE), AND PRINTS A
C     DIAGNOSTIC IF IT IS NOT.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 29, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IVAL,IVALMN,IVALMX,MSGTYP
      LOGICAL
     +   ERROR,HEAD
C
C  ARRAY ARGUMENTS
      CHARACTER
     +   NMMAX(8)*1,NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERROR
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     LOGICAL HEAD
C        A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED
C        (TRUE) OR NOT (FALSE).  IF A HEADING IS PRINTED, THE VALUE
C        OF HEAD WILL BE CHANGED TO FALSE.
C     INTEGER I
C        AN INDEX ARGUMENT.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IVAL
C        THE INPUT VALUE OF THE ARGUMENT BEING CHECKED.
C     INTEGER IVALMN, IVALMX
C        THE MINIMUM AND MAXIMUM OF THE RANGE WITHIN WHICH THE
C        ARGUMENT MUST LIE.
C     INTEGER MSGTYP
C        AN ARGUMENT USED TO INDICATE THE TYPE OF MESSAGE TO BE
C        PRINTED, WHERE IF ERROR IS .TRUE. AND
C        MSGTYP = 1 THE INPUT VALUE WAS OUTSIDE THE RANGE DETERMINED
C                   FROM OTHER INPUT ARGUMENTS
C        MSGTYP = 2 THE INPUT VALUE WAS OUTSIDE THE RANGE IMPOSED BY
C                   STARPAC
C     CHARACTER*1 NMMAX(8)
C        THE NAME OF THE ARGUMENT SPECIFYING THE MAXIMUM.
C     CHARACTER*1 NMMIN(8)
C        THE NAME OF THE ARGUMENT SPECIFYING THE MINIMUM.
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING SUBROUTINES NAME.
C     CHARACTER*1 NMVAR(8)
C        THE CHARACTERS OF THE ARGUMENTS NAME.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      ERROR = .FALSE.
C
      IF (((IVALMN.LE.IVAL) .AND. (IVAL.LE.IVALMX)) .OR.
     +   (IVALMX.LT.IVALMN)) RETURN
C
      ERROR = .TRUE.
CCCCC CALL IPRINT(IPRT)
      CALL EHDR(NMSUB, HEAD)
C
      IF (MSGTYP.LE.2) THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT, 1000) (NMVAR(I),I=1,6), IVAL
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C     PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE DETERMINED FROM
C     OTHER INPUT ARGUMENTS.
C
      IF (MSGTYP .EQ. 1) THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT, 1010) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8),
     +      (NMMAX(I),I=1,8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C     PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE IMPOSED BY STARPAC
C
      IF (MSGTYP .EQ. 2) THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT, 1020) (NMVAR(I),I=1,6), IVALMN, IVALMX
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C     PRINT MESSAGE FOR AOV ROUTINES
C
      IF (MSGTYP .EQ. 3) THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT, 1030)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT, 1031)
        CALL DPWRST('XXX','BUG ')
      ENDIF
      RETURN
C
C     FORMAT STATEMENTS
C
  999 FORMAT(1X)
 1000 FORMAT (' THE INPUT VALUE OF ', 6A1, ' IS ', I6, '.')
 1010 FORMAT(
     +   ' THE VALUE OF THE ARGUMENT ', 6A1,
     +   ' MUST BE BETWEEN', 1X, 8A1,
     +   ' AND ', 8A1, ', INCLUSIVE.')
 1020 FORMAT(
     +   ' THE VALUE OF THE ARGUMENT ', 6A1,
     +   ' MUST BE BETWEEN', 1X, I6,
     +   ' AND ', I6, ', INCLUSIVE.')
 1030 FORMAT(' THE NUMBER OF DISTINCT GROUPS (NG) MUST BE BETWEEN')
 1031 FORMAT(
     +' TWO AND ONE LESS THAN THE NUMBER OF POSITIVE TAG VALUES.')
C
      END
*IMDCON
      INTEGER FUNCTION IMDCON(K)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C  ***  RETURN INTEGER MACHINE-DEPENDENT CONSTANTS  ***
C
C     ***  K = 1 MEANS RETURN STANDARD OUTPUT UNIT NUMBER.   ***
C     ***  K = 2 MEANS RETURN ALTERNATE OUTPUT UNIT NUMBER.  ***
C     ***  K = 3 MEANS RETURN  INPUT UNIT NUMBER.            ***
C          (NOTE -- K = 2, 3 ARE USED ONLY BY TEST PROGRAMS.)
C
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   K
C
C  LOCAL ARRAYS
      INTEGER
     +   MDCON(3)
C
C  EXTERNAL FUNCTIONS
CCCCC INTEGER
CCCCC+   I1MACH
CCCCC EXTERNAL I1MACH
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      MDCON(1) = I1MACH(2)
      MDCON(2) = I1MACH(3)
      MDCON(3) = I1MACH(1)
C
      IMDCON = MDCON(K)
      RETURN
C  ***  LAST CARD OF IMDCON FOLLOWS  ***
      END
*MDLTS1
      SUBROUTINE MDLTS1 (PAR, NPAR, XM, N, M, IXM, RESTS)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR ESTIMATING BOX-JENKINS
C     ARIMA MODELS.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 4, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IXM,M,N,NPAR
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   PAR(NPAR),RESTS(NRESTS),XM(IXM,M)
C
C  SCALARS IN COMMON
      INTEGER
     +   IFLAG,MBO,MBOL,MSPECT,NFACT,NPARAR,NPARDF,NPARMA,NRESTS,
     +   PARAR,PARDF,PARMA,T,TEMP
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   PMU
      INTEGER
     +   I,I1
C
C  LOCAL ARRAYS
      DOUBLE PRECISION
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
C
C  EXTERNAL SUBROUTINES
      EXTERNAL MDLTS2
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /MDLTSC/MSPECT,NFACT,PARDF,NPARDF,PARAR,NPARAR,PARMA,
     +   NPARMA,MBO,MBOL,T,TEMP,NRESTS,IFLAG
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),ISTAK(1))
      EQUIVALENCE (DSTAK(1),RSTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IFLAG
C        AN INDICATOR VARIABLE DESIGNATING WHETHER THE BACK FORECASTS
C        WERE ESSENTIALLY ZERO (IFLAG=0) OR NOT (IFLAG=1).
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER IXM
C        THE FIRST DIMENSION OF MATRIX XM.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     INTEGER MBO
C        THE MAXIMUM BACK ORDER OPERATOR.
C     INTEGER MBOL
C        THE MAXIMUM BACK ORDER ON THE LEFT
C     INTEGER MSPECT
C        THE STARTING LOCATION IN THE WORK SPACE FOR
C        THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NFACT
C        THE NUMBER OF FACTORS IN THE MODEL
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     INTEGER NPARAR
C        THE NUMBER OF AUTOREGRESSIVE PARAMETERS
C     INTEGER NPARDF
C        THE ORDER OF THE EXPANDED DIFFERENCE FILTER.
C     INTEGER NPARMA
C        THE LENGTH OF THE VECTOR PARMA
C     INTEGER NRESTS
C        THE MAXIMUM NUMBER OF RESIDUALS TO BE COMPUTED.
C     DOUBLE PRECISION PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     INTEGER PARAR
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        THE AUTOREGRESSIVE PARAMETERS
C     INTEGER PARDF
C        THE STARTING LOCATION IN THE WORK SPACE FOR
C        THE VECTOR CONTAINING THE DIFFERENCE FILTER PARAMETERS
C     INTEGER PARMA
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        THE MOVING AVERAGE PARAMETERS
C     DOUBLE PRECISION PMU
C        THE VALUE OF MU, I.E., THE TREND OR MEAN.
C     DOUBLE PRECISION RESTS(NRESTS)
C        THE RESIDUALS FROM THE ARIMA MODEL.
C     DOUBLE PRECISION RSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER T
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        A TEMPORARY WORK VECTOR.
C     INTEGER TEMP
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        A TEMPORARY WORK VECTOR
C     DOUBLE PRECISION XM(IXM,M)
C        THE INDEPENDENT VARIABLE.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
C     COMPUTE RESIDUALS
C
      CALL MDLTS2 (PAR, RESTS, XM(1,1), NPAR, N, NFACT, ISTAK(MSPECT),
     +  PMU, RSTAK(PARDF), NPARDF, RSTAK(T), RSTAK(TEMP), RSTAK(PARAR),
     +  RSTAK(PARMA), MBO, N-NRESTS+1, N, IFLAG)
C
C     COMPUTE PREDICTED VALUES
C
      I1=NRESTS-N
      DO 20 I = 1,N
        I1=I1+1
        RESTS(I) = XM(I1,1)-RESTS(I1)
   20 CONTINUE
C
      RETURN
      END
*PPFNML
      DOUBLE PRECISION FUNCTION PPFNML(P)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS FUNCTION IS A VERSION OF DATAPAC SUBROUTINE
C     NORPPF, WITH MODIFICATIONS TO FACILITATE CONVERSION TO
C     DOUBLE PRECISION AUTOMATICALLY USING THE NAG, INC. CODE APT, AND
C     TO CORRESPOND TO STARPAC CONVENTIONS.
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE NORMAL (GAUSSIAN)
C              DISTRIBUTION WITH MEAN = 0 AND STANDARD DEVIATION = 1.
C              THIS DISTRIBUTION IS DEFINED FOR ALL X AND HAS
C              THE PROBABILITY DENSITY FUNCTION
C              F(X) = (1/SQRT(2*PI))*EXP(-X*X/2).
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     ERROR CHECKING--NONE
C     RESTRICTIONS--P SHOULD BE BETWEEN 0.0D0 AND 1.0D0, EXCLUSIVELY.
C     REFERENCES--ODEH AND EVANS, THE PERCENTAGE POINTS
C                 OF THE NORMAL DISTRIBUTION, ALGORTIHM 70,
C                 APPLIED STATISTICS, 1974, PAGES 96-97.
C               --EVANS, ALGORITHMS FOR MINIMAL DEGREE
C                 POLYNOMIAL AND RATIONAL APPROXIMATION,
C                 M. SC. THESIS, 1972, UNIVERSITY
C                 OF VICTORIA, B. C., CANADA.
C               --HASTINGS, APPROXIMATIONS FOR DIGITAL
C                 COMPUTERS, 1955, PAGES 113, 191, 192.
C               --NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 933, FORMULA 26.2.23.
C               --FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION
C                 OF THE LOCATION PARAMETER OF A SYMMETRIC
C                 DISTRIBUTION (UNPUBLISHED PH.D. DISSERTATION,
C                 PRINCETON UNIVERSITY), 1969, PAGES 21-44, 229-231.
C               --FILLIBEN, "THE PERCENT POINT FUNCTION",
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--1, 1970, PAGES 40-111.
C               --THE KELLEY STATISTICAL TABLES, 1948.
C               --OWEN, HANDBOOK OF STATISTICAL TABLES,
C                 1962, PAGES 3-16.
C               --PEARSON AND HARTLEY, BIOMETRIKA TABLES
C                 FOR STATISTICIANS, VOLUME 1, 1954,
C                 PAGES 104-113.
C     COMMENTS--THE CODING AS PRESENTED BELOW
C               IS ESSENTIALLY IDENTICAL TO THAT
C               PRESENTED BY ODEH AND EVANS
C               AS ALGORTIHM 70 OF APPLIED STATISTICS.
C               THE PRESENT AUTHOR HAS MODIFIED THE
C               ORIGINAL ODEH AND EVANS CODE WITH ONLY
C               MINOR STYLISTIC CHANGES.
C             --AS POINTED OUT BY ODEH AND EVANS
C               IN APPLIED STATISTICS,
C               THEIR ALGORITHM REPRESENTES A
C               SUBSTANTIAL IMPROVEMENT OVER THE
C               PREVIOUSLY EMPLOYED
C               HASTINGS APPROXIMATION FOR THE
C               NORMAL PERCENT POINT FUNCTION--
C               THE ACCURACY OF APPROXIMATION
C               BEING IMPROVED FROM 4.5*(10**-4)
C               TO 1.5*(10**-8).
C
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING LABORATORY
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C     ORIGINAL VERSION--JUNE      1972.
C     UPDATED         --SEPTEMBER 1975.
C     UPDATED         --NOVEMBER  1975.
C     UPDATED         --OCTOBER   1976.
C
C     MODIFIED BY     --JANET R. DONALDSON, DECEMBER 7, 1981
C                       STATISTICAL ENGINEERING DIVISION
C                       NATIONAL BUREAU OF STANDARDS, BOULDER, COLORDAO
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   P
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   ADEN,ANUM,P0,P1,P2,P3,P4,Q0,Q1,Q2,Q3,Q4,R,T
C
C  INTRINSIC FUNCTIONS
      INTRINSIC LOG,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION ADEN, ANUM
C        *
C     DOUBLE PRECISION P
C        THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE EVALUATED
C     DOUBLE PRECISION P0, P1, P2, P3, P4
C        VARIOUS PARAMETERS USED IN THE APPROXIMATIONS.
C     DOUBLE PRECISION Q0, Q1, Q2, Q3, Q4
C        VARIOUS ADDITIONAL PARAMETERS USED IN THE APPROXIMATIONS.
C     DOUBLE PRECISION R
C        *
C     DOUBLE PRECISION T
C        *
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA P0, P1, P2, P3, P4
     +  /-.322232431088D0, -1.0D0, -.342242088547D0,
     +   -.204231210245D-1,-.453642210148D-4/
      DATA Q0, Q1, Q2, Q3, Q4
     +  /.993484626060D-1, .588581570495D0,
     +   .531103462366D0, .103537752850D0, .38560700634D-2/
C
C
      IF (P.NE.0.5D0) GO TO 30
      PPFNML = 0.0D0
      RETURN
C
   30 R = P
      IF (P.GT.0.5D0) R = 1.0D0 - R
      T = SQRT(-2.0D0*LOG(R))
      ANUM = ((((T*P4+P3)*T+P2)*T+P1)*T+P0)
      ADEN = ((((T*Q4+Q3)*T+Q2)*T+Q1)*T+Q0)
      PPFNML = T + (ANUM/ADEN)
C
      IF (P.LT.0.5D0) PPFNML = -PPFNML
C
      RETURN
C
      END
*STKSET
      SUBROUTINE STKSET (NITEMS, ITYPE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C  INITIALIZES THE STACK TO NITEMS OF TYPE ITYPE
C
C     THIS FUNCTION WAS ADAPTED FROM THE FRAMEWORK SUBROUTINE ISTKIN
C
C     ADAPTED BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  NOVEMBER 26, 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   ITYPE,NITEMS
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   LBOOK,LMAX,LNOW,LOUT,LUSED
C
C  LOCAL ARRAYS
      INTEGER
     +   ISIZE(5),ISTAK(12)
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),ISTAK(1))
      EQUIVALENCE (ISTAK(1),LOUT)
      EQUIVALENCE (ISTAK(2),LNOW)
      EQUIVALENCE (ISTAK(3),LUSED)
      EQUIVALENCE (ISTAK(4),LMAX)
      EQUIVALENCE (ISTAK(5),LBOOK)
      EQUIVALENCE (ISTAK(6),ISIZE(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ISIZE(5)
C        THE NUMBER OF WORDS IN EACH OF THE VARIOUS DATA TYPES.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ITYPE
C        THE TYPE OF ARRAY OF LENGTH NITEMS TO BE ALLOCATED.
C     INTEGER LBOOK
C        THE NUMBER OF WORDS USED FOR BOOKEEPING.
C     INTEGER LMAX
C        THE MAXIMUM LENGTH OF THE STACK.
C     INTEGER LNOW
C        THE CURRENT ACTIVE LENGTH OF THE STACK.
C     INTEGER LOUT
C        THE NUMBER OF CURRENT ALLOCATIONS.
C     INTEGER LUSED
C        THE MAXIMUM VALUE OF ISTAK(2) ACHEIVED.
C     INTEGER NITEMS
C        THE LENGTH OF THE ARRAY OF ITYPE TO BE ALLOCATED.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C  HERE TO INITIALIZE
C
C  SET DATA SIZES APPROPRIATE FOR A STANDARD CONFORMING
C  FORTRAN SYSTEM USING THE FORTRAN "STORAGE UNIT" AS THE
C  MEASURE OF SIZE.
C
C  LOGICAL
      ISIZE(1) = 1
C  INTEGER
      ISIZE(2) = 1
C  DOUBLE PRECISION
      ISIZE(3) = 1
C  DOUBLE PRECISION
      ISIZE(4) = 2
C  COMPLEX
      ISIZE(5) = 2
C
      LBOOK = 10
      LNOW  = LBOOK
      LUSED = LBOOK
      LMAX  = MAX( (NITEMS*ISIZE(ITYPE))/ISIZE(2), 12 )
      LOUT  = 0
C
      RETURN
C
      END
*AMECNT
      SUBROUTINE AMECNT(Y, WT, LWT, XM, N, M, IXM, MDL, NLDRV, APRXDV,
     +   DRV, PAR, NPAR, RES, IFIXED, LIFIXD, STP, LSTP, MIT, STOPSS,
     +   STOPP, SCALE, LSCALE, DELTA, IVAPRX, RSD, PV, LPV, SDPV,
     +   LSDPV, SDRES, LSDRES, VCV, IVCV, WEIGHT, SAVE, NNZW, NPARE,
     +   NLHDR, PAGE, WIDE, IPTOUT, NDIGIT, HLFRPT, NRESTS)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE CONTROLLING SUBROUTINE FOR NONLINEAR LEAST
C     SQUARES REGRESSION.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  OCTOBER 3, 1983
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   DELTA,RSD,STOPP,STOPSS
      INTEGER
     +   IVAPRX,IVCV,IXM,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP,LWT,M,
     +   MIT,N,NDIGIT,NNZW,NPAR,NPARE,NRESTS
      LOGICAL
     +   APRXDV,HLFRPT,PAGE,SAVE,WEIGHT,WIDE
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   PAR(*),PV(*),RES(*),SCALE(*),SDPV(*),SDRES(*),STP(*),
     +   VCV(IVCV,*),WT(*),XM(IXM,*),Y(*)
      INTEGER
     +   IFIXED(*),IPTOUT(5)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL DRV,MDL,NLDRV,NLHDR
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   D,IFIXD,IFP,IIWORK,IRWORK,IWORK,LVCVL,NALL0,PARE,PVI,
     +   RESTS,RWORK,SDPVI,SDRESI,VCVL
C
C  LOCAL ARRAYS
      DOUBLE PRECISION
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMEMN,CPYASF,CPYVII,DCOPY,SETIV,STKCLR
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),ISTAK(1))
      EQUIVALENCE (DSTAK(1),RSTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL APRXDV
C        THE VARIABLE USED TO INDICATE WHETHER NUMERICAL
C        APPROXIMATIONS TO THE DERIVATIVE WERE USED (TRUE) OR NOT
C        (FALSE).
C     INTEGER D
C        THE STARTING LOCATION IN RSTAK/DSTAK OF
C        THE ARRAY IN WHICH THE NUMERICAL DERIVATIVES WITH RESPECT TO
C        EACH PARAMETER ARE STORED.
C     DOUBLE PRECISION DELTA
C        THE MAXIMUM CHANGE ALLOWED IN THE MODEL PARAMETERS AT THE
C        FIRST ITERATION.
C     EXTERNAL DRV
C        THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE
C        DERIVATIVE (JACOBIAN) MATRIX OF THE MODEL.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     LOGICAL HLFRPT
C        THE VARIABLE WHICH INDICATES WHETHER THE DERIVATIVE
C        CHECKING ROUTINE HAS ALREADY PRINTED PART OF THE
C        INITIAL SUMMARY (TRUE) OR NOT (FALSE).
C     INTEGER IERR
C        THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .GE. 1, ERRORS WERE DETECTED.
C     INTEGER IFIXD
C        THE STARTING LOCATION IN ISTAK OF
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE
C        PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED.
C        IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED.
C        IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED.
C     INTEGER IFIXED(LIFIXD)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE
C        PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED.  IF
C        IFIXED(I).NE.0, THEN PAR(I) WILL BE OPTIMIZED.  IF IFIXED(I).EQ
C        THEN PAR(I) WILL BE HELD FIXED.
C     INTEGER IFP
C        AN INDICATOR FOR STACK ALLOCATION TYPE, WHERE IFP=3 INDICATES
C        REAL AND IFP=4 INDICATES DOUBLE PRECISION.
C     INTEGER IIWORK
C        THE DIMENSION OF THE INTEGER WORK VECTOR IWORK.
C     INTEGER IPTOUT(5)
C        THE VARIABLE USED TO CONTROL PRINTED OUTPUT FOR EACH SECTION.
C     INTEGER IRWORK
C        THE DIMENSION OF THE DOUBLE PRECISION WORK VECTOR RWORK.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER IVAPRX
C        AN INDICATOR VALUE USED TO DESIGNATE WHICH OPTION IS TO BE USED
C        TO COMPUTE THE VARIANCE COVARIANCE MATRIX (VCV), WHERE
C        IVAPRX LE 0 INDICATES THE THE DEFAULT OPTION WILL BE USED
C        IVAPRX EQ 1 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN)
C                    USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED
C                    DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE
C        IVAPRX EQ 2 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(HESSIAN)
C                    USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED
C                    DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE
C        IVAPRX EQ 3 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN
C                          *INVERSE(HESSIAN)
C                    USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED
C                    DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE
C        IVAPRX EQ 4 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN)
C                    USING ONLY THE MODEL SUBROUTINE
C        IVAPRX EQ 5 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(HESSIAN)
C                    USING ONLY THE MODEL SUBROUTINE
C        IVAPRX EQ 6 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN
C                          *INVERSE(HESSIAN)
C                    USING ONLY THE MODEL SUBROUTINE
C        IVAPRX GE 7 INDICATES THE DEFAULT OPTION WILL BE USED
C     INTEGER IVCV
C        THE FIRST DIMENSION OF THE VARIANCE COVARIANCE MATRIX VCV.
C     INTEGER IWORK
C        THE STARTING LOCATION IN ISTAK OF
C        THE INTEGER WORK SPACE VECTOR USED BY THE NL2 SUBROUTINES.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER LIFIXD
C        THE ACTUAL LENGTH OF THE VECTOR IFIXED.
C     INTEGER LPV
C        THE ACTUAL LENGTH OF THE VECTOR PV.
C     INTEGER LSCALE
C        THE ACTUAL LENGTH OF THE VECTOR SCALE.
C     INTEGER LSDPV
C        THE ACTUAL LENGTH OF THE VECTOR SDPV.
C     INTEGER LSDRES
C        THE ACTUAL LENGTH OF THE VECTOR SDRES.
C     INTEGER LSTP
C        THE ACTUAL LENGTH OF THE VECTOR STP.
C     INTEGER LVCVL
C        THE LENGTH OF THE VECTOR CONTAINING
C        THE LOWER HALF OF THE VCV MATRIX, STORED ROW WISE.
C     INTEGER LWT
C        THE ACTUAL LENGTH OF THE VECTOR WT.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     INTEGER MIT
C        THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C     EXTERNAL MDL
C        THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE
C        PREDICTED VALUES BASED ON THE CURRENT PARAMETER ESTIMATE.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NALL0
C        NUMBER OF ALLOCATIONS ON ENTRY.
C     INTEGER NDIGIT
C        THE NUMBER OF DIGITS IN THE PRINT CONTROL VALUE.
C     EXTERNAL NLDRV
C        THE NAME OF THE ROUTINE WHICH CALCULATES THE DERIVATIVES.
C     EXTERNAL NLHDR
C        THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING.
C     INTEGER NNZW
C        THE NUMBER OF NON ZERO WEIGHTS.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     INTEGER NPARE
C        THE NUMBER OF PARAMETERS TO BE ESTIMATED.
C     INTEGER NRESTS
C        THE MAXIMUM NUMBER OF RESIDUALS TO BE COMPUTED.
C     LOGICAL PAGE
C        THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF
C        THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     INTEGER PARE
C        THE STARTING LOCATION IN RSTAK/DSTAK OF
C        THE CURRENT ESTIMATES OF THE PARAMETERS, BUT ONLY
C        THOSE TO BE OPTIMIZED (NOT THOSE WHOSE VALUES ARE FIXED).
C     DOUBLE PRECISION PV(LPV)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     INTEGER PVI
C        THE STARTING LOCATION IN RSTAK/DSTAK OF
C        THE PREDICTED VALUES.
C     DOUBLE PRECISION RES(N)
C        THE RESIDUALS FROM THE FIT.
C     INTEGER RESTS
C        THE STARTING LOCATION IN RSTAK/DSTAK OF
C        THE RESIDUALS FROM THE ARIMA MODEL.
C     DOUBLE PRECISION RSD
C        THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION.
C     DOUBLE PRECISION RSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER RWORK
C        THE STARTING LOCATION IN RSTAK/DSTAK OF
C        THE DOUBLE PRECISION WORK VECTOR USED BY THE NL2 SUBROUTINES.
C     LOGICAL SAVE
C        THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN
C        THE RESIDUALS AND PARAMETERS ARE TO BE SAVED (TRUE) OR NOT
C        (FALSE).
C     DOUBLE PRECISION SCALE(LSCALE)
C        A VALUE TO INDICATE USE OF THE DEFAULT VALUES OF
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     DOUBLE PRECISION SDPV(LSDPV)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     INTEGER SDPVI
C        THE STARTING LOCATION IN RWORK OF
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     DOUBLE PRECISION SDRES(LSDRES)
C        THE STANDARDIZED RESIDUALS.
C     INTEGER SDRESI
C        THE STARTING LOCATION IN RWORK OF THE
C        THE STANDARDIZED RESIDUALS.
C     DOUBLE PRECISION STOPP
C        THE STOPPING CRITERION FOR THE TEST BASED ON THE MAXIMUM SCALED
C        RELATIVE CHANGE IN THE ELEMENTS OF THE MODEL PARAMETER VECTOR
C     DOUBLE PRECISION STOPSS
C        THE STOPPING CRITERION FOR THE TEST BASED ON THE RATIO OF THE
C        PREDICTED DECREASE IN THE RESIDUAL SUM OF SQUARES (COMPUTED
C        BY STARPAC) TO THE CURRENT RESIDUAL SUM OF SQUARES ESTIMATE.
C     DOUBLE PRECISION STP(LSTP)
C        THE STEP SIZE ARRAY.
C     DOUBLE PRECISION VCV(IVCV,NPAR)
C        THE VARIANCE-COVARIANCE MATRIX.
C     INTEGER VCVL
C        THE STARTING LOCATION IN RWORK OF
C        THE VARIANCE-COVARIANCE MATRIX.
C     LOGICAL WEIGHT
C        THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO
C        BE PERFORMED (TRUE) OR NOT (FALSE).
C     LOGICAL WIDE
C        THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD
C        BE FULL WIDTH (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION WT(LWT)
C        THE USER SUPPLIED WEIGHTS.
C     DOUBLE PRECISION XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     DOUBLE PRECISION Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     SET VARIOUS PROGRAM VALUES
C
      NALL0 = STKST(1)
C
      IFP = 4
C
      IERR = 0
C
C     SUBDIVIDE WORK AREA FOR LEAST SQUARES ANALYSIS
C
      IIWORK = NPARE + 60
      IRWORK = 94 + 2*NRESTS + NPARE*(3*NPARE+33)/2
C
      IFIXD = STKGET(NPAR,2)
      IWORK = STKGET(IIWORK,2)
C
      D = STKGET(NRESTS*NPAR,IFP)
      PARE = STKGET(NPARE,IFP)
      RESTS = STKGET(NRESTS,IFP)
      PVI = RESTS
      RWORK = STKGET(IRWORK,IFP)
C
      IF (IERR.EQ.1) RETURN
C
C     SET VALUES FOR IFIXD
C
      IF (IFIXED(1).GE.0) CALL CPYVII(NPAR, IFIXED, 1, ISTAK(IFIXD), 1)
      IF (IFIXED(1).LT.0) CALL SETIV(ISTAK(IFIXD), NPAR, 0)
C
      CALL AMEMN(Y, WEIGHT, NNZW, WT, LWT, XM, N, M, IXM, NRESTS,
     +   APRXDV, ISTAK(IFIXD), PAR, RSTAK(PARE), NPAR, RES, PAGE,
     +   WIDE, HLFRPT, STP, LSTP, MIT, STOPSS, STOPP, SCALE, LSCALE,
     +   DELTA, IVAPRX, IPTOUT, NDIGIT, RSD, RSTAK(RESTS), SDPVI,
     +   SDRESI, VCVL, LVCVL, RSTAK(D), ISTAK(IWORK), IIWORK,
     +   RSTAK(RWORK), IRWORK, NLHDR, NPARE, RSTAK(PVI))
C
      IF (.NOT.SAVE) GO TO 10
C
      SDPVI = RWORK + SDPVI - 1
      SDRESI = RWORK + SDRESI - 1
      VCVL = RWORK + VCVL - 1
C
      CALL DCOPY(N, RSTAK(PVI), 1, PV, 1)
      CALL DCOPY(N, RSTAK(SDPVI), 1, SDPV, 1)
      CALL DCOPY(N, RSTAK(SDRESI), 1, SDRES, 1)
      CALL CPYASF(NPARE, RSTAK(VCVL), LVCVL, VCV, IVCV)
C
   10 CALL STKCLR(NALL0)
C
      RETURN
C
      END
*ASSESS
      SUBROUTINE ASSESS (D, IV, P, STEP, STLSTG, V, X, X0)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C
C  ***  ASSESS CANDIDATE STEP (NL2SOL VERSION 2.2)  ***
C
C  ***  PURPOSE  ***
C
C        THIS SUBROUTINE IS CALLED BY AN UNCONSTRAINED MINIMIZATION
C     ROUTINE TO ASSESS THE NEXT CANDIDATE STEP.  IT MAY RECOMMEND ONE
C     OF SEVERAL COURSES OF ACTION, SUCH AS ACCEPTING THE STEP, RECOM-
C     PUTING IT USING THE SAME OR A NEW QUADRATIC MODEL, OR HALTING DUE
C     TO CONVERGENCE OR FALSE CONVERGENCE.  SEE THE RETURN CODE LISTING
C     BELOW.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   P
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   D(P),STEP(P),STLSTG(P),V(*),X(P),X0(P)
      INTEGER
     +   IV(*)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   EMAX,GTS,HALF,ONE,RELDX1,RFAC1,TEMP,TWO,XMAX,ZERO
      INTEGER
     +   AFCTOL,DECFAC,DST0,DSTNRM,DSTSAV,F,F0,FDIF,FLSTGD,GTSLST,
     +   GTSTEP,I,INCFAC,IRC,LMAX0,MLSTGD,MODEL,NFC,NFCALL,NFGCAL,
     +   NREDUC,PLSTGD,PREDUC,RADFAC,RADINC,RDFCMN,RDFCMX,RELDX,
     +   RESTOR,RFCTOL,STAGE,STGLIM,STPPAR,SWITCH,TOOBIG,TUNER1,
     +   TUNER2,TUNER3,XCTOL,XFTOL,XIRC
      LOGICAL
     +   GOODX
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION
CCCCC+   D1MACH,RELDST
     +   RELDST
CCCCC EXTERNAL D1MACH,RELDST
      EXTERNAL RELDST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL VCOPY
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MAX
C
C--------------------------  PARAMETER USAGE  --------------------------
C
C     IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION
C             BELOW OF IV VALUES REFERENCED.
C      D (IN)  SCALE VECTOR USED IN COMPUTING V(RELDX) -- SEE BELOW.
C      P (IN)  NUMBER OF PARAMETERS BEING OPTIMIZED.
C   STEP (I/O) ON INPUT, STEP IS THE STEP TO BE ASSESSED.  IT IS UN-
C             CHANGED ON OUTPUT UNLESS A PREVIOUS STEP ACHIEVED A
C             BETTER OBJECTIVE FUNCTION REDUCTION, IN WHICH CASE STLSTG
C             WILL HAVE BEEN COPIED TO STEP.
C STLSTG (I/O) WHEN ASSESS RECOMMENDS RECOMPUTING STEP EVEN THOUGH THE
C             CURRENT (OR A PREVIOUS) STEP YIELDS AN OBJECTIVE FUNC-
C             TION DECREASE, IT SAVES IN STLSTG THE STEP THAT GAVE THE
C             BEST FUNCTION REDUCTION SEEN SO FAR (IN THE CURRENT ITERA-
C             TION).  IF THE RECOMPUTED STEP YIELDS A LARGER FUNCTION
C             VALUE, THEN STEP IS RESTORED FROM STLSTG AND
C             X = X0 + STEP IS RECOMPUTED.
C      V (I/O) REAL PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION
C             BELOW OF V VALUES REFERENCED.
C      X (I/O) ON INPUT, X = X0 + STEP IS THE POINT AT WHICH THE OBJEC-
C             TIVE FUNCTION HAS JUST BEEN EVALUATED.  IF AN EARLIER
C             STEP YIELDED A BIGGER FUNCTION DECREASE, THEN X IS
C             RESTORED TO THE CORRESPONDING EARLIER VALUE.  OTHERWISE,
C             IF THE CURRENT STEP DOES NOT GIVE ANY FUNCTION DECREASE,
C             THEN X IS RESTORED TO X0.
C     X0 (IN)  INITIAL OBJECTIVE FUNCTION PARAMETER VECTOR (AT THE
C             START OF THE CURRENT ITERATION).
C
C  ***  IV VALUES REFERENCED  ***
C
C    IV(IRC) (I/O) ON INPUT FOR THE FIRST STEP TRIED IN A NEW ITERATION,
C             IV(IRC) SHOULD BE SET TO 3 OR 4 (THE VALUE TO WHICH IT IS
C             SET WHEN STEP IS DEFINITELY TO BE ACCEPTED).  ON INPUT
C             AFTER STEP HAS BEEN RECOMPUTED, IV(IRC) SHOULD BE
C             UNCHANGED SINCE THE PREVIOUS RETURN OF ASSESS.
C                ON OUTPUT, IV(IRC) IS A RETURN CODE HAVING ONE OF THE
C             FOLLOWING VALUES...
C                  1 = SWITCH MODELS OR TRY SMALLER STEP.
C                  2 = SWITCH MODELS OR ACCEPT STEP.
C                  3 = ACCEPT STEP AND DETERMINE V(RADFAC) BY GRADIENT
C                       TESTS.
C                  4 = ACCEPT STEP, V(RADFAC) HAS BEEN DETERMINED.
C                  5 = RECOMPUTE STEP (USING THE SAME MODEL).
C                  6 = RECOMPUTE STEP WITH RADIUS = V(LMAX0) BUT DO NOT
C                       EVAULATE THE OBJECTIVE FUNCTION.
C                  7 = X-CONVERGENCE (SEE V(XCTOL)).
C                  8 = RELATIVE FUNCTION CONVERGENCE (SEE V(RFCTOL)).
C                  9 = BOTH X- AND RELATIVE FUNCTION CONVERGENCE.
C                 10 = ABSOLUTE FUNCTION CONVERGENCE (SEE V(AFCTOL)).
C                 11 = SINGULAR CONVERGENCE (SEE V(LMAX0)).
C                 12 = FALSE CONVERGENCE (SEE V(XFTOL)).
C                 13 = IV(IRC) WAS OUT OF RANGE ON INPUT.
C             RETURN CODE I HAS PRECDENCE OVER I+1 FOR I = 9, 10, 11.
C IV(MLSTGD) (I/O) SAVED VALUE OF IV(MODEL).
C  IV(MODEL) (I/O) ON INPUT, IV(MODEL) SHOULD BE AN INTEGER IDENTIFYING
C             THE CURRENT QUADRATIC MODEL OF THE OBJECTIVE FUNCTION.
C             IF A PREVIOUS STEP YIELDED A BETTER FUNCTION REDUCTION,
C             THEN IV(MODEL) WILL BE SET TO IV(MLSTGD) ON OUTPUT.
C IV(NFCALL) (IN)  INVOCATION COUNT FOR THE OBJECTIVE FUNCTION.
C IV(NFGCAL) (I/O) VALUE OF IV(NFCALL) AT STEP THAT GAVE THE BIGGEST
C             FUNCTION REDUCTION THIS ITERATION.  IV(NFGCAL) REMAINS
C             UNCHANGED UNTIL A FUNCTION REDUCTION IS OBTAINED.
C IV(RADINC) (I/O) THE NUMBER OF RADIUS INCREASES (OR MINUS THE NUMBER
C             OF DECREASES) SO FAR THIS ITERATION.
C IV(RESTOR) (OUT) SET TO 0 UNLESS X AND V(F) HAVE BEEN RESTORED, IN
C             WHICH CASE ASSESS SETS IV(RESTOR) = 1.
C  IV(STAGE) (I/O) COUNT OF THE NUMBER OF MODELS TRIED SO FAR IN THE
C             CURRENT ITERATION.
C IV(STGLIM) (IN)  MAXIMUM NUMBER OF MODELS TO CONSIDER.
C IV(SWITCH) (OUT) SET TO 0 UNLESS A NEW MODEL IS BEING TRIED AND IT
C             GIVES A SMALLER FUNCTION VALUE THAN THE PREVIOUS MODEL,
C             IN WHICH CASE ASSESS SETS IV(SWITCH) = 1.
C IV(TOOBIG) (IN)  IS NONZERO IF STEP WAS TOO BIG (E.G. IF IT CAUSED
C             OVERFLOW).
C   IV(XIRC) (I/O) VALUE THAT IV(IRC) WOULD HAVE IN THE ABSENCE OF
C             CONVERGENCE, FALSE CONVERGENCE, AND OVERSIZED STEPS.
C
C  ***  V VALUES REFERENCED  ***
C
C V(AFCTOL) (IN)  ABSOLUTE FUNCTION CONVERGENCE TOLERANCE.  IF THE
C             ABSOLUTE VALUE OF THE CURRENT FUNCTION VALUE V(F) IS LESS
C             THAN V(AFCTOL), THEN ASSESS RETURNS WITH IV(IRC) = 10.
C V(DECFAC) (IN)  FACTOR BY WHICH TO DECREASE RADIUS WHEN IV(TOOBIG) IS
C             NONZERO.
C V(DSTNRM) (IN)  THE 2-NORM OF D*STEP.
C V(DSTSAV) (I/O) VALUE OF V(DSTNRM) ON SAVED STEP.
C   V(DST0) (IN)  THE 2-NORM OF D TIMES THE NEWTON STEP (WHEN DEFINED,
C             I.E., FOR V(NREDUC) .GE. 0).
C      V(F) (I/O) ON BOTH INPUT AND OUTPUT, V(F) IS THE OBJECTIVE FUNC-
C             TION VALUE AT X.  IF X IS RESTORED TO A PREVIOUS VALUE,
C             THEN V(F) IS RESTORED TO THE CORRESPONDING VALUE.
C   V(FDIF) (OUT) THE FUNCTION REDUCTION V(F0) - V(F) (FOR THE OUTPUT
C             VALUE OF V(F) IF AN EARLIER STEP GAVE A BIGGER FUNCTION
C             DECREASE, AND FOR THE INPUT VALUE OF V(F) OTHERWISE).
C V(FLSTGD) (I/O) SAVED VALUE OF V(F).
C     V(F0) (IN)  OBJECTIVE FUNCTION VALUE AT START OF ITERATION.
C V(GTSLST) (I/O) VALUE OF V(GTSTEP) ON SAVED STEP.
C V(GTSTEP) (IN)  INNER PRODUCT BETWEEN STEP AND GRADIENT.
C V(INCFAC) (IN)  MINIMUM FACTOR BY WHICH TO INCREASE RADIUS.
C  V(LMAX0) (IN)  MAXIMUM REASONABLE STEP SIZE (AND INITIAL STEP BOUND).
C             IF THE ACTUAL FUNCTION DECREASE IS NO MORE THAN TWICE
C             WHAT WAS PREDICTED, IF A RETURN WITH IV(IRC) = 7, 8, 9,
C             OR 10 DOES NOT OCCUR, IF V(DSTNRM) .GT. V(LMAX0), AND IF
C             V(PREDUC) .LE. V(RFCTOL) * ABS(V(F0)), THEN ASSESS RE-
C             TURNS WITH IV(IRC) = 11.  IF SO DOING APPEARS WORTHWHILE,
C             THEN ASSESS REPEATS THIS TEST WITH V(PREDUC) COMPUTED FOR
C             A STEP OF LENGTH V(LMAX0) (BY A RETURN WITH IV(IRC) = 6).
C V(NREDUC) (I/O)  FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR
C             NEWTON STEP.  IF ASSESS IS CALLED WITH IV(IRC) = 6, I.E.,
C             IF V(PREDUC) HAS BEEN COMPUTED WITH RADIUS = V(LMAX0) FOR
C             USE IN THE SINGULAR CONVERVENCE TEST, THEN V(NREDUC) IS
C             SET TO -V(PREDUC) BEFORE THE LATTER IS RESTORED.
C V(PLSTGD) (I/O) VALUE OF V(PREDUC) ON SAVED STEP.
C V(PREDUC) (I/O) FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR
C             CURRENT STEP.
C V(RADFAC) (OUT) FACTOR TO BE USED IN DETERMINING THE NEW RADIUS,
C             WHICH SHOULD BE V(RADFAC)*DST, WHERE  DST  IS EITHER THE
C             OUTPUT VALUE OF V(DSTNRM) OR THE 2-NORM OF
C             DIAG(NEWD)*STEP  FOR THE OUTPUT VALUE OF STEP AND THE
C             UPDATED VERSION, NEWD, OF THE SCALE VECTOR D.  FOR
C             IV(IRC) = 3, V(RADFAC) = 1.0 IS RETURNED.
C V(RDFCMN) (IN)  MINIMUM VALUE FOR V(RADFAC) IN TERMS OF THE INPUT
C             VALUE OF V(DSTNRM) -- SUGGESTED VALUE = 0.1.
C V(RDFCMX) (IN)  MAXIMUM VALUE FOR V(RADFAC) -- SUGGESTED VALUE = 4.0.
C  V(RELDX) (OUT) SCALED RELATIVE CHANGE IN X CAUSED BY STEP, COMPUTED
C             BY FUNCTION  RELDST  AS
C                 MAX (D(I)*ABS(X(I)-X0(I)), 1 .LE. I .LE. P) /
C                    MAX (D(I)*(ABS(X(I))+ABS(X0(I))), 1 .LE. I .LE. P).
C             IF AN ACCEPTABLE STEP IS RETURNED, THEN V(RELDX) IS COM-
C             PUTED USING THE OUTPUT (POSSIBLY RESTORED) VALUES OF X
C             AND STEP.  OTHERWISE IT IS COMPUTED USING THE INPUT
C             VALUES.
C V(RFCTOL) (IN)  RELATIVE FUNCTION CONVERGENCE TOLERANCE.  IF THE
C             ACTUAL FUNCTION REDUCTION IS AT MOST TWICE WHAT WAS PRE-
C             DICTED AND  V(NREDUC) .LE. V(RFCTOL)*ABS(V(F0)),  THEN
C             ASSESS RETURNS WITH IV(IRC) = 8 OR 9.  SEE ALSO V(LMAX0).
C V(STPPAR) (IN)  MARQUARDT PARAMETER -- 0 MEANS FULL NEWTON STEP.
C V(TUNER1) (IN)  TUNING CONSTANT USED TO DECIDE IF THE FUNCTION
C             REDUCTION WAS MUCH LESS THAN EXPECTED.  SUGGESTED
C             VALUE = 0.1.
C V(TUNER2) (IN)  TUNING CONSTANT USED TO DECIDE IF THE FUNCTION
C             REDUCTION WAS LARGE ENOUGH TO ACCEPT STEP.  SUGGESTED
C             VALUE = 10**-4.
C V(TUNER3) (IN)  TUNING CONSTANT USED TO DECIDE IF THE RADIUS
C             SHOULD BE INCREASED.  SUGGESTED VALUE = 0.75.
C  V(XCTOL) (IN)  X-CONVERGENCE CRITERION.  IF STEP IS A NEWTON STEP
C             (V(STPPAR) = 0) HAVING V(RELDX) .LE. V(XCTOL) AND GIVING
C             AT MOST TWICE THE PREDICTED FUNCTION DECREASE, THEN
C             ASSESS RETURNS IV(IRC) = 7 OR 9.
C  V(XFTOL) (IN)  FALSE CONVERGENCE TOLERANCE.  IF STEP GAVE NO OR ONLY
C             A SMALL FUNCTION DECREASE AND V(RELDX) .LE. V(XFTOL),
C             THEN ASSESS RETURNS WITH IV(IRC) = 12.
C
C-------------------------------  NOTES  -------------------------------
C
C  ***  APPLICATION AND USAGE RESTRICTIONS  ***
C
C        THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR
C     LEAST-SQUARES) PACKAGE.  IT MAY BE USED IN ANY UNCONSTRAINED
C     MINIMIZATION SOLVER THAT USES DOGLEG, GOLDFELD-QUANDT-TROTTER,
C     OR LEVENBERG-MARQUARDT STEPS.
C
C  ***  ALGORITHM NOTES  ***
C
C        SEE (1) FOR FURTHER DISCUSSION OF THE ASSESSING AND MODEL
C     SWITCHING STRATEGIES.  WHILE NL2SOL CONSIDERS ONLY TWO MODELS,
C     ASSESS IS DESIGNED TO HANDLE ANY NUMBER OF MODELS.
C
C  ***  USAGE NOTES  ***
C
C        ON THE FIRST CALL OF AN ITERATION, ONLY THE I/O VARIABLES
C     STEP, X, IV(IRC), IV(MODEL), V(F), V(DSTNRM), V(GTSTEP), AND
C     V(PREDUC) NEED HAVE BEEN INITIALIZED.  BETWEEN CALLS, NO I/O
C     VALUES EXECPT STEP, X, IV(MODEL), V(F) AND THE STOPPING TOLER-
C     ANCES SHOULD BE CHANGED.
C        AFTER A RETURN FOR CONVERGENCE OR FALSE CONVERGENCE, ONE CAN
C     CHANGE THE STOPPING TOLERANCES AND CALL ASSESS AGAIN, IN WHICH
C     CASE THE STOPPING TESTS WILL BE REPEATED.
C
C  ***  REFERENCES  ***
C
C     (1) DENNIS, J.E., JR., GAY, D.M., AND WELSCH, R.E. (1980),
C        AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM,
C        SUBMITTED TO ACM TRANS. MATH. SOFTWARE.
C
C     (2) POWELL, M.J.D. (1970)  A FORTRAN SUBROUTINE FOR SOLVING
C        SYSTEMS OF NONLINEAR ALGEBRAIC EQUATIONS, IN NUMERICAL
C        METHODS FOR NONLINEAR ALGEBRAIC EQUATIONS, EDITED BY
C        P. RABINOWITZ, GORDON AND BREACH, LONDON.
C
C  ***  HISTORY  ***
C
C        JOHN DENNIS DESIGNED MUCH OF THIS ROUTINE, STARTING WITH
C     IDEAS IN (2). ROY WELSCH SUGGESTED THE MODEL SWITCHING STRATEGY.
C        DAVID GAY AND STEPHEN PETERS CAST THIS SUBROUTINE INTO A MORE
C     PORTABLE FORM (WINTER 1977), AND DAVID GAY CAST IT INTO ITS
C     PRESENT FORM (FALL 1978).
C
C  ***  GENERAL  ***
C
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
C     MCS-7906671.
C
C------------------------  EXTERNAL QUANTITIES  ------------------------
C
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
C     EXTERNAL RELDST, VCOPY
C     DOUBLE PRECISION D1MACH, RELDST
C
C VCOPY.... COPIES ONE VECTOR TO ANOTHER.
C
C/
C  ***  NO COMMON BLOCKS  ***
C
C--------------------------  LOCAL VARIABLES  --------------------------
C
C     LOGICAL GOODX
C     INTEGER I, NFC
C     DOUBLE PRECISION EMAX, GTS, HALF, ONE, RELDX1, RFAC1,
C    +                 TEMP, TWO, XMAX, ZERO
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
C     INTEGER AFCTOL, DECFAC, DSTNRM, DSTSAV, DST0, F, FDIF, FLSTGD, F0,
C    1        GTSLST, GTSTEP, INCFAC, IRC, LMAX0, MLSTGD, MODEL, NFCALL,
C    2        NFGCAL, NREDUC, PLSTGD, PREDUC, RADFAC, RADINC, RDFCMN,
C    3        RDFCMX, RELDX, RESTOR, RFCTOL, STAGE, STGLIM, STPPAR,
C    4        SWITCH, TOOBIG, TUNER1, TUNER2, TUNER3, XCTOL, XFTOL,
C    5        XIRC
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C  ***  DATA INITIALIZATIONS  ***
C
      DATA HALF/0.5D0/, ONE/1.0D0/, TWO/2.0D0/, ZERO/0.0D0/
C
      DATA IRC/3/, MLSTGD/4/, MODEL/5/, NFCALL/6/,
     +     NFGCAL/7/, RADINC/8/, RESTOR/9/, STAGE/10/,
     +     STGLIM/11/, SWITCH/12/, TOOBIG/2/, XIRC/13/
      DATA AFCTOL/31/, DECFAC/22/, DSTNRM/2/, DST0/3/,
     +     DSTSAV/18/, F/10/, FDIF/11/, FLSTGD/12/, F0/13/,
     +     GTSLST/14/, GTSTEP/4/, INCFAC/23/,
     +     LMAX0/35/, NREDUC/6/, PLSTGD/15/, PREDUC/7/,
     +     RADFAC/16/, RDFCMN/24/, RDFCMX/25/,
     +     RELDX/17/, RFCTOL/32/, STPPAR/5/, TUNER1/26/,
     +     TUNER2/27/, TUNER3/28/, XCTOL/33/, XFTOL/34/
C
C+++++++++++++++++++++++++++++++  BODY  ++++++++++++++++++++++++++++++++
C
      NFC = IV(NFCALL)
      IV(SWITCH) = 0
      IV(RESTOR) = 0
      RFAC1 = ONE
      GOODX = .TRUE.
      I = IV(IRC)
      IF (I .GE. 1 .AND. I .LE. 12)
     +             GO TO (20,30,10,10,40,360,290,290,290,290,290,140), I
         IV(IRC) = 13
         GO TO 999
C
C  ***  INITIALIZE FOR NEW ITERATION  ***
C
 10   IV(STAGE) = 1
      IV(RADINC) = 0
      V(FLSTGD) = V(F0)
      IF (IV(TOOBIG) .EQ. 0) GO TO 90
         IV(STAGE) = -1
         IV(XIRC) = I
         GO TO 60
C
C  ***  STEP WAS RECOMPUTED WITH NEW MODEL OR SMALLER RADIUS  ***
C  ***  FIRST DECIDE WHICH  ***
C
 20   IF (IV(MODEL) .NE. IV(MLSTGD)) GO TO 30
C        ***  OLD MODEL RETAINED, SMALLER RADIUS TRIED  ***
C        ***  DO NOT CONSIDER ANY MORE NEW MODELS THIS ITERATION  ***
         IV(STAGE) = IV(STGLIM)
         IV(RADINC) = -1
         GO TO 90
C
C  ***  A NEW MODEL IS BEING TRIED.  DECIDE WHETHER TO KEEP IT.  ***
C
 30   IV(STAGE) = IV(STAGE) + 1
C
C     ***  NOW WE ADD THE POSSIBILTIY THAT STEP WAS RECOMPUTED WITH  ***
C     ***  THE SAME MODEL, PERHAPS BECAUSE OF AN OVERSIZED STEP.     ***
C
 40   IF (IV(STAGE) .GT. 0) GO TO 50
C
C        ***  STEP WAS RECOMPUTED BECAUSE IT WAS TOO BIG.  ***
C
         IF (IV(TOOBIG) .NE. 0) GO TO 60
C
C        ***  RESTORE IV(STAGE) AND PICK UP WHERE WE LEFT OFF.  ***
C
         IV(STAGE) = -IV(STAGE)
         I = IV(XIRC)
         GO TO (20, 30, 90, 90, 70), I
C
 50   IF (IV(TOOBIG) .EQ. 0) GO TO 70
C
C  ***  HANDLE OVERSIZE STEP  ***
C
      IF (IV(RADINC) .GT. 0) GO TO 80
         IV(STAGE) = -IV(STAGE)
         IV(XIRC) = IV(IRC)
C
 60      V(RADFAC) = V(DECFAC)
         IV(RADINC) = IV(RADINC) - 1
         IV(IRC) = 5
         GO TO 999
C
 70   IF (V(F) .LT. V(FLSTGD)) GO TO 90
C
C     *** THE NEW STEP IS A LOSER.  RESTORE OLD MODEL.  ***
C
      IF (IV(MODEL) .EQ. IV(MLSTGD)) GO TO 80
         IV(MODEL) = IV(MLSTGD)
         IV(SWITCH) = 1
C
C     ***  RESTORE STEP, ETC. ONLY IF A PREVIOUS STEP DECREASED V(F).
C
 80   IF (V(FLSTGD) .GE. V(F0)) GO TO 90
         IV(RESTOR) = 1
         V(F) = V(FLSTGD)
         V(PREDUC) = V(PLSTGD)
         V(GTSTEP) = V(GTSLST)
         IF (IV(SWITCH) .EQ. 0) RFAC1 = V(DSTNRM) / V(DSTSAV)
         V(DSTNRM) = V(DSTSAV)
         NFC = IV(NFGCAL)
         GOODX = .FALSE.
C
C
C  ***  COMPUTE RELATIVE CHANGE IN X BY CURRENT STEP  ***
C
 90   RELDX1 = RELDST(P, D, X, X0)
C
C  ***  RESTORE X AND STEP IF NECESSARY  ***
C
      IF (GOODX) GO TO 105
      DO 100 I = 1, P
         STEP(I) = STLSTG(I)
         X(I) = X0(I) + STLSTG(I)
 100     CONTINUE
C
 105  V(FDIF) = V(F0) - V(F)
      TEMP = 0.0
      IF (V(PREDUC).GT.D1MACH(1)/V(TUNER2)) TEMP = V(TUNER2) * V(PREDUC)
      IF (V(FDIF).GT.TEMP) GO TO 120
C
C        ***  NO (OR ONLY A TRIVIAL) FUNCTION DECREASE
C        ***  -- SO TRY NEW MODEL OR SMALLER RADIUS
C
         V(RELDX) = RELDX1
         IF (V(F) .LT. V(F0)) GO TO 110
              IV(MLSTGD) = IV(MODEL)
              V(FLSTGD) = V(F)
              V(F) = V(F0)
              CALL VCOPY(P, X, X0)
              IV(RESTOR) = 1
              GO TO 115
 110     IV(NFGCAL) = NFC
 115     IV(IRC) = 1
         IF (IV(STAGE) .LT. IV(STGLIM)) GO TO 130
              IV(IRC) = 5
              IV(RADINC) = IV(RADINC) - 1
              GO TO 130
C
C  ***  NONTRIVIAL FUNCTION DECREASE ACHIEVED  ***
C
 120  IV(NFGCAL) = NFC
      RFAC1 = ONE
      IF (GOODX) V(RELDX) = RELDX1
      V(DSTSAV) = V(DSTNRM)
      IF (V(FDIF) .GT. V(PREDUC)*V(TUNER1)) GO TO 200
C
C  ***  DECREASE WAS MUCH LESS THAN PREDICTED -- EITHER CHANGE MODELS
C  ***  OR ACCEPT STEP WITH DECREASED RADIUS.
C
      IF (IV(STAGE) .GE. IV(STGLIM)) GO TO 125
C        ***  CONSIDER SWITCHING MODELS  ***
         IV(IRC) = 2
         GO TO 130
C
C     ***  ACCEPT STEP WITH DECREASED RADIUS  ***
C
 125  IV(IRC) = 4
C
C  ***  SET V(RADFAC) TO FLETCHER*S DECREASE FACTOR  ***
C
 130  IV(XIRC) = IV(IRC)
      EMAX = V(GTSTEP) + V(FDIF)
      V(RADFAC) = HALF * RFAC1
      IF (EMAX .LT. V(GTSTEP)) V(RADFAC) = RFAC1 * MAX(V(RDFCMN),
     +                                           HALF * V(GTSTEP)/EMAX)
C
C  ***  DO FALSE CONVERGENCE TEST  ***
C
 140  IF (V(RELDX) .LE. V(XFTOL)) GO TO 160
         IV(IRC) = IV(XIRC)
         IF (V(F) .LT. V(F0)) GO TO 230
              GO TO 300
C
 160  IV(IRC) = 12
      GO TO 310
C
C  ***  HANDLE GOOD FUNCTION DECREASE  ***
C
 200  IF (V(FDIF) .LT. (-V(TUNER3) * V(GTSTEP))) GO TO 260
C
C     ***  INCREASING RADIUS LOOKS WORTHWHILE.  SEE IF WE JUST
C     ***  RECOMPUTED STEP WITH A DECREASED RADIUS OR RESTORED STEP
C     ***  AFTER RECOMPUTING IT WITH A LARGER RADIUS.
C
      IF (IV(RADINC) .LT. 0) GO TO 260
      IF (IV(RESTOR) .EQ. 1) GO TO 260
C
C        ***  WE DID NOT.  TRY A LONGER STEP UNLESS THIS WAS A NEWTON
C        ***  STEP.
C
         V(RADFAC) = V(RDFCMX)
         GTS = V(GTSTEP)
         IF (V(FDIF) .LT. (HALF/V(RADFAC) - ONE) * GTS)
     +            V(RADFAC) = MAX(V(INCFAC), HALF*GTS/(GTS + V(FDIF)))
         IV(IRC) = 4
         IF (V(STPPAR) .EQ. ZERO) GO TO 300
C             ***  STEP WAS NOT A NEWTON STEP.  RECOMPUTE IT WITH
C             ***  A LARGER RADIUS.
              IV(IRC) = 5
              IV(RADINC) = IV(RADINC) + 1
C
C  ***  SAVE VALUES CORRESPONDING TO GOOD STEP  ***
C
 230  V(FLSTGD) = V(F)
      IV(MLSTGD) = IV(MODEL)
      CALL VCOPY(P, STLSTG, STEP)
      V(DSTSAV) = V(DSTNRM)
      IV(NFGCAL) = NFC
      V(PLSTGD) = V(PREDUC)
      V(GTSLST) = V(GTSTEP)
      GO TO 300
C
C  ***  ACCEPT STEP WITH RADIUS UNCHANGED  ***
C
 260  V(RADFAC) = ONE
      IV(IRC) = 3
      GO TO 300
C
C  ***  COME HERE FOR A RESTART AFTER CONVERGENCE  ***
C
 290  IV(IRC) = IV(XIRC)
      IF (V(DSTSAV) .GE. ZERO) GO TO 310
         IV(IRC) = 12
         GO TO 310
C
C  ***  PERFORM CONVERGENCE TESTS  ***
C
 300  IV(XIRC) = IV(IRC)
 310  IF (ABS(V(F)) .LT. V(AFCTOL)) IV(IRC) = 10
      IF (HALF * V(FDIF) .GT. V(PREDUC)) GO TO 999
      EMAX = 0.0
      IF (ABS(V(F0)).GT.D1MACH(1)/V(RFCTOL))
     +   EMAX = V(RFCTOL) * ABS(V(F0))
      IF (V(DSTNRM) .GT. V(LMAX0) .AND. V(PREDUC) .LE. EMAX)
     +                       IV(IRC) = 11
      IF (V(DST0) .LT. ZERO) GO TO 320
      I = 0
      IF ((V(NREDUC) .GT. ZERO .AND. V(NREDUC) .LE. EMAX) .OR.
     +    (V(NREDUC) .EQ. ZERO. AND. V(PREDUC) .EQ. ZERO))  I = 2
      IF (V(STPPAR) .EQ. ZERO .AND. V(RELDX) .LE. V(XCTOL)) I = I + 1
      IF (I .GT. 0) IV(IRC) = I + 6
C
C  ***  CONSIDER RECOMPUTING STEP OF LENGTH V(LMAX0) FOR SINGULAR
C  ***  CONVERGENCE TEST.
C
 320  IF (ABS(IV(IRC)-3) .GT. 1 .AND. IV(IRC) .NE. 12) GO TO 999
      IF (V(DSTNRM) .GT. V(LMAX0)) GO TO 330
         IF (V(PREDUC) .GE. EMAX) GO TO 999
              IF (V(DST0) .LT. ZERO) GO TO 340
                   IF (HALF * V(DST0) .LE. V(LMAX0)) GO TO 999
                        GO TO 340
 330  IF (HALF * V(DSTNRM) .LE. V(LMAX0)) GO TO 999
      XMAX = V(LMAX0) / V(DSTNRM)
      IF (XMAX * (TWO - XMAX) * V(PREDUC) .GE. EMAX) GO TO 999
 340  IF (V(NREDUC) .LT. ZERO) GO TO 370
C
C  ***  RECOMPUTE V(PREDUC) FOR USE IN SINGULAR CONVERGENCE TEST  ***
C
      V(GTSLST) = V(GTSTEP)
      V(DSTSAV) = V(DSTNRM)
      IF (IV(IRC) .EQ. 12) V(DSTSAV) = -V(DSTSAV)
      V(PLSTGD) = V(PREDUC)
      IV(IRC) = 6
      CALL VCOPY(P, STLSTG, STEP)
      GO TO 999
C
C  ***  PERFORM SINGULAR CONVERGENCE TEST WITH RECOMPUTED V(PREDUC)  ***
C
 360  V(GTSTEP) = V(GTSLST)
      V(DSTNRM) = ABS(V(DSTSAV))
      CALL VCOPY(P, STEP, STLSTG)
      IV(IRC) = IV(XIRC)
      IF (V(DSTSAV) .LE. ZERO) IV(IRC) = 12
      V(NREDUC) = -V(PREDUC)
      V(PREDUC) = V(PLSTGD)
 370  IF (-V(NREDUC) .LE. V(RFCTOL) * ABS(V(F0))) IV(IRC) = 11
C
 999  RETURN
C
C  ***  LAST CARD OF ASSESS FOLLOWS  ***
      END
*ERIODD
      SUBROUTINE ERIODD(NMSUB, NMVAR, NVAL, MSGTYP, HEAD, ERROR)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE SETS ERROR TO TRUE IF THE VALUE   NVAL   IS NOT EVEN
C     OR ODD, AS SPECIFIED BY THE PARAMETER ODD.  IN ADDITION, IF THIS
C     IS THE FIRST ERROR FOUND FOR THE CALLING SUBROUTINE   NMSUB   , IE
C     IF   HEAD   IS TRUE, THEN A HEADING FOR THE CALLING SUBROUTINE
C     IS ALSO PRINTED OUT.
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  NOVEMBER 26, 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   MSGTYP,NVAL
      LOGICAL
     +   ERROR,HEAD
C
C  ARRAY ARGUMENTS
      CHARACTER
     +   NMSUB(6)*1,NMVAR(8)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MOD
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERROR
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     LOGICAL HEAD
C        A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED
C        (TRUE) OR NOT (FALSE).  IF A HEADING IS PRINTED, THE VALUE
C        OF HEAD WILL BE CHANGED TO FALSE.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER MSGTYP
C        A VARIABLE USED TO INDICATE THE TYPE OF MESSAGE TO BE
C        PRINTED, WHERE IF
C        MSGTYP = 1, THE INPUT VALUE SHOULD BE ODD AND
C        MSGTYP = 2, THE INPUT VALUE SHOULD BE EVEN.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THE CALLING SUBROUTINE.
C     CHARACTER*1 NMVAR(8)
C        THE ARRAY CONTAINING THE NAME OF THE VARIABLE BEING CHECKED.
C     INTEGER NVAL
C        THE VALUE OF THE VARIABLE BEING CHECKED.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      ERROR = .FALSE.
C
      IF (MSGTYP .EQ. 2) GO TO 10
C
C     CHECK FOR ODD
C
      IF (MOD(NVAL, 2) .EQ. 1) RETURN
C
CCCCC CALL IPRINT(IPRT)
      CALL EHDR(NMSUB, HEAD)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
C
      WRITE(ICOUT,1010) (NMVAR(I),I =1,6), (NMVAR(I), I = 1, 6)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1011) NVAL
      CALL DPWRST('XXX','BUG ')
      ERROR = .TRUE.
      RETURN
C
   10 CONTINUE
C
C     CHECK FOR EVEN
C
      IF (MOD(NVAL, 2) .EQ. 0) RETURN
C
      CALL EHDR(NMSUB, HEAD)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1020) (NMVAR(I),I=1,6), (NMVAR(I), I = 1, 6)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1021) NVAL
      CALL DPWRST('XXX','BUG ')
      ERROR = .TRUE.
      RETURN
C
C     FORMAT STATEMENTS
C
  999 FORMAT(1X)
 1010 FORMAT(
     +   ' THE VALUE OF THE VARIABLE ', 6A1,
     +   ' MUST BE ODD.  THE INPUT VALUE OF ', 6A1)
 1011 FORMAT(
     +    ' IS ', I5, '.')
 1020 FORMAT(
     +   ' THE VALUE OF THE VARIABLE ', 6A1,
     +   ' MUST BE EVEN.  THE INPUT VALUE OF ', 6A1)
 1021 FORMAT(
     +    ' IS ', I5, '.')
C
      END
*INPERL
      INTEGER FUNCTION INPERL (IDUM)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE NUMBER OF VECTOR ELEMENTS THAT CAN
C     BE PRINTED IN A LINE OF OUTPUT ON THE STANDARD OUTPUT FILE.
C
C     ASSUMPTIONS RE -
C
C        1) MAXIMUM WIDTH OF LINE TO USE (IMAXW) IS 132.
C        2) NUMBER OF CHARACTERS NOT VECTOR ELEMENTS PER LINE
C                (IOCPL) IS 15.
C        2) WIDTH OF FIELD FOR AN ELEMENT, INCLUDING SPACING
C                BETWEEN ELEMENTS (IEW) IS 15.
C        4) MAXIMUM ELEMENTS PER LINE (IMAXE) IS 7.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 29, 1982
C                       EXTRACTED FROM EARLIER LSTVEC.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IDUM
C
C  LOCAL SCALARS
      INTEGER
     +   IEW,IMAXE,IMAXW,IOCPL,IWIDTH
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IDUM
C        INPUT PARAMETER.  UNUSED ARGUMENT.
C     INTEGER IEW
C        WIDTH OF A FIELD FOR PRINTING OUT A VECTOR ELEMENT,
C        INCLUDING SPACES BETWEEN ADJACENT ELEMENTS.
C     INTEGER IMAXE
C        MAXIMUM NUMBER OF ARRAY ELEMENTS PER LINE.
C     INTEGER IMAXW
C        MAXIMUM NUMBER OF CHARACTERS TO ALLOW PER LINE.
C     INTEGER IOCPL
C        NUMBER OF CHARACTERS TO BE INTRODUCED TO LINE IN ADDITION
C        TO CHARACTERS IN THE ELEMENT FIELDS.
C     INTEGER IWIDTH
C        NUMBER OF CHARACTERS IN A LINE ON THE STANDARD OUTPUT FILE.
C
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     INITIALIZATIONS
C
CCCCC DATA IEW /15/, IMAXE /7/, IMAXW /132/, IOCPL /15/
      DATA IEW /15/, IMAXE /7/, IMAXW /80/, IOCPL /15/
C
C     COMMENCE BODY OF ROUTINE
C
CCCCC IWIDTH = 132
      IWIDTH = 80
      INPERL = (MIN(IWIDTH, IMAXW) - IOCPL)/IEW
      INPERL = MIN(INPERL, IMAXE)
      RETURN
      END
*MDLTS2
      SUBROUTINE MDLTS2 (PAR, RESTS, Y, NPAR, N, NFAC, MSPECT, PMU,
     +  PARDF, NPARDF, T, TEMP, PARAR, PARMA, MBO, N1, N2, IFLAG)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE MODEL ROUTINE FOR PACKS SPECIFICATION OF
C     BOX-JENKINS MODELS.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 4, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   PMU
      INTEGER
     +   IFLAG,MBO,N,N1,N2,NFAC,NPAR,NPARDF
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   PAR(NPAR),PARAR(*),PARDF(*),PARMA(*),RESTS(N1:N2),T(*),
     +   TEMP(*),Y(N)
      INTEGER
     +   MSPECT(NFAC,4)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   FPLPM,RESMAX,WTEST
      INTEGER
     +   I,IMOD,IMOD1,IPAR,IPQ,ISTART,J,K,L,MAXORD,MBO1,NP,NPARAR,
     +   NPARMA
      LOGICAL
     +   PARLE1
C
C  EXTERNAL FUNCTIONS
CCCCC DOUBLE PRECISION
CCCCC+   D1MACH
CCCCC EXTERNAL D1MACH
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,LOG,MOD,SIGN,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION FPLPM
C        THE FLOATING POINT LARGEST POSITIVE MAGNITUDE.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IFLAG
C        AN INDICATOR VARIABLE DESIGNATING WHETHER THE BACK FORECASTS
C        WERE ESSENTIALLY ZERO (IFLAG=0) OR NOT (IFLAG=1).
C     INTEGER IMOD
C        AN INDEX VARIABLE.
C     INTEGER IPAR
C        AN INDEX VARIABLE.
C     INTEGER IPQ
C        AN INDEX VARIABLE.
C     INTEGER ISTART
C        ***
C     INTEGER J
C        AN INDEX VARIABLE.
C     INTEGER K
C        AN INDEX VARIABLE.
C     INTEGER L
C        AN INDEX VARIABLE.
C     INTEGER MAXORD
C        THE LARGEST BACK ORDER.
C     INTEGER MBO
C        THE MAXIMUM BACK ORDER OPERATOR.
C     INTEGER MBO1
C        THE VALUE MBO+1
C     INTEGER MSPECT(NFAC,4)
C        THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NFAC
C        THE NUMBER OF FACTORS IN THE MODEL
C     INTEGER NP
C        THE NUMBER OF PARAMETERS IN THE EXPANDED TERM.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     INTEGER NPARAR
C        THE NUMBER OF AUTOREGRESSIVE PARAMETERS
C     INTEGER NPARDF
C        THE ORDER OF THE EXPANDED DIFFERENCE FILTER.
C     INTEGER NPARMA
C        THE LENGTH OF THE VECTOR PARMA
C     INTEGER N1
C        THE LOWER BOUND FOR RESTS.
C     INTEGER N2
C        THE UPPER BOUND FOR RESTS.
C     DOUBLE PRECISION PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     DOUBLE PRECISION PARAR(MBO)
C        THE AUTOREGRESSIVE PARAMETERS
C     DOUBLE PRECISION PARDF(NPARDF)
C        THE VECTOR CONTAINING THE DIFFERENCE FILTER PARAMETERS.
C     LOGICAL PARLE1
C        A FLAG INDICATING WHETHER ALL OF THE MOVING AVERAGE PARAMETERS
C        ARE LESS THAN OR EQUAL TO 1 (PARLE1 = .TRUE.) OR NOT
C        (PARLE1 = .FALSE.)
C     DOUBLE PRECISION PARMA(MBO)
C        THE MOVING AVERAGE PARAMETERS
C     DOUBLE PRECISION PMU
C        THE VALUE OF MU, I.E., THE TREND OR MEAN.
C     DOUBLE PRECISION RESMAX
C        THE LARGEST POSSIBLE RESIDUAL WHICH WILL STILL AVOID OVERFLOW.
C     DOUBLE PRECISION RESTS(N1:N2)
C        THE PREDICTED VALUE OF THE FIT.
C     DOUBLE PRECISION T(2*MBO)
C        A TEMPORARY WORK VECTOR.
C     DOUBLE PRECISION TEMP(MBO)
C        A TEMPORARY WORK VECTOR
C     DOUBLE PRECISION WTEST
C        THE TEST VALUE USED TO DETERMINE IF THE DIFFERENCED SERIES
C        BACK FORECAST IS EFFECTIVELY ZERO OR NOT.
C     DOUBLE PRECISION Y(N)
C        THE DEPENDENT VARIABLE.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      FPLPM = D1MACH(2)
C
C     ZERO THE PARAMETER ARRAYS PARAR AND PARMA
C
      DO 10 I=1,MBO
         T(I) = 0.0D0
         TEMP(I) = 0.0D0
   10 CONTINUE
C
      NP = 0
      IPAR = 0
      NPARAR = 0
      ISTART = 0
C
C     EXPAND THE MODEL AND STORE AUTOREGRESSIVE PARAMETERS IN PARAR
C     AND MOVING AVERAGE PARAMETERS IN PARMA
C
      DO 110 IPQ = 1, 3, 2
         DO 100 L=1,NFAC
            IF (MSPECT(L,IPQ).EQ.0) GO TO 100
            MAXORD = MSPECT(L,IPQ)*MSPECT(L,4)
            DO 90 K = MSPECT(L,4), MAXORD, MSPECT(L,4)
               IPAR = IPAR + 1
               TEMP(K) = TEMP(K) + PAR(IPAR)
               DO 80 I = 1, NP
                  TEMP(K+I) = TEMP(K+I) - T(I)*PAR(IPAR)
   80          CONTINUE
   90       CONTINUE
            NP = NP + MAXORD
            DO 95 K = 1, NP
               T(K) = TEMP(K)
   95       CONTINUE
  100    CONTINUE
          IF (IPQ.NE.3) THEN
            IPAR = IPAR + 1
            PMU = PAR(IPAR)
            NPARAR = NP
            DO 105 K =1, NPARAR
               PARAR(K) = T(K)
               T(K) = 0.0D0
               TEMP(K) = 0.0D0
  105       CONTINUE
            NP = 0
         END IF
  110 CONTINUE
      NPARMA = NP
      PARLE1 = .TRUE.
      DO 115 K =1, NPARMA
         PARMA(K) = T(K)
         IF (ABS(PARMA(K)).GT.1.0D0) PARLE1 = .FALSE.
  115 CONTINUE
C
C     COMPUTE FITTED VALUES AND RESIDUALS FOR MODEL.
C
C     COMPUTE W, THE DIFFERENCED SERIES MINUS ITS MEAN, AND STORE IN
C     RESTS(NPARDF+1) TO RESTS(N2)
C
      DO 140 I = NPARDF+1, N2, 1
         RESTS(I) = Y(I) - PMU
         DO 130 J = 1,NPARDF
            RESTS(I) = RESTS(I) - PARDF(J)*Y(I-J)
  130    CONTINUE
  140 CONTINUE
      WTEST = ABS(RESTS(NPARDF+1))*0.01
C
C     BACK FORECAST THE ERROR, E, FOR I = N-NPARAR TO NPARDF+1, AND
C     THE DIFFERENCED SERIES FOR I = NPARDF TO N1
C
      MBO1 = MBO+1
      IFLAG = 0
      DO 170 I = N2-NPARAR,NPARDF+1,-1
         IMOD = MOD(I+1-N1,MBO1) + 1
         T(IMOD) = RESTS(I)
         DO 150 J = 1,NPARAR
            T(IMOD) = T(IMOD) - PARAR(J)*RESTS(I+J)
  150    CONTINUE
         DO 160 J = 1,NPARMA
            IF ((I+J.GT.NPARDF) .AND. (I+J.LE.N))
     +         T(IMOD) = T(IMOD) + PARMA(J)*T(MOD(I+J+1-N1,MBO1)+1)
  160    CONTINUE
  170 CONTINUE
      DO 175 I = NPARDF,N1,-1
         IMOD = MOD(I+1-N1,MBO1) + 1
         RESTS(I) = 0.0D0
         DO 163 J = 1,NPARAR
            RESTS(I) = RESTS(I) + PARAR(J)*RESTS(I+J)
  163    CONTINUE
         DO 166 J = 1,NPARMA
            IF ((I+J.GT.NPARDF) .AND. (I+J.LE.N))
     +         RESTS(I) = RESTS(I) -
     +                    PARMA(J)*T(MOD(I+J+1-N1,MBO1)+1)
  166    CONTINUE
         ISTART = I
         IF ((ISTART.LE.1) .AND. (ABS(RESTS(I)).LE.WTEST)) GO TO 180
  175 CONTINUE
      IFLAG = 1
C
C     COMPUTE RESIDUALS AND STORE VALUES IN RESTS
C
  180 CONTINUE
      DO 210 I = ISTART,N2,1
         IMOD = MOD(I+1-N1,MBO1) + 1
         T(IMOD) = RESTS(I)
         DO 190 J = 1,NPARAR
            IF (I-J.GE.ISTART) T(IMOD) = T(IMOD) - PARAR(J)*RESTS(I-J)
  190    CONTINUE
C
         IF (PARLE1) THEN
C
C     COMPUTE RESIDUALS WHERE THERE IS NO CHANCE OF OVERFLOW
C
            DO 200 J = 1,NPARMA
               IF (I-J.GE.ISTART)
     +            T(IMOD) = T(IMOD) + PARMA(J)*T(MOD(I-J+1-N1,MBO1)+1)
  200       CONTINUE
         ELSE
C
C     COMPUTE RESIDUALS WHERE THERE IS A CHANCE OF OVERFLOW
C
            DO 205 J = 1,NPARMA
               IF (I-J.GE.ISTART) THEN
                  IMOD1 = MOD(I-J+1-N1,MBO1)+1
                  IF (PARMA(J).NE.0.0D0 .AND. T(IMOD1).NE.0.0D0) THEN
                     IF (LOG(ABS(PARMA(J)))+LOG(ABS(T(IMOD1))).LT.
     +                         LOG(FPLPM)
     +                     .AND.
     +                     (SIGN(1.0D0,T(IMOD)).NE.
     +                         SIGN(1.0D0,PARMA(J)*T(IMOD1))
     +                     .OR.
     +                     LOG(ABS(PARMA(J)))+LOG(ABS(T(IMOD1))).LT.
     +                         LOG(FPLPM-ABS(T(IMOD))))) THEN
                        T(IMOD) = T(IMOD) + PARMA(J)*T(IMOD1)
                     ELSE
                        GO TO 300
                     END IF
                  END IF
               END IF
  205       CONTINUE
         END IF
         IF (I-MBO.GE.ISTART) THEN
            RESTS(I-MBO) = T(MOD(I-MBO+1-N1,MBO1)+1)
         END IF
  210 CONTINUE
      DO 220 I = N-MBO+1,N
        RESTS(I) = T(MOD(I-MBO+2-N1,MBO1)+1)
  220 CONTINUE
C
      DO 230 I = N1, ISTART-1
         RESTS(I) = 0.0D0
  230 CONTINUE
C
      RETURN
C
C     SET RESIDUALS TO LARGEST POSSIBLE VALUE
C
  300 RESMAX = SQRT(FPLPM/(N2-N1+1))
      DO 310 I=N1,N2
         RESTS(I) = RESMAX
  310 CONTINUE
C
      RETURN
C
      END
*PPFT
      DOUBLE PRECISION FUNCTION PPFT(P, IDF)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS FUNCTION IS A VERSION OF DATAPAC SUBROUTINE
C     TPPF, WITH MODIFICATIONS TO FACILITATE CONVERSION TO
C     DOUBLE PRECISION AUTOMATICALLY USING THE NAG, INC. CODE APT,
C     AND TO CORRESPOND TO STARPAC CONVENTIONS.
C
C     PURPOSE--THIS SUBROUTINE COMPUTES THE PERCENT POINT
C              FUNCTION VALUE FOR THE STUDENT"S T DISTRIBUTION
C              WITH INTEGER DEGREES OF FREEDOM PARAMETER = IDF.
C              THE STUDENT"S T DISTRIBUTION USED
C              HEREIN IS DEFINED FOR ALL X,
C              AND ITS PROBABILITY DENSITY FUNCTION IS GIVEN
C              IN THE REFERENCES BELOW.
C              NOTE THAT THE PERCENT POINT FUNCTION OF A DISTRIBUTION
C              IS IDENTICALLY THE SAME AS THE INVERSE CUMULATIVE
C              DISTRIBUTION FUNCTION OF THE DISTRIBUTION.
C     ERROR CHECKING--NONE
C     RESTRICTIONS--IDF SHOULD BE A POSITIVE INTEGER VARIABLE.
C                 --P SHOULD BE BETWEEN 0.0D0 (EXCLUSIVELY)
C                   AND 1.0D0 (EXCLUSIVELY).
C     COMMENT--FOR IDF = 1 AND IDF = 2, THE PERCENT POINT FUNCTION
C              FOR THE T DISTRIBUTION EXISTS IN SIMPLE CLOSED FORM
C              AND SO THE COMPUTED PERCENT POINTS ARE EXACT.
C            --FOR OTHER SMALL VALUES OF IDF (IDF BETWEEN 3 AND 6,
C              INCLUSIVELY), THE APPROXIMATION
C              OF THE T PERCENT POINT BY THE FORMULA
C              GIVEN IN THE REFERENCE BELOW IS AUGMENTED
C              BY 3 ITERATIONS OF NEWTON"S METHOD FOR
C              ROOT DETERMINATION.
C              THIS IMPROVES THE ACCURACY--ESPECIALLY FOR
C              VALUES OF P NEAR 0 OR 1.
C     REFERENCES--NATIONAL BUREAU OF STANDARDS APPLIED MATHMATICS
C                 SERIES 55, 1964, PAGE 949, FORMULA 26.7.5.
C               --JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE
C                 DISTRIBUTIONS--2, 1970, PAGE 102,
C                 FORMULA 11.
C               --FEDERIGHI, "EXTENDED TABLES OF THE
C                 PERCENTAGE POINTS OF STUDENT"S T
C                 DISTRIBUTION, JOURNAL OF THE
C                 AMERICAN STATISTICAL ASSOCIATION,
C                 1969, PAGES 683-688.
C               --HASTINGS AND PEACOCK, STATISTICAL
C                 DISTRIBUTIONS--A HANDBOOK FOR
C                 STUDENTS AND PRACTITIONERS, 1975,
C                 PAGES 120-123.
C     WRITTEN BY--JAMES J. FILLIBEN
C                 STATISTICAL ENGINEERING DIVISION
C                 NATIONAL BUREAU OF STANDARDS
C                 WASHINGTON, D. C. 20234
C     ORIGINAL VERSION--OCTOBER   1975.
C     UPDATED         --NOVEMBER  1975.
C
C     MODIFIED BY     --JANET R. DONALDSON, DECEMBER 7, 1981
C                       STATISTICAL ENGINEERING DIVISION
C                       NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   P
      INTEGER
     +   IDF
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   ARG,B21,B31,B32,B33,B34,B41,B42,B43,B44,B45,
     +   B51,B52,B53,B54,B55,B56,C,CON,D1,D3,D5,D7,D9,DF,PI,PPFN,
     +   S,SQRT2,TERM1,TERM2,TERM3,TERM4,TERM5,Z
      INTEGER
     +   IPASS,MAXIT
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   PPFNML
      EXTERNAL PPFNML
C
C  EXTERNAL SUBROUTINES
      EXTERNAL GETPI
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ATAN,COS,SIN,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION ARG
C        *
C     DOUBLE PRECISION B21
C        *
C     DOUBLE PRECISION B31, B32, B33, B34
C        *
C     DOUBLE PRECISION B41, B42, B43, B44, B45
C        *
C     DOUBLE PRECISION B51, B52, B53, B54, B55, B56
C        *
C     DOUBLE PRECISION C, CON
C        *
C     DOUBLE PRECISION DF
C        THE DEGREES OF FREEDOM.
C     DOUBLE PRECISION D1, D3, D5, D7, D9
C        *
C     INTEGER IDF
C        THE (INTEGER) DEGREES OF FREEDOM.
C     INTEGER IPASS
C        *
C     INTEGER MAXIT
C        *
C     DOUBLE PRECISION P
C        THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE EVALUATED.
C     DOUBLE PRECISION PI
C        THE VALUE OF PI.
C     DOUBLE PRECISION PPFN
C        THE NORMAL PERCENT POINT VALUE.
C     DOUBLE PRECISION S
C        *
C     DOUBLE PRECISION SQRT2
C        THE SQUARE ROOT OF TWO.
C        *
C     DOUBLE PRECISION TERM1, TERM2, TERM3, TERM4, TERM5
C        *
C     DOUBLE PRECISION Z
C        *
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     DEFINE CONSTANTS USED IN THE APPROXIMATIONS
C
      DATA B21 /4.0D0/
      DATA B31, B32, B33, B34 /96.0D0, 5.0D0, 16.0D0, 3.0D0/
      DATA B41, B42, B43, B44, B45
     +  /384.0D0, 3.0D0, 19.0D0, 17.0D0, -15.0D0/
      DATA B51, B52, B53, B54, B55, B56
     +   /9216.0D0, 79.0D0, 776.0D0, 1482.0D0,
     +   -1920.0D0, -945.0D0/
C
      CALL GETPI(PI)
C
      SQRT2 = SQRT(2.0D0)
C
      DF = IDF
      MAXIT = 5
C
      IF (IDF.GE.3) GO TO 50
      IF (IDF.EQ.1) GO TO 30
      IF (IDF.EQ.2) GO TO 40
      PPFT = 0.0D0
      RETURN
C
C     TREAT THE IDF = 1 (CAUCHY) CASE
C
   30 ARG = PI*P
      PPFT = -COS(ARG)/SIN(ARG)
      RETURN
C
C     TREAT THE IDF = 2 CASE
C
   40 TERM1 = SQRT2/2.0D0
      TERM2 = 2.0D0*P - 1.0D0
      TERM3 = SQRT(P*(1.0D0-P))
      PPFT = TERM1*TERM2/TERM3
      RETURN
C
C     TREAT THE IDF GREATER THAN OR EQUAL TO 3 CASE
C
   50 PPFN = PPFNML(P)
      D1 = PPFN
      D3 = PPFN**3
      D5 = PPFN**5
      D7 = PPFN**7
      D9 = PPFN**9
      TERM1 = D1
      TERM2 = (1.0D0/B21)*(D3+D1)/DF
      TERM3 = (1.0D0/B31)*(B32*D5+B33*D3+B34*D1)/(DF**2)
      TERM4 = (1.0D0/B41)*(B42*D7+B43*D5+B44*D3+B45*D1)/(DF**3)
      TERM5 = (1.0D0/B51)*(B52*D9+B53*D7+B54*D5+B55*D3+B56*D1)/(DF**4)
      PPFT = TERM1 + TERM2 + TERM3 + TERM4 + TERM5
      IF (IDF.GE.7) RETURN
      IF (IDF.EQ.3) GO TO 60
      IF (IDF.EQ.4) GO TO 80
      IF (IDF.EQ.5) GO TO 100
      IF (IDF.EQ.6) GO TO 120
      RETURN
C
C     AUGMENT THE RESULTS FOR THE IDF = 3 CASE
C
   60 CON = PI*(P-0.5D0)
      ARG = PPFT/SQRT(DF)
      Z = ATAN(ARG)
      DO 70 IPASS=1,MAXIT
         S = SIN(Z)
         C = COS(Z)
         Z = Z - (Z+S*C-CON)/(2.0D0*C*C)
   70 CONTINUE
      PPFT = SQRT(DF)*S/C
      RETURN
C
C     AUGMENT THE RESULTS FOR THE IDF = 4 CASE
C
   80 CON = 2.0D0*(P-0.5D0)
      ARG = PPFT/SQRT(DF)
      Z = ATAN(ARG)
      DO 90 IPASS=1,MAXIT
         S = SIN(Z)
         C = COS(Z)
         Z = Z - ((1.0D0+0.5D0*C*C)*S-CON)/(1.5D0*C*C*C)
   90 CONTINUE
      PPFT = SQRT(DF)*S/C
      RETURN
C
C     AUGMENT THE RESULTS FOR THE IDF = 5 CASE
C
  100 CON = PI*(P-0.5D0)
      ARG = PPFT/SQRT(DF)
      Z = ATAN(ARG)
      DO 110 IPASS=1,MAXIT
         S = SIN(Z)
         C = COS(Z)
         Z = Z - (Z+(C+(2.0D0/3.0D0)*C*C*C)*S-CON)/((8.0D0/3.0D0)*C**4)
  110 CONTINUE
      PPFT = SQRT(DF)*S/C
      RETURN
C
C     AUGMENT THE RESULTS FOR THE IDF = 6 CASE
C
  120 CON = 2.0D0*(P-0.5D0)
      ARG = PPFT/SQRT(DF)
      Z = ATAN(ARG)
      DO 130 IPASS=1,MAXIT
         S = SIN(Z)
         C = COS(Z)
         Z = Z - ((1.0D0+0.5D0*C*C+0.375D0*C**4)*S-CON)/
     +           ((15.0D0/8.0D0)*C**5)
  130 CONTINUE
      PPFT = SQRT(DF)*S/C
      RETURN
C
      END
*STKST
      INTEGER FUNCTION STKST (NFACT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE REPLACES INTEGER FUNCTION ISTKST IN THE FRAMEWORK
C     FOR USE WITH STARPAC.  RETURNS ONE OF FOUR STATISTICS ON THE
C     STATE OF THE CSTAK STACK.
C
C     IMPORTANT - THIS ROUTINE ASSUMES THAT THE STACK IS INITIALIZED.
C                 IT DOES NOT CHECK TO SEE IF IT IS.  IN FACT, THERE
C                 IS NO WAY THAT IT COULD CHECK.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 14, 1983
C        BASED ON FRAMEWORK ROUTINE ISTKST.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   NFACT
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
C
C  LOCAL ARRAYS
      INTEGER
     +   ISTAK(12),ISTATS(4)
C
C  EXTERNAL SUBROUTINES
CCCCC EXTERNAL IPRINT
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),ISTAK(1))
      EQUIVALENCE (ISTAK(1),ISTATS(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER IPRT
C        THE NUMBER OF THE STANDARD OUTPUT UNIT.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ISTATS(4)
C        INTEGER ARRAY INCLUDING THE FOUR STACK STATISTICS.
C     INTEGER NFACT
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
C     COMMENCE BODY OF ROUTINE
C
      IF (NFACT .GT. 0 .AND. NFACT .LT. 6) GO TO 10
C
C     REPORT ERROR STATUS
C
CCCCC CALL IPRINT (IPRT)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
C
      WRITE (ICOUT, 1000)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1001) I1MACH(2)
      CALL DPWRST('XXX','BUG ')
      STKST = 0
      RETURN
C
C     REPORT TRUE VALUE OF A STATISTIC, ASSUMING STACK IS
C     DEFINED.
C
   10 STKST = ISTATS(NFACT)
      RETURN
C
C     FORMAT STATEMENTS
C
  999 FORMAT(1X)
 1000 FORMAT (' ***** ERROR *****')
 1001 FORMAT (' ILLEGAL STACK STATISTIC', I5, ' REQUESTED.')
      END
*AMEDRV
      SUBROUTINE AMEDRV(Y, N, MSPEC, NFAC, PAR, NPAR,
     +   RES, LDSTAK, IFIXED, LIFIXD, STP, LSTP, MIT, STOPSS, STOPP,
     +   SCALE, LSCALE, DELTA, IVAPRX, NPRT, RSD, PV, LPV, SDPV, LSDPV,
     +   SDRES, LSDRES, VCV, IVCV, NMSUB, SAVE, NPARE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE CONTROLLING SUBROUTINE FOR NONLINEAR LEAST
C     SQUARES REGRESSION USING NUMERICALLY APPROXIMATED DERIVATIVES.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 2, 1985
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   DELTA,RSD,STOPP,STOPSS
      INTEGER
     +   IVAPRX,IVCV,LDSTAK,LIFIXD,LPV,LSCALE,LSDPV,LSDRES,LSTP,
     +   MIT,N,NFAC,NPAR,NPARE,NPRT
      LOGICAL
     +   SAVE
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   PAR(*),PV(*),RES(*),SCALE(*),SDPV(*),SDRES(*),STP(*),VCV(*),
     +   Y(*)
      INTEGER
     +   IFIXED(*),MSPEC(4,*)
      CHARACTER
     +   NMSUB(6)*1
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR,IFLAG,MBO,MBOL,MSPECT,NFACT,NPARAR,NPARDF,NPARMA,
     +   NRESTS,PARAR,PARDF,PARMA,T,TEMP
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   EXMPT
      INTEGER
     +   IFP,IS,ISUBHD,IXM,LDSMIN,LWT,M,NALL0,NDIGIT,NETA,NNZW,STPT
      LOGICAL
     +   APRXDV,HLFRPT,PAGE,PRTFXD,WEIGHT,WIDE
C
C  LOCAL ARRAYS
      DOUBLE PRECISION
     +   RSTAK(12),WT(1)
      INTEGER
     +   IPTOUT(5),ISTAK(12)
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   ICNTI,STKGET,STKST
      EXTERNAL ICNTI,STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMECNT,AMEER,AMEHDR,AMESTP,BACKOP,CPYVII,
     +   DCOEF,DRV,LDSCMP,MDLTS1,MDLTS3,NLDRVN,PRTCNT,DCOPY,
     +   STKCLR,STKSET,STPAMO
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
      COMMON /MDLTSC/MSPECT,NFACT,PARDF,NPARDF,PARAR,NPARAR,PARMA,
     +   NPARMA,MBO,MBOL,T,TEMP,NRESTS,IFLAG
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),ISTAK(1))
      EQUIVALENCE (DSTAK(1),RSTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     EXTERNAL AMEHDR
C        THE ROUTINE USED TO PRINT THE HEADING
C     LOGICAL APRXDV
C        THE VARIABLE USED TO INDICATE WHETHER NUMERICAL
C        APPROXIMATIONS TO THE DERIVATIVE WERE USED (TRUE) OR NOT
C        (FALSE).
C     DOUBLE PRECISION DELTA
C        THE MAXIMUM CHANGE ALLOWED IN THE MODEL PARAMETERS AT THE
C        FIRST ITERATION.
C     EXTERNAL DRV
C        THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE
C        DERIVATIVE (JACOBIAN) MATRIX OF THE MODEL.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     DOUBLE PRECISION EXMPT
C        THE PROPORTION OF OBSERVATIONS FOR WHICH THE COMPUTED
C        NUMERICAL DERIVATIVES WRT A GIVEN PARAMETER ARE EXEMPTED
C        FROM MEETING THE DERIVATIVE ACCEPTANCE CRITERIA.
C     LOGICAL HLFRPT
C        THE VARIABLE WHICH INDICATES WHETHER THE DERIVATIVE
C        CHECKING ROUTINE HAS ALREADY PRINTED PART OF THE
C        INITIAL SUMMARY (TRUE) OR NOT (FALSE).
C     INTEGER IERR
C        THE VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .GE. 1, ERRORS WERE DETECTED.
C     INTEGER IFIXED(LIFIXD)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE
C        PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED.
C        IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED.
C        IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED.
C     INTEGER IFLAG
C        ...
C     INTEGER IFP
C        AN INDICATOR FOR THE PRECISION OF THE STACK ALLOCATION TYPE,
C        WHERE IFP=3 INDICATES SINGLE AND IFP=4 INDICATES DOUBLE.
C     INTEGER IPTOUT(5)
C        THE VARIABLE USED TO CONTROL PRINTED OUTPUT FOR EACH SECTION.
C     INTEGER IS
C        A VALUE USED TO DETERMINE THE AMOUNT OF WORK SPACE NEEDED
C        BASED ON WHETHER STEP SIZES ARE INPUT OR ARE TO BE CALCULATED.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ISUBHD
C        AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED.
C     INTEGER IVAPRX
C        AN INDICATOR VALUE USED TO DESIGNATE WHICH OPTION IS TO BE USED
C        TO COMPUTE THE VARIANCE COVARIANCE MATRIX (VCV), WHERE FOR
C        IVAPRX LE 0, VCV = THE DEFAULT OPTION
C        IVAPRX EQ 1, VCV = INVERSE(TRANSPOSE(J)*J)
C                     USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED
C                     DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE
C        IVAPRX EQ 2, VCV = INVERSE(H)
C                     USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED
C                     DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE
C        IVAPRX EQ 3, VCV = INVERSE(H)*TRANSPOSE(J)*JACOBIAN*INVERSE(H)
C                     USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED
C                     DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE
C        IVAPRX EQ 4, VCV = INVERSE(TRANSPOSE(J)*J)
C                     USING ONLY THE MODEL SUBROUTINE
C        IVAPRX EQ 5, VCV = INVERSE(H)
C                     USING ONLY THE MODEL SUBROUTINE
C        IVAPRX EQ 6, VCV = INVERSE(H)*TRANSPOSE(J)*JACOBIAN*INVERSE(H)
C                     USING ONLY THE MODEL SUBROUTINE
C        IVAPRX GE 7, VCV = THE DEFAULT OPTION
C        WITH J REPRESENTING THE JACOBIAN AND H THE HESSIAN.
C     INTEGER IVCV
C        THE FIRST DIMENSION OF MATRIX VCV.
C     INTEGER IXM
C        THE FIRST DIMENSION OF MATRIX XM.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER LIFIXD
C        THE DIMENSION OF VECTOR IFIXED.
C     INTEGER LPV
C        THE DIMENSION OF VECTOR PV.
C     INTEGER LSCALE
C        THE DIMENSION OF VECTOR SCALE.
C     INTEGER LSDPV
C        THE DIMENSION OF VECTOR SDPV.
C     INTEGER LSDRES
C        THE DIMENSION OF VECTOR SDRES.
C     INTEGER LSTP
C        THE DIMENSION OF VECTOR STP.
C     INTEGER LWT
C        THE DIMENSION OF VECTOR WT.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     INTEGER MBO
C        THE MAXIMUM BACK ORDER OPERATOR.
C     INTEGER MBOL
C        THE MAXIMUM BACK ORDER ON THE LEFT
C     EXTERNAL MDLTS1
C        THE STARPAC FORMAT SUBROUTINE FOR COMPUTING THE ARIMA MODEL
C        PREDICTED VALUES.
C     EXTERNAL MDLTS3
C        THE STARPAC FORMAT SUBROUTINE FOR COMPUTING THE ARIMA MODEL
C        RESIDUALS.
C     INTEGER MIT
C        THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C     INTEGER MSPEC(4,NFAC)
C        THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT
C     INTEGER MSPECT
C        THE STARTING LOCATION IN THE WORK SPACE FOR
C        THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NALL0
C        NUMBER OF STACK ALLOCATIONS OUTSTANDING.
C     INTEGER NDIGIT
C        THE NUMBER OF DIGITS IN THE PRINT CONTROL VALUE.
C     INTEGER NETA
C        THE NUMBER OF ACCURATE DIGITS IN THE MODEL RESULTS.
C     INTEGER NFAC
C        THE NUMBER OF FACTORS IN THE MODEL
C     INTEGER NFACT
C        THE NUMBER OF FACTORS IN THE MODEL
C     EXTERNAL NLDRVN
C        THE NAME OF THE ROUTINE WHICH CALCULATES THE DERIVATIVES.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE ROUTINE CALLING THE ERROR CHECKING ROUTINE
C     INTEGER NNZW
C        THE NUMBER OF NON ZERO WEIGHTS.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     INTEGER NPARAR
C        THE NUMBER OF AUTOREGRESSIVE PARAMETERS
C     INTEGER NPARDF
C        THE ORDER OF THE EXPANDED DIFFERENCE FILTER.
C     INTEGER NPARE
C        THE NUMBER OF PARAMETERS TO BE OPTIMIZED.
C     INTEGER NPARMA
C        THE LENGTH OF THE VECTOR PARMA
C     INTEGER NPRT
C        THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS
C        TO BE PROVIDED.
C     INTEGER NRESTS
C        THE MAXIMUM NUMBER OF RESIDUALS TO BE COMPUTED.
C     LOGICAL PAGE
C        THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF
C        THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     INTEGER PARAR
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        THE AUTOREGRESSIVE PARAMETERS
C     INTEGER PARDF
C        THE STARTING LOCATION IN THE WORK SPACE FOR
C        THE VECTOR CONTAINING THE DIFFERENCE FILTER PARAMETERS
C     INTEGER PARMA
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        THE MOVING AVERAGE PARAMETERS
C     LOGICAL PRTFXD
C        THE INDICATOR VALUE USED TO DESIGNATE WHETHER THE
C        OUTPUT IS TO INCLUDE INFORMATION ON WHETHER THE
C        PARAMETER IS FIXED (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION PV(LPV)
C        THE PREDICTED VALUE OF THE FIT.
C     DOUBLE PRECISION RES(N)
C        THE RESIDUALS FROM THE FIT.
C     DOUBLE PRECISION RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     DOUBLE PRECISION RSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     LOGICAL SAVE
C        THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN
C        THE RESIDUALS AND PARAMETERS ARE TO BE SAVED (TRUE) OR NOT
C        (FALSE).
C     DOUBLE PRECISION SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     DOUBLE PRECISION SDPV(LSDPV)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     DOUBLE PRECISION SDRES(LSDRES)
C        THE STANDARDIZED RESIDUALS.
C     DOUBLE PRECISION STOPP
C        THE STOPPING CRITERION FOR THE TEST BASED ON THE MAXIMUM SCALED
C        RELATIVE CHANGE IN THE ELEMENTS OF THE MODEL PARAMETER VECTOR
C     DOUBLE PRECISION STOPSS
C        THE STOPPING CRITERION FOR THE TEST BASED ON THE RATIO OF THE
C        PREDICTED DECREASE IN THE RESIDUAL SUM OF SQUARES (COMPUTED
C        BY STARPAC) TO THE CURRENT RESIDUAL SUM OF SQUARES ESTIMATE.
C     DOUBLE PRECISION STP(LSTP)
C        THE STEP SIZE ARRAY.
C     EXTERNAL STPAMO
C        THE ROUTINE USED TO PRINT THE OUTPUT FROM THE STEP SIZE SELECTI
C        ROUTINES.
C     INTEGER STPT
C        THE STARTING LOCATION IN /CSTAK/ OF VECTOR STPT CONTAINING
C        THE STEP SIZE ARRAY.
C     INTEGER T
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        A TEMPORARY WORK VECTOR.
C     INTEGER TEMP
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        A TEMPORARY WORK VECTOR
C     DOUBLE PRECISION VCV(IVCV,NPAR)
C        THE VARIANCE-COVARIANCE MATRIX.
C     LOGICAL WEIGHT
C        THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO
C        BE PERFORMED (TRUE) OR NOT (FALSE).
C     LOGICAL WIDE
C        THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD
C        BE FULL WIDTH (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION WT(1)
C        THE USER SUPPLIED WEIGHTS, UNUSED WHEN WEIGHT = FALSE.
C     DOUBLE PRECISION Y(N)
C        THE DEPENDENT VARIABLE.
C
C     SET VARIOUS PROGRAM VALUES
C
      CHARACTER*4 IBUGA3
      CHARACTER*4 ISUBRO
      CHARACTER*4 IFOUND
      CHARACTER*4 IERROR
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      WEIGHT = .FALSE.
      WT(1) = 1.0D0
      LWT = 1
C
      HLFRPT = .FALSE.
      APRXDV = .TRUE.
      PRTFXD = .TRUE.
      EXMPT = -1.0D0
      NETA = 0
C
      WIDE = .TRUE.
      PAGE = .FALSE.
C
      NDIGIT = 5
C
C     COMPUTE BACK OPERATORS
C
      CALL BACKOP(MSPEC, NFAC, NPARDF, MBOL, MBO, NPARMA, NPARAR)
      NNZW = N - NPARDF
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      NPARE = NPAR
      IF ((IFIXED(1).GE.0) .AND. (NPAR.GE.1)) NPARE =
     +   ICNTI(IFIXED,NPAR,0)
      IS = 0
      IF (STP(1).LE.0.0D0) IS = 1
C
      CALL LDSCMP(25, 0, MAX(IS*2*(N+NPAR),60+NPAR+NPARE) + 4*NFAC,
     +   0, 0, 0, 'D', 5*MBO +
     +   MAX(IS*(10*N+6*MBO+606),
     +        94+4*(N+MBO+101)+NPARE*(3*NPARE+35)/2),
     +   LDSMIN)
C
      CALL AMEER(NMSUB, N, NPAR, NPARE, LDSTAK,
     +   LDSMIN, STP, LSTP, SCALE, LSCALE, IVCV, SAVE, MSPEC, NFAC)
C
      IF (IERR.NE.0) RETURN
C
      CALL STKSET(LDSTAK, 4)
C
C     SET PRINT CONTROL VALUES
C
      CALL PRTCNT(NPRT, NDIGIT, IPTOUT)
C
C     SUBDIVIDE WORKSPACE FOR STEP SIZES
C
      NALL0 = STKST(1)
C
      IFP = 4
C
      STPT = STKGET(NPAR,IFP)
C
      PARDF = STKGET(MBO, IFP)
      PARAR = STKGET(MBO, IFP)
      PARMA = STKGET(MBO, IFP)
      T = STKGET(2*MBO, IFP)
C
      TEMP = T + MBO
C
      NFACT = NFAC
      MSPECT = STKGET(4*NFAC, 2)
C
C     SET UP FOR MODEL
C
      APRXDV = .TRUE.
      M = 1
      IXM = N
      NRESTS = MBO + 101 + N
C
      CALL CPYVII(NFAC, MSPEC(1,1), 4, ISTAK(MSPECT), 1)
      CALL CPYVII(NFAC, MSPEC(2,1), 4, ISTAK(MSPECT+NFAC), 1)
      CALL CPYVII(NFAC, MSPEC(3,1), 4, ISTAK(MSPECT+2*NFAC), 1)
      CALL CPYVII(NFAC, MSPEC(4,1), 4, ISTAK(MSPECT+3*NFAC), 1)
      CALL DCOEF (NFAC, ISTAK(MSPECT+NFAC), ISTAK(MSPECT+3*NFAC),
     +  NPARDF, RSTAK(PARDF), MBO, RSTAK(T))
C
C     COPY SUPPLIED STEP SIZES TO WORK SPACE
C
      CALL DCOPY(LSTP, STP, 1, RSTAK(STPT), 1)
C
      IF (IERR.NE.0) GO TO 10
C
C     SELECT STEP SIZES, IF DESIRED
C
      ISUBHD = 1
      IF (STP(1).LE.0.0D0) CALL AMESTP(Y, N, M, IXM, MDLTS3, PAR, NPAR,
     +  RSTAK(STPT), EXMPT, NETA, SCALE, LSCALE, IPTOUT(1), AMEHDR,
     +  PAGE, WIDE, ISUBHD, HLFRPT, PRTFXD, IFIXED, LIFIXD, STPAMO,
     +  NRESTS-N)
C
      ISUBRO='AMES'
      IBUGA3='OFF'
      IFOUND='NO'
      IERROR='OFF'
      CALL DPFLSH(IPR,IBUGA3,ISUBRO,IFOUND,IERROR)
      CALL AMECNT(Y, WT, LWT, Y, N, M, IXM, MDLTS1, NLDRVN, APRXDV, DRV,
     +  PAR, NPAR, RES, IFIXED, LIFIXD, RSTAK(STPT), NPAR, MIT,
     +  STOPSS, STOPP, SCALE, LSCALE, DELTA, IVAPRX, RSD, PV, LPV,
     +  SDPV, LSDPV, SDRES, LSDRES, VCV, IVCV, WEIGHT, SAVE, NNZW,
     +  NPARE, AMEHDR, PAGE, WIDE, IPTOUT, NDIGIT, HLFRPT, NRESTS)
C
      CALL DPFLSH(IPR,IBUGA3,ISUBRO,IFOUND,IERROR)
   10 CONTINUE
C
      CALL STKCLR(NALL0)
C
      RETURN
C
      END
*BACKOP
      SUBROUTINE BACKOP (MSPEC, NFAC, NPARDF, MBOL, MBO, NPARMA, NPARAR)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     COMPUTE NUMBER OF BACK ORDER TERMS FOR ARIMA MODEL
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 4, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   MBO,MBOL,NFAC,NPARAR,NPARDF,NPARMA
C
C  ARRAY ARGUMENTS
      INTEGER
     +   MSPEC(4,*)
C
C  LOCAL SCALARS
      INTEGER
     +   J
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER J
C        AN INDEX VARIABLE.
C     INTEGER MBO
C        THE MAXIMUM BACK ORDER OPERATOR.
C     INTEGER MBOL
C        THE MAXIMUM BACK ORDER ON THE LEFT
C     INTEGER MSPEC(4,NFAC)
C        THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT
C     INTEGER NFAC
C        THE NUMBER OF FACTORS IN THE MODEL
C     INTEGER NPARAR
C        THE NUMBER OF AUTOREGRESSIVE PARAMETERS
C     INTEGER NPARDF
C        THE ORDER OF THE EXPANDED DIFFERENCE FILTER.
C     INTEGER NPARMA
C        THE LENGTH OF THE VECTOR PARMA
C
C     COMPUTE DEGREE OF BACK OPERATOR RESULTING FROM THE NDF
C     DIFFERENCING FACTORS (= ND DOT IOD).
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      NPARAR = 0
      NPARDF = 0
      NPARMA = 0
      IF (NFAC .EQ. 0) GO TO 20
      DO 10 J = 1, NFAC
         NPARAR = NPARAR + MSPEC(1,J)*MSPEC(4,J)
         NPARDF = NPARDF + MSPEC(2,J)*MSPEC(4,J)
         NPARMA = NPARMA + MSPEC(3,J)*MSPEC(4,J)
   10 CONTINUE
C
   20 CONTINUE
C
      MBOL = NPARDF + NPARAR
      MBO = MAX(MBOL,NPARMA)
C
      RETURN
C
      END
*ERSII
      SUBROUTINE ERSII(NMSUB, NMVAR, VAL, VALMN, VALMX, MSGTYP, HEAD,
     +   ERROR, NMMIN, NMMAX)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THE ROUTINE CHECKS WHETHER THE VALUE   VAL   IS WITHIN THE
C     THE RANGE VALMN (INCLUSIVE) TO VALMX (INCLUSIVE), AND PRINTS A
C     DIAGNOSTIC IF IT IS NOT.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JUNE 10, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   VAL,VALMN,VALMX
      INTEGER
     +   MSGTYP
      LOGICAL
     +   ERROR,HEAD
C
C  ARRAY ARGUMENTS
      CHARACTER
     +   NMMAX(8)*1,NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERROR
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     LOGICAL HEAD
C        A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED
C        (TRUE) OR NOT (FALSE).  IF A HEADING IS PRINTED, THE VALUE
C        OF HEAD WILL BE CHANGED TO FALSE.
C     INTEGER I
C        AN INDEX ARGUMENT.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER MSGTYP
C        AN ARGUMENT USED TO INDICATE THE TYPE OF MESSAGE TO BE
C        PRINTED, WHERE IF ERROR IS .TRUE. AND
C        MSGTYP = 1 THE INPUT VALUE WAS OUTSIDE THE RANGE DETERMINED
C                   FROM OTHER INPUT ARGUMENTS
C        MSGTYP = 2 THE INPUT VALUE WAS OUTSIDE THE RANGE IMPOSED BY
C                   STARPAC
C     CHARACTER*1 NMMAX(8)
C        THE NAME OF THE ARGUMENT SPECIFYING THE MAXIMUM.
C     CHARACTER*1 NMMIN(8)
C        THE NAME OF THE ARGUMENT SPECIFYING THE MINIMUM.
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING SUBROUTINES NAME.
C     CHARACTER*1 NMVAR(8)
C        THE CHARACTERS OF THE ARGUMENTS NAME.
C     DOUBLE PRECISION VAL
C        THE INPUT VALUE OF THE ARGUMENT BEING CHECKED.
C     DOUBLE PRECISION VALMN, VALMX
C        THE MINIMUM AND MAXIMUM OF THE RANGE WITHIN WHICH THE
C        ARGUMENT MUST LIE.
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      ERROR = .FALSE.
C
      IF (((VALMN.LE.VAL) .AND. (VAL.LE.VALMX)) .OR.
     +   (VALMX.LT.VALMN)) RETURN
C
      ERROR = .TRUE.
      CALL EHDR(NMSUB, HEAD)
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
C
      WRITE (ICOUT, 1000) (NMVAR(I),I=1,6), VAL
      CALL DPWRST('XXX','BUG ')
C
C     PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE DETERMINED FROM
C     OTHER INPUT ARGUMENTS.
C
      IF (MSGTYP .EQ. 1) THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT, 1010) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8),
     +      (NMMAX(I),I=1,8)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C     PRINT MESSAGE FOR VALUE OUTSIDE OF RANGE IMPOSED BY STARPAC
C
      IF (MSGTYP .EQ. 2) THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT, 1020) (NMVAR(I),I=1,6), VALMN, VALMX
        CALL DPWRST('XXX','BUG ')
      ENDIF
      RETURN
C
C     FORMAT STATEMENTS
C
  999 FORMAT(1X)
 1000 FORMAT (' THE INPUT VALUE OF ', 6A1, ' IS ', G15.8, '.')
 1010 FORMAT(
     +   ' THE VALUE OF THE ARGUMENT ', 6A1,
     +   ' MUST BE BETWEEN', 1X, 8A1,
     +   ' AND ', 8A1, ', INCLUSIVE.')
 1020 FORMAT(
     +   ' THE VALUE OF THE ARGUMENT ', 6A1,
     +   ' MUST BE BETWEEN', 1X, G15.8,
     +   ' AND ', G15.8, ', INCLUSIVE.')
C
      END
*ITSMRY
      SUBROUTINE ITSMRY(D, IV, P, V, X)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C  ***  PRINT NL2SOL (VERSION 2.2) ITERATION SUMMARY  ***
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   P
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   D(P),V(*),X(P)
      INTEGER
     +   IV(*)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   NRELDF,OLDF,PRELDF,RELDF,ZERO
      INTEGER
     +   COV1,COVMAT,COVPRT,COVREQ,DSTNRM,F,F0,FDIF,G,G1,I,I1,ICH,
     +   II,IV1,J,M,NEEDHD,NF,NFCALL,NFCOV,NG,NGCALL,NGCOV,NITER,
     +   NREDUC,OL,OUTLEV,PREDUC,PRNTIT,PRUNIT,PU,RELDX,SIZE,
     +   SOLPRT,STATPR,STPPAR,SUSED,X0PRT
C
C  LOCAL ARRAYS
      CHARACTER
     +   MODEL1(3,6)*1,MODEL2(4,6)*1
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS
C
C  ***  PARAMETER DECLARATIONS  ***
C
C     INTEGER IV(1), P
C     DOUBLE PRECISION D(P), V(1), X(P)
C     DIMENSION IV(*), V(*)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  ***  LOCAL VARIABLES  ***
C
C     INTEGER COV1, G1, I, II, IV1, I1, J, M, NF, NG, OL, PU
C     CHARACTER*1 MODEL1(3, 6), MODEL2(4, 6)
C     DOUBLE PRECISION NRELDF, OLDF, PRELDF, RELDF, ZERO
C
C/
C  ***  NO EXTERNAL FUNCTIONS OR SUBROUTINES  ***
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
C     INTEGER COVMAT, COVPRT, COVREQ, DSTNRM, F, FDIF, F0, G,
C    1        NEEDHD, NFCALL, NFCOV, NGCOV, NGCALL, NITER, NREDUC,
C    2        OUTLEV, PREDUC, PRNTIT, PRUNIT, RELDX, SIZE, SOLPRT,
C    3        STATPR, STPPAR, SUSED, X0PRT
C
C  ***  IV SUBSCRIPT VALUES  ***
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA COVMAT/26/, COVPRT/14/, G/28/, COVREQ/15/,
     +     NEEDHD/39/, NFCALL/6/, NFCOV/40/, NGCOV/41/,
     +     NGCALL/30/, NITER/31/, OUTLEV/19/, PRNTIT/48/,
     +     PRUNIT/21/, SOLPRT/22/, STATPR/23/, SUSED/57/,
     +     X0PRT/24/
C
C  ***  V SUBSCRIPT VALUES  ***
C
      DATA DSTNRM/2/, F/10/, F0/13/, FDIF/11/, NREDUC/6/,
     +     PREDUC/7/, RELDX/17/, SIZE/47/, STPPAR/5/
C
      DATA MODEL1(1, 1), MODEL1(2, 1), MODEL1(3, 1)
     +   /        ' ',          ' ',          ' '  /
      DATA MODEL1(1, 2), MODEL1(2, 2), MODEL1(3, 2)
     +   /        ' ',          ' ',          ' '  /
      DATA MODEL1(1, 3), MODEL1(2, 3), MODEL1(3, 3)
     +   /        ' ',          ' ',          ' '  /
      DATA MODEL1(1, 4), MODEL1(2, 4), MODEL1(3, 4)
     +   /        ' ',          ' ',          ' '  /
      DATA MODEL1(1, 5), MODEL1(2, 5), MODEL1(3, 5)
     +   /        ' ',          'G',          ' '  /
      DATA MODEL1(1, 6), MODEL1(2, 6), MODEL1(3, 6)
     +   /        ' ',          'S',          ' '  /
      DATA MODEL2(1, 1), MODEL2(2, 1), MODEL2(3, 1), MODEL2(4, 1)
     +    /       ' ',          'G',          ' ',          ' '  /
      DATA MODEL2(1, 2), MODEL2(2, 2), MODEL2(3, 2), MODEL2(4, 2)
     +   /        ' ',          'S',          ' ',          ' '  /
      DATA MODEL2(1, 3), MODEL2(2, 3), MODEL2(3, 3), MODEL2(4, 3)
     +   /        'G',          '-',          'S',          ' '  /
      DATA MODEL2(1, 4), MODEL2(2, 4), MODEL2(3, 4), MODEL2(4, 4)
     +   /        'S',          '-',          'G',          ' '  /
      DATA MODEL2(1, 5), MODEL2(2, 5), MODEL2(3, 5), MODEL2(4, 5)
     +   /        '-',          'S',          '-',          'G'  /
      DATA MODEL2(1, 6), MODEL2(2, 6), MODEL2(3, 6), MODEL2(4, 6)
     +   /        '-',          'G',          '-',          'S'  /
      DATA ZERO/0.0D0/
C
C-----------------------------------------------------------------------
C
CCCCC PU = IV(PRUNIT)
CCCCC IF (PU .EQ. 0) GO TO 999
      PU=6
      IV1 = IV(1)
      OL = IV(OUTLEV)
      IF (IV1 .LT. 2 .OR. IV1 .GT. 15) GO TO 140
      IF (OL .EQ. 0) GO TO 20
      IF (IV1 .GE. 12) GO TO 20
      IF (IV1 .GE. 10 .AND. IV(PRNTIT) .EQ. 0) GO TO 20
      IF (IV1 .GT. 2) GO TO 10
         IV(PRNTIT) = IV(PRNTIT) + 1
         IF (IV(PRNTIT) .LT. ABS(OL)) GO TO 999
 10   NF = IV(NFCALL) - ABS(IV(NFCOV))
      IV(PRNTIT) = 0
      RELDF = ZERO
      PRELDF = ZERO
      OLDF = V(F0)
      IF (OLDF .LE. ZERO) GO TO 12
         RELDF = V(FDIF) / OLDF
         PRELDF = V(PREDUC) / OLDF
 12   IF (OL .GT. 0) GO TO 15
C
C        ***  PRINT SHORT SUMMARY LINE  ***
C
         IF (IV(NEEDHD) .EQ. 1) THEN
            WRITE(IOUNI3, 1010)
 1010 FORMAT(12H    IT    NF,6X,'F',8X,5HRELDF,6X,6HPRELDF,5X,5HRELDX)
CCCCC       CALL DPWRST('XXX','BUG ')
         ENDIF
         IV(NEEDHD) = 0
         WRITE(IOUNI3,1017)IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX)
CCCCC    CALL DPWRST('XXX','BUG ')
         GO TO 20
C
C     ***  PRINT LONG SUMMARY LINE  ***
C
 15   IF (IV(NEEDHD) .EQ. 1) THEN
         WRITE(IOUNI3,1015)
 1015 FORMAT(12H    IT    NF,6X,'F',8X,5HRELDF,6X,6HPRELDF,5X,5HRELDX,
     +       4X,15HMODEL    STPPAR,6X,4HSIZE,6X,6HD*STEP,5X,7HNPRELDF)
CCCCC    CALL DPWRST('XXX','BUG ')
      ENDIF
      IV(NEEDHD) = 0
      M = IV(SUSED)
      NRELDF = ZERO
      IF (OLDF .GT. ZERO) NRELDF = V(NREDUC) / OLDF
      WRITE(IOUNI3,1017) IV(NITER), NF, V(F), RELDF, PRELDF, V(RELDX),
     +               (MODEL1(ICH, M), ICH = 1, 3),
     +               (MODEL2(ICH, M), ICH = 1, 4),
     +               V(STPPAR), V(SIZE), V(DSTNRM), NRELDF
 1017 FORMAT(1X,I5,I6,4D11.3,7A1,4D11.3)
CCCCC CALL DPWRST('XXX','BUG ')
C
 20   GO TO (999,999,30,35,40,45,50,60,70,80,90,150,110,120,130), IV1
C
 30   WRITE(IOUNI3,1030)
 1030 FORMAT(26H ***** X-CONVERGENCE *****)
CCCCC CALL DPWRST('XXX','BUG ')
      GO TO 180
C
 35   WRITE(IOUNI3,1035)
 1035 FORMAT(42H ***** RELATIVE FUNCTION CONVERGENCE *****)
CCCCC CALL DPWRST('XXX','BUG ')
      GO TO 180
C
 40   WRITE(IOUNI3,1040)
 1040 FORMAT(49H ***** X- AND RELATIVE FUNCTION CONVERGENCE *****)
CCCCC CALL DPWRST('XXX','BUG ')
      GO TO 180
C
 45   WRITE(IOUNI3,1045)
 1045 FORMAT(42H ***** ABSOLUTE FUNCTION CONVERGENCE *****)
CCCCC CALL DPWRST('XXX','BUG ')
      GO TO 180
C
 50   WRITE(IOUNI3,1050)
 1050 FORMAT(33H ***** SINGULAR CONVERGENCE *****)
CCCCC CALL DPWRST('XXX','BUG ')
      GO TO 180
C
 60   WRITE(IOUNI3,1060)
 1060 FORMAT(30H ***** FALSE CONVERGENCE *****)
CCCCC CALL DPWRST('XXX','BUG ')
      GO TO 180
C
 70   WRITE(IOUNI3,1070)
 1070 FORMAT(38H ***** FUNCTION EVALUATION LIMIT *****)
CCCCC CALL DPWRST('XXX','BUG ')
      GO TO 180
C
 80   WRITE(IOUNI3,1080)
 1080 FORMAT(28H ***** ITERATION LIMIT *****)
CCCCC CALL DPWRST('XXX','BUG ')
      GO TO 180
C
 90   WRITE(IOUNI3,1090)
 1090 FORMAT(18H ***** STOPX *****)
CCCCC CALL DPWRST('XXX','BUG ')
      GO TO 180
C
 110  WRITE(IOUNI3,1100)
 1100 FORMAT(45H ***** INITIAL SUM OF SQUARES OVERFLOWS *****)
CCCCC CALL DPWRST('XXX','BUG ')
C
      GO TO 150
C
 120  WRITE(IOUNI3,1120)
 1120 FORMAT(37H ***** BAD PARAMETERS TO ASSESS *****)
CCCCC CALL DPWRST('XXX','BUG ')
      GO TO 999
C
 130  WRITE(IOUNI3,1130)
 1130 FORMAT(36H ***** J COULD NOT BE COMPUTED *****)
CCCCC CALL DPWRST('XXX','BUG ')
      IF (IV(NITER) .GT. 0) GO TO 190
      GO TO 150
C
 140  WRITE(IOUNI3,1140) IV1
 1140 FORMAT(14H ***** IV(1) =,I5,6H *****)
CCCCC CALL DPWRST('XXX','BUG ')
      GO TO 999
C
C  ***  INITIAL CALL ON ITSMRY  ***
C
 150  IF (IV(X0PRT) .NE. 0) THEN
         WRITE(IOUNI3,1150)
 1150    FORMAT(23H     I     INITIAL X(I),7X,4HD(I))
CCCCC    CALL DPWRST('XXX','BUG ')
         WRITE(IOUNI3,1151) (I, X(I), D(I), I = 1, P)
 1151    FORMAT(1X,I5,D17.6,D14.3)
CCCCC    CALL DPWRST('XXX','BUG ')
      ENDIF
      IF (IV1 .GE. 13) GO TO 999
      IV(NEEDHD) = 0
      IV(PRNTIT) = 0
      IF (OL .EQ. 0) GO TO 999
      IF (OL .LT. 0) THEN
         WRITE(IOUNI3,1010)
CCCCC    CALL DPWRST('XXX','BUG ')
      ENDIF
      IF (OL .GT. 0) THEN
         WRITE(IOUNI3,1015)
CCCCC    CALL DPWRST('XXX','BUG ')
      ENDIF
      WRITE(IOUNI3,1160) V(F)
 1160 FORMAT(12H     0     1,D11.3,11X,D11.3)
CCCCC CALL DPWRST('XXX','BUG ')
      GO TO 999
C
C  ***  PRINT VARIOUS INFORMATION REQUESTED ON SOLUTION  ***
C
 180  IV(NEEDHD) = 1
      IF (IV(STATPR) .EQ. 0) GO TO 190
         OLDF = V(F0)
         PRELDF = ZERO
         NRELDF = ZERO
         IF (OLDF .LE. ZERO) GO TO 185
              PRELDF = V(PREDUC) / OLDF
              NRELDF = V(NREDUC) / OLDF
 185     NF = IV(NFCALL) - IV(NFCOV)
         NG = IV(NGCALL) - IV(NGCOV)
         WRITE(IOUNI3,1180) V(F), V(RELDX)
 1180    FORMAT(9H FUNCTION,D17.6,8H   RELDX,D20.6)
CCCCC    CALL DPWRST('XXX','BUG ')
         WRITE(IOUNI3,1180) V(F), V(RELDX), NF, NG, PRELDF, NRELDF
 1181    FORMAT(12H FUNC. EVALS,
     +   I8,9X,'GRAD. EVALS',I8)
CCCCC    CALL DPWRST('XXX','BUG ')
         WRITE(IOUNI3,1182) PRELDF, NRELDF
 1182 FORMAT(
     +   ' PRELDF',D19.6,3X,'NPRELDF',D18.6)
CCCCC    CALL DPWRST('XXX','BUG ')
C
         IF (IV(NFCOV) .GT. 0) THEN
            WRITE(IOUNI3,1185) IV(NFCOV)
 1185       FORMAT(' ',I4,' EXTRA FUNC. EVALS FOR COVARIANCE.')
CCCCC       CALL DPWRST('XXX','BUG ')
         ENDIF
         IF (IV(NGCOV) .GT. 0) THEN
            WRITE(IOUNI3,1186) IV(NGCOV)
 1186       FORMAT(1X,I4,' EXTRA GRAD. EVALS FOR COVARIANCE.')
CCCCC       CALL DPWRST('XXX','BUG ')
         ENDIF
C
 190  IF (IV(SOLPRT) .EQ. 0) GO TO 210
         IV(NEEDHD) = 1
         G1 = IV(G)
         WRITE(IOUNI3,1190)
 1190    FORMAT('     I      FINAL X(I)',8X,'D(I)',10X,'G(I)'/)
CCCCC    CALL DPWRST('XXX','BUG ')
         DO 200 I = 1, P
              WRITE(IOUNI3,1200) I, X(I), D(I), V(G1)
CCCCC         CALL DPWRST('XXX','BUG ')
              G1 = G1 + 1
 200     CONTINUE
 1200    FORMAT(1X,I5,D17.6,2D14.3)
C
 210  IF (IV(COVPRT) .EQ. 0) GO TO 999
      COV1 = IV(COVMAT)
      IV(NEEDHD) = 1
      IF (COV1) 220, 230, 240
 220  IF (-1 .EQ. COV1) THEN
         WRITE(IOUNI3,1220)
 1220    FORMAT(43H ++++++ INDEFINITE COVARIANCE MATRIX ++++++)
CCCCC    CALL DPWRST('XXX','BUG ')
      ENDIF
      IF (-2 .EQ. COV1) THEN
         WRITE(IOUNI3,1225)
 1225 FORMAT(52H ++++++ OVERSIZE STEPS IN COMPUTING COVARIANCE +++++)
CCCCC    CALL DPWRST('XXX','BUG ')
      ENDIF
      GO TO 999
C
 230  WRITE(IOUNI3,1230)
 1230 FORMAT(45H +++++  COVARIANCE MATRIX NOT COMPUTED ++++++)
CCCCC CALL DPWRST('XXX','BUG ')
      GO TO 999
C
 240  I = ABS(IV(COVREQ))
      IF (I .LE. 1) THEN
         WRITE(IOUNI3,1241)
 1241 FORMAT(48H COVARIANCE = SCALE * H**-1 * (J**T * J) * H**-1/)
CCCCC    CALL DPWRST('XXX','BUG ')
      ENDIF
      IF (I .EQ. 2) THEN
         WRITE(IOUNI3,1242)
 1242    FORMAT(27H COVARIANCE = SCALE * H**-1/)
CCCCC    CALL DPWRST('XXX','BUG ')
      ENDIF
      IF (I .GE. 3) THEN
         WRITE(IOUNI3,1243)
 1243    FORMAT(36H COVARIANCE = SCALE * (J**T * J)**-1/)
CCCCC    CALL DPWRST('XXX','BUG ')
      ENDIF
      II = COV1 - 1
      IF (OL .LE. 0) GO TO 260
      DO 250 I = 1, P
         I1 = II + 1
         II = II + I
         WRITE(IOUNI3,1250) I, (V(J), J = I1, II)
CCCCC    CALL DPWRST('XXX','BUG ')
 250  CONTINUE
 1250 FORMAT(4H ROW,I3,2X,9D12.4/(9X,9D12.4))
      GO TO 999
C
 260  DO 270 I = 1, P
         I1 = II + 1
         II = II + I
         WRITE(IOUNI3,1270) I, (V(J), J = I1, II)
CCCCC    CALL DPWRST('XXX','BUG ')
 270     CONTINUE
 1270 FORMAT(4H ROW,I3,2X,5D12.4/(9X,5D12.4))
C
 999  RETURN
C  ***  LAST CARD OF ITSMRY FOLLOWS  ***
      END
*MDLTS3
      SUBROUTINE MDLTS3 (PAR, NPAR, XM, N, M, IXM, RESTS)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE USER CALLABLE ROUTINE FOR ESTIMATING BOX-JENKINS
C     ARIMA MODELS.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 4, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IXM,M,N,NPAR
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   PAR(NPAR),RESTS(NRESTS),XM(IXM,M)
C
C  SCALARS IN COMMON
      INTEGER
     +   IFLAG,MBO,MBOL,MSPECT,NFACT,NPARAR,NPARDF,NPARMA,NRESTS,
     +   PARAR,PARDF,PARMA,T,TEMP
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   PMU
C
C  LOCAL ARRAYS
      DOUBLE PRECISION
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
C
C  EXTERNAL SUBROUTINES
      EXTERNAL MDLTS2
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /MDLTSC/MSPECT,NFACT,PARDF,NPARDF,PARAR,NPARAR,PARMA,
     +   NPARMA,MBO,MBOL,T,TEMP,NRESTS,IFLAG
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),ISTAK(1))
      EQUIVALENCE (DSTAK(1),RSTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER IFLAG
C        AN INDICATOR VARIABLE DESIGNATING WHETHER THE BACK FORECASTS
C        WERE ESSENTIALLY ZERO (IFLAG=0) OR NOT (IFLAG=1).
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER IXM
C        THE FIRST DIMENSION OF MATRIX XM.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     INTEGER MBO
C        THE MAXIMUM BACK ORDER OPERATOR.
C     INTEGER MBOL
C        THE MAXIMUM BACK ORDER ON THE LEFT
C     INTEGER MSPECT
C        THE STARTING LOCATION IN THE WORK SPACE FOR
C        THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NFACT
C        THE NUMBER OF FACTORS IN THE MODEL
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     INTEGER NPARAR
C        THE NUMBER OF AUTOREGRESSIVE PARAMETERS
C     INTEGER NPARDF
C        THE ORDER OF THE EXPANDED DIFFERENCE FILTER.
C     INTEGER NPARMA
C        THE LENGTH OF THE VECTOR PARMA
C     INTEGER NRESTS
C        THE MAXIMUM NUMBER OF RESIDUALS TO BE COMPUTED.
C     DOUBLE PRECISION PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     INTEGER PARAR
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        THE AUTOREGRESSIVE PARAMETERS
C     INTEGER PARDF
C        THE STARTING LOCATION IN THE WORK SPACE FOR
C        THE VECTOR CONTAINING THE DIFFERENCE FILTER PARAMETERS
C     INTEGER PARMA
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        THE MOVING AVERAGE PARAMETERS
C     DOUBLE PRECISION PMU
C        THE VALUE OF MU, I.E., THE TREND OR MEAN.
C     DOUBLE PRECISION RESTS(NRESTS)
C        THE RESIDUALS FROM THE ARIMA MODEL.
C     DOUBLE PRECISION RSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER T
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        A TEMPORARY WORK VECTOR.
C     INTEGER TEMP
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        A TEMPORARY WORK VECTOR
C     DOUBLE PRECISION XM(IXM,M)
C        THE INDEPENDENT VARIABLE.
C
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     COMPUTE RESIDUALS
C
      CALL MDLTS2 (PAR, RESTS, XM(1,1), NPAR, N, NFACT, ISTAK(MSPECT),
     +  PMU, RSTAK(PARDF), NPARDF, RSTAK(T), RSTAK(TEMP), RSTAK(PARAR),
     +  RSTAK(PARMA), MBO, N-NRESTS+1, N, IFLAG)
C
      RETURN
      END
*PRTCNT
      SUBROUTINE PRTCNT(NPRT, NDIGIT, IPTOUT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE SETS UP THE PRINT CONTROL PARAMETERS.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 29, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   NDIGIT,NPRT
C
C  ARRAY ARGUMENTS
      INTEGER
     +   IPTOUT(NDIGIT)
C
C  LOCAL SCALARS
      INTEGER
     +   I,IFAC1,IFAC2
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MOD
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I, IFAC1, IFAC2
C     INTEGER IPTOUT(NDIGIT)
C        THE VARIABLE USED TO CONTROL PRINTED OUTPUT FOR EACH SECTION.
C     INTEGER NDIGIT
C        THE NUMBER OF DIGITS IN THE PRINT CONTROL VALUE.
C     INTEGER NPRT
C        THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS
C        TO BE PROVIDED.
C
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      IF (NPRT.LE.-1) GO TO 20
C
      IFAC1 = 10 ** (NDIGIT)
      DO 10 I = 1, NDIGIT
         IFAC2 = IFAC1/10
         IPTOUT(I) = MOD(NPRT, IFAC1) / IFAC2
         IFAC1 = IFAC2
   10 CONTINUE
      RETURN
C
   20 DO 30 I = 1, NDIGIT
         IPTOUT(I) = 1
   30 CONTINUE
      IPTOUT (NDIGIT) = 2
C
      RETURN
C
      END
*STOPX
      LOGICAL FUNCTION STOPX(IDUMMY)
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IDUMMY
C
C     *****PURPOSE...
C     THIS FUNCTION MAY SERVE AS THE STOPX (ASYNCHRONOUS INTERRUPTION)
C     FUNCTION FOR THE NL2SOL (NONLINEAR LEAST-SQUARES) PACKAGE AT
C     THOSE INSTALLATIONS WHICH DO NOT WISH TO IMPLEMENT A
C     DYNAMIC STOPX.
C
C     *****ALGORITHM NOTES...
C     AT INSTALLATIONS WHERE THE NL2SOL SYSTEM IS USED
C     INTERACTIVELY, THIS DUMMY STOPX SHOULD BE REPLACED BY A
C     FUNCTION THAT RETURNS .TRUE. IF AND ONLY IF THE INTERRUPT
C     (BREAK) KEY HAS BEEN PRESSED SINCE THE LAST CALL ON STOPX.
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      STOPX = .FALSE.
      RETURN
      END
*AMEER
      SUBROUTINE AMEER(NMSUB, N, NPAR, NPARE, LDSTAK, LDSMIN,
     +  STP, LSTP, SCALE, LSCALE, IVCV, SAVE, MSPEC, NFAC)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE ERROR CHECKING ROUTINE FOR NONLINEAR LEAST SQUARES
C     ESTIMATION ROUTINES.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 2, 1985
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IVCV,LDSMIN,LDSTAK,LSCALE,LSTP,N,NFAC,NPAR,NPARE
      LOGICAL
     +   SAVE
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   SCALE(*),STP(*)
      INTEGER
     +   MSPEC(4,*)
      CHARACTER
     +   NMSUB(6)*1
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   I,NP,NV
      LOGICAL
     +   HEAD
C
C  LOCAL ARRAYS
      LOGICAL
     +   ERROR(20)
      CHARACTER
     +   LIVCV(8)*1,LLDS(8)*1,LMSPEC(8)*1,LN(8)*1,LNFAC(8)*1,
     +   LNPAR(8)*1,LNPARE(8)*1,LONE(8)*1,LSCL(8)*1,LSTEP(8)*1,
     +   LZERO(8)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EIAGE,EISEQ,EISGE,ERVGT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERROR(20)
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     LOGICAL HEAD
C        THE VARIABLE USED TO INDICATE WHETHER A HEADING IS TO BE
C        PRINTED DURING A GIVEN CALL TO THE ITERATION REPORT (TRUE)
C        OR NOT (FALSE).
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IERR
C        THE VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .GE. 1, ERRORS WERE DETECTED.
C     INTEGER IVCV
C        THE FIRST DIMENSION OF MATRIX VCV.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     CHARACTER*1 LIVCV(8), LLDS(8), LMSPEC(8), LN(8), LNFAC(8),
C    *   LNPAR(8), LNPARE(8), LONE(8), LSCL(8), LSTEP(8), LZERO(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S)
C        CHECKED FOR ERRORS.
C     INTEGER LSCALE
C        THE DIMENSION OF VECTOR SCALE.
C     INTEGER LSTP
C        THE DIMENSION OF VECTOR STP.
C     INTEGER MSPEC(4,*)
C        INTEGER MSPEC(4,NFAC)
C        THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NFAC
C        THE NUMBER OF FACTORS IN THE MODEL.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE ROUTINE CALLING THE ERROR CHECKING ROUTINE
C     INTEGER NP
C        THE NUMBER OF PARAMETERS SPECIFIED BY MSPEC.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     INTEGER NPARE
C        THE NUMBER OF PARAMETERS TO BE OPTIMIZED.
C     INTEGER NV
C        *
C     LOGICAL SAVE
C        THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN
C        THE RESIDUALS AND PARAMETERS ARE TO BE SAVED (TRUE) OR NOT
C        (FALSE).
C     DOUBLE PRECISION SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     DOUBLE PRECISION STP(LSTP)
C        THE STEP SIZE ARRAY.
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     SET UP NAME ARRAYS
C
      DATA LIVCV(1), LIVCV(2), LIVCV(3), LIVCV(4), LIVCV(5),
     +   LIVCV(6), LIVCV(7), LIVCV(8) /'I','V','C','V',' ',' ',' ',' '/
      DATA LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6),
     +   LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/
      DATA LMSPEC(1), LMSPEC(2), LMSPEC(3), LMSPEC(4), LMSPEC(5),
     +   LMSPEC(6), LMSPEC(7), LMSPEC(8)
     +  /'M','S','P','C',' ',' ',' ',' '/
      DATA LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) /'N',
     +   ' ',' ',' ',' ',' ',' ',' '/
      DATA LNFAC(1), LNFAC(2), LNFAC(3), LNFAC(4), LNFAC(5),
     +   LNFAC(6), LNFAC(7), LNFAC(8) /'N','F','A','C',' ',' ',' ',' '/
      DATA LNPAR(1), LNPAR(2), LNPAR(3), LNPAR(4), LNPAR(5),
     +   LNPAR(6), LNPAR(7), LNPAR(8) /'N','P','A','R',' ',' ',' ',
     +   ' '/
      DATA LNPARE(1), LNPARE(2), LNPARE(3), LNPARE(4), LNPARE(5),
     +   LNPARE(6), LNPARE(7), LNPARE(8) /'N','P','A','R','E',' ',' ',
     +   ' '/
      DATA LONE(1), LONE(2), LONE(3), LONE(4), LONE(5),
     +   LONE(6), LONE(7), LONE(8) /'1',' ',' ',' ',' ',' ',' ',' '/
      DATA LSCL(1), LSCL(2), LSCL(3), LSCL(4), LSCL(5),
     +   LSCL(6), LSCL(7), LSCL(8) /'S','C','A','L','E',' ',' ',
     +   ' '/
      DATA LSTEP(1), LSTEP(2), LSTEP(3), LSTEP(4), LSTEP(5),
     +   LSTEP(6), LSTEP(7), LSTEP(8) /'S','T','P',' ',' ',' ',' ',' '/
      DATA LZERO(1), LZERO(2), LZERO(3), LZERO(4), LZERO(5),
     +   LZERO(6), LZERO(7), LZERO(8) /'Z','E','R','O',' ',' ',' ',' '/
C
C     ERROR CHECKING
C
      DO 10 I=1,20
         ERROR(I) = .FALSE.
   10 CONTINUE
C
      IERR = 0
      HEAD = .TRUE.
C
      CALL EISGE(NMSUB, LN, N, 1, 2, HEAD, ERROR(1), LONE)
C
      CALL EISGE(NMSUB, LNFAC, NFAC, 1, 2, HEAD, ERROR(2), LONE)
C
      IF (.NOT. ERROR(2))
     +  CALL EIAGE(NMSUB, LMSPEC, MSPEC, 4, NFAC, 4, 0, 0, HEAD, 1, NV,
     +  ERROR(3), LMSPEC)
C
      IF ((.NOT. ERROR(2)) .AND. (.NOT. ERROR(3))) THEN
        NP = 1
         DO 20 I = 1, NFAC
          NP = NP + MSPEC(1,I) + MSPEC(3,I)
   20   CONTINUE
        CALL EISEQ(NMSUB, LNPAR, NPAR, NP, 1, HEAD, ERROR(4), LNPAR)
C
        IF (.NOT.ERROR(4)) THEN
          CALL EISGE(NMSUB, LNPARE, NPARE, 1, 2, HEAD, ERROR(5), LONE)
          CALL ERVGT(NMSUB, LSTEP, STP, LSTP, 0.0D0, 0, HEAD, 6, NV,
     +      ERROR(8), LZERO)
          CALL ERVGT(NMSUB, LSCL, SCALE, LSCALE, 0.0D0, 0, HEAD, 6, NV,
     +      ERROR(12), LZERO)
          IF (SAVE .AND. (.NOT.ERROR(5)))
     +      CALL EISGE(NMSUB, LIVCV, IVCV, NPARE, 3, HEAD, ERROR(15),
     +      LNPARE)
        END IF
      END IF
C
      IF ((.NOT.ERROR(1)) .AND. (.NOT.ERROR(2)) .AND. (.NOT.ERROR(3))
     +   .AND. (.NOT.ERROR(4)) .AND. (.NOT.ERROR(5)))
     +   CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERROR(6),
     +   LLDS)
C
      DO 30 I=1,20
         IF (ERROR(I)) GO TO 40
   30 CONTINUE
      RETURN
C
   40 CONTINUE
      IERR = 1
      RETURN
C
      END
*CMPFD
      SUBROUTINE CMPFD(N,STP,PVSTP,PV,FD)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES A FINITE DIFFERENCE DERIVATIVE,
C     ASSUMING THAT IF THE DIFFERENCE BETWEEN PVSTP(I) AND PV(I) IS
C     SMALL ENOUGH THE DERIVATIVE IS ZERO.
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JUNE 30, 1987
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   STP
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   FD(*),PV(*),PVSTP(*)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   FPLRS
      INTEGER
     +   I
C
C  EXTERNAL FUNCTIONS
CCCCC DOUBLE PRECISION
CCCCC+   D1MACH
CCCCC EXTERNAL D1MACH
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        AN INDEX VARIABLE.
C     DOUBLE PRECISION FD(N)
C        THE FINITE-DIFFERENCE DERIVATIVE.
C     DOUBLE PRECISION FPLRS
C        THE FLOATING POINT LARGEST RELATIVE SPACING.
C     DOUBLE PRECISION PV(N)
C        THE PREDICTED VALUES AT THE CURRENT PARAMETER VALUE.
C     DOUBLE PRECISION PVSTP(N)
C        THE PREDICTED VALUES AT THE CURRENT PARAMETER VALUE PLUS STP.
C     DOUBLE PRECISION STP
C        THE STEP.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      FPLRS = D1MACH(4)
C
      DO 10 I=1,N
         FD(I) = PVSTP(I) - PV(I)
         IF (ABS(FD(I)).GE.5*FPLRS*MIN(ABS(PVSTP(I)),ABS(PV(I)))) THEN
            FD(I) = FD(I) / STP
         ELSE
            FD(I) = 0.0D0
         END IF
   10 CONTINUE
      RETURN
      END
*ERSLFS
      SUBROUTINE ERSLFS(NMSUB, FC, K, HEAD, ERROR)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE PERFORMS ERROR CHECKING FOR THE INPUT
C     VALUES USED TO SPECIFY SYMMETRIC LINEAR FILTERING OF A
C     TIME SERIES
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  NOVEMBER 26, 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   FC
      INTEGER
     +   K
      LOGICAL
     +   ERROR,HEAD
C
C  ARRAY ARGUMENTS
      CHARACTER
     +   NMSUB(6)*1
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   TEMP
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERROR
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     DOUBLE PRECISION FC
C        THE USER SUPPLIED CUTOFF FREQUENCY.
C     LOGICAL HEAD
C        A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED
C        (TRUE) OR NOT (FALSE).  IF A HEADING IS PRINTED, THE VALUE
C        OF HEAD WILL BE CHANGED TO FALSE.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER K
C        THE NUMBER OF TERMS IN THE FILTER.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THE CALLING SUBROUTINE.
C     DOUBLE PRECISION TEMP
C        A TEMPORARY VARIABLE USED FOR TYPE CONVERSION.
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      ERROR = .FALSE.
      TEMP = K
C
      IF (FC - 1.0D0/TEMP .GE. 0.0D0) GO TO 10
C
      CALL EHDR(NMSUB, HEAD)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
C
      WRITE (ICOUT, 1010)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1011)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1012) FC, K
      CALL DPWRST('XXX','BUG ')
      ERROR = .TRUE.
      RETURN
C
   10 CONTINUE
C
      IF (FC + 1.0D0/K .LT. 0.5D0) RETURN
C
      CALL EHDR(NMSUB, HEAD)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1020)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1021)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1022) FC, K
      CALL DPWRST('XXX','BUG ')
      ERROR = .TRUE.
      RETURN
C
C     FORMAT STATEMENTS
C
  999 FORMAT(1X)
 1010 FORMAT (
     +   ' THE CUTOFF FREQUENCY, FC, MINUS ONE',
     +   ' OVER THE NUMBER OF FILTER TERMS, K, THAT')
 1011 FORMAT (
     +   ' IS, FC - 1/K, MUST BE GREATER THAN OR EQUAL TO ZERO.',
     +   ' THE INPUT VALUES OF FC AND K')
 1012 FORMAT (
     +   ' ARE', F8.5, ' AND', I5, ', RESPECTIVELY.')
 1020 FORMAT (
     +   ' THE CUTOFF FREQUENCY, FC, PLUS ONE',
     +   ' OVER THE NUMBER OF FILTER TERMS, K, THAT IS')
 1021 FORMAT (
     +   ' FC + 1/K, MUST BE LESS THAN 0.5.',
     +   '  THE INPUT VALUES OF FC AND K')
 1022 FORMAT (
     +   ' ARE', F7.5, ' AND', I5, ', RESPECTIVELY.')
C
      END
*LDSCMP
      SUBROUTINE LDSCMP (NARR, NLOG, NINT, NREAL, NDBL, NCMP,
     +   FLAG, NFP, LDSMIN)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     COMPUTES LDSMIN, THE MINIMUM NUMBER OF DOUBLE PRECISION LOCATIONS
C     NEEDED BY THE FRAMEWORK TO STORE NARR ARRAYS, COMPRISING NLOG
C     LOGICAL LOCATIONS, NINT INTEGER LOCATIONS, NREAL REAL LOCATIONS,
C     NDBL DOUBLE PRECISION LOCATIONS, AND NCMP COMPLEX LOCATIONS,
C     TOGETHER WITH THE NOVER OVERHEAD INTEGER LOCATIONS THAT THE
C     FRAMEWORK ALWAYS USES AND THE 3 OVERHEAD LOCATIONS THAT IT USES
C     PER ARRAY STORED.  (ALL THE LOCATIONS ARE ASSIGNED OUT OF THE
C     LABELED COMMON CSTAK, USING A STACK DISCIPLINE.)
C
C     IT IS ASSUMED, BASED UPON THE FORTRAN STANDARD (ANSI X3.9 1966),
C     THAT DOUBLE PRECISION AND COMPLEX DATA ELEMENTS ARE TWICE AS LONG
C     AS INTEGER AND LOGICAL ELEMENTS.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 7, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   LDSMIN,NARR,NCMP,NDBL,NFP,NINT,NLOG,NREAL
      CHARACTER
     +   FLAG*1
C
C  LOCAL SCALARS
      INTEGER
     +   NOVER
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     CHARACTER*1 FLAG
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE NFP
C        ELEMENTS ARE REAL OR DOUBLE PRECISION, WHERE FLAG=S INDICATES
C        THE NFP ELEMENTS ARE REAL (SINGLE PRECISION), AND FLAG=D
C        INDICATES THE ELEMENTS ARE DOUBLE PRECISION.
C     INTEGER LDSMIN
C        OUTPUT PARAMETER.  THE MINIMUM NUMBER OF DOUBLE PRECISION
C        LOCATIONS IN CSTAK REQUIRED FOR THE QUANTITIES OF ARRAY
C        ELEMENTS AND ARRAYS SPECIFIED BY THE INPUT PARAMETERS.
C     INTEGER NARR
C        INPUT PARAMETER.  THE NUMBER OF ARRAYS TO BE STORED IN CSTAK.
C     INTEGER NCMP
C        INPUT PARAMETER.  THE NUMBER OF COMPLEX ELEMENTS IN THE
C        ARRAYS TO BE STORED IN CSTAK.
C     INTEGER NDBL
C        INPUT PARAMETER.  THE NUMBER OF DOUBLE PRECISION ELEMENTS IN
C        THE ARRAYS TO BE STORED, IN CSTAK.
C     INTEGER NFP
C        THE NUMBER OF ELEMENTS WHICH DEPEND ON THE PRECISION OF THE
C        VERSION OF STARPAC BEING USED.
C     INTEGER NINT
C        INPUT PARAMETER.  THE NUMBER OF INTEGER ELEMENTS IN THE
C        ARRAYS TO BE STORED IN CSTAK.
C     INTEGER NLOG
C        INPUT PARAMETER.  THE NUMBER OF LOGICAL ELEMENTS IN THE
C        ARRAYS TO BE STORED IN CSTAK.
C     INTEGER NOVER
C        THE NUMBER OF INTEGER LOCATIONS THAT THE FRAMEWORK ALWAYS
C        USES FOR OVERHEAD PURPOSES.
C     INTEGER NREAL
C        INPUT PARAMETER.  THE NUMBER OF REAL ELEMENTS IN THE ARRAYS
C        TO BE STORED IN CSTAK.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     DEFINE CONSTANTS
C
      DATA NOVER /10/
C
C     COMMENCE BODY OF ROUTINE
C
      LDSMIN = (NLOG + NINT + NREAL + 3*NARR + NOVER + 1)/2
     +       + NDBL + NCMP
      IF (FLAG.EQ.'S') THEN
         LDSMIN = LDSMIN + (NFP+1)/2
      ELSE
         LDSMIN = LDSMIN + NFP
      END IF
      RETURN
      END
*MODSUM
      SUBROUTINE MODSUM(NFAC, MSPECT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRINTS THE MODEL SUMMARY FOR THE ARIMA ROUTINES
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JANUARY 4, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   NFAC
C
C  ARRAY ARGUMENTS
      INTEGER
     +   MSPECT(NFAC,4)
C
C  LOCAL SCALARS
CCCCC INTEGER
CCCCC+   I,J
C
C  EXTERNAL SUBROUTINES
CCCCC EXTERNAL IPRINT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER NFAC
C        THE NUMBER OF FACTORS IN THE MODEL
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER J
C        AN INDEX VARIABLE.
C     INTEGER MSPECT(NFAC,4)
C        THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
C
CCCCC CALL IPRINT(IPRT)
C
C     PRINT MODEL SPECIFICATION
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT, 1002)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT, 1003)
      CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
      DO1005I=1,NFAC
        WRITE(ICOUT, 1004)I,(MSPECT(I,J),J=1,4)
        CALL DPWRST('XXX','BUG ')
 1005 CONTINUE
C
      RETURN
C
C     FORMAT STATEMENTS
C
  999 FORMAT(1X)
 1002 FORMAT(
     +   '    MODEL SPECIFICATION')
 1003 FORMAT(
     +   '       FACTOR          (P     D     Q)    S')
 1004 FORMAT(
     +   (7X, I6, 6X, 4I6))
      END
*QAPPLY
      SUBROUTINE QAPPLY(NN, N, P, J, R, IERR)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C  VARIABLE DECLARATIONS
C
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IERR,N,NN,P
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   J(NN,P),R(N)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   T
      INTEGER
     +   I,K,L,NL1
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DOTPRD
      EXTERNAL DOTPRD
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS
C
C     *****PARAMETERS.
C     INTEGER NN, N, P, IERR
C     DOUBLE PRECISION J(NN,P), R(N)
C
C     =================================================================
C
C     *****PURPOSE.
C     THIS SUBROUTINE APPLIES TO R THE ORTHOGONAL TRANSFORMATIONS
C     STORED IN J BY QRFACT
C
C     *****PARAMETER DESCRIPTION.
C     ON INPUT.
C
C        NN IS THE ROW DIMENSION OF THE MATRIX J AS DECLARED IN
C             THE CALLING PROGRAM DIMENSION STATEMENT
C
C        N IS THE NUMBER OF ROWS OF J AND THE SIZE OF THE VECTOR R
C
C        P IS THE NUMBER OF COLUMNS OF J AND THE SIZE OF SIGMA
C
C        J CONTAINS ON AND BELOW ITS DIAGONAL THE COLUMN VECTORS
C             U WHICH DETERMINE THE HOUSEHOLDER TRANSFORMATIONS
C             IDENT - U*U.TRANSPOSE
C
C        R IS THE RIGHT HAND SIDE VECTOR TO WHICH THE ORTHOGONAL
C             TRANSFORMATIONS WILL BE APPLIED
C
C        IERR IF NON-ZERO INDICATES THAT NOT ALL THE TRANSFORMATIONS
C             WERE SUCCESSFULLY DETERMINED AND ONLY THE FIRST
C             ABS(IERR) - 1 TRANSFORMATIONS WILL BE USED
C
C     ON OUTPUT.
C
C        R HAS BEEN OVERWRITTEN BY ITS TRANSFORMED IMAGE
C
C     *****APPLICATION AND USAGE RESTRICTIONS.
C     NONE
C
C     *****ALGORITHM NOTES.
C     THE VECTORS U WHICH DETERMINE THE HOUSEHOLDER TRANSFORMATIONS
C     ARE NORMALIZED SO THAT THEIR 2-NORM SQUARED IS 2.  THE USE OF
C     THESE TRANSFORMATIONS HERE IS IN THE SPIRIT OF (1).
C
C     *****SUBROUTINES AND FUNCTIONS CALLED.
C
C     DOTPRD - FUNCTION, RETURNS THE INNER PRODUCT OF VECTORS
C
C     *****REFERENCES.
C     (1) BUSINGER, P. A., AND GOLUB, G. H. (1965), LINEAR LEAST SQUARES
C        SOLUTIONS BY HOUSEHOLDER TRANSFORMATIONS, NUMER. MATH. 7,
C        PP. 269-276.
C
C     *****HISTORY.
C     DESIGNED BY DAVID M. GAY, CODED BY STEPHEN C. PETERS (WINTER 1977)
C
C     *****GENERAL.
C
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989.
C
C     =================================================================
C
C     *****LOCAL VARIABLES.
C     INTEGER I, K, L, NL1
C     DOUBLE PRECISION T
C/
C     *****FUNCTIONS.
C     EXTERNAL DOTPRD
C     DOUBLE PRECISION DOTPRD
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      K = P
      IF (IERR .NE. 0) K = ABS(IERR) - 1
      IF ( K .EQ. 0) GO TO 999
C
      DO 20 L = 1, K
         NL1 = N - L + 1
         T = -DOTPRD(NL1, J(L,L), R(L))
C
         DO 10 I = L, N
            R(I) = R(I) + T*J(I,L)
 10      CONTINUE
 20   CONTINUE
 999  RETURN
C     ==== LAST CARD OF QAPPLY =========================================
      END
*STPADJ
      SUBROUTINE STPADJ(XM, N, M, IXM, MDL, PAR, NPAR,
     +   NEXMPT, STP, NFAIL, IFAIL, J, RELTOL, ABSTOL, STPLOW, STPMID,
     +   STPUP, ITEMP, FD, FDLAST, PV, PVNEW)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE ADJUSTS THE SELECTED STEP SIZES TO OPTIMAL
C     VALUES.
C
C     WRITTEN BY  -  ROBERT B. SCHNABEL (CODED BY JANET R. DONALDSON)
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  APRIL 2, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   ABSTOL,RELTOL,STP,STPLOW,STPMID,STPUP
      INTEGER
     +   IXM,J,M,N,NEXMPT,NFAIL,NPAR
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   FD(N),FDLAST(N),PAR(NPAR),PV(N),PVNEW(N),XM(IXM,M)
      INTEGER
     +   IFAIL(N),ITEMP(N)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL MDL
C
C  SCALARS IN COMMON
      DOUBLE PRECISION
     +   Q
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   FACTOR,STPNEW,TEMP
      INTEGER
     +   NCOUNT
      LOGICAL
     +   DONE,FIRST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL CMPFD,ICOPY,RELCOM,DCOPY
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,SIGN
C
C  COMMON BLOCKS
      COMMON /NOTOPT/Q
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION ABSTOL
C        THE ABSOLUTE AGREEMENT TOLERANCE.
C     LOGICAL DONE
C        THE VARIABLE USED TO INDICATE WHETHER THE ADJUSTMENT
C        PROCESS IS COMPLETE OR NOT.
C     DOUBLE PRECISION FACTOR
C        A FACTOR USED IN COMPUTING THE STEP SIZE.
C     DOUBLE PRECISION FD(N)
C        THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE
C        DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER
C     DOUBLE PRECISION FDLAST(N)
C        THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE
C        DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER
C        COMPUTED WITH THE MOST RECENT STEP SIZE SELECTED.
C     LOGICAL FIRST
C        THE VARIABLE USED TO INDICATE WHETHER THIS STEP SIZE
C        IS BEING USED FOR THE FIRST TIME OR WHETHER IT HAS BEEN
C        PREVIOUSLY ADJUSTED.
C     INTEGER IFAIL(N)
C        AN INDICATOR VECTOR USED TO DESIGNATE THOSE OBSERVATIONS
C        FOR WHICH THE STEP SIZE DOES NOT MEET THE CRITERIA.
C     INTEGER ITEMP(N)
C        A TEMPORARY VECTOR USED FOR STORING PAST VALUES OF ITEMP.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER J
C        THE INDEX OF THE PARAMETER BEING EXAMINED.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     EXTERNAL MDL
C        THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE
C        PREDICTED VALUES BASED ON THE CURRENT PARAMETER ESTIMATES.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NPAR
C        THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL.
C     INTEGER NCOUNT
C        THE NUMBER OF OBSERVATIONS AT WHICH THE NEW STEP SIZE DOES
C        SATISFY THE CRITERIA.
C     INTEGER NEXMPT
C        THE NUMBER OF OBSERVATIONS FOR WHICH A GIVEN STEP SIZE
C        DOES NOT HAVE TO BE SATISFACTORY AND THE SELECTED STEP
C        SIZE STILL BE CONSIDERED OK.
C     INTEGER NFAIL
C        A VECTOR CONTAINING FOR EACH OBSERVATION THE NUMBER OF
C        OBSERVATIONS FOR WHICH THE STEP SIZE DID NOT MEET THE CRITERIA.
C     DOUBLE PRECISION PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
C        PARAMETERS ARE STORED.
C     DOUBLE PRECISION PV(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     DOUBLE PRECISION PVNEW(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C        FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J)+STPCD.
C     DOUBLE PRECISION Q
C        A DUMMY VARIABLE WHICH IS USED, ALONG WITH COMMON NOTOPT (NO
C        OPTIMIZATION), TO COMPUTE THE STEP SIZE.
C     DOUBLE PRECISION RELTOL
C        THE RELATIVE AGREEMENT TOLERANCE.
C     DOUBLE PRECISION STP
C        THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FORWARD
C        DIFFERENCE APPROXIMATION TO THE DERIVATIVE.
C     DOUBLE PRECISION STPLOW
C        THE LOWER LIMIT ON THE STEP SIZE.
C     DOUBLE PRECISION STPMID
C        THE MIDPOINT OF THE ACCEPTABLE RANGE OF THE STEP SIZE.
C     DOUBLE PRECISION STPNEW
C        THE VALUE OF THE NEW STEP SIZE BEING TESTED.
C     DOUBLE PRECISION STPUP
C        THE UPPER LIMIT ON THE STEP SIZE.
C     DOUBLE PRECISION TEMP
C        A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE JTH
C        PARAMETER IS STORED.
C     DOUBLE PRECISION XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      CALL ICOPY(N, IFAIL, 1, ITEMP, 1)
      NCOUNT = NFAIL
C
      IF ((STPLOW.LE.ABS(STP)) .AND. (ABS(STP).LE.STPUP)) RETURN
C
      IF (ABS(STP).GT.STPMID) THEN
C
            STPNEW = STPUP * SIGN(1.0D0, PAR(J))
            FACTOR = 10.0D0
      ELSE
C
            STPNEW = STPLOW * SIGN(1.0D0, PAR(J))
            FACTOR = 0.1D0
C
      END IF
C
      Q = STPNEW + PAR(J)
      STPNEW = Q - PAR(J)
C
      DONE = .FALSE.
      FIRST = .TRUE.
C
C     REPEAT STATEMENTS 60 TO 130 UNTIL (DONE)
C
   60 CONTINUE
C
         CALL DCOPY(N, FD, 1, FDLAST, 1)
C
         TEMP = PAR(J)
         PAR(J) = TEMP + STPNEW
         CALL MDL(PAR, NPAR, XM, N, M, IXM, PVNEW)
         PAR(J) = TEMP
C
         CALL CMPFD(N, STPNEW, PVNEW, PV, FD)
C
         CALL RELCOM(N, FD, FDLAST, RELTOL, ABSTOL, NCOUNT, ITEMP)
C
         IF (NCOUNT.LE.NEXMPT) THEN
               DONE = .TRUE.
               CALL ICOPY(N, ITEMP, 1, IFAIL, 1)
               NFAIL = NCOUNT
C
               IF (FIRST) THEN
                     STP = STPNEW
               ELSE
                     STP = STPNEW / FACTOR
               END IF
C
         ELSE
C
               FIRST = .FALSE.
               STPNEW = STPNEW * FACTOR
               Q = STPNEW + PAR(J)
               STPNEW = Q - PAR(J)
C
               IF ((FACTOR.GT.1.0D0 .AND. ABS(STPNEW).GT.ABS(STP))
     +            .OR.
     +            (FACTOR.LT.1.0D0 .AND. ABS(STPNEW).LT.ABS(STP)))
     +            DONE = .TRUE.
          END IF
C
      IF (DONE) THEN
         RETURN
      ELSE
         GO TO 60
      END IF
C
      END
*AMEFIN
      SUBROUTINE AMEFIN(Y, WEIGHT, NNZW, WT, LWT, XM, N, M, IXM, IFIXD,
     +   PAR, NPAR, NPARE, RES, PAGE, WIDE, IPTOUT, NDIGIT, RSSHLF, RSD,
     +   PVT, SDPVT, SDREST, RD, VCVL, LVCVL, D, AMEHDR, IVCVPT, ISKULL,
     +   NRESTS)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPLETES THE ANALYSIS FOR THE NONLINEAR
C     LEAST SQUARES ESTIMATION ROUTINES ONCE THE ESTIMATES
C     HAVE BEEN FOUND.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 2, 1985
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   RSD,RSSHLF
      INTEGER
     +   IVCVPT,IXM,LVCVL,LWT,M,N,NDIGIT,NNZW,NPAR,NPARE,NRESTS
      LOGICAL
     +   PAGE,WEIGHT,WIDE
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   D(N,*),PAR(*),PVT(*),RD(*),RES(*),SDPVT(*),SDREST(*),VCVL(*),
     +   WT(*),XM(IXM,*),Y(*)
      INTEGER
     +   IFIXD(*),IPTOUT(*),ISKULL(10)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL AMEHDR
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   COND,RSS,YSS
      INTEGER
     +   I,IDF
      LOGICAL
     +   EXACT,PRTFSM
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMEOUT,NLCMP
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION COND
C        THE CONDITION NUMBER OF D.
C     DOUBLE PRECISION D(N,NPAR)
C        THE FIRST DERIVATIVE OF THE MODEL (JACOBIAN).
C     LOGICAL EXACT
C        AN INDICATOR VALUE USED TO DESIGNATE WHETHER THE FIT
C        WAS EXACT TO MACHINE PRECISION (TRUE) OR NOT (FALSE).
C     EXTERNAL AMEHDR
C        THE ROUTINE USED TO PRINT THE HEADING
C     INTEGER IDF
C        THE DEGREES OF FREEDOM IN THE FIT.
C     INTEGER IERR
C        THE VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .GE. 1, ERRORS WERE DETECTED.
C     INTEGER IFIXD(NPAR)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE
C        PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED.
C        IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED.
C        IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED.
C     INTEGER IPTOUT(NDIGIT)
C        THE VARIABLE USED TO CONTROL PRINTED OUTPUT FOR EACH SECTION.
C     INTEGER ISKULL(10)
C        AN ERROR MESSAGE INDICATOR VARIABLE.
C     INTEGER IVCVPT
C        AN INDICATOR VALUE USED TO DESIGNATE WHICH FORM OF THE
C        VARIANCE COVARIANCE MATRIX (VCV) IS BEING PRINTED, WHERE
C        IVCVPT = 1 INDICATES THE VCV WAS COMPUTED AS
C                   INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN)
C        IVCVPT = 2 INDICATES THE VCV WAS COMPUTED AS
C                   INVERSE(HESSIAN)
C        IVCVPT = 3 INDICATES THE VCV WAS COMPUTED AS
C                   INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN
C                       *INVERSE(HESSIAN)
C     INTEGER IXM
C        THE FIRST DIMENSION OF MATRIX XM.
C     INTEGER LVCVL
C        THE DIMENSION OF VECTOR VCVL.
C     INTEGER LWT
C        THE DIMENSION OF VECTOR WT.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NDIGIT
C        THE NUMBER OF DIGITS IN THE PRINT CONTROL VALUE.
C     INTEGER NNZW
C        THE NUMBER OF NON ZERO WEIGHTS.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     INTEGER NPARE
C        THE NUMBER OF PARAMETERS TO BE OPTIMIZED.
C     INTEGER NRESTS
C        THE MAXIMUM NUMBER OF RESIDUALS TO BE COMPUTED.
C     LOGICAL PAGE
C        THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF
C        THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     LOGICAL PRTFSM
C        THE VARIABLE USED TO INDICATE WHETHER ANY OF THE SUMMARY
C        INFORMATION IS TO BE PRINTED (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION PVT(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES.
C     DOUBLE PRECISION RD(N)
C        THE DIAGONAL ELEMENTS OF THE R MATRIX OF THE Q - R
C        FACTORIZATION OF D.
C     DOUBLE PRECISION RES(N)
C        THE RESIDUALS FROM THE FIT.
C     DOUBLE PRECISION RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     DOUBLE PRECISION RSS
C        THE RESIDUAL SUM OF SQUARES.
C     DOUBLE PRECISION RSSHLF
C        HALF THE RESIDUAL SUM OF SQUARES.
C     DOUBLE PRECISION SDPVT(N)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     DOUBLE PRECISION SDREST(N)
C        THE STANDARDIZED RESIDUALS.
C     DOUBLE PRECISION VCVL(LVCVL)
C        THE LOWER HALF OF THE VARIANCE-COVARIANCE MATRIX, STORED
C        ROW WISE.
C     LOGICAL WEIGHT
C        THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO
C        BE PERFORMED (TRUE) OR NOT (FALSE).
C     LOGICAL WIDE
C        THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD
C        BE FULL WIDTH (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION WT(LWT)
C        THE USER SUPPLIED WEIGHTS.
C     DOUBLE PRECISION XM(IXM,M)
C        THE INDEPENDENT VARIABLE.
C     DOUBLE PRECISION Y(N)
C        THE DEPENDENT VARIABLE.
C     DOUBLE PRECISION YSS
C        THE SUM OF THE SQUARES ABOUT THE MEAN Y VALUE.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     MODIFY VCV TO REFLECT PROPER DEGREES OF FREEDOM
C
      DO 10 I=1,LVCVL
         VCVL(I) = (NRESTS-NPAR)*VCVL(I)/(N-NPAR)
   10 CONTINUE
C
C     COMPUTE RETURNED AND/OR PRINTED VALUES.
C
      CALL NLCMP (Y, WEIGHT, WT, LWT, N, NPAR, NPARE, RES,
     +   D, RD, COND, VCVL, LVCVL, NNZW, IDF, RSSHLF, RSS, RSD, YSS,
     +   EXACT, PVT, SDPVT, SDREST, ISKULL)
C
      PRTFSM = ((IPTOUT(3).NE.0) .OR. (IPTOUT(4).NE.0) .OR.
     +   (IPTOUT(5).NE.0) .OR. (IERR.NE.0))
C
C     PRINT SUMMARY INFORMATION IF DESIRED OR IF AN ERROR FLAG
C     HAS BEEN SET.
C
      IF (PRTFSM) CALL AMEOUT(Y, N,
     +   IFIXD, PAR, NPAR, NPARE, RES, IPTOUT, NDIGIT, PAGE, IDF, COND,
     +   RSS, RSD, YSS, EXACT, PVT, SDPVT, SDREST, VCVL, LVCVL, IVCVPT,
     +   ISKULL, AMEHDR, WIDE)
      RETURN
C
      END
*COVCLC
      SUBROUTINE COVCLC(COVIRC, D, IV, J, N, NN, P, R, V, X)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C  ***  COMPUTE COVARIANCE MATRIX FOR NL2ITR (NL2SOL VERSION 2.2)  ***
C
C  ***  LET K = ABS(IV(COVREQ).  FOR K .LE. 2, A FINITE-DIFFERENCE
C  ***  HESSIAN H IS COMPUTED (USING FUNC. AND GRAD. VALUES IF
C  ***  IV(COVREQ) IS NONNEGATIVE, AND USING ONLY FUNC. VALUES IF
C  ***  IV(COVREQ) IS NEGATIVE).  FOR SCALE = 2*F(X) / MAX(1, N-P),
C  ***  WHERE 2*F(X) IS THE RESIDUAL SUM OF SQUARES, COVCLC COMPUTES...
C  ***             K = 0 OR 1...  SCALE * H**-1 * (J**T * J) * H**-1.
C  ***             K = 2...  SCALE * H**-1.
C  ***             K .GE. 3...  SCALE * (J**T * J)**-1.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   COVIRC,N,NN,P
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   D(P),J(NN,P),R(N),V(1),X(P)
      INTEGER
     +   IV(1)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   DEL,HALF,NEGPT5,ONE,T,TWO,WK,ZERO
      INTEGER
     +   COV,COVMAT,COVREQ,DELTA,DELTA0,DLTFDC,F,FX,G,G1,GP,GSAVE1,
     +   H,HC,HMI,HPI,HPM,I,IERR,IP1,IPIV0,IPIVI,IPIVK,IPIVOT,IRC,
     +   K,KAGQT,KALM,KIND,KL,L,LMAT,M,MM1,MM1O2,MODE,NFGCAL,PP1O2,
     +   QTR,QTR1,RD,RD1,RSAVE,SAVEI,STP0,STPI,STPM,SWITCH,TOOBIG,
     +   W,W0,W1,WL,XMSAVE
      LOGICAL
     +   HAVEJ
C
C  EXTERNAL SUBROUTINES
      EXTERNAL LINVRT,LITVMU,LIVMUL,LSQRTZ,LTSQAR,QRFACT,VCOPY,VSCOPY
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MAX
C
C  ***  PARAMETER DECLARATIONS  ***
C
C     INTEGER COVIRC, IV(1), N, NN, P
C     DOUBLE PRECISION D(P), J(NN,P), R(N), V(1), X(P)
C     DIMENSION IV(*), V(*)
C
C  ***  LOCAL VARIABLES  ***
C
C     LOGICAL HAVEJ
C     INTEGER COV, GP, GSAVE1, G1, HC, HMI, HPI, HPM, I, IPIVI, IPIVK,
C    1        IP1, IRC, K, KIND, KL, L, M, MM1, MM1O2, PP1O2, QTR1,
C    2        RD1, STPI, STPM, STP0, WL, W0, W1
C     DOUBLE PRECISION DEL, HALF, NEGPT5, ONE, T, TWO, WK, ZERO
C
C/
C  ***  EXTERNAL SUBROUTINES  ***
C
C     EXTERNAL LINVRT, LITVMU, LIVMUL, LSQRTZ, LTSQAR, QRFACT,
C    1         VCOPY, VSCOPY
C
C LINVRT... INVERT LOWER TRIANGULAR MATRIX.
C LITVMU... APPLY INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX.
C LIVMUL... APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX.
C LSQRTZ.... COMPUTE CHOLESKY FACTOR OF (LOWER TRINAG. OF) A SYM. MATRIX.
C LTSQAR... GIVEN LOWER TRIANG. MATRIX L, COMPUTE (L**T)*L.
C QRFACT... COMPUTE QR DECOMPOSITION OF A MATRIX.
C VCOPY.... COPY ONE VECTOR TO ANOTHER.
C VSCOPY... SET ALL ELEMENTS OF A VECTOR TO A SCALAR.
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
C     INTEGER COVMAT, COVREQ, DELTA, DELTA0, DLTFDC, F, FX, G, H, IERR,
C    1        IPIVOT, IPIV0, KAGQT, KALM, LMAT, MODE, NFGCAL, QTR,
C    2        RD, RSAVE, SAVEI, SWITCH, TOOBIG, W, XMSAVE
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA HALF/0.5D0/, NEGPT5/-0.5D0/, ONE/1.0D0/, TWO/2.0D0/,
     +     ZERO/0.0D0/
C
      DATA COVMAT/26/, COVREQ/15/, DELTA/50/, DELTA0/44/,
     +     DLTFDC/40/, F/10/, FX/46/, G/28/, H/44/, IERR/32/,
     +     IPIVOT/61/, IPIV0/60/, KAGQT/35/, KALM/36/,
     +     LMAT/58/, MODE/38/, NFGCAL/7/, QTR/49/,
     +     RD/51/, RSAVE/52/, SAVEI/54/, SWITCH/12/,
     +     TOOBIG/2/, W/59/, XMSAVE/49/
C
C+++++++++++++++++++++++++++++++  BODY  ++++++++++++++++++++++++++++++++
C
      COV = IV(LMAT)
C
      COVIRC = 4
      KIND = IV(COVREQ)
      M = IV(MODE)
      IF (M .GT. 0) GO TO 10
         IV(KAGQT) = -1
         IF (IV(KALM) .GT. 0) IV(KALM) = 0
         IF (ABS(KIND) .GE. 3) GO TO 300
         V(FX) = V(F)
         K = IV(RSAVE)
         CALL VCOPY(N, V(K), R)
 10   IF (M .GT. P) GO TO 200
      IF (KIND .LT. 0) GO TO 100
C
C  ***  COMPUTE FINITE-DIFFERENCE HESSIAN USING BOTH FUNCTION AND
C  ***  GRADIENT VALUES.
C
      GSAVE1 = IV(W) + P
      G1 = IV(G)
      IF (M .GT. 0) GO TO 15
C        ***  FIRST CALL ON COVCLC.  SET GSAVE = G, TAKE FIRST STEP  ***
         CALL VCOPY(P, V(GSAVE1), V(G1))
         IV(SWITCH) = IV(NFGCAL)
         GO TO 80
C
 15   DEL = V(DELTA)
      X(M) = V(XMSAVE)
      IF (IV(TOOBIG) .EQ. 0) GO TO 30
C
C     ***  HANDLE OVERSIZE V(DELTA)  ***
C
         IF (DEL*X(M) .GT. ZERO) GO TO 20
C             ***  WE ALREADY TRIED SHRINKING V(DELTA), SO QUIT  ***
              IV(COVMAT) = -2
              GO TO 190
C
C        ***  TRY SHRINKING V(DELTA)  ***
 20      DEL = NEGPT5 * DEL
         GO TO 90
C
 30   COV = IV(LMAT)
      GP = G1 + P - 1
C
C  ***  SET  G = (G - GSAVE)/DEL  ***
C
      DO 40 I = G1, GP
         V(I) = (V(I) - V(GSAVE1)) / DEL
         GSAVE1 = GSAVE1 + 1
 40      CONTINUE
C
C  ***  ADD G AS NEW COL. TO FINITE-DIFF. HESSIAN MATRIX  ***
C
      K = COV + M*(M-1)/2
      L = K + M - 2
      IF ( M .EQ. 1) GO TO 60
C
C  ***  SET  H(I,M) = 0.5 * (H(I,M) + G(I))  FOR I = 1 TO M-1  ***
C
      DO 50 I = K, L
         V(I) = HALF * (V(I) + V(G1))
         G1 = G1 + 1
 50      CONTINUE
C
C  ***  ADD  H(I,M) = G(I)  FOR I = M TO P  ***
C
 60   L = L + 1
      DO 70 I = M, P
         V(L) = V(G1)
         L = L + I
         G1 = G1 + 1
 70      CONTINUE
C
 80   M = M + 1
      IV(MODE) = M
      IF (M .GT. P) GO TO 190
C
C  ***  CHOOSE NEXT FINITE-DIFFERENCE STEP, RETURN TO GET G THERE  ***
C
      DEL = V(DELTA0) * MAX(ONE/D(M), ABS(X(M)))
      IF (X(M) .LT. ZERO) DEL = -DEL
      V(XMSAVE) = X(M)
 90   X(M) = X(M) + DEL
      V(DELTA) = DEL
      COVIRC = 2
      GO TO 999
C
C  ***  COMPUTE FINITE-DIFFERENCE HESSIAN USING FUNCTION VALUES ONLY.
C
 100  STP0 = IV(W) + P - 1
      MM1 = M - 1
      MM1O2 = M*MM1/2
      IF (M .GT. 0) GO TO 105
C        ***  FIRST CALL ON COVCLC.  ***
         IV(SAVEI) = 0
         GO TO 180
C
 105  I = IV(SAVEI)
      IF (I .GT. 0) GO TO 160
      IF (IV(TOOBIG) .EQ. 0) GO TO 120
C
C     ***  HANDLE OVERSIZE STEP  ***
C
         STPM = STP0 + M
         DEL = V(STPM)
         IF (DEL*X(XMSAVE) .GT. ZERO) GO TO 110
C             ***  WE ALREADY TRIED SHRINKING THE STEP, SO QUIT  ***
              IV(COVMAT) = -2
              GO TO 999
C
C        ***  TRY SHRINKING THE STEP  ***
 110     DEL = NEGPT5 * DEL
         X(M) = X(XMSAVE) + DEL
         V(STPM) = DEL
         COVIRC = 1
         GO TO 999
C
C  ***  SAVE F(X + STP(M)*E(M)) IN H(P,M)  ***
C
 120  PP1O2 = P * (P-1) / 2
      COV = IV(LMAT)
      HPM = COV + PP1O2 + MM1
      V(HPM) = V(F)
C
C  ***  START COMPUTING ROW M OF THE FINITE-DIFFERENCE HESSIAN H.  ***
C
      HMI = COV + MM1O2
      IF (MM1 .EQ. 0) GO TO 140
      HPI = COV + PP1O2
      DO 130 I = 1, MM1
         V(HMI) = V(FX) - (V(F) + V(HPI))
         HMI = HMI + 1
         HPI = HPI + 1
 130     CONTINUE
 140  V(HMI) = V(F) - TWO*V(FX)
C
C  ***  COMPUTE FUNCTION VALUES NEEDED TO COMPLETE ROW M OF H.  ***
C
      I = 1
C
 150  IV(SAVEI) = I
      STPI = STP0 + I
      V(DELTA) = X(I)
      X(I) = X(I) + V(STPI)
      IF (I .EQ. M) X(I) = V(XMSAVE) - V(STPI)
      COVIRC = 1
      GO TO 999
C
 160  X(I) = V(DELTA)
      IF (IV(TOOBIG) .EQ. 0) GO TO 170
C        ***  PUNT IN THE EVENT OF AN OVERSIZE STEP  ***
         IV(COVMAT) = -2
         GO TO 999
C
C  ***  FINISH COMPUTING H(M,I)  ***
C
 170  STPI = STP0 + I
      HMI = COV + MM1O2 + I - 1
      STPM = STP0 + M
      V(HMI) = (V(HMI) + V(F)) / (V(STPI)*V(STPM))
      I = I + 1
      IF (I .LE. M) GO TO 150
      IV(SAVEI) = 0
      X(M) = V(XMSAVE)
C
 180  M = M + 1
      IV(MODE) = M
      IF (M .GT. P) GO TO 190
C
C  ***  PREPARE TO COMPUTE ROW M OF THE FINITE-DIFFERENCE HESSIAN H.
C  ***  COMPUTE M-TH STEP SIZE STP(M), THEN RETURN TO OBTAIN
C  ***  F(X + STP(M)*E(M)), WHERE E(M) = M-TH STD. UNIT VECTOR.
C
      DEL = V(DLTFDC) * MAX(ONE/D(M), ABS(X(M)))
      IF (X(M) .LT. ZERO) DEL = -DEL
      V(XMSAVE) = X(M)
      X(M) = X(M) + DEL
      STPM = STP0 + M
      V(STPM) = DEL
      COVIRC = 1
      GO TO 999
C
C  ***  RESTORE R, V(F), ETC.  ***
C
 190  K = IV(RSAVE)
      CALL VCOPY(N, R, V(K))
      V(F) = V(FX)
      IF (KIND .LT. 0) GO TO 200
         IV(NFGCAL) = IV(SWITCH)
         QTR1 = IV(QTR)
         CALL VCOPY(N, V(QTR1), R)
         IF (IV(COVMAT) .LT. 0) GO TO 999
         COVIRC = 3
         GO TO 999
C
 200  COV = IV(LMAT)
C
C  ***  THE COMPLETE FINITE-DIFF. HESSIAN IS NOW STORED AT V(COV).   ***
C  ***  USE IT TO COMPUTE THE REQUESTED COVARIANCE MATRIX.           ***
C
C     ***  COMPUTE CHOLESKY FACTOR C OF H = C*(C**T)  ***
C     ***  AND STORE IT AT V(HC).  ***
C
      HC = COV
      IF (ABS(KIND) .EQ. 2) GO TO 210
         HC = ABS(IV(H))
         IV(H) = -HC
 210  CALL LSQRTZ(1, P, V(HC), V(COV), IRC)
      IV(COVMAT) = -1
      IF (IRC .NE. 0) GO TO 999
C
      W1 = IV(W) + P
      IF (ABS(KIND) .GT. 1) GO TO 350
C
C  ***  COVARIANCE = SCALE * H**-1 * (J**T * J) * H**-1  ***
C
      CALL VSCOPY(P*(P+1)/2, V(COV), ZERO)
      HAVEJ = IV(KALM) .EQ. (-1)
C     ***  HAVEJ = .TRUE. MEANS J IS IN ITS ORIGINAL FORM, WHILE
C     ***  HAVEJ = .FALSE. MEANS QRFACT HAS BEEN APPLIED TO J.
C
      M = P
      IF (HAVEJ) M = N
      W0 = W1 - 1
      RD1 = IV(RD)
      DO 290 I = 1, M
         IF (HAVEJ) GO TO 240
C
C        ***  SET W = IPIVOT * (ROW I OF R MATRIX FROM QRFACT).  ***
C
              CALL VSCOPY(P, V(W1), ZERO)
              IPIVI = IPIV0 + I
              L = W0 + IV(IPIVI)
              V(L) = V(RD1)
              RD1 = RD1 + 1
              IF (I .EQ. P) GO TO 260
              IP1 = I + 1
              DO 230 K = IP1, P
                   IPIVK = IPIV0 + K
                   L = W0 + IV(IPIVK)
                   V(L) = J(I,K)
 230               CONTINUE
              GO TO 260
C
C        ***  SET W = (ROW I OF J).  ***
C
 240     L = W0
         DO 250 K = 1, P
              L = L + 1
              V(L) = J(I,K)
 250          CONTINUE
C
C        ***  SET W = H**-1 * W.  ***
C
 260     CALL LIVMUL(P, V(W1), V(HC), V(W1))
         CALL LITVMU(P, V(W1), V(HC), V(W1))
C
C        ***  ADD  W * W**T  TO COVARIANCE MATRIX.  ***
C
         KL = COV
         DO 280 K = 1, P
              L = W0 + K
              WK = V(L)
              DO 270 L = 1, K
                   WL = W0 + L
                   V(KL) = V(KL)  +  WK * V(WL)
                   KL = KL + 1
 270               CONTINUE
 280          CONTINUE
 290     CONTINUE
      GO TO 380
C
C  ***  COVARIANCE = SCALE * (J**T * J)**-1.  ***
C
 300  RD1 = IV(RD)
      IF (IV(KALM) .NE. (-1)) GO TO 310
C
C        ***  APPLY QRFACT TO J  ***
C
         QTR1 = IV(QTR)
         CALL VCOPY(N, V(QTR1), R)
         W1 = IV(W) + P
         CALL QRFACT(NN, N, P, J, V(RD1), IV(IPIVOT), IV(IERR), 0,
     +               V(W1))
         IV(KALM) = -2
 310  IV(COVMAT) = -1
      IF (IV(IERR) .NE. 0) GO TO 999
      COV = IV(LMAT)
      HC = ABS(IV(H))
      IV(H) = -HC
C
C     ***  SET HC = (R MATRIX FROM QRFACT).  ***
C
      L = HC
      DO 340 I = 1, P
         IF (I .GT. 1) CALL VCOPY(I-1, V(L), J(1,I))
         L = L + I - 1
         V(L) = V(RD1)
         L = L + 1
         RD1 = RD1 + 1
 340     CONTINUE
C
C  ***  THE CHOLESKY FACTOR C OF THE UNSCALED INVERSE COVARIANCE MATRIX
C  ***  (OR PERMUTATION THEREOF) IS STORED AT V(HC).
C
C  ***  SET C = C**-1.
C
 350  CALL LINVRT(P, V(HC), V(HC))
C
C  ***  SET C = C**T * C.
C
      CALL LTSQAR(P, V(HC), V(HC))
C
      IF (HC .EQ. COV) GO TO 380
C
C     ***  C = PERMUTED, UNSCALED COVARIANCE.
C     ***  SET COV = IPIVOT * C * IPIVOT**T.
C
         DO 370 I = 1, P
              M = IPIV0 + I
              IPIVI = IV(M)
              KL = COV-1 + IPIVI*(IPIVI-1)/2
              DO 360 K = 1, I
                   M = IPIV0 + K
                   IPIVK = IV(M)
                   L = KL + IPIVK
                   IF (IPIVK .GT. IPIVI)
     +                       L = L + (IPIVK-IPIVI)*(IPIVK+IPIVI-3)/2
                   V(L) = V(HC)
                   HC = HC + 1
 360               CONTINUE
 370          CONTINUE
C
 380  IV(COVMAT) = COV
C
C  ***  APPLY SCALE FACTOR = (RESID. SUM OF SQUARES) / MAX(1,N-P).
C
      T = V(F) / (HALF * MAX(1,N-P))
      K = COV - 1 + P*(P+1)/2
      DO 390 I = COV, K
 390     V(I) = T * V(I)
C
 999  RETURN
C  ***  LAST CARD OF COVCLC FOLLOWS  ***
      END
*ERVGT
      SUBROUTINE ERVGT (NMSUB, NMVAR, VEC, N, VECLB, NVMX,
     +   HEAD, MSGTYP, NV, ERROR, NMMIN)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE CHECKS TO ENSURE THAT NO VALUES, OR ONLY A MAXIMUM
C     OF NVMX, ARE NOT GREATER THAN A SPECIFIED LOWER BOUND VECLB,
C     WITH NAME NMMIN. THE ROUTINE ALTERNATIVELY CHECKS TO MAKE SURE
C     THAT NO VALUES ARE IN VIOLATION OF THIS LOWER BOUND IF THE FIRST
C     VALUE IN THE VECTOR IS NOT.  THE CHECKING OPTION IS SPECIFIED
C     WITH MSGTYP.  IF AN ERROR IS FOUND, THE ERROR IS PRINTED AND
C     AN ERROR FLAG AND THE NUMBER OF VIOLATINS ARE RETURNED.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  OCTOBER 3, 1983
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   VECLB
      INTEGER
     +   MSGTYP,N,NV,NVMX
      LOGICAL
     +   ERROR,HEAD
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   VEC(*)
      CHARACTER
     +   NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I,NVMN
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ERVGTP
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MOD
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERROR
C        THE VALUE RETURNED FROM THE ERROR CHECKING ROUTINES TO INDICATE
C        WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT (FALSE).
C     LOGICAL HEAD
C        A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED (TRUE)
C        OR NOT (FALSE).
C     INTEGER I
C        AN INDEX ARGUMENT.
C     INTEGER MSGTYP
C        THE INDICATOR ARGUMENT FOR THE TYPE OF MESSAGE.
C        IF (MSGTYP.GE.4) THE MESSAGE PRINTED WILL USE NMMIN
C        OTHERWISE IT WILL USE VECLB.
C        IF (MSGTYP = 1 OR 4) NO VIOLATIONS ARE ALLOWED.
C        IF (MSGTYP = 2 OR 5) THE NUMBER OF VIOLATIONS MUST
C                             BE LESS THAN   NVMX   .
C        IF (MSGTYP = 3 OR 6) VIOLATIONS ARE COUNTED ONLY IF THE
C                             THE FIRST ELEMENT IS NOT IN VIOLATION.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     CHARACTER*1 NMMIN(8)
C        THE NAME OF THE ARGUMENT SPECIFYING THE MINIMUM.
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING SUBROUTINES NAME.
C     CHARACTER*1 NMVAR(8)
C        THE CHARACTERS OF THE ARGUMENTS NAME.
C     INTEGER NV
C        THE NUMBER OF VIOLATIONS FOUND.
C     INTEGER NVMN
C        THE SMALLEST NUMBER OF NON-VIOLATIONS ALLOWED.
C     INTEGER NVMX
C        THE LARGEST NUMBER OF VIOLATIONS ALLOWED.
C     DOUBLE PRECISION VEC(N)
C        THE VECTOR BEING TESTED.
C     DOUBLE PRECISION VECLB
C        THE VALUE THAT THE VECTOR IS BEING TESTED AGAINST.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      ERROR = .FALSE.
C
      IF (N .LE. 0) RETURN
C
C     TEST WHETHER TESTING IS NECESSRY
C
      IF ((MOD(MSGTYP,3) .EQ. 0) .AND. (VEC(1) .LE. VECLB)) RETURN
C
C     CHECK FOR VIOLATIONS
C
      NV = 0
      DO 5 I = 1, N
         IF ((VEC(I).LE.VECLB)) NV = NV + 1
    5 CONTINUE
C
      IF (NV .LE. NVMX) RETURN
C
C     VIOLATIONS FOUND
C
      ERROR = .TRUE.
      NVMN = N - NVMX
      CALL ERVGTP (NMSUB, NMVAR, VECLB, NVMN, NVMX, HEAD, MSGTYP, NV,
     +   NMMIN)
C
      RETURN
C
      END
*LINVRT
      SUBROUTINE LINVRT(N, LIN, L)
C
C  ***  COMPUTE  LIN = L**-1,  BOTH  N X N  LOWER TRIANG. STORED   ***
C  ***  COMPACTLY BY ROWS.  LIN AND L MAY SHARE THE SAME STORAGE.  ***
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   L(*),LIN(*)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   ONE,T,ZERO
      INTEGER
     +   I,II,IM1,J0,J1,JJ,K,K0,NP1
C
C  ***  PARAMETERS  ***
C
C     INTEGER N
C     DOUBLE PRECISION L(*), LIN(*)
C     DIMENSION L(N*(N+1)/2), LIN(N*(N+1)/2)
C
C  ***  LOCAL VARIABLES  ***
C
C     INTEGER I, II, IM1, JJ, J0, J1, K, K0, NP1
C     DOUBLE PRECISION ONE, T, ZERO
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ONE/1.0D0/, ZERO/0.0D0/
C
C  ***  BODY  ***
C
      NP1 = N + 1
      J0 = N*(NP1)/2
      DO 30 II = 1, N
         I = NP1 - II
         LIN(J0) = ONE/L(J0)
         IF (I .LE. 1) GO TO 999
         J1 = J0
         IM1 = I - 1
         DO 20 JJ = 1, IM1
              T = ZERO
              J0 = J1
              K0 = J1 - JJ
              DO 10 K = 1, JJ
                   T = T - L(K0)*LIN(J0)
                   J0 = J0 - 1
                   K0 = K0 + K - I
 10                CONTINUE
              LIN(J0) = T/L(K0)
 20           CONTINUE
         J0 = J0 - 1
 30      CONTINUE
 999  RETURN
C  ***  LAST CARD OF LINVRT FOLLOWS  ***
      END
*MULTBP
      SUBROUTINE MULTBP(T, LT, C, LC, TEMP, LTEMP, MBO)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE MULTIPLIES TOGETHER TWO DIFFERENCE FACTORS FROM A
C     (BOX-JENKINS) TIME SERIES MODEL.
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  AUGUST 1, 1985
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   LC,LT,LTEMP,MBO
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   C(MBO),T(2*MBO),TEMP(MBO)
C
C  LOCAL SCALARS
      INTEGER
     +   I,J,JI,K
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION C(MBO)
C        THE SECOND FACTOR ON INPUT AND THE EXPANDED FACTOR ON OUTPUT.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER J
C        AN INDEX VARIABLE.
C     INTEGER JI
C        AN INDEX VARIABLE
C     INTEGER K
C        AN INDEX VARIABLE.
C     INTEGER LC
C        THE LARGEST ORDER OF THE SECOND FACTOR ON INPUT, AND
C        THE LARGEST ORDER OF THE EXPANDED FACTOR ON OUTPUT.
C     INTEGER LT
C        THE LARGEST ORDER OF THE FIRST FACTOR.
C     INTEGER LTEMP
C        THE LENGTH OF THE VECTOR TEMP.
C     INTEGER MBO
C        THE MAXIMUM BACK ORDER OPERATOR.
C     DOUBLE PRECISION T(2*MBO)
C        A TEMPORARY WORK VECTOR.
C     DOUBLE PRECISION TEMP(MBO)
C        A TEMPORARY WORK VECTOR
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      IF (LC .EQ. 0) GO TO 15
      DO 10 J = 1, LC
         TEMP(J) = C(J)
   10 CONTINUE
   15 K = LC + 1
      DO 20 J=K,LTEMP
         TEMP(J) = 0.0D0
   20 CONTINUE
      IF (LT .EQ. 0) GO TO 50
      DO 40 J=1,LT
         TEMP(J) = TEMP(J) + T(J)
         IF (LC .EQ. 0) GO TO 40
         DO 30 I=1,LC
            JI = J + I
            TEMP(JI) = TEMP(JI) - C(I)*T(J)
   30    CONTINUE
   40 CONTINUE
C
   50 DO 60 J=1,LTEMP
         C(J) = TEMP(J)
   60 CONTINUE
      LC = LTEMP
      RETURN
      END
*QRFACT
      SUBROUTINE QRFACT(NM,M,N,QR,ALPHA,IPIVOT,IERR,NOPIVK,SUM)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C  ***  COMPUTE THE QR DECOMPOSITION OF THE MATRIX STORED IN QR  ***
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IERR,M,N,NM,NOPIVK
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   ALPHA(N),QR(NM,N),SUM(N)
      INTEGER
     +   IPIVOT(N)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   ALPHAK,BETA,ONE,P01,P99,QRKK,QRKMAX,RKTOL,RKTOL1,SIGMA,SUMJ,
     +   TEMP,UFETA,ZERO
      INTEGER
     +   I,J,JBAR,K,K1,MINUM,MK1
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DOTPRD,RMDCON,V2NORM
      EXTERNAL DOTPRD,RMDCON,V2NORM
C
C  EXTERNAL SUBROUTINES
      EXTERNAL VAXPY,VSCOPY
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MIN,SQRT
C
C     *****PARAMETERS.
C     INTEGER NM,M,N,IPIVOT(N),IERR,NOPIVK
C     DOUBLE PRECISION  QR(NM,N),ALPHA(N),SUM(N)
C     *****LOCAL VARIABLES.
C     INTEGER I,J,JBAR,K,K1,MINUM,MK1
C     DOUBLE PRECISION  ALPHAK,BETA,QRKK,QRKMAX,SIGMA,TEMP,UFETA,RKTOL,
C    1        RKTOL1,SUMJ
C     *****FUNCTIONS.
C/+
C     INTEGER MIN
C     DOUBLE PRECISION              ABS,SQRT
C/
C     EXTERNAL DOTPRD, RMDCON, VAXPY, VSCOPY, V2NORM
C     DOUBLE PRECISION DOTPRD, RMDCON, V2NORM
C DOTPRD... RETURNS INNER PRODUCT OF TWO VECTORS.
C RMDCON... RETURNS MACHINE-DEPENDENT CONSTANTS.
C VAXPY... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
C VSCOPY... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
C V2NORM... RETURNS THE 2-NORM OF A VECTOR.
C
C     *****CONSTANTS.
C     DOUBLE PRECISION ONE, P01, P99, ZERO
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ONE/1.0D0/, P01/0.01D0/, P99/0.99D0/, ZERO/0.0D0/
C
C
C     ==================================================================
C
C
C     *****PURPOSE.
C
C     THIS SUBROUTINE DOES A QR-DECOMPOSITION ON THE M X N MATRIX QR,
C        WITH AN OPTIONALLY MODIFIED COLUMN PIVOTING, AND RETURNS THE
C        UPPER TRIANGULAR R-MATRIX, AS WELL AS THE ORTHOGONAL VECTORS
C        USED IN THE TRANSFORMATIONS.
C
C     *****PARAMETER DESCRIPTION.
C     ON INPUT.
C
C        NM MUST BE SET TO THE ROW DIMENSION OF THE TWO DIMENSIONAL
C             ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C             DIMENSION STATEMENT.
C
C        M MUST BE SET TO THE NUMBER OF ROWS IN THE MATRIX.
C
C        N MUST BE SET TO THE NUMBER OF COLUMNS IN THE MATRIX.
C
C        QR CONTAINS THE REAL RECTANGULAR MATRIX TO BE DECOMPOSED.
C
C     NOPIVK IS USED TO CONTROL PIVOTTING.  COLUMNS 1 THROUGH
C        NOPIVK WILL REMAIN FIXED IN POSITION.
C
C        SUM IS USED FOR TEMPORARY STORAGE FOR THE SUBROUTINE.
C
C     ON OUTPUT.
C
C        QR CONTAINS THE NON-DIAGONAL ELEMENTS OF THE R-MATRIX
C             IN THE STRICT UPPER TRIANGLE. THE VECTORS U, WHICH
C             DEFINE THE HOUSEHOLDER TRANSFORMATIONS   I - U*U-TRANSP,
C             ARE IN THE COLUMNS OF THE LOWER TRIANGLE. THESE VECTORS U
C             ARE SCALED SO THAT THE SQUARE OF THEIR 2-NORM IS 2.0.
C
C        ALPHA CONTAINS THE DIAGONAL ELEMENTS OF THE R-MATRIX.
C
C        IPIVOT REFLECTS THE COLUMN PIVOTING PERFORMED ON THE INPUT
C             MATRIX TO ACCOMPLISH THE DECOMPOSITION. THE J-TH
C             ELEMENT OF IPIVOT GIVES THE COLUMN OF THE ORIGINAL
C             MATRIX WHICH WAS PIVOTED INTO COLUMN J DURING THE
C             DECOMPOSITION.
C
C        IERR IS SET TO.
C             0 FOR NORMAL RETURN,
C             K IF NO NON-ZERO PIVOT COULD BE FOUND FOR THE K-TH
C                  TRANSFORMATION, OR
C             -K FOR AN ERROR EXIT ON THE K-TH THANSFORMATION.
C             IF AN ERROR EXIT WAS TAKEN, THE FIRST (K - 1)
C             TRANSFORMATIONS ARE CORRECT.
C
C
C     *****APPLICATIONS AND USAGE RESTRICTIONS.
C     THIS MAY BE USED WHEN SOLVING LINEAR LEAST-SQUARES PROBLEMS --
C     SEE SUBROUTINE QR1 OF ROSEPACK.  IT IS CALLED FOR THIS PURPOSE
C     BY LLSQST IN THE NL2SOL (NONLINEAR LEAST-SQUARES) PACKAGE.
C
C     *****ALGORITHM NOTES.
C     THIS VERSION OF QRFACT TRIES TO ELIMINATE THE OCCURRENCE OF
C     UNDERFLOWS DURING THE ACCUMULATION OF INNER PRODUCTS.  RKTOL1
C     IS CHOSEN BELOW SO AS TO INSURE THAT DISCARDED TERMS HAVE NO
C     EFFECT ON THE COMPUTED TWO-NORMS.
C
C     ADAPTED FROM THE ALGOL ROUTINE SOLVE (1).
C
C     *****REFERENCES.
C     (1)     BUSINGER,P. AND GOLUB,G.H., LINEAR LEAST SQUARES
C     SOLUTIONS BY HOUSHOLDER TRANSFORMATIONS, IN WILKINSON,J.H.
C     AND REINSCH,C.(EDS.), HANDBOOK FOR AUTOMATIC COMPUTATION,
C     VOLUME II. LINEAR ALGEBRA, SPRINGER-VERLAG, 111-118 (1971).
C     PREPUBLISHED IN NUMER.MATH. 7, 269-276 (1965).
C
C     *****HISTORY.
C     THIS AMOUNTS TO THE SUBROUTINE QR1 OF ROSEPACK WITH RKTOL1 USED
C     IN PLACE OF RKTOL BELOW, WITH V2NORM USED TO INITIALIZE (AND
C     SOMETIMES UPDATE) THE SUM ARRAY, AND WITH CALLS ON DOTPRD AND
C     VAXPY IN PLACE OF SOME LOOPS.
C
C     *****GENERAL.
C
C     DEVELOPMENT OF THIS PROGRAM SUPPORTED IN PART BY
C     NATIONAL SCIENCE FOUNDATION GRANT GJ-1154X3 AND
C     NATIONAL SCIENCE FOUNDATION GRANT DCR75-08802
C     TO NATIONAL BUREAU OF ECONOMIC RESEARCH, INC.
C
C
C
C     =================================================================
C     =================================================================
C
C
C     ==========  UFETA IS THE SMALLEST POSITIVE FLOATING POINT NUMBER
C        S.T. UFETA AND -UFETA CAN BOTH BE REPRESENTED.
C
C     ==========  RKTOL IS THE SQUARE ROOT OF THE RELATIVE PRECISION
C        OF FLOATING POINT ARITHMETIC (MACHEP).
      DATA RKTOL/0.0D0/, UFETA/0.0D0/
C     *****BODY OF PROGRAM.
      IF (UFETA .GT. ZERO) GO TO 10
         UFETA = RMDCON(1)
         RKTOL = RMDCON(4)
   10 IERR = 0
      RKTOL1 = P01 * RKTOL
C
      DO 20 J=1,N
         SUM(J) = V2NORM(M, QR(1,J))
         IPIVOT(J) = J
   20 CONTINUE
C
      MINUM = MIN(M,N)
C
      DO 120 K=1,MINUM
         MK1 = M - K + 1
C        ==========K-TH HOUSEHOLDER TRANSFORMATION==========
         SIGMA = ZERO
         JBAR = 0
C        ==========FIND LARGEST COLUMN SUM==========
      IF (K .LE. NOPIVK) GO TO 50
         DO 30 J=K,N
              IF (SIGMA .GE. SUM(J))  GO TO 30
              SIGMA = SUM(J)
              JBAR = J
   30    CONTINUE
C
         IF (JBAR .EQ. 0)  GO TO 220
         IF (JBAR .EQ. K)  GO TO 50
C        ==========COLUMN INTERCHANGE==========
         I = IPIVOT(K)
         IPIVOT(K) = IPIVOT(JBAR)
         IPIVOT(JBAR) = I
         SUM(JBAR) = SUM(K)
         SUM(K) = SIGMA
C
         DO 40 I=1,M
              SIGMA = QR(I,K)
              QR(I,K) = QR(I,JBAR)
              QR(I,JBAR) = SIGMA
   40    CONTINUE
C        ==========END OF COLUMN INTERCHANGE==========
   50    CONTINUE
C        ==========  SECOND INNER PRODUCT  ==========
         QRKMAX = ZERO
C
         DO 60 I=K,M
              IF (ABS( QR(I,K) ) .GT. QRKMAX)  QRKMAX = ABS( QR(I,K) )
   60    CONTINUE
C
         IF (QRKMAX .LT. UFETA)  GO TO 210
         ALPHAK = V2NORM(MK1, QR(K,K)) / QRKMAX
         SIGMA = ALPHAK**2
C
C        ==========  END SECOND INNER PRODUCT  ==========
         QRKK = QR(K,K)
         IF (QRKK .GE. ZERO)  ALPHAK = -ALPHAK
         ALPHA(K) = ALPHAK * QRKMAX
         BETA = QRKMAX * SQRT(SIGMA - (QRKK*ALPHAK/QRKMAX) )
         QR(K,K) = QRKK - ALPHA(K)
         DO 65 I=K,M
   65         QR(I,K) =  QR(I,K) / BETA
         K1 = K + 1
         IF (K1 .GT. N) GO TO 120
C
         DO 110 J = K1, N
              TEMP = -DOTPRD(MK1, QR(K,K), QR(K,J))
C
C             ***  SET QR(I,J) = QR(I,J) + TEMP*QR(I,K), I = K,...,M.
C
              CALL VAXPY(MK1, QR(K,J), TEMP, QR(K,K), QR(K,J))
C
              IF (K1 .GT. M) GO TO 110
              SUMJ = SUM(J)
              IF (SUMJ .LT. UFETA) GO TO 110
              TEMP = ABS(QR(K,J)/SUMJ)
              IF (TEMP .LT. RKTOL1) GO TO 110
              IF (TEMP .GE. P99) GO TO 90
                   SUM(J) = SUMJ * SQRT(ONE - TEMP**2)
                   GO TO 110
   90         SUM(J) = V2NORM(M-K, QR(K1,J))
  110    CONTINUE
C        ==========END OF K-TH HOUSEHOLDER TRANSFORMATION==========
  120 CONTINUE
C
      GO TO 999
C     ==========ERROR EXIT ON K-TH TRANSFORMATION==========
  210 IERR = -K
      GO TO 230
C     ==========NO NON-ZERO ACCEPTABLE PIVOT FOUND==========
  220 IERR = K
  230 DO 240 I = K, N
         ALPHA(I) = ZERO
         IF (I .GT. K) CALL VSCOPY(I-K, QR(K,I), ZERO)
 240     CONTINUE
C     ==========RETURN TO CALLER==========
  999 RETURN
C     ==========LAST CARD OF QRFACT==========
      END
*STPAMO
      SUBROUTINE STPAMO(HEAD, N, EXM, NEXMPT, NETA, J, PAR, NPAR, STP,
     +   NFAIL, IFAIL, SCALE, LSCALE, HDR, PAGE, WIDE, ISUBHD, NPRT,
     +   PRTFXD, IFIXD)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS A DUMMY ROUTINE FOR THE ARIMA ESTIMATION ROUTINES
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  APRIL 2, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   EXM
      INTEGER
     +   ISUBHD,J,LSCALE,N,NETA,NEXMPT,NPAR,NPRT
      LOGICAL
     +   HEAD,PAGE,PRTFXD,WIDE
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   PAR(NPAR),SCALE(LSCALE),STP(NPAR)
      INTEGER
     +   IFAIL(N),IFIXD(NPAR),NFAIL(NPAR)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL HDR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION EXM
C        THE PROPORTION OF OBSERVATIONS ACTUALLY USED FOR WHICH THE
C        COMPUTED NUMERICAL DERIVATIVES WRT A GIVEN PARAMETER ARE
C        EXEMPTED FROM MEETING THE DERIVATIVE ACCEPTANCE CRITERIA.
C     EXTERNAL HDR
C        THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING
C     LOGICAL HEAD
C        A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED
C        (TRUE) OR NOT (FALSE).  IF A HEADING IS PRINTED, THE VALUE
C        OF HEAD WILL BE CHANGED TO FALSE.
C     INTEGER IFAIL(N)
C        THE ARRAY OF INDICATOR VARIABLES DESIGNATING WHETHER
C        THE STEP SIZE SELECTED WAS SATISFACTORY FOR A GIVEN
C        OBSERVATION AND PARAMETER.
C     INTEGER IFIXD(NPAR)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE
C        PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED.  IF
C        IFIXD(I).NE.0, THEN PAR(I) WILL BE OPTIMIZED.  IF
C        IFIXD(I).EQ.0, THEN PAR(I) WILL BE HELD FIXED.
C     INTEGER ISUBHD
C     INTEGER J
C        THE INDEX OF THE PARAMETER BEING EXAMINED.
C     INTEGER LSCALE
C        THE LENGTH OF VECTOR SCALE.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     INTEGER NETA
C        THE NUMBER OF RELIABLE DIGITS IN THE MODEL.
C     INTEGER NEXMPT
C        THE NUMBER OF OBSERVATIONS FOR WHICH A GIVEN STEP SIZE
C        DOES NOT HAVE TO BE SATISFACTORY AND THE SELECTED STEP
C        SIZE STILL BE CONSIDERED OK.
C     INTEGER NFAIL(NPAR)
C        THE NUMBER OF OBSERVATIONS FOR WHICH THE SELECTED STEP
C        SIZE DOES NOT MEET THE CRITERIA.
C     INTEGER NPRT
C        THE INDICATOR VARIABLE USED TO SPECIFY WHETHER OR NOT
C        PRINTED OUTPUT IS TO BE PROVIDED, WHERE IF THE VALUE OF
C        NPRT IS ZERO, NO PRINTED OUTPUT IS GIVEN.
C     LOGICAL PAGE
C        THE VARIABLE USED TO INDICATE WHETHER OR NOT THE OUTPUT
C        IS TO BEGIN ON A NEW PAGE.
C     DOUBLE PRECISION PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE
C        PARAMETERS ARE STORED.
C     LOGICAL PRTFXD
C        THE INDICATOR VALUE USED TO DESIGNATE WHETHER THE
C        OUTPUT IS TO INCLUDE INFORMATION ON WHETHER THE
C        PARAMETER IS FIXED (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     DOUBLE PRECISION STP(NPAR)
C        THE SELECTED STEP SIZE.
C     LOGICAL WIDE
C        THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD
C        BE FULL WIDTH (TRUE) OR NOT (FALSE).
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      RETURN
C
      END
*AMEHDR
      SUBROUTINE AMEHDR(PAGE, WIDE, ISUBHD)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE PRINTS THE PAGE HEADINGS FOR THE NONLINEAR
C     LEAST SQUARES ESTIMATION ROUTINES FOR ARIMA MODELS THAT USE
C     NUMERICAL APPROXIMATIONS TO THE DERIVATIVES.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  AUGUST 1, 1985
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   ISUBHD
      LOGICAL
     +   PAGE,WIDE
C
C  LOCAL SCALARS
CCCCC INTEGER
CCCCC+   IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL VERSP
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER ISUBHD
C        AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED.
C     LOGICAL PAGE
C        THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF
C        THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE).
C     LOGICAL WIDE
C        THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD
C        BE FULL WIDTH (TRUE) OR NOT (FALSE).
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC CALL IPRINT(IPRT)
      WRITE(ICOUT,1020)
      CALL DPWRST('XXX','BUG ')
C
      IF (PAGE) THEN
CCCCC    WRITE (ICOUT, 1020)
CCCCC    CALL DPWRST('XXX','BUG ')
CCCCC    WRITE (ICOUT, 1020)
CCCCC    CALL DPWRST('XXX','BUG ')
CCCCC    WRITE (ICOUT, 1020)
CCCCC    CALL DPWRST('XXX','BUG ')
      ENDIF
      CALL VERSP(WIDE)
CCCCC NAH.  DON'T INCLUDE PAGE HEADING IN DATAPLOT OUTPUT.
      IF (PAGE) THEN
CCCCC   WRITE (ICOUT,1000)
CCCCC   CALL DPWRST('XXX','BUG ')
CCCCC   WRITE (ICOUT,1001)
CCCCC   CALL DPWRST('XXX','BUG ')
      ENDIF
      IF (.NOT.PAGE) THEN
        WRITE (ICOUT,1010)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT,1011)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT,1012)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT,1010)
        CALL DPWRST('XXX','BUG ')
      ENDIF
      PAGE = .TRUE.
C
      IF (ISUBHD.EQ.0) RETURN
C
      GO TO (10), ISUBHD
C
   10 CONTINUE
      WRITE (ICOUT, 1020)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1030)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1031)
      CALL DPWRST('XXX','BUG ')
C
      RETURN
C
C     FORMAT STATEMENTS FOR PAGE HEADINGS
C
 1000 FORMAT ('NONLINEAR LEAST SQUARES ESTIMATION',
     +   ' FOR THE PARAMETERS OF')
 1001 FORMAT (
     +   ' AN ARIMA MODEL USING BACKFORECASTS')
 1010 FORMAT (61('#'))
 1011 FORMAT (
     +   '#  NONLINEAR LEAST SQUARES ESTIMATION',
     +   ' FOR THE PARAMETERS OF #')
 1012 FORMAT (
     +   '#  AN ARIMA MODEL USING BACKFORECASTS',
     +   '                       #')
C1020 FORMAT ('1')
 1020 FORMAT (1X)
 1030 FORMAT (' SUMMARY OF INITIAL CONDITIONS')
 1031 FORMAT (1X, 30('-'))
      END
*CPYASF
      SUBROUTINE CPYASF (M, X, LX, Y, IY)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COPIES THE ELEMENTS OF SYMMETRIC MATRIX X,
C     STORED ROW WISE, TO MATRIX Y.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  OCTOBER 3, 1983
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IY,LX,M
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   X(*),Y(IY,*)
C
C  LOCAL SCALARS
      INTEGER
     +   I,IJ,J
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        AN INDEX VALUE.
C     INTEGER IY
C        THE FIRST DIMENSION OF THE MATRIX Y.
C     INTEGER J
C        AN INDEX VALUE.
C     INTEGER LX
C        THE LENGTH OF SYMMETRIC MATRIX X, STORED ROW WISE.
C     INTEGER M
C        THE NUMBER OF COLUMNS OF DATA TO BE COPIED FROM MATRIX X.
C     DOUBLE PRECISION X(LX)
C        THE MATRIX TO BE COPIED FROM.
C     DOUBLE PRECISION Y(IY,M)
C        THE MATRIX TO BE COPIED TO.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DO 20 I = 1, M
         DO 10 J = 1, I
            IJ = I*(I-1)/2 + J
            Y(I,J) = X(IJ)
            Y(J,I) = Y(I,J)
   10    CONTINUE
   20 CONTINUE
C
      RETURN
C
      END
*ERVGTP
      SUBROUTINE ERVGTP (NMSUB, NMVAR, VECLB, NVMN, NVMX, HEAD, MSGTYP,
     +  NV, NMMIN)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRINTS THE ERROR MESSAGES FOR ERVGT AND ERVGTM.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  OCTOBER 3, 1983
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   VECLB
      INTEGER
     +   MSGTYP,NV,NVMN,NVMX
      LOGICAL
     +   HEAD
C
C  ARRAY ARGUMENTS
      CHARACTER
     +   NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EHDR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL HEAD
C        A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED (TRUE)
C        OR NOT (FALSE).
C     INTEGER I
C        AN INDEX ARGUMENT.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER MSGTYP
C        THE INDICATOR ARGUMENT FOR THE TYPE OF MESSAGE.
C        IF (MSGTYP.GE.4) THE MESSAGE PRINTED WILL USE NMMIN
C        OTHERWISE IT WILL USE VECLB.
C        IF (MSGTYP = 1 OR 4) NO VIOLATIONS ARE ALLOWED.
C        IF (MSGTYP = 2 OR 5) THE NUMBER OF VIOLATIONS MUST
C                             BE LESS THAN   NVMX   .
C        IF (MSGTYP = 3 OR 6) VIOLATIONS ARE COUNTED ONLY IF THE
C                             THE FIRST ELEMENT IS NOT IN VIOLATION.
C     CHARACTER*1 NMMIN(8)
C        THE NAME OF THE ARGUMENT SPECIFYING THE MINIMUM.
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING SUBROUTINES NAME.
C     CHARACTER*1 NMVAR(8)
C        THE CHARACTERS OF THE ARGUMENTS NAME.
C     INTEGER NV
C        THE NUMBER OF VIOLATIONS FOUND.
C     INTEGER NVMX
C        THE LARGEST NUMBER OF VIOLATIONS ALLOWED.
C     DOUBLE PRECISION VECLB
C        THE VALUE THAT THE VECTOR IS BEING TESTED AGAINST.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC CALL IPRINT(IPRT)
      CALL EHDR(NMSUB, HEAD)
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
C
      IF (MSGTYP.LE.3) THEN
        WRITE (ICOUT, 1000) (NMVAR(I),I=1,6), VECLB, NV
        CALL DPWRST('XXX','BUG ')
      ELSE
        IF (MSGTYP.GE.7) THEN
          WRITE (ICOUT, 1001) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), NV
          CALL DPWRST('XXX','BUG ')
        ELSE
          WRITE (ICOUT, 1002) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8), NV
          CALL DPWRST('XXX','BUG ')
        END IF
      END IF
C
      GO TO (10, 20, 30, 40, 50, 60, 70), MSGTYP
C
   10 WRITE(ICOUT, 1010) (NMVAR(I),I=1,6), VECLB
      CALL DPWRST('XXX','BUG ')
      RETURN
C
   20 WRITE(ICOUT, 1020) (NMVAR(I),I=1,3), VECLB
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT, 1021) NVMX
      CALL DPWRST('XXX','BUG ')
      RETURN
C
   30 WRITE(ICOUT, 1030) (NMVAR(I),I=1,6), VECLB
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT, 1031) VECLB
      CALL DPWRST('XXX','BUG ')
      RETURN
C
   40 WRITE(ICOUT, 1040) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
   50 WRITE(ICOUT, 1050) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT, 1051) NVMX
      CALL DPWRST('XXX','BUG ')
      RETURN
C
   60 WRITE(ICOUT, 1060) (NMVAR(I),I=1,6), (NMMIN(I),I=1,8)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT, 1061) (NMMIN(I),I=1,8)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
   70 WRITE(ICOUT, 1070) NVMN, (NMVAR(I),I=1,6)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT, 1071) (NMMIN(I),I=1,8)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     FORMAT STATEMENTS
C
  999 FORMAT(1X)
 1000 FORMAT (
     +   ' THE NUMBER OF VALUES IN VECTOR ', 6A1,
     +   ' LESS THAN OR EQUAL TO ', 1PE14.7, ' IS ', I6, '.')
 1001 FORMAT (
     +   ' THE NUMBER OF VALUES IN VECTOR ', 6A1,
     +  ' GREATER THAN ', 8A1, ' IS ', I2, '.')
 1002 FORMAT (
     +   ' THE NUMBER OF VALUES IN VECTOR ', 6A1,
     +   ' LESS THAN OR EQUAL TO ', 8A1, ' IS ', I6, '.')
 1010 FORMAT(
     +   ' THE VALUES IN THE VECTOR ', 6A1,
     +   ' MUST ALL BE GREATER THAN ', 1PE14.7, '.')
 1020 FORMAT(
     +   ' THE NUMBER OF VALUES IN THE VECTOR ', 6A1,
     +   ' LESS THAN OR EQUAL TO ', 1PE14.7)
 1021 FORMAT(
     +   ' MUST BE LESS THAN ', I5, '.')
 1030 FORMAT(
     +   ' SINCE THE FIRST VALUE OF THE VECTOR ', 6A1,
     +   ' IS GREATER THAN ', 1PE14.7)
 1031 FORMAT(
     +   ' ALL OF THE VALUES MUST BE GREATER THAN ', 1PE14.7, '.')
 1040 FORMAT(
     +   ' THE VALUES IN THE VECTOR ', 6A1,
     +   ' MUST ALL BE GREATER THAN ', 8A1, '.')
 1050 FORMAT(
     +   ' THE NUMBER OF VALUES IN THE VECTOR ', 6A1,
     +   ' LESS THAN OR EQUAL TO ', 8A1)
 1051 FORMAT(
     +   ' MUST BE LESS THAN ', I5, '.')
 1060 FORMAT(
     +   ' SINCE THE FIRST VALUE OF THE VECTOR ', 6A1,
     +   ' IS GREATER THAN ', 8A1)
 1061 FORMAT(
     +   ' ALL OF THE VALUES MUST BE GREATER THAN ', 8A1, '.')
 1070 FORMAT(
     +  ' THERE MUST BE AT LEAST ', I2, ' VALUES IN VECTOR ', 6A1)
 1071 FORMAT(
     +  ' GREATER THAN OR EQUAL TO ', 8A1, '.')
C
      END
*LITVMU
      SUBROUTINE LITVMU(N, X, L, Y)
C
C  ***  SOLVE  (L**T)*X = Y,  WHERE  L  IS AN  N X N  LOWER TRIANGULAR
C  ***  MATRIX STORED COMPACTLY BY ROWS.  X AND Y MAY OCCUPY THE SAME
C  ***  STORAGE.  ***
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   L(1),X(N),Y(N)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   XI,ZERO
      INTEGER
     +   I,I0,II,IJ,IM1,J,NP1
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ZERO/0.0D0/
C
      DO 10 I = 1, N
 10      X(I) = Y(I)
      NP1 = N + 1
      I0 = N*(N+1)/2
      DO 30 II = 1, N
         I = NP1 - II
         XI = X(I)/L(I0)
         X(I) = XI
         IF (I .LE. 1) GO TO 999
         I0 = I0 - I
         IF (XI .EQ. ZERO) GO TO 30
         IM1 = I - 1
         DO 20 J = 1, IM1
              IJ = I0 + J
              X(J) = X(J) - XI*L(IJ)
 20           CONTINUE
 30      CONTINUE
 999  RETURN
C  ***  LAST CARD OF LITVMU FOLLOWS  ***
      END
*NCHOSE
      INTEGER FUNCTION NCHOSE(N,K)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE IS USED TO COMBINE THE DIFFERENCE FACTORS FROM A
C     (BOX-JENKINS) TIME SERIES MODEL.
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  NOVEMBER 21, 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   K,N
C
C  LOCAL SCALARS
      INTEGER
     +   I,KK,NN
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      IF (N .GT. K) GO TO 10
      NCHOSE = 1
      RETURN
C
   10 KK = MIN(K, N - K)
      NN = 1
      DO 20 I = 1, KK
         NN = (NN*(N - I + 1))/I
   20 CONTINUE
      NCHOSE = NN
      RETURN
      END
*RELCOM
      SUBROUTINE RELCOM(N, V, W, RELTOL, ABSTOL, NFAIL, IFAIL)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE COMPUTES THE NUMBER OF TIMES THE
C     RELATIVE DIFFERENCE BETWEEN V(I) AND W(I), I = 1, 2, ..., N,
C     IS GREATER THAN   RELTOL  .
C
C     WRITTEN BY  -  ROBERT B. SCHNABEL (CODED BY JANET R. DONALDSON)
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  APRIL 2, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   ABSTOL,RELTOL
      INTEGER
     +   N,NFAIL
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   V(N),W(N)
      INTEGER
     +   IFAIL(N)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MAX
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION ABSTOL
C        THE ABSOLUTE TOLERANCE USED IN THE COMPARISON.
C     INTEGER I
C        AN INDEXING VARIABLE.
C     INTEGER IFAIL(N)
C        AN INDICATOR VARIABLE DESIGNATING WHETHER OR NOT THE COMPARISON
C        FAILED OR NOT, WHERE 0 INDICATES NOT FAILURE AND 1 INDICATES
C        FALURE.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NFAIL
C        THE TOTAL NUMBER OF FAILURES.
C     DOUBLE PRECISION RELTOL
C        THE RELATIVE TOLERANCE USED IN THE COMPARISON.
C     DOUBLE PRECISION V(N), W(N)
C        THE VALUES BEING COMPARED.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      NFAIL = 0
C
      DO 30 I = 1, N
         IF ((ABS(V(I)-W(I)).LE.RELTOL*MAX(ABS(V(I)),ABS(W(I)))) .OR.
     +       (((V(I).EQ.0.0D0).OR.(W(I).EQ.0.0D0)).AND.
     +        (ABS(V(I)-W(I)).LE.ABSTOL))) THEN
            IFAIL(I) = 0
         ELSE
            IFAIL(I) = 1
            NFAIL = NFAIL + 1
         END IF
   30 CONTINUE
C
      RETURN
C
      END
*STPMN
      SUBROUTINE STPMN(J,XM,N,M,IXM,MDL,PAR,NPAR,
     +   NEXMPT,ETA,RELTOL,SCALE,STP,NFAIL,IFAIL,CD,
     +   ITEMP,FD,FDLAST,FDSAVE,PV,PVMCD,PVNEW,PVPCD,PVSTP,PVTEMP)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE MAIN SUBROUTINE FOR SELECTING THE STEP SIZE FOR
C     COMPUTING AGAINST NUMERICAL DERIVATIVES
C
C     WRITTEN BY  -  ROBERT B. SCHNABEL (CODED BY JANET R. DONALDSON)
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  APRIL 2, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   ETA,RELTOL,SCALE,STP
      INTEGER
     +   IXM,J,M,N,NEXMPT,NFAIL,NPAR
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   CD(N),FD(N),FDLAST(N),FDSAVE(N),PAR(NPAR),PV(N),PVMCD(N),
     +   PVNEW(N),PVPCD(N),PVSTP(N),PVTEMP(N),XM(IXM,M)
      INTEGER
     +   IFAIL(N),ITEMP(N)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL MDL
C
C  SCALARS IN COMMON
      DOUBLE PRECISION
     +   Q
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   ABSTOL,CURVE,ETA3,FPLRS,PARMX,PVMEAN,PVTYP,STPCD,STPLOW,
     +   STPMID,STPUP,TAUABS,TEMP,THIRD
      INTEGER
     +   I
C
C  EXTERNAL FUNCTIONS
CCCCC DOUBLE PRECISION
CCCCC+   D1MACH
CCCCC EXTERNAL D1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL CMPFD,GMEAN,RELCOM,STPADJ,STPSEL
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MAX,SIGN,SQRT
C
C  COMMON BLOCKS
      COMMON /NOTOPT/Q
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION ABSTOL
C        THE ABSOLUTE AGREEMENT TOLERANCE.
C     DOUBLE PRECISION CD(N)
C        THE CENTRAL DIFFERENCE QUOTIENT APPROXIMATION TO THE
C        DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER.
C     DOUBLE PRECISION CURVE
C        A MEASURE OF THE CURVATURE OF THE MODEL.
C     DOUBLE PRECISION ETA
C        THE RELATIVE NOISE IN THE MODEL
C     DOUBLE PRECISION ETA3
C        THE CUBE ROOT OF ETA.
C     DOUBLE PRECISION FD(N)
C        THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE
C        DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER
C     DOUBLE PRECISION FDLAST(N)
C        THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE
C        DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER
C        COMPUTED WITH THE MOST RECENT STEP SIZE SELECTED.
C     DOUBLE PRECISION FDSAVE(N)
C        A VECTOR USED TO SAVE THE BEST OF THE
C        THE FORWARD DIFFERENCE QUOTIENT APPROXIMATIONS TO THE
C        DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER
C     DOUBLE PRECISION FPLRS
C        THE FLOATING POINT LARGEST RELATIVE SPACING.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IFAIL(N)
C        THE VECTOR OF INDICATOR VARIABLES DESIGNATING WHETHER
C        THE STEP SIZE SELECTED WAS SATISFACTORY FOR A GIVEN
C        OBSERVATION AND PARAMETER.
C     INTEGER ITEMP(N)
C        A TEMPORARY STORAGE VECTOR.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER J
C        THE INDEX OF THE PARAMETER BEING EXAMINED.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     EXTERNAL MDL
C        THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE
C        PREDICTED VALUES BASED ON THE CURRENT PARAMETER ESTIMATES.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NPAR
C        THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL.
C     INTEGER NEXMPT
C        THE NUMBER OF OBSERVATIONS FOR WHICH A GIVEN STEP SIZE
C        DOES NOT HAVE TO BE SATISFACTORY AND THE SELECTED STEP
C        SIZE STILL BE CONSIDERED OK.
C     INTEGER NFAIL
C        THE VECTOR CONTAINING THE COUNTS FOR EACH PARAMETER
C        OF THE NUMBER OF OBSERVATIONS THE SELECTED STEP SIZE WAS
C        NOT SATISFACTORY.
C     DOUBLE PRECISION PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
C        PARAMETERS ARE STORED.
C     DOUBLE PRECISION PARMX
C        THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE AND THE
C        TYPICAL VALUE OF THAT PARAMETER
C     DOUBLE PRECISION PV(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     DOUBLE PRECISION PVMCD(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C        FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J)-STPCD.
C     DOUBLE PRECISION PVMEAN
C        THE MEAN OF A FUNCTION OF THE PREDICTED VALUES.
C     DOUBLE PRECISION PVNEW(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C        FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J)+STPNEW.
C     DOUBLE PRECISION PVPCD(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C        FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J)+STPCD.
C     DOUBLE PRECISION PVSTP(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C        FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J)+STP.
C     DOUBLE PRECISION PVTEMP(N)
C        A TEMPORARY STORAGE VECTOR FOR PREDICTED VALUES.
C     DOUBLE PRECISION PVTYP
C        THE TYPICAL SIZE OF THE PREDICTED VALUES OF THE MODEL.
C     DOUBLE PRECISION Q
C        A DUMMY VARIABLE WHICH IS USED, ALONG WITH COMMON NOTOPT (NO
C        OPTIMIZATION), TO COMPUTE THE STEP SIZE.
C     DOUBLE PRECISION SCALE
C        THE TYPICAL SIZE OF THE JTH PARAMETER.
C     DOUBLE PRECISION STP
C        THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FORWARD
C        DIFFERENCE APPROXIMATION TO THE DERIVATIVE.
C     DOUBLE PRECISION STPCD
C        THE STEP SIZE USED FOR THE CENTRAL DIFFERENCE QUOTIENT.
C     DOUBLE PRECISION STPLOW
C        THE LOWER LIMIT ON THE STEP SIZE.
C     DOUBLE PRECISION STPMID
C        THE MIDPOINT OF THE ACCEPTABLE RANGE OF THE STEP SIZE.
C     DOUBLE PRECISION STPUP
C        THE UPPER LIMIT ON THE STEP SIZE.
C     DOUBLE PRECISION RELTOL
C        THE RELATIVE AGREEMENT TOLERANCE.
C     DOUBLE PRECISION TAUABS
C        THE ABSOLUTE AGREEMENT TOLERANCE.
C     DOUBLE PRECISION TEMP
C        A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE JTH
C        PARAMETER IS STORED.
C     DOUBLE PRECISION THIRD
C        THE VALUE ONE THIRD.
C     DOUBLE PRECISION XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      FPLRS = D1MACH(4)
C
C     SET VARIOUS PARAMETERS NECESSARY FOR COMPUTING THE
C     OPTIMUM STEP SIZE
C
      THIRD = 1.0D0 / 3.0D0
C
      ETA3 = ETA ** THIRD
C
      PARMX = MAX(ABS(PAR(J)), ABS(SCALE))
      IF (PARMX .EQ. 0.0D0) PARMX = 1.0D0
C
      STPCD = ((3.0D0 ** THIRD) * ETA3 * PARMX * SIGN(1.0D0, PAR(J)))
C
      Q = STPCD + PAR(J)
      STPCD = Q - PAR(J)
C
      TEMP = PAR(J)
C
      PAR(J) = TEMP + STPCD
      CALL MDL(PAR, NPAR, XM, N, M, IXM, PVPCD)
C
      PAR(J) = TEMP - STPCD
      CALL MDL(PAR, NPAR, XM, N, M, IXM, PVMCD)
C
      PAR(J) = TEMP
C
C     ESTIMATE CURVATURE BY SECOND DERIVATIVE OF MODEL WITH RESPECT TO
C     PAR(J)
C
      DO 10 I = 1, N
         PVTEMP(I) = ABS((PVPCD(I)+PVMCD(I)) - 2*PV(I))
         IF (PVTEMP(I).EQ.0.0D0) THEN
            IF (PV(I).EQ.0.0D0) THEN
               PVTEMP(I) = FPLRS
            ELSE
               PVTEMP(I) = FPLRS*ABS(PV(I))
            END IF
         END IF
   10 CONTINUE
C
C     COMPUTE THE GEOMETRIC MEAN
C
      CALL GMEAN(PVTEMP, N, PVMEAN)
C
      CURVE = ABS(PVMEAN / STPCD / STPCD)
C
C     COMPUTE A TYPICAL VALUE OF THE MODEL
C
      DO 20 I = 1, N
         PVTEMP(I) = ABS(PVPCD(I) + PV(I) + PVMCD(I))
         IF (PVTEMP(I).EQ.0.0D0) THEN
            IF (PV(I).EQ.0.0D0) THEN
               PVTEMP(I) = FPLRS
            ELSE
               PVTEMP(I) = FPLRS*ABS(PV(I))
            END IF
         END IF
   20 CONTINUE
C
      CALL GMEAN(PVTEMP, N, PVMEAN)
C
      PVTYP = ABS(PVMEAN / 3.0D0)
C
C     SET VALUES REPRESENTATIVE OF THE RANGE THE STEP SIZE
C     CAN BE EXPECTED TO TAKE
C
      STPUP = (ETA3) * PARMX
      STPLOW = (ETA3) * STPUP
      STPMID = SQRT(STPLOW) * SQRT(STPUP)
C
C     SELECT AN OPTIMUM STARTING STEP SIZE
C
      IF (CURVE.EQ.0.0D0) THEN
         STP = PARMX * SIGN(1.0D0, PAR(J))
      ELSE
         STP = (2.0D0 * SQRT(ETA) * SQRT(PVTYP) / SQRT(CURVE)) *
     +         SIGN(1.0D0,PAR(J))
      END IF
C
      IF (ABS(STP).GT.PARMX) STP = PARMX * SIGN(1.0D0,PAR(J))
C
      Q = STP + PAR(J)
      STP = Q - PAR(J)
C
      IF (STP.EQ.0.0D0) THEN
         STP = FPLRS * PAR(J)
         IF (STP.EQ.0.0D0) STP = FPLRS
C
   30    CONTINUE
         Q = STP + PAR(J)
         STP = Q - PAR(J)
C
         IF (STP.EQ.0.0D0) THEN
            STP = 2.0D0 * STP
            GO TO 30
         END IF
      END IF
C
C     COMPUTE THE ABSOLUTE TOLERANCES
C
      ABSTOL = 10.0D0 * ETA * PVTYP
C
      TAUABS = 2.0D0 * SQRT(ETA) * SQRT(PVTYP)
      IF (CURVE .NE. 0.0D0) TAUABS = TAUABS * SQRT(CURVE)
C
      TEMP = PAR(J)
      PAR(J) = TEMP + STP
C
      CALL MDL(PAR, NPAR, XM, N, M, IXM, PVSTP)
C
      PAR(J) = TEMP
C
C     COMPUTE THE FORWARD AND CENTRAL DIFFERENCE QUOTIENT ESTIMATE
C     OF THE DERIVATIVE
C
      CALL CMPFD(N, STP, PVSTP, PV, FD)
C
      CALL CMPFD(N, 2.0D0*STPCD, PVPCD, PVMCD, CD)
C
C     COMPUTE THE NUMBER OF OBSERVATIONS FOR WHICH THE FD DOES NOT
C     AGREE WITH THE CD WITHIN THE TOLERANCE SPECIFIED.
C
      CALL RELCOM(N, FD, CD, RELTOL, ABSTOL, NFAIL, IFAIL)
C
C     IF THE FORWARD DIFFERENCE APPROXIMATION DOES NOT AGREE WITHIN
C     TOLERANCE FOR MORE THAN   NEXMPT   OBSERVATION, SELECT NEW
C     VALUE OF THE STEP SIZE, ELSE ADJUST THE STEP SIZE AND RETURN.
C
      IF (NFAIL.GT.NEXMPT) THEN
C
C        SELECT NEW VALUE OF THE STEP SIZE
C
            CALL STPSEL(XM, N, M, IXM, MDL, PAR, NPAR,
     +         NEXMPT, STP, NFAIL, IFAIL, J, ETA3, RELTOL, ABSTOL,
     +         TAUABS, STPLOW,
     +         STPMID, STPUP, ITEMP, FD, FDLAST, FDSAVE, PV, PVNEW)
      ELSE
C
C        ADJUST THE CURRENT STEP SIZE VALUE
C
            CALL STPADJ(XM, N, M, IXM, MDL, PAR, NPAR,
     +         NEXMPT, STP, NFAIL, IFAIL, J, RELTOL, ABSTOL, STPLOW,
     +         STPMID, STPUP, ITEMP, FD, FDLAST, PV, PVNEW)
C
      END IF
C
C     CONVERT SELECTED ABSOLUTE STEP SIZE TO RELATIVE STEP SIZE
C
      STP = ABS(STP) / PARMX
C
      RETURN
C
      END
*AMEISM
      SUBROUTINE AMEISM (AMEHDR, PAGE, WIDE, HLFRPT, NPAR, M, N, NNZW,
     +   WEIGHT, IFIXD, PAR, SCALE, LSCALE, IWORK, LIWORK, RWORK,
     +   LRWORK, RES, APRXDV, STPT, LSTPT, NPARE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE PRINTS AN INITIAL SUMMARY OF THE STARTING
C     ESTIMATES AND THE CONTROL PARAMETERS FOR THE NONLINEAR
C     LEAST SQUARES SUBROUTINES FOR ARIMA MODELING.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 2, 1985
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   LIWORK,LRWORK,LSCALE,LSTPT,M,N,NNZW,NPAR,NPARE
      LOGICAL
     +   APRXDV,HLFRPT,PAGE,WEIGHT,WIDE
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   PAR(*),RES(*),RWORK(*),SCALE(*),STPT(*)
      INTEGER
     +   IFIXD(*),IWORK(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL AMEHDR
C
C  SCALARS IN COMMON
      INTEGER
     +   IFLAG,MBO,MBOL,MSPECT,NFACT,NPARAR,NPARDF,NPARMA,NRESTS,
     +   PARAR,PARDF,PARMA,T,TEMP
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   RSD,RSS
      INTEGER
CCCCC+   IAMHD,IPRT,ISUBHD,LMAX0,MXFCAL,MXITER,RFCTOL,XCTOL
     +   IAMHD,ISUBHD,LMAX0,MXFCAL,MXITER,RFCTOL,XCTOL
C
C  LOCAL ARRAYS
      INTEGER
     +   ISTAK(12)
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DNRM2
      EXTERNAL DNRM2
C
C  EXTERNAL SUBROUTINES
CCCCC EXTERNAL AMLST,IPRINT,MODSUM
      EXTERNAL AMLST,MODSUM
C
C  INTRINSIC FUNCTIONS
      INTRINSIC DBLE,SQRT
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /MDLTSC/MSPECT,NFACT,PARDF,NPARDF,PARAR,NPARAR,PARMA,
     +   NPARMA,MBO,MBOL,T,TEMP,NRESTS,IFLAG
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     EXTERNAL AMEHDR
C        THE ROUTINE USED TO PRINT THE HEADING
C     LOGICAL APRXDV
C        THE VARIABLE USED TO INDICATE WHETHER NUMERICAL
C        APPROXIMATIONS TO THE DERIVATIVE WERE USED (TRUE) OR NOT
C        (FALSE).
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     LOGICAL HLFRPT
C        THE VARIABLE WHICH INDICATES WHETHER THE DERIVATIVE
C        CHECKING ROUTINE HAS ALREADY PRINTED PART OF THE
C        INITIAL SUMMARY (TRUE) OR NOT (FALSE).
C     INTEGER IAMHD
C        THE INDICATOR VALUE USED TO DESIGNATE THE TYPE OF LIST
C        TO BE GENERATED
C        IF IAMHD=1, THE LIST IS FOR THE INITIAL SUMMARY OF THE
C                    ESTIMATION ROUTINES.
C        IF IAMHD=2, THE LIST IS FOR THE INITIAL REPORT OF THE
C                    FORECASTING ROUTINES.
C        IF IAMHD=3, THE LIST IS FOR THE FINAL REPORT OF THE
C                    ESTIMATION ROUTINES.
C     INTEGER IFIXD(NPAR)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE
C        PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED.
C        IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED.
C        IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ISUBHD
C        AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED.
C     INTEGER IWORK(LIWORK)
C        WORK SPACE USED BY THE NL2 SUBROUTINES.
C     INTEGER LIWORK
C        THE DIMENSION OF VECTOR IWORK.
C     INTEGER LMAX0
C        THE LOCATION IN RWORK OF THE VALUE INDICATING THE
C        MAXIMUM CHANGE ALLOWED IN THE MODEL PARAMETERS AT THE
C        FIRST ITERATION.
C     INTEGER LRWORK
C        THE DIMENSION OF VECTOR RWORK.
C     INTEGER LSCALE
C        THE DIMENSION OF VECTOR SCALE.
C     INTEGER LSTPT
C        THE DIMENSION OF VECTOR STPT.
C     INTEGER M
C        A DUMMY VARIABLE.
C     INTEGER MBO
C        THE MAXIMUM BACK ORDER OPERATOR.
C     INTEGER MBOL
C        THE MAXIMUM BACK ORDER ON THE LEFT
C     INTEGER MSPECT
C        THE STARTING LOCATION IN THE WORK SPACE FOR
C        THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT
C     INTEGER MXFCAL
C        THE LOCATION IN IWORK OF THE VARIABLE DESIGNATING THE
C        MAXIMUM NUMBER OF FUNCTION CALLS ALLOWED, EXCLUDING
C        CALLS NECESSARY TO COMPUTE THE DERIVATIVES AND VARIANCE
C        COVARIANCE MATRIX.
C     INTEGER MXITER
C        THE LOCATION IN IWORK OF THE VARIABLE DESIGNATING THE
C        MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NFACT
C        THE NUMBER OF FACTORS IN THE MODEL
C     INTEGER NNZW
C        THE NUMBER OF NON ZERO WEIGHTS.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     INTEGER NPARAR
C        THE NUMBER OF AUTOREGRESSIVE PARAMETERS
C     INTEGER NPARDF
C        THE ORDER OF THE EXPANDED DIFFERENCE FILTER.
C     INTEGER NPARE
C        THE NUMBER OF PARAMETERS TO BE OPTIMIZED.
C     INTEGER NPARMA
C        THE LENGTH OF THE VECTOR PARMA
C     INTEGER NRESTS
C        THE MAXIMUM NUMBER OF RESIDUALS TO BE COMPUTED.
C     LOGICAL PAGE
C        THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF
C        THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     INTEGER PARAR
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        THE AUTOREGRESSIVE PARAMETERS
C     INTEGER PARDF
C        THE STARTING LOCATION IN THE WORK SPACE FOR
C        THE VECTOR CONTAINING THE DIFFERENCE FILTER PARAMETERS
C     INTEGER PARMA
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        THE MOVING AVERAGE PARAMETERS
C     DOUBLE PRECISION RES(N)
C        THE RESIDUALS FROM THE FIT.
C     INTEGER RFCTOL
C        THE LOCATION IN RWORK OF THE RELATIVE FUNCTION CONVERGENCE
C        TOLERANCE.
C     DOUBLE PRECISION RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     DOUBLE PRECISION RSS
C        THE RESIDUAL SUM OF SQUARES.
C     DOUBLE PRECISION RWORK(LRWORK)
C        WORK SPACE USED BY THE NL2 SUBROUTINES.
C     DOUBLE PRECISION SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     DOUBLE PRECISION STPT(LSTPT)
C        THE STEP SIZE ARRAY.
C     INTEGER T
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        A TEMPORARY WORK VECTOR.
C     INTEGER TEMP
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        A TEMPORARY WORK VECTOR
C     LOGICAL WEIGHT
C        THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO
C        BE PERFORMED (TRUE) OR NOT (FALSE).
C     LOGICAL WIDE
C        THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD
C        BE FULL WIDTH (TRUE) OR NOT (FALSE).
C     INTEGER XCTOL
C        THE LOCATION IN RWORK OF THE PARAMETER CONVERGENCE TOLERANCE.
C
C     IWORK SUBSCRIPT VALUES
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA MXFCAL/17/, MXITER/18/
C
C     RWORK SUBSCRIPT VALUES
C
      DATA LMAX0/35/, RFCTOL/32/, XCTOL/33/
C
CCCCC CALL IPRINT(IPRT)
C
      ISUBHD = 1
      CALL AMEHDR(PAGE, WIDE, ISUBHD)
C
      CALL MODSUM(NFACT, ISTAK(MSPECT))
      IAMHD = 1
      CALL AMLST (IAMHD, PAR, NPAR, NFACT, ISTAK(MSPECT), N, PAR, NPAR,
     +  SCALE, LSCALE, STPT, LSTPT, IFIXD, RSS, RSD, NPARDF, NPARE, 0)
C
      IF (WEIGHT) THEN
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE (ICOUT, 1170) NNZW
         CALL DPWRST('XXX','BUG ')
      ENDIF
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT, 1070) IWORK(MXITER)
      CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT, 1090) IWORK(MXFCAL)
      CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT, 1080)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT, 1100) RWORK(RFCTOL)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT, 1110) RWORK(XCTOL)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT, 1120) RWORK(LMAX0)
      CALL DPWRST('XXX','BUG ')
      RSD = DNRM2(NRESTS, RES, 1)
      RSS = RSD * RSD
      IF (N-NPARDF-NPARE.GE.1)
     +     RSD = RSD / SQRT(DBLE(N-NPARDF-NPARE))
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1200) RSS
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1202)
      CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1210) RSD
      CALL DPWRST('XXX','BUG ')
CCCCC WRITE(ICOUT,999)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1220) N, NPARDF, NPARE, NNZW-NPARE
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
C
      RETURN
C
C     FORMAT STATEMENTS
C
  999 FORMAT(1X)
 1070 FORMAT (' MAXIMUM NUMBER OF ITERATIONS ALLOWED', 22X, 5H(MIT),
     +   1X, I5)
 1080 FORMAT(' CONVERGENCE CRITERION FOR TEST BASED ON THE')
 1090 FORMAT(' MAXIMUM NUMBER OF MODEL SUBROUTINE CALLS',
     +   ' ALLOWED', 16X, I5)
 1100 FORMAT (3X, 39H FORECASTED RELATIVE CHANGE IN RESIDUAL,
     +   15H SUM OF SQUARES, 1X, 8H(STOPSS), 1X, G11.4)
 1110 FORMAT(3X, 49H MAXIMUM SCALED RELATIVE CHANGE IN THE PARAMETERS,
     +   7X, 7H(STOPP), 1X, G11.4)
 1120 FORMAT(' MAXIMUM CHANGE ALLOWED IN THE PARAMETERS',
     +   ' AT FIRST ITERATION (DELTA) ', G11.4)
 1170 FORMAT (' NUMBER OF NON ZERO WEIGHTED OBSERVATIONS', 17X,
     +   6H(NNZW), 1X, I5)
 1200 FORMAT (' RESIDUAL SUM OF SQUARES FOR INPUT PARAMETER',
     +   7H VALUES, 18X, G11.4)
 1202 FORMAT ('      (BACKFORECASTS INCLUDED)')
 1210 FORMAT (' RESIDUAL STANDARD DEVIATION FOR INPUT PARAMETER',
     +   7H VALUES, 4X, 5H(RSD), 5X, G11.4)
 1220 FORMAT (' BASED ON DEGREES OF FREEDOM      ',
     +   I4, 3H - , I3, 3H - , I3, 3H = , I4)
      END
*CPYVII
      SUBROUTINE CPYVII(N,X,INCX,Y,INCY)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     COPY INTEGER X TO INTEGER Y.
C     FOR I = 0 TO N-1, COPY  X(LX+I*INCX) TO Y(LY+I*INCY),
C     WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS
C     DEFINED IN A SIMILAR WAY USING INCY.
C
C     MODELED AFTER BLAS COPY ROUTINES.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  OCTOBER 3, 1983
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   INCX,INCY,N
C
C  ARRAY ARGUMENTS
      INTEGER
     +   X(N),Y(N)
C
C  LOCAL SCALARS
      INTEGER
     +   I,IX,IY,M,MP1,NS
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MOD
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        AN INDEX VALUE.
C     INTEGER INCX
C        THE INCREMENT FOR THE MATRIX X.
C     INTEGER INCY
C        THE INCREMENT FOR THE MATRIX Y.
C     INTEGER N
C        THE NUMBER OF ROWS OF DATA TO BE COPIED FROM MATRIX X.
C     INTEGER X(N)
C        THE MATRIX TO BE COPIED FROM.
C     INTEGER Y(N)
C        THE MATRIX TO BE COPIED TO.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60
    5 CONTINUE
C
C        CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS.
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        Y(IY) = X(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C        CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 7.
C
   20 M = MOD(N,7)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        Y(I) = X(I)
   30 CONTINUE
      IF( N .LT. 7 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,7
        Y(I) = X(I)
        Y(I + 1) = X(I + 1)
        Y(I + 2) = X(I + 2)
        Y(I + 3) = X(I + 3)
        Y(I + 4) = X(I + 4)
        Y(I + 5) = X(I + 5)
        Y(I + 6) = X(I + 6)
   50 CONTINUE
      RETURN
C
C        CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS.
C
   60 CONTINUE
      NS = N*INCX
          DO 70 I=1,NS,INCX
          Y(I) = X(I)
   70     CONTINUE
      RETURN
      END
*ETAMDL
      SUBROUTINE ETAMDL(MDL, PAR, NPAR, XM, N, M, IXM, ETA, NETA,
     +   PARTMP, PV, NROWIN)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     ROUTINE TO COMPUTE NOISE AND NUMBER OF GOOD DIGITS IN
C     RESULTS OF MODEL ROUTINE AT ROW <NROW>.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  OCTOBER 3, 1983
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   ETA
      INTEGER
     +   IXM,M,N,NETA,NPAR,NROWIN
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   PAR(NPAR),PARTMP(NPAR),PV(N),XM(IXM,M)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL MDL
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   A,B,FAC,FPLRS,J,RSSSM,RSSSMJ,SQRTMP
      INTEGER
     +   I,K,NROW
C
C  LOCAL ARRAYS
      DOUBLE PRECISION
     +   RSS(5)
C
C  EXTERNAL FUNCTIONS
CCCCC DOUBLE PRECISION
CCCCC+   D1MACH
CCCCC EXTERNAL D1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL SETROW
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,LOG10,MAX,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION A, B
C        PARAMETERS OF THE FIT.
C     DOUBLE PRECISION ETA
C        THE NOISE IN THE MODEL RESULTS.
C     DOUBLE PRECISION FAC
C        A FACTOR USED IN THE COMPUTATIONS.
C     DOUBLE PRECISION FPLRS
C        THE FLOATING POINT LARGEST RELATIVE SPACING.
C     INTEGER I
C        AN INDEXING VARIABLE.
C     INTEGER IXM
C        ACTUAL FIRST DIMENSION OF XM
C     DOUBLE PRECISION J
C        THE VALUE FLOAT(I-3).
C     INTEGER K
C        AN INDEX VARIABLE.
C     INTEGER M
C        NUMBER OF VARIABLES
C     EXTERNAL MDL
C        THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE
C        PREDICTED VALUES BASED ON THE CURRENT PARAMETER ESTIMATES.
C     INTEGER N
C        NUMBER OF OBSERVATIONS
C     INTEGER NETA
C        THE NUMBER OF ACCURATE DIGITS IN THE MODEL RESULTS.
C     INTEGER NPAR
C        NUMBER OF PARAMETERS
C     INTEGER NROW
C        THE ROW NUMBER ACTUALLY USED.
C     INTEGER NROWIN
C        THE INPUT NUMBER OF THE ROW BEING CHECKED.
C     DOUBLE PRECISION PAR(NPAR)
C        MODEL PARAMETERS
C     DOUBLE PRECISION PARTMP(NPAR)
C        MODIFIED MODEL PARAMETERS
C     DOUBLE PRECISION PV(N)
C        PREDICTED VALUES
C     DOUBLE PRECISION RSS(5)
C        THE RESIDUAL SUM OF SQUARES FOR EACH VALUE OF J.
C     DOUBLE PRECISION RSSSM
C        THE SUM OF THE RESIDUAL SUM OF SQUARES FOR EACH SET OF
C        PARAMETER VALUES.
C     DOUBLE PRECISION RSSSMJ
C        THE SUM OF THE RESIDUAL SUM OF SQUARES TIMES J FOR EACH
C        SET OF PARAMETER VALUES.
C     DOUBLE PRECISION SQRTMP
C        THE SQUARE ROOT OF MACHINE PRECISION (FPLRS).
C     DOUBLE PRECISION XM(IXM,M)
C        INDEPENDENT VARIABLES
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      FPLRS = D1MACH(4)
C
C     SELECT FIRST ROW OF INDEPENDENT VARIABLES WHICH CONTAINS NO ZEROS
C
      CALL SETROW(NROWIN, XM, N, M, IXM, NROW)
C
      SQRTMP = SQRT(FPLRS)
      RSSSM = 0.0D0
      RSSSMJ = 0.0D0
      DO 20 I=1,5
         J = I-3
         DO 10 K=1,NPAR
            PARTMP(K) = PAR(K)*(1.0D0+J*SQRTMP)
   10    CONTINUE
         CALL MDL(PARTMP, NPAR, XM, N, M, IXM, PV)
C
         RSS(I) = PV(NROW)
C
         RSSSM = RSSSM + RSS(I)
         RSSSMJ = RSSSMJ + J*RSS(I)
   20 CONTINUE
      A = 0.2D00*RSSSM
      B = 0.1D00*RSSSMJ
      FAC = 1.0D0
      IF (RSS(3).NE.0.0D0) FAC = FAC/RSS(3)
      DO 30 I=1,5
         J = I-3
         RSS(I) = ABS((RSS(I)-(A+J*B))*FAC)
   30 CONTINUE
      ETA = MAX(RSS(1),RSS(2),RSS(3),RSS(4),RSS(5),FPLRS)
      NETA = -LOG10(ETA)
      ETA = 10.0D0**(-NETA)
      RETURN
      END
*LIVMUL
      SUBROUTINE LIVMUL(N, X, L, Y)
C
C  ***  SOLVE  L*X = Y, WHERE  L  IS AN  N X N  LOWER TRIANGULAR
C  ***  MATRIX STORED COMPACTLY BY ROWS.  X AND Y MAY OCCUPY THE SAME
C  ***  STORAGE.  ***
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   L(1),X(N),Y(N)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   T,ZERO
      INTEGER
     +   I,J,K
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DOTPRD
      EXTERNAL DOTPRD
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ZERO/0.0D0/
C
      DO 10 K = 1, N
         IF (Y(K) .NE. ZERO) GO TO 20
         X(K) = ZERO
 10      CONTINUE
      GO TO 999
 20   J = K*(K+1)/2
      X(K) = Y(K) / L(J)
      IF (K .GE. N) GO TO 999
      K = K + 1
      DO 30 I = K, N
         T = DOTPRD(I-1, L(J+1), X)
         J = J + I
         X(I) = (Y(I) - T)/L(J)
 30      CONTINUE
 999  RETURN
C  ***  LAST CARD OF LIVMUL FOLLOWS  ***
      END
*NL2ITR
      SUBROUTINE NL2ITR (D, IV, J, N, NN, P, R, V, X)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C
C  ***  CARRY OUT NL2SOL (NONLINEAR LEAST-SQUARES) ITERATIONS  ***
C  ***  (NL2SOL VERSION 2.2)  ***
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N,NN,P
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   D(P),J(NN,P),R(N),V(*),X(P)
      INTEGER
     +   IV(*)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   E,HALF,NEGONE,ONE,RDOF1,STTSST,T,T1,ZERO
      INTEGER
     +   CNVCOD,COSMIN,COVMAT,COVPRT,COVREQ,D0INIT,DGNORM,DIG,DIG1,
     +   DINIT,DSTNRM,DTYPE,DUMMY,F,F0,FDIF,FUZZ,G,G01,G1,GTSTEP,H,
     +   H0,H1,I,IERR,IM1,INCFAC,INITS,IPIV0,IPIV1,IPIVI,IPIVK,
     +   IPIVOT,IPK,IRC,JTINIT,JTOL1,K,KAGQT,KALM,KM1,L,LKY,LKY1,
     +   LMAT,LMAT1,LMAX0,LSTGST,M,MODE,MODEL,MXFCAL,MXITER,NFCALL,
     +   NFCOV,NFGCAL,NGCALL,NGCOV,NITER,NVSAVE,PHMXFC,PP1O2,
     +   PREDUC,QTR,QTR1,RAD0,RADFAC,RADINC,RADIUS,RD,RD0,RD1,RDK,
     +   RESTOR,RLIMIT,RSAVE,RSAVE1,S,S1,SIZE,SMH,SSTEP,STEP,STEP1,
     +   STGLIM,STLSTG,STPMOD,STPPAR,SUSED,SWITCH,TEMP1,TEMP2,
     +   TOOBIG,TUNER4,TUNER5,VSAVE1,W,W1,WSCALE,X0,X01,XIRC
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION
CCCCC+   DOTPRD,D1MACH,V2NORM
     +   DOTPRD,V2NORM
      LOGICAL
     +   STOPX
CCCCC EXTERNAL DOTPRD,D1MACH,V2NORM,STOPX
      EXTERNAL DOTPRD,V2NORM,STOPX
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ASSESS,COVCLC,DUPDAT,GQTSTP,ITSMRY,LMSTEP,PARCHK,QAPPLY,
     +   QRFACT,RPTMUL,SLUPDT,SLVMUL,VAXPY,VCOPY,VSCOPY
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,SQRT
C
C  ***  PARAMETER DECLARATIONS  ***
C
C     INTEGER IV(1), N, NN, P
C     DOUBLE PRECISION D(P), J(NN,P), R(N), V(1), X(P)
C     DIMENSION IV(60+P), V(93 + 2*N + P*(3*P+31)/2)
C
C
C--------------------------  PARAMETER USAGE  --------------------------
C
C D.... SCALE VECTOR.
C IV... INTEGER VALUE ARRAY.
C J.... N BY P JACOBIAN MATRIX (LEAD DIMENSION NN).
C N.... NUMBER OF OBSERVATIONS (COMPONENTS IN R).
C NN... LEAD DIMENSION OF J.
C P.... NUMBER OF PARAMETERS (COMPONENTS IN X).
C R.... RESIDUAL VECTOR.
C V.... FLOATING-POINT VALUE ARRAY.
C X.... PARAMETER VECTOR.
C
C  ***  DISCUSSION  ***
C
C        PARAMETERS IV, N, P, V, AND X ARE THE SAME AS THE CORRESPOND-
C     ING ONES TO NL2SOL (WHICH SEE), EXCEPT THAT V CAN BE SHORTER
C     (SINCE THE PART OF V THAT NL2SOL USES FOR STORING D, J, AND R IS
C     NOT NEEDED).  MOREOVER, COMPARED WITH NL2SOL, IV(1) MAY HAVE THE
C     TWO ADDITIONAL OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW,
C     AS IS THE USE OF IV(TOOBIG) AND IV(NFGCAL).  THE VALUES IV(D),
C     IV(J), AND IV(R), WHICH ARE OUTPUT VALUES FROM NL2SOL (AND
C     NL2SNO), ARE NOT REFERENCED BY NL2ITR OR THE SUBROUTINES IT CALLS.
C        ON A FRESH START, I.E., A CALL ON NL2ITR WITH IV(1) = 0 OR 12,
C     NL2ITR ASSUMES THAT R = R(X), THE RESIDUAL AT X, AND J = J(X),
C     THE CORRESPONDING JACOBIAN MATRIX OF R AT X.
C
C IV(1) = 1 MEANS THE CALLER SHOULD SET R TO R(X), THE RESIDUAL AT X,
C             AND CALL NL2ITR AGAIN, HAVING CHANGED NONE OF THE OTHER
C             PARAMETERS.  AN EXCEPTION OCCURS IF R CANNOT BE EVALUATED
C             AT X (E.G. IF R WOULD OVERFLOW), WHICH MAY HAPPEN BECAUSE
C             OF AN OVERSIZED STEP.  IN THIS CASE THE CALLER SHOULD SET
C             IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE NL2ITR TO IG-
C             NORE R AND TRY A SMALLER STEP.  THE PARAMETER NF THAT
C             NL2SOL PASSES TO CALCR (FOR POSSIBLE USE BY CALCJ) IS A
C             COPY OF IV(NFCALL) = IV(6).
C IV(1) = 2 MEANS THE CALLER SHOULD SET J TO J(X), THE JACOBIAN MATRIX
C             OF R AT X, AND CALL NL2ITR AGAIN.  THE CALLER MAY CHANGE
C             D AT THIS TIME, BUT SHOULD NOT CHANGE ANY OF THE OTHER
C             PARAMETERS.  THE PARAMETER NF THAT NL2SOL PASSES TO
C             CALCJ IS IV(NFGCAL) = IV(7).  IF J CANNOT BE EVALUATED
C             AT X, THEN THE CALLER MAY SET IV(NFGCAL) TO 0, IN WHICH
C             CASE NL2ITR WILL RETURN WITH IV(1) = 15.
C
C  ***  GENERAL  ***
C
C     CODED BY DAVID M. GAY.
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C
C     MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
C     MCS-7906671.
C        (SEE NL2SOL FOR REFERENCES.)
C
C+++++++++++++++++++++++++++  DECLARATIONS  ++++++++++++++++++++++++++++
C
C  ***  LOCAL VARIABLES  ***
C
C     INTEGER DUMMY, DIG1, G1, G01, H0, H1, I, IM1, IPIVI, IPIVK, IPIV1,
C    1        IPK, K, KM1, L, LKY1, LMAT1, LSTGST, M, PP1O2, QTR1,
C    2        RDK, RD0, RD1, RSAVE1, SMH, SSTEP, STEP1, STPMOD, S1,
C    3        TEMP1, TEMP2, W1, X01
C     DOUBLE PRECISION E, RDOF1, STTSST, T, T1
C
C     ***  CONSTANTS  ***
C
C     DOUBLE PRECISION HALF, NEGONE, ONE, ZERO
C
C/
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
C     EXTERNAL ASSESS, COVCLC, DOTPRD, DUPDAT, GQTSTP, ITSMRY, LMSTEP,
C    1         PARCHK, QAPPLY, QRFACT, RPTMUL, SLUPDT, SLVMUL, STOPX,
C    2         VAXPY, VCOPY, VSCOPY, V2NORM
C     LOGICAL STOPX
C     DOUBLE PRECISION DOTPRD, D1MACH, V2NORM
C
C ASSESS... ASSESSES CANDIDATE STEP.
C COVCLC... COMPUTES COVARIANCE MATRIX.
C DOTPRD... RETURNS INNER PRODUCT OF TWO VECTORS.
C DUPDAT... UPDATES SCALE VECTOR D.
C GQTSTP... COMPUTES GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL).
C ITSMRY... PRINTS ITERATION SUMMARY AND INFO ABOUT INITIAL AND FINAL X.
C LMSTEP... COMPUTES LEVENBERG-MARQUARDT STEP (GAUSS-NEWTON MODEL).
C PARCHK... CHECKS VALIDITY OF INPUT IV AND V VALUES.
C QAPPLY... APPLIES ORTHOGONAL MATRIX Q FROM QRFACT TO A VECTOR.
C QRFACT... COMPUTES QR DECOMPOSITION OF A MATRIX VIA HOUSEHOLDER TRANS.
C RPTMUL... MULTIPLIES VECTOR BY THE R MATRIX (AND/OR ITS TRANSPOSE)
C             STORED BY QRFACT.
C SLUPDT... PERFORMS QUASI-NEWTON UPDATE ON COMPACTLY STORED LOWER TRI-
C             ANGLE OF A SYMMETRIC MATRIX.
C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED.
C VAXPY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
C VCOPY.... COPIES ONE VECTOR TO ANOTHER.
C VSCOPY... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
C V2NORM... RETURNS THE 2-NORM OF A VECTOR.
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
C     INTEGER CNVCOD, COSMIN, COVMAT, COVPRT, COVREQ, DGNORM, DIG,
C    1        DINIT, DSTNRM, DTYPE, D0INIT, F, FDIF, FUZZ,
C    2        F0, G, GTSTEP, H, IERR, INCFAC, INITS, IPIVOT, IPIV0, IRC,
C    3        JTINIT, JTOL1, KAGQT, KALM, LKY, LMAT, LMAX0, MODE, MODEL,
C    4        MXFCAL, MXITER, NFCALL, NFGCAL, NFCOV, NGCOV, NGCALL,
C    5        NITER, NVSAVE, PHMXFC, PREDUC, QTR, RADFAC, RADINC,
C    6        RADIUS, RAD0, RD, RESTOR, RLIMIT, RSAVE, S, SIZE, STEP,
C    7        STGLIM, STLSTG, STPPAR, SUSED, SWITCH, TOOBIG, TUNER4,
C    8        TUNER5, VSAVE1, W, WSCALE, XIRC, X0
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C  ***  IV SUBSCRIPT VALUES  ***
C
      DATA CNVCOD/34/, COVMAT/26/, COVPRT/14/,
     +     COVREQ/15/, DIG/43/, DTYPE/16/, G/28/, H/44/,
     +     IERR/32/, INITS/25/, IPIVOT/61/, IPIV0/60/,
     +     IRC/3/, KAGQT/35/, KALM/36/, LKY/37/, LMAT/58/,
     +     MODE/38/, MODEL/5/, MXFCAL/17/, MXITER/18/,
     +     NFCALL/6/, NFGCAL/7/, NFCOV/40/, NGCOV/41/,
     +     NGCALL/30/, NITER/31/, QTR/49/,
     +     RADINC/8/, RD/51/, RESTOR/9/, RSAVE/52/, S/53/,
     +     STEP/55/, STGLIM/11/, STLSTG/56/, SUSED/57/,
     +     SWITCH/12/, TOOBIG/2/, W/59/, XIRC/13/, X0/60/
C
C  ***  V SUBSCRIPT VALUES  ***
C
      DATA COSMIN/43/, DGNORM/1/, DINIT/38/, DSTNRM/2/,
     +     D0INIT/37/, F/10/, FDIF/11/, FUZZ/45/,
     +     F0/13/, GTSTEP/4/, INCFAC/23/,
     +     JTINIT/39/, JTOL1/87/, LMAX0/35/,
     +     NVSAVE/9/, PHMXFC/21/, PREDUC/7/,
     +     RADFAC/16/, RADIUS/8/, RAD0/9/, RLIMIT/42/,
     +     SIZE/47/, STPPAR/5/, TUNER4/29/, TUNER5/30/,
     +     VSAVE1/78/, WSCALE/48/
C
C
      DATA HALF/0.5D0/, NEGONE/-1.0D0/, ONE/1.0D0/, ZERO/0.0D0/
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      I = IV(1)
      IF (I .EQ. 1) GO TO 20
      IF (I .EQ. 2) GO TO 50
C
C  ***  CHECK VALIDITY OF IV AND V INPUT VALUES  ***
C
C     ***  NOTE -- IF IV(1) = 0, THEN PARCHK CALLS DFAULT(IV, V)  ***
      CALL PARCHK(IV, N, NN, P, V)
      I = IV(1) - 2
      IF (I .GT. 10) GO TO 999
      GO TO (350, 350, 350, 350, 350, 350, 195, 160, 195, 10), I
C
C  ***  INITIALIZATION AND STORAGE ALLOCATION  ***
C
 10   IV(NITER) = 0
      IV(NFCALL) = 1
      IV(NGCALL) = 1
      IV(NFGCAL) = 1
      IV(MODE) = -1
      IV(STGLIM) = 2
      IV(TOOBIG) = 0
      IV(CNVCOD) = 0
      IV(COVMAT) = 0
      IV(NFCOV) = 0
      IV(NGCOV) = 0
      IV(KALM) = -1
      IV(RADINC) = 0
      IV(S) = JTOL1 + 2*P
      PP1O2 = P * (P + 1) / 2
      IV(X0) = IV(S) + PP1O2
      IV(STEP) = IV(X0) + P
      IV(STLSTG) = IV(STEP) + P
      IV(DIG) = IV(STLSTG) + P
      IV(G) = IV(DIG) + P
      IV(LKY) = IV(G) + P
      IV(RD) = IV(LKY) + P
      IV(RSAVE) = IV(RD) + P
      IV(QTR) = IV(RSAVE) + N
      IV(H) = IV(QTR) + N
      IV(W) = IV(H) + PP1O2
      IV(LMAT) = IV(W) + 4*P + 7
C     +++ LENGTH OF W = P*(P+9)/2 + 7.  LMAT IS CONTAINED IN W.
      IF (V(DINIT) .GE. ZERO) CALL VSCOPY(P, D, V(DINIT))
      IF (V(JTINIT) .GT. ZERO) CALL VSCOPY(P, V(JTOL1), V(JTINIT))
      I = JTOL1 + P
      IF (V(D0INIT) .GT. ZERO) CALL VSCOPY(P, V(I), V(D0INIT))
      V(RAD0) = ZERO
      V(STPPAR) = ZERO
      V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC))
C
C  ***  SET INITIAL MODEL AND S MATRIX  ***
C
      IV(MODEL) = 1
      IF (IV(INITS) .EQ. 2) IV(MODEL) = 2
      S1 = IV(S)
      IF (IV(INITS) .EQ. 0) CALL VSCOPY(PP1O2, V(S1), ZERO)
C
C  ***  COMPUTE FUNCTION VALUE (HALF THE SUM OF SQUARES)  ***
C
 20   T = V2NORM(N, R)
      IF (T .GT. V(RLIMIT)) IV(TOOBIG) = 1
      IF (IV(TOOBIG) .NE. 0) GO TO 30
      V(F) = 0.0
      IF (T.GT.SQRT(D1MACH(1))) V(F) = HALF * T**2
 30   IF (IV(MODE)) 40, 350, 730
C
 40   IF (IV(TOOBIG) .EQ. 0) GO TO 60
         IV(1) = 13
         GO TO 900
C
C  ***  MAKE SURE JACOBIAN COULD BE COMPUTED  ***
C
 50   IF (IV(NFGCAL) .NE. 0) GO TO 60
         IV(1) = 15
         GO TO 900
C
C  ***  COMPUTE GRADIENT  ***
C
 60   IV(KALM) = -1
      G1 = IV(G)
      DO 70 I = 1, P
         V(G1) = DOTPRD(N, R, J(1,I))
         G1 = G1 + 1
 70      CONTINUE
      IF (IV(MODE) .GT. 0) GO TO 710
C
C  ***  UPDATE D AND MAKE COPIES OF R FOR POSSIBLE USE LATER  ***
C
      IF (IV(DTYPE) .GT. 0) CALL DUPDAT(D, IV, J, N, NN, P, V)
      RSAVE1 = IV(RSAVE)
      CALL VCOPY(N, V(RSAVE1), R)
      QTR1 = IV(QTR)
      CALL VCOPY(N, V(QTR1), R)
C
C  ***  COMPUTE  D**-1 * GRADIENT  ***
C
      G1 = IV(G)
      DIG1 = IV(DIG)
      K = DIG1
      DO 80 I = 1, P
         V(K) = V(G1) / D(I)
         K = K + 1
         G1 = G1 + 1
 80      CONTINUE
      V(DGNORM) = V2NORM(P, V(DIG1))
C
      IF (IV(CNVCOD) .NE. 0) GO TO 700
      IF (IV(MODE) .EQ. 0) GO TO 570
      IV(MODE) = 0
C
C
C-----------------------------  MAIN LOOP  -----------------------------
C
C
C  ***  PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT  ***
C
 150  CALL ITSMRY(D, IV, P, V, X)
 160  K = IV(NITER)
      IF (K .LT. IV(MXITER)) GO TO 170
         IV(1) = 10
         GO TO 900
 170  IV(NITER) = K + 1
C
C  ***  UPDATE RADIUS  ***
C
      IF (K .EQ. 0) GO TO 185
      STEP1 = IV(STEP)
      DO 180 I = 1, P
         V(STEP1) = D(I) * V(STEP1)
         STEP1 = STEP1 + 1
 180     CONTINUE
      STEP1 = IV(STEP)
      V(RADIUS) = V(RADFAC) * V2NORM(P, V(STEP1))
C
C  ***  INITIALIZE FOR START OF NEXT ITERATION  ***
C
 185  X01 = IV(X0)
      V(F0) = V(F)
      IV(KAGQT) = -1
      IV(IRC) = 4
      IV(H) = -ABS(IV(H))
      IV(SUSED) = IV(MODEL)
C
C     ***  COPY X TO X0  ***
C
      CALL VCOPY(P, V(X01), X)
C
C  ***  CHECK STOPX AND FUNCTION EVALUATION LIMIT  ***
C
 190  IF (.NOT. STOPX(DUMMY)) GO TO 200
         IV(1) = 11
         GO TO 205
C
C     ***  COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX.
C
 195  IF (V(F) .GE. V(F0)) GO TO 200
         V(RADFAC) = ONE
         K = IV(NITER)
         GO TO 170
C
 200  IF (IV(NFCALL) .LT. IV(MXFCAL) + IV(NFCOV)) GO TO 210
         IV(1) = 9
 205     IF (V(F) .GE. V(F0)) GO TO 900
C
C        ***  IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH
C        ***  IMPROVED V(F), EVALUATE THE GRADIENT AT X.
C
              IV(CNVCOD) = IV(1)
              GO TO 560
C
C. . . . . . . . . . . . .  COMPUTE CANDIDATE STEP  . . . . . . . . . .
C
 210  STEP1 = IV(STEP)
      W1 = IV(W)
      IF (IV(MODEL) .EQ. 2) GO TO 240
C
C  ***  COMPUTE LEVENBERG-MARQUARDT STEP  ***
C
         QTR1 = IV(QTR)
         IF (IV(KALM) .GE. 0) GO TO 215
              RD1 = IV(RD)
              IF (-1 .EQ. IV(KALM)) CALL QRFACT(NN, N, P, J, V(RD1),
     +                                   IV(IPIVOT), IV(IERR), 0, V(W1))
              CALL QAPPLY(NN, N, P, J, V(QTR1), IV(IERR))
 215     H1 = IV(H)
         IF (H1 .GT. 0) GO TO 230
C
C        ***  COPY R MATRIX TO H  ***
C
              H1 = -H1
              IV(H) = H1
              K = H1
              RD1 = IV(RD)
              V(K) = V(RD1)
              IF (P .EQ. 1) GO TO 230
              DO 220 I = 2, P
                   CALL VCOPY(I-1, V(K+1), J(1,I))
                   K = K + I
                   RD1 = RD1 + 1
                   V(K) = V(RD1)
 220               CONTINUE
C
 230     G1 = IV(G)
         CALL LMSTEP(D, V(G1), IV(IERR), IV(IPIVOT), IV(KALM), P,
     +               V(QTR1), V(H1), V(STEP1), V, V(W1))
         GO TO 310
C
C  ***  COMPUTE GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL)  ***
C
 240  IF (IV(H) .GT. 0) GO TO 300
C
C     ***  SET H TO  D**-1 * ( (J**T)*J + S) ) * D**-1.  ***
C
         H1 = -IV(H)
         IV(H) = H1
         S1 = IV(S)
         IF (IV(KALM) .GE. 0) GO TO 270
C
C        ***  J IS IN ITS ORIGINAL FORM  ***
C
              DO 260 I = 1, P
                   T = ONE / D(I)
                   DO 250 K = 1, I
                        V(H1) = T*(DOTPRD(N,J(1,I),J(1,K))+V(S1)) / D(K)
                        H1 = H1 + 1
                        S1 = S1 + 1
 250                    CONTINUE
 260               CONTINUE
              GO TO 300
C
C  ***  LMSTEP HAS APPLIED QRFACT TO J  ***
C
 270     SMH = S1 - H1
         H0 = H1 - 1
         IPIV1 = IV(IPIVOT)
         T1 = ONE / D(IPIV1)
         RD0 = IV(RD) - 1
         RDOF1 = V(RD0 + 1)
         DO 290 I = 1, P
              L = IPIV0 + I
              IPIVI = IV(L)
              H1 = H0 + IPIVI*(IPIVI-1)/2
              L = H1 + IPIVI
              M = L + SMH
C             ***  V(L) = H(IPIVOT(I), IPIVOT(I))  ***
C             ***  V(M) = S(IPIVOT(I), IPIVOT(I))  ***
              T = ONE / D(IPIVI)
              RDK = RD0 + I
              E = V(RDK)**2
              IF (I .GT. 1) E = E + DOTPRD(I-1, J(1,I), J(1,I))
              V(L) = (E + V(M)) * T**2
              IF (I .EQ. 1) GO TO 290
              L = H1 + IPIV1
              IF (IPIVI .LT. IPIV1) L = L +
     +                               ((IPIV1-IPIVI)*(IPIV1+IPIVI-3))/2
              M = L + SMH
C             ***  V(L) = H(IPIVOT(I), IPIVOT(1))  ***
C             ***  V(M) = S(IPIVOT(I), IPIVOT(1))  ***
              V(L) = T * (RDOF1 * J(1,I)  +  V(M)) * T1
              IF (I .EQ. 2) GO TO 290
              IM1 = I - 1
              DO 280 K = 2, IM1
                   IPK = IPIV0 + K
                   IPIVK = IV(IPK)
                   L = H1 + IPIVK
                   IF (IPIVI .LT. IPIVK) L = L +
     +                               ((IPIVK-IPIVI)*(IPIVK+IPIVI-3))/2
                   M = L + SMH
C                  ***  V(L) = H(IPIVOT(I), IPIVOT(K))  ***
C                  ***  V(M) = S(IPIVOT(I), IPIVOT(K))  ***
                   KM1 = K - 1
                   RDK = RD0 + K
                   V(L) = T * (DOTPRD(KM1, J(1,I), J(1,K)) +
     +                            V(RDK)*J(K,I) + V(M)) / D(IPIVK)
 280               CONTINUE
 290          CONTINUE
C
C  ***  COMPUTE ACTUAL GOLDFELD-QUANDT-TROTTER STEP  ***
C
 300  H1 = IV(H)
      DIG1 = IV(DIG)
      LMAT1 = IV(LMAT)
      CALL GQTSTP(D, V(DIG1), V(H1), IV(KAGQT), V(LMAT1), P, V(STEP1),
     +            V, V(W1))
C
C
C  ***  COMPUTE R(X0 + STEP)  ***
C
 310  IF (IV(IRC) .EQ. 6) GO TO 350
      X01 = IV(X0)
      STEP1 = IV(STEP)
      CALL VAXPY(P, X, ONE, V(STEP1), V(X01))
      IV(NFCALL) = IV(NFCALL) + 1
      IV(1) = 1
      IV(TOOBIG) = 0
      GO TO 999
C
C. . . . . . . . . . . . .  ASSESS CANDIDATE STEP  . . . . . . . . . . .
C
 350  STEP1 = IV(STEP)
      LSTGST = IV(STLSTG)
      X01 = IV(X0)
      CALL ASSESS(D, IV, P, V(STEP1), V(LSTGST), V, X, V(X01))
C
C  ***  IF NECESSARY, SWITCH MODELS AND/OR RESTORE R  ***
C
      IF (IV(SWITCH) .EQ. 0) GO TO 360
         IV(H) = -ABS(IV(H))
         IV(SUSED) = IV(SUSED) + 2
         CALL VCOPY(NVSAVE, V, V(VSAVE1))
 360  IF (IV(RESTOR) .EQ. 0) GO TO 390
         RSAVE1 = IV(RSAVE)
         CALL VCOPY(N, R, V(RSAVE1))
 390  L = IV(IRC) - 4
      STPMOD = IV(MODEL)
      IF (L .GT. 0) GO TO (410,440,450,450,450,450,450,450,640,570), L
C
C  ***  DECIDE WHETHER TO CHANGE MODELS  ***
C
      E = V(PREDUC) - V(FDIF)
      SSTEP = IV(LKY)
      S1 = IV(S)
      CALL SLVMUL(P, V(SSTEP), V(S1), V(STEP1))
      STTSST = HALF * DOTPRD(P, V(STEP1), V(SSTEP))
      IF (IV(MODEL) .EQ. 1) STTSST = -STTSST
      IF (ABS(E + STTSST) * V(FUZZ) .GE. ABS(E)) GO TO 400
C
C     ***  SWITCH MODELS  ***
C
         IV(MODEL) = 3 - IV(MODEL)
         IF (IV(MODEL) .EQ. 1) IV(KAGQT) = -1
         IF (IV(MODEL) .EQ. 2 .AND. IV(KALM) .GT. 0) IV(KALM) = 0
         IF (-2 .LT. L) GO TO 480
              IV(H) = -ABS(IV(H))
              IV(SUSED) = IV(SUSED) + 2
              CALL VCOPY(NVSAVE, V(VSAVE1), V)
              GO TO 420
C
 400  IF (-3 .LT. L) GO TO 480
C
C     ***  RECOMPUTE STEP WITH DECREASED RADIUS  ***
C
         V(RADIUS) = V(RADFAC) * V(DSTNRM)
         GO TO 190
C
C  ***  RECOMPUTE STEP, SAVING V VALUES AND R IF NECESSARY  ***
C
 410  V(RADIUS) = V(RADFAC) * V(DSTNRM)
 420  IF (V(F) .GE. V(F0)) GO TO 190
      RSAVE1 = IV(RSAVE)
      CALL VCOPY(N, V(RSAVE1), R)
      GO TO 190
C
C  ***  COMPUTE STEP OF LENGTH V(LMAX0) FOR SINGULAR CONVERGENCE TEST
C
 440  V(RADIUS) = V(LMAX0)
      GO TO 210
C
C  ***  CONVERGENCE OR FALSE CONVERGENCE  ***
C
 450  IV(CNVCOD) = L
      IF (V(F) .GE. V(F0)) GO TO 700
         IF (IV(XIRC) .EQ. 14) GO TO 700
              IV(XIRC) = 14
C
C. . . . . . . . . . . .  PROCESS ACCEPTABLE STEP  . . . . . . . . . . .
C
 480  IV(COVMAT) = 0
C
C  ***  SET  LKY = (J(X0)**T) * R(X)  ***
C
      LKY1 = IV(LKY)
      IF (IV(KALM) .GE. 0) GO TO 500
C
C     ***  JACOBIAN HAS NOT BEEN MODIFIED  ***
C
         DO 490 I = 1, P
              V(LKY1) = DOTPRD(N, J(1,I), R)
              LKY1 = LKY1 + 1
 490          CONTINUE
         GO TO 510
C
C  ***  QRFACT HAS BEEN APPLIED TO J.  STORE COPY OF R IN QTR AND  ***
C  ***  APPLY Q TO IT.                                             ***
C
 500  QTR1 = IV(QTR)
      CALL VCOPY(N, V(QTR1), R)
      CALL QAPPLY(NN, N, P, J, V(QTR1), IV(IERR))
C
C  ***  MULTIPLY TOP P-VECTOR IN QTR BY PERMUTED UPPER TRIANGLE    ***
C  ***  STORED BY QRFACT IN J AND RD.                              ***
C
      RD1 = IV(RD)
      TEMP1 = IV(STLSTG)
      CALL RPTMUL(3, IV(IPIVOT), J, NN, P, V(RD1), V(QTR1), V(LKY1),
     +            V(TEMP1))
C
C  ***  SEE WHETHER TO SET V(RADFAC) BY GRADIENT TESTS  ***
C
 510  IF (IV(IRC) .NE. 3) GO TO 560
         STEP1 = IV(STEP)
         TEMP1 = IV(STLSTG)
         TEMP2 = IV(X0)
C
C     ***  SET  TEMP1 = HESSIAN * STEP  FOR USE IN GRADIENT TESTS  ***
C
         IF (STPMOD .EQ. 2) GO TO 530
C
C        ***  STEP COMPUTED USING GAUSS-NEWTON MODEL  ***
C        ***  -- QRFACT HAS BEEN APPLIED TO J         ***
C
              RD1 = IV(RD)
              CALL RPTMUL(2, IV(IPIVOT), J, NN, P, V(RD1),
     +                    V(STEP1), V(TEMP1), V(TEMP2))
              GO TO 560
C
C     ***  STEP COMPUTED USING AUGMENTED MODEL  ***
C
 530     H1 = IV(H)
         K = TEMP2
         DO 540 I = 1, P
              V(K) = D(I) * V(STEP1)
              K = K + 1
              STEP1 = STEP1 + 1
 540          CONTINUE
         CALL SLVMUL(P, V(TEMP1), V(H1), V(TEMP2))
         DO 550 I = 1, P
              V(TEMP1) = D(I) * V(TEMP1)
              TEMP1 = TEMP1 + 1
 550          CONTINUE
C
C  ***  SAVE OLD GRADIENT AND COMPUTE NEW ONE  ***
C
 560  IV(NGCALL) = IV(NGCALL) + 1
      G1 = IV(G)
      G01 = IV(W)
      CALL VCOPY(P, V(G01), V(G1))
      IV(1) = 2
      GO TO 999
C
C  ***  INITIALIZATIONS -- G0 = G - G0, ETC.  ***
C
 570  G01 = IV(W)
      G1 = IV(G)
      CALL VAXPY(P, V(G01), NEGONE, V(G01), V(G1))
      STEP1 = IV(STEP)
      TEMP1 = IV(STLSTG)
      TEMP2 = IV(X0)
      IF (IV(IRC) .NE. 3) GO TO 600
C
C  ***  SET V(RADFAC) BY GRADIENT TESTS  ***
C
C     ***  SET  TEMP1 = D**-1 * (HESSIAN * STEP  +  (G(X0) - G(X)))  ***
C
         K = TEMP1
         L = G01
         DO 580 I = 1, P
              V(K) = (V(K) - V(L)) / D(I)
              K = K + 1
              L = L + 1
 580          CONTINUE
C
C        ***  DO GRADIENT TESTS  ***
C
         IF (V2NORM(P, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4))  GO TO 590
              IF (DOTPRD(P, V(G1), V(STEP1))
     +                  .GE. V(GTSTEP) * V(TUNER5))  GO TO 600
 590               V(RADFAC) = V(INCFAC)
C
C  ***  FINISH COMPUTING LKY = ((J(X) - J(X0))**T) * R  ***
C
C     ***  CURRENTLY LKY = (J(X0)**T) * R  ***
C
 600  LKY1 = IV(LKY)
      CALL VAXPY(P, V(LKY1), NEGONE, V(LKY1), V(G1))
C
C  ***  DETERMINE SIZING FACTOR V(SIZE)  ***
C
C     ***  SET TEMP1 = S * STEP  ***
      S1 = IV(S)
      CALL SLVMUL(P, V(TEMP1), V(S1), V(STEP1))
C
      T1 = ABS(DOTPRD(P, V(STEP1), V(TEMP1)))
      T = ABS(DOTPRD(P, V(STEP1), V(LKY1)))
      V(SIZE) = ONE
      IF (T .LT. T1) V(SIZE) = T / T1
C
C  ***  UPDATE S  ***
C
      CALL SLUPDT(V(S1), V(COSMIN), P, V(SIZE), V(STEP1), V(TEMP1),
     +            V(TEMP2), V(G01), V(WSCALE), V(LKY1))
      IV(1) = 2
      GO TO 150
C
C. . . . . . . . . . . . . .  MISC. DETAILS  . . . . . . . . . . . . . .
C
C  ***  BAD PARAMETERS TO ASSESS  ***
C
 640  IV(1) = 14
      GO TO 900
C
C  ***  CONVERGENCE OBTAINED -- COMPUTE COVARIANCE MATRIX IF DESIRED ***
C
 700  IF (IV(COVREQ) .EQ. 0 .AND. IV(COVPRT) .EQ. 0) GO TO 760
      IF (IV(COVMAT) .NE. 0) GO TO 760
      IF (IV(CNVCOD) .GE. 7) GO TO 760
      IV(MODE) = 0
 710  CALL COVCLC(I, D, IV, J, N, NN, P, R, V, X)
      GO TO (720, 720, 740, 750), I
 720  IV(NFCOV) = IV(NFCOV) + 1
      IV(NFCALL) = IV(NFCALL) + 1
      IV(RESTOR) = I
      IV(1) = 1
      GO TO 999
C
 730  IF (IV(RESTOR) .EQ. 1 .OR. IV(TOOBIG) .NE. 0) GO TO 710
      IV(NFGCAL) = IV(NFCALL)
 740  IV(NGCOV) = IV(NGCOV) + 1
      IV(NGCALL) = IV(NGCALL) + 1
      IV(1) = 2
      GO TO 999
C
 750  IV(MODE) = 0
      IF (IV(NITER) .EQ. 0) IV(MODE) = -1
C
 760  IV(1) = IV(CNVCOD)
      IV(CNVCOD) = 0
C
C  ***  PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS  ***
C
 900  CALL ITSMRY(D, IV, P, V, X)
C
 999  RETURN
C
C  ***  LAST CARD OF NL2ITR FOLLOWS  ***
      END
*RELDST
      DOUBLE PRECISION FUNCTION RELDST(P, D, X, X0)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C
C  ***  COMPUTE AND RETURN RELATIVE DIFFERENCE BETWEEN X AND X0  ***
C  ***  NL2SOL VERSION 2.2  ***
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   P
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   D(P),X(P),X0(P)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   EMAX,T,XMAX,ZERO
      INTEGER
     +   I
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ZERO/0.0D0/
C
      EMAX = ZERO
      XMAX = ZERO
      DO 10 I = 1, P
         T = ABS(D(I) * (X(I) - X0(I)))
         IF (EMAX .LT. T) EMAX = T
         T = D(I) * (ABS(X(I)) + ABS(X0(I)))
         IF (XMAX .LT. T) XMAX = T
 10      CONTINUE
      RELDST = ZERO
      IF (XMAX .GT. ZERO) RELDST = EMAX / XMAX
      RETURN
C  ***  LAST CARD OF RELDST FOLLOWS  ***
      END
*STPSEL
      SUBROUTINE STPSEL(XM, N, M, IXM, MDL, PAR, NPAR,
     +   NEXMPT, STP, NFAIL, IFAIL, J, ETA3, RELTOL, ABSTOL, TAUABS,
     +   STPLOW, STPMID, STPUP, ITEMP, FD, FDLAST, FDSAVE, PV, PVNEW)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE SELECTS NEW STEP SIZES UNITL EITHER
C     THE NUMBER OF OBSERVATIONS AT WHICH THE SELECTION CRITERIA
C     IS NOT MET DOES NOT EXCEED NEXMPT OR UNTIL NO FURTHER
C     IMPROVEMENT CAN BE MADE.
C
C     WRITTEN BY  -  ROBERT B. SCHNABEL (CODED BY JANET R. DONALDSON)
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  APRIL 2, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   ABSTOL,ETA3,RELTOL,STP,STPLOW,STPMID,STPUP,TAUABS
      INTEGER
     +   IXM,J,M,N,NEXMPT,NFAIL,NPAR
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   FD(N),FDLAST(N),FDSAVE(N),PAR(NPAR),PV(N),PVNEW(N),XM(IXM,M)
      INTEGER
     +   IFAIL(N),ITEMP(N)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL MDL
C
C  SCALARS IN COMMON
      DOUBLE PRECISION
     +   Q
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   FACTOR,STP1,STP2,STPNEW,TEMP
      INTEGER
     +   NCOUNT
      LOGICAL
     +   FAIL,FIRST,FORWRD,HICURV,SUCCES
C
C  EXTERNAL SUBROUTINES
      EXTERNAL ABSCOM,CMPFD,ICOPY,RELCOM,DCOPY,STPADJ
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS
C
C  COMMON BLOCKS
      COMMON /NOTOPT/Q
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION ABSTOL
C        THE ABSOLUTE AGREEMENT TOLERANCE.
C     DOUBLE PRECISION ETA3
C        THE CUBE ROOT OF THE RELATIVE NOISE IN THE MODEL
C     DOUBLE PRECISION FACTOR
C        A FACTOR USED IN COMPUTING THE STEP SIZE.
C     LOGICAL FAIL
C        THE VARIABLE USED TO INDICATE WHETHER A STEP SIZE
C        CANNOT BE SELECTED WHICH WILL SUCCESSFULLY MEET THE CRITERIA.
C     DOUBLE PRECISION FD(N)
C        THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE
C        DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER
C     DOUBLE PRECISION FDLAST(N)
C        THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE
C        DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER
C        COMPUTED WITH THE MOST RECENT STEP SIZE SELECTED.
C     DOUBLE PRECISION FDSAVE(N)
C        A VECTOR USED TO SAVE THE BEST OF THE
C        THE FORWARD DIFFERENCE QUOTIENT APPROXIMATIONS TO THE
C        DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER
C     LOGICAL FIRST
C        THE VARIABLE USED TO INDICATE WHETHER THIS STEP SIZE
C        IS BEING USED FOR THE FIRST TIME OR WHETHER IT HAS BEEN
C        PREVIOUSLY ADJUSTED.
C     LOGICAL FORWRD
C        THE VARIABLE USED TO INDICATE THE DIRECTION OF CHANGE IN
C        THE STEP SIZE.
C     LOGICAL HICURV
C        THE VARIABLE USED TO INDICATE WHETHER THE MODEL HAS
C        HIGH CURVATURE.
C     INTEGER IFAIL(N)
C        AN INDICATOR VECTOR USED TO DESIGNATE THOSE OBSERVATIONS
C        FOR WHICH THE STEP SIZE DOES NOT MEET THE CRITERIA.
C     INTEGER ITEMP(N)
C        A TEMPORARY VECTOR USED FOR STORING PAST VALUES OF ITEMP.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER J
C        THE INDEX OF THE PARAMETER BEING EXAMINED.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     EXTERNAL MDL
C        THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE
C        PREDICTED VALUES BASED ON THE CURRENT PARAMETER ESTIMATES.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NPAR
C        THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL.
C     INTEGER NCOUNT
C        THE NUMBER OF OBSERVATIONS AT WHICH THE NEW STEP SIZE DOES
C        SATISFY THE CRITERIA.
C     INTEGER NEXMPT
C        THE NUMBER OF OBSERVATIONS FOR WHICH A GIVEN STEP SIZE
C        DOES NOT HAVE TO BE SATISFACTORY AND THE SELECTED STEP
C        SIZE STILL BE CONSIDERED OK.
C     INTEGER NFAIL
C        A VECTOR CONTAINING FOR EACH OBSERVATION THE NUMBER OF
C        OBSERVATIONS FOR WHICH THE STEP SIZE DID NOT MEET THE CRITERIA.
C     DOUBLE PRECISION PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
C        PARAMETERS ARE STORED.
C     DOUBLE PRECISION PV(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     DOUBLE PRECISION PVNEW(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C        FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J)+STPCD.
C     DOUBLE PRECISION Q
C        A DUMMY VARIABLE WHICH IS USED, ALONG WITH COMMON NOTOPT (NO
C        OPTIMIZATION), TO COMPUTE THE STEP SIZE.
C     DOUBLE PRECISION STP
C        THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FORWARD
C        DIFFERENCE APPROXIMATION TO THE DERIVATIVE.
C     DOUBLE PRECISION STPLOW
C        THE LOWER LIMIT ON THE STEP SIZE.
C     DOUBLE PRECISION STPMID
C        THE MIDPOINT OF THE ACCEPTABLE RANGE OF THE STEP SIZE.
C     DOUBLE PRECISION STPNEW
C        THE VALUE OF THE NEW STEP SIZE BEING TESTED.
C     DOUBLE PRECISION STPUP
C        THE UPPER LIMIT ON THE STEP SIZE.
C     DOUBLE PRECISION STP1, STP2
C        TEMPORARY STORAGE LOCATIONS FOR STEP SIZES.
C     LOGICAL SUCCES
C        THE VARIABLE USED TO INDICATE WHETHER THE STEP SIZE
C        SUCCESSFULLY MEETS THE CRITERIA USED TO SELECT THE STEP
C        SIZES.
C     DOUBLE PRECISION RELTOL
C        THE RELATIVE AGREEMENT TOLERANCE.
C     DOUBLE PRECISION TAUABS
C        THE ABSOLUTE AGREEMENT TOLERANCE.
C     DOUBLE PRECISION TEMP
C        A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE JTH
C        PARAMETER IS STORED.
C     DOUBLE PRECISION XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      CALL DCOPY(N, FD, 1, FDSAVE, 1)
C
      FACTOR = 10.0D0
      IF (ABS(STP) .GT. STPMID) FACTOR = 0.1D0
C
      STPNEW = STP * FACTOR
      STP1 = STPNEW
      STP2 = STPNEW
C
      Q = STPNEW + PAR(J)
      STPNEW = Q - PAR(J)
C
      FIRST = .TRUE.
      FORWRD = .TRUE.
      SUCCES = .FALSE.
      FAIL = .FALSE.
C
      NFAIL = N + 1
C
C     REPEAT FOLLOWING UNTIL (SUCCES) OR (FAIL)
C
   10 CONTINUE
C
      CALL DCOPY(N, FD, 1, FDLAST, 1)
C
      TEMP = PAR(J)
      PAR(J) = TEMP + STPNEW
C
      CALL MDL(PAR, NPAR, XM, N, M, IXM, PVNEW)
C
      PAR(J) = TEMP
C
      CALL CMPFD(N, STPNEW, PVNEW, PV, FD)
C
      CALL RELCOM(N, FD, FDLAST, RELTOL, ABSTOL, NCOUNT, ITEMP)
C
      IF (NCOUNT.LE.NEXMPT) THEN
            SUCCES = .TRUE.
            NFAIL = NCOUNT
            CALL ICOPY(N, ITEMP, 1, IFAIL, 1)
            IF (ABS(ABS(STPNEW) - STPMID) .GT.
     +         ABS(ABS(STPNEW/FACTOR) - STPMID)) THEN
                  STP = STPNEW / FACTOR
            ELSE
                  STP = STPNEW
            END IF
      ELSE
            IF (NCOUNT.LT.NFAIL) THEN
                  NFAIL = NCOUNT
                  STP1 = STPNEW
                  STP2 = STPNEW / FACTOR
                  CALL ICOPY(N, ITEMP, 1, IFAIL, 1)
            END IF
            IF (FIRST) THEN
                  FIRST = .FALSE.
                  CALL ABSCOM(N, FD, FDLAST, TAUABS, NCOUNT)
                  IF (NCOUNT.LE.NEXMPT) THEN
                         HICURV = .TRUE.
                  ELSE
                         HICURV = .FALSE.
                  END IF
            END IF
            STPNEW = STPNEW * FACTOR
            Q = STPNEW + PAR(J)
            STPNEW = Q - PAR(J)
            IF ((FACTOR.GT.1.0D0 .AND. ABS(STPNEW).GT.STPUP) .OR.
     +          (FACTOR.LT.1.0D0 .AND. ABS(STPNEW).LT.STPLOW)) THEN
                  IF (FORWRD) THEN
                        FORWRD = .FALSE.
                        FACTOR = 1.0D0 / FACTOR
                        STPNEW = STP * FACTOR
                        Q = STPNEW + PAR(J)
                        STPNEW = Q - PAR(J)
                        CALL DCOPY(N, FDSAVE, 1, FD, 1)
                        STPLOW = STPLOW * (ETA3)
                        STPUP = STPUP / (ETA3)
                  ELSE
                        FAIL = .TRUE.
                  END IF
            END IF
      END IF
C
      IF (.NOT.(SUCCES.OR.FAIL)) GO TO 10
C
      IF (SUCCES .AND. FORWRD) THEN
            CALL STPADJ(XM, N, M, IXM, MDL, PAR, NPAR,
     +         NEXMPT, STP, NFAIL, IFAIL, J, RELTOL, ABSTOL, STPLOW,
     +         STPMID, STPUP, ITEMP, FD, FDLAST, PV, PVNEW)
            RETURN
      ELSE
            IF (SUCCES) THEN
                  RETURN
            ELSE
C                 IF (HICURV) NFAIL = -NFAIL
C
                  IF (ABS(STP1).LT.ABS(STP2)) THEN
                        STP = STP1
                        RETURN
                  ELSE
                        STP = STP2
                        RETURN
                  END IF
            END IF
      END IF
C
      END
*AMEMN
      SUBROUTINE AMEMN(Y, WEIGHT, NNZW, WT, LWT, XM, N, M, IXM, NRESTS,
     +   APRXDV, IFIXD, PAR, PARE, NPAR, RES, PAGE, WIDE,
     +   HLFRPT, STP, LSTP, MIT, STOPSS, STOPP, SCALE, LSCALE, DELTA,
     +   IVAPRX, IPTOUT, NDIGIT, RSD, RESTS, SDPVI, SDRESI, VCVL, LVCVL,
     +   D, IWORK, IIWORK, RWORK, IRWORK, NLHDR, NPARE, PVT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE CONTROLING SUBROUTINE FOR PERFORMING NONLINEAR
C     LEAST SQUARES REGRESSION USING THE NL2 SOFTWARE PACKAGE
C     (IMPLEMENTING THE METHOD OF DENNIS, GAY AND WELSCH).
C     THIS SUBROUTINE WAS ADAPTED FROM SUBROUTINE NL2SOL.
C
C     REFERENCES
C
C     DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1979), AN ADAPTIVE
C             NONLINEAR LEAST-SQUARES ALGORITHM, (BEING REVISED).
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  APRIL 2, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   DELTA,RSD,STOPP,STOPSS
      INTEGER
     +   IIWORK,IRWORK,IVAPRX,IXM,LSCALE,LSTP,LVCVL,LWT,M,MIT,N,
     +   NDIGIT,NNZW,NPAR,NPARE,NRESTS,SDPVI,SDRESI,VCVL
      LOGICAL
     +   APRXDV,HLFRPT,PAGE,WEIGHT,WIDE
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   D(NRESTS,*),PAR(*),PARE(*),PVT(*),RES(*),RESTS(*),RWORK(*),
     +   SCALE(*),STP(*),WT(*),XM(IXM,*),Y(*)
      INTEGER
     +   IFIXD(*),IPTOUT(*),IWORK(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL NLHDR
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   CNVCOD,COVMAT,I,ICNVCD,IVCVPT,QTR,RD,RDI,RSAVE,RSSHLF,S,
     +   SCL
      LOGICAL
     +   CMPDRV,DONE,HEAD,NEWITR,PRTSMY
C
C  LOCAL ARRAYS
      INTEGER
     +   ISKULL(10)
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMDRV,AMEFIN,AMEISM,DRV,MDLTS3,NL2ITR,NLERR,NLINIT,
     +   NLITRP,NLSUPK,REPCK,DCOPY
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL APRXDV
C        THE VARIABLE USED TO INDICATE WHETHER NUMERICAL
C        APPROXIMATIONS TO THE DERIVATIVE WERE USED (TRUE) OR NOT
C        (FALSE).
C     LOGICAL CMPDRV
C        THE VARIABLE USED TO INDICATE WHETHER DERIVATIVES MUST BE
C        COMPUTED (TRUE) OR NOT (FALSE).
C     INTEGER CNVCOD
C        A VALUE USED TO CONTROL THE PRINTING OF ITERATION REPORTS.
C     INTEGER COVMAT
C        THE LOCATION IN IWORK OF THE STARTING LOCATION IN RWORK
C        OF THE BEGINNING OF THE VCV MATRIX.
C     DOUBLE PRECISION D(NRESTS,NPAR)
C        THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE
C        DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER.
C     DOUBLE PRECISION DELTA
C        THE MAXIMUM CHANGE ALLOWED IN THE MODEL PARAMETERS AT THE
C        FIRST ITERATION.
C     EXTERNAL DRV
C        THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE
C        DERIVATIVE (JACOBIAN) MATRIX OF THE MODEL.
C     LOGICAL DONE
C        THE VARIABLE USED TO INDICATE WHETHER THIS IS THE FINAL
C        COMPUTATION OF THE JACOBIAN OR NOT.
C     LOGICAL HEAD
C        THE VARIABLE USED TO INDICATE WHETHER A HEADING IS TO BE
C        PRINTED DURING A GIVEN CALL TO THE ITERATION REPORT (TRUE)
C        OR NOT (FALSE).
C     LOGICAL HLFRPT
C        THE VARIABLE WHICH INDICATES WHETHER THE DERIVATIVE
C        CHECKING ROUTINE HAS ALREADY PRINTED PART OF THE
C        INITIAL SUMMARY (TRUE) OR NOT (FALSE).
C     INTEGER I
C        AN INDEXING VARIABLE.
C     INTEGER ICNVCD
C        THE LOCATION IN IWORK OF
C        THE CONVERGENCE CONDITION.
C     INTEGER IERR
C        THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .GE. 1, ERRORS WERE DETECTED.
C     INTEGER IFIXD(NPAR)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE
C        PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED.
C        IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED.
C        IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED.
C     INTEGER IIWORK
C        THE DIMENSION OF THE INTEGER WORK VECTOR IWORK.
C     INTEGER IPTOUT(NDIGIT)
C        THE VARIABLE USED TO CONTROL PRINTED OUTPUT FOR EACH SECTION.
C     INTEGER IRWORK
C        THE DIMENSION OF THE DOUBLE PRECISION WORK VECTOR RWORK.
C     INTEGER ISKULL(10)
C        AN ERROR MESSAGE INDICATOR VARIABLE.
C     INTEGER IVAPRX
C        AN INDICATOR VALUE USED TO DESIGNATE WHICH OPTION IS TO BE USED
C        TO COMPUTE THE VARIANCE COVARIANCE MATRIX (VCV), WHERE
C        IVAPRX LE 0 INDICATES THE THE DEFAULT OPTION WILL BE USED
C        IVAPRX EQ 1 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN)
C                    USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED
C                    DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE
C        IVAPRX EQ 2 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(HESSIAN)
C                    USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED
C                    DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE
C        IVAPRX EQ 3 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN
C                          *INVERSE(HESSIAN)
C                    USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED
C                    DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE
C        IVAPRX EQ 4 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN)
C                    USING ONLY THE MODEL SUBROUTINE
C        IVAPRX EQ 5 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(HESSIAN)
C                    USING ONLY THE MODEL SUBROUTINE
C        IVAPRX EQ 6 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN
C                          *INVERSE(HESSIAN)
C                    USING ONLY THE MODEL SUBROUTINE
C        IVAPRX GE 7 INDICATES THE DEFAULT OPTION WILL BE USED
C     INTEGER IVCVPT
C        AN INDICATOR VALUE USED TO DESIGNATE WHICH FORM OF THE
C        VARIANCE COVARIANCE MATRIX (VCV) IS BEING PRINTED, WHERE
C        IVCVPT = 1 INDICATES THE VCV WAS COMPUTED AS
C                   INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN)
C        IVCVPT = 2 INDICATES THE VCV WAS COMPUTED AS
C                   INVERSE(HESSIAN)
C        IVCVPT = 3 INDICATES THE VCV WAS COMPUTED AS
C                   INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN
C                       *INVERSE(HESSIAN)
C     INTEGER IWORK(IIWORK)
C        THE INTEGER WORK SPACE VECTOR USED BY THE NL2 SUBROUTINES.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY.
C     INTEGER LSCALE
C        THE ACTUAL LENGTH OF THE VECTOR SCALE.
C     INTEGER LSTP
C        THE ACTUAL LENGTH OF THE VECTOR STP.
C     INTEGER LVCVL
C        THE LENGTH OF THE VECTOR CONTAINING
C        THE LOWER HALF OF THE VCV MATRIX, STORED ROW WISE.
C     INTEGER LWT
C        THE ACTUAL LENGTH OF THE VECTOR WT.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     INTEGER MIT
C        THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C     EXTERNAL MDLTS3
C        THE STARPAC FORMAT SUBROUTINE FOR COMPUTING THE ARIMA MODEL
C        RESIDUALS.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NDIGIT
C        THE NUMBER OF DIGITS IN THE PRINT CONTROL VALUE.
C     LOGICAL NEWITR
C        A FLAG USED TO INDICATE WHETHER A NEW ITERATION HAS BEEN
C        COMPLETED (TRUE) OR NOT (FALSE).
C     EXTERNAL NLHDR
C        THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING.
C     INTEGER NNZW
C        THE NUMBER OF NON ZERO WEIGHTS.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     INTEGER NPARE
C        THE NUMBER OF PARAMETERS TO BE OPTIMIZED.
C     INTEGER NRESTS
C        THE MAXIMUM NUMBER OF RESIDUALS TO BE COMPUTED.
C     LOGICAL PAGE
C        THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF
C        THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     DOUBLE PRECISION PARE(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS, BUT ONLY
C        THOSE TO BE OPTIMIZED (NOT THOSE WHOSE VALUES ARE FIXED).
C     LOGICAL PRTSMY
C        THE VARIABLE USED TO INDICATE WHETHER THE SUMMARY
C        INFORMATION IS TO BE PRINTED (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION PVT(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES.
C     INTEGER QTR
C        THE LOCATION IN IWORK OF THE STARTING LOCATION IN RWORK
C        THE ARRAY Q TRANSPOSE R.
C     INTEGER RD
C        THE LOCATION IN IWORK OF THE STARTING LOCATION IN RWORK OF
C        THE DIAGONAL ELEMENTS OF THE R MATRIX OF THE Q - R
C        FACTORIZATION OF D.
C     INTEGER RDI
C        THE LOCATION IN RWORK OF THE DIAGONAL ELEMENTS OF THE R
C        MATRIX OF THE Q - R FACTORIZATION OF D.
C     DOUBLE PRECISION RES(N)
C        THE RESIDUALS FROM THE FIT.
C     DOUBLE PRECISION RESTS(NRESTS)
C        THE RESIDUALS FROM THE ARIMA MODEL.
C     INTEGER RSAVE
C        THE LOCATION IN IWORK OF THE STARTING LOCATION IN RWORK
C        THE ARRAY RSAVE.
C     DOUBLE PRECISION RSD
C        THE VALUE OF THE RESIDUAL STANDARD DEVIATION AT THE SOLUTION.
C     INTEGER RSSHLF
C        THE LOCATION IN RWORK OF
C        HALF THE RESIDUAL SUM OF SQUARES.
C     DOUBLE PRECISION RWORK(IRWORK)
C        THE DOUBLE PRECISION WORK VECTOR USED BY THE NL2 SUBROUTINES.
C     INTEGER S
C        THE LOCATION IN IWORK OF THE STARTING LOCATION IN RWORK
C        THE ARRAY OF SECOND ORDER TERMS OF THE HESSIAN.
C     DOUBLE PRECISION SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     INTEGER SCL
C        THE INDEX IN RWORK OF THE 1ST VALUE OF THE USER SUPPLIED SCALE
C        VALUE.
C     INTEGER SDPVI
C        THE STARTING LOCATION IN RWORK OF
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     INTEGER SDRESI
C        THE STARTING LOCATION IN RWORK OF THE
C        THE STANDARDIZED RESIDUALS.
C     DOUBLE PRECISION STOPP
C        THE STOPPING CRITERION FOR THE TEST BASED ON THE MAXIMUM SCALED
C        RELATIVE CHANGE IN THE ELEMENTS OF THE MODEL PARAMETER VECTOR
C        PREDICTED DECREASE IN THE RESIDUAL STANDARD DEVIATION (COMPUTED
C        BY STARPAC) TO THE CURRENT RESIDUAL SUM OF SQUARES ESTIMATE.
C     DOUBLE PRECISION STOPSS
C        THE STOPPING CRITERION FORTHE TEST BASED ON THE RATIO OF THE
C        PREDICTED DECREASE IN THE RESIDUAL SUM OF SQUARES (COMPUTED
C        BY STARPAC) TO THE CURRENT RESIDUAL SUM OF SQUARES ESTIMATE.
C     DOUBLE PRECISION STP(LSTP)
C        THE DUMMY STEP SIZE ARRAY.
C     INTEGER VCVL
C        THE STARTING LOCATION IN RWORK OF THE LOWER HALF OF THE
C        VCV MATRIX, STORED ROW WISE.
C     LOGICAL WEIGHT
C        THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO
C        BE PERFORMED (TRUE) OR NOT (FALSE).
C     LOGICAL WIDE
C        THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD
C        BE FULL WIDTH (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION WT(LWT)
C        THE USER SUPPLIED WEIGHTS.
C     DOUBLE PRECISION XM(IXM,M)
C        THE ARRAY IN WHICH ONE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        IS STORED.
C     DOUBLE PRECISION Y(N)
C        THE ARRAY OF THE DEPENDENT VARIABLE.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     IWORK SUBSCRIPT VALUES
C
      DATA CNVCOD /34/, ICNVCD /1/, COVMAT /26/, QTR /49/, RD /51/,
     +   RSAVE /52/, S/53/
      DATA RSSHLF /10/
C
C+++++++++++++++++++++++++++++++  BODY  ++++++++++++++++++++++++++++++++
C
C     INITIALIZE CONTROL PARAMETERS
C
      CALL NLINIT (NRESTS, IFIXD, PAR, NPAR, PARE, NPARE, MIT, STOPSS,
     +   STOPP, SCALE, LSCALE, DELTA, IVAPRX, APRXDV, IVCVPT, IWORK,
     +   IIWORK, RWORK, IRWORK, SCL)
C
      CMPDRV = .TRUE.
      DONE = .FALSE.
      HEAD = .TRUE.
      NEWITR = .FALSE.
      PRTSMY = (IPTOUT(1).NE.0)
C
C     COMPUTE RESIDUALS
C
   10 CALL MDLTS3(PAR, NPAR, XM, N, M, IXM, RESTS)
C
C     PRINT INITIAL SUMMARY
C
      IF (.NOT.PRTSMY) GO TO 30
      CALL AMEISM(NLHDR, PAGE, WIDE, HLFRPT, NPAR, M, N, NNZW, WEIGHT,
     +   IFIXD, PAR, SCALE, LSCALE, IWORK, IIWORK, RWORK, IRWORK, RESTS,
     +   APRXDV, STP, LSTP, NPARE)
      PRTSMY = .FALSE.
C
   30 CONTINUE
C
      IF (.NOT.CMPDRV) GO TO 50
C
      CMPDRV = .FALSE.
C
   40 CONTINUE
C
C     PRINT ITERATION REPORT IF DESIRED
C
      IF ((IPTOUT(2).NE.0) .AND. NEWITR) CALL NLITRP(NLHDR, HEAD, PAGE,
     +   WIDE, IPTOUT(2), NPAR, NNZW, IWORK, IIWORK, RWORK, IRWORK,
     +   IFIXD, PARE, NPARE)
C
C  ***  COMPUTE JACOBIAN  ***
C
      IF (DONE) CALL MDLTS3(PAR, NPAR, XM, N, M, IXM, RESTS)
C
      CALL AMDRV(MDLTS3, DRV, DONE, IFIXD, PAR, NPAR, XM, N, M, IXM,
     +  NRESTS, RESTS, D, WEIGHT, WT, LWT, STP, LSTP, RWORK(SCL), NPARE)
C
      IF (DONE) GO TO 70
C
C     COMPUTE NEXT ITERATION
C
   50 CALL NL2ITR(RWORK(SCL), IWORK, D, NRESTS, NRESTS, NPARE, RESTS,
     +   RWORK, PARE)
C
C     UNPACK PARAMETERS
C
      CALL NLSUPK(PARE, NPARE, PAR, IFIXD, NPAR)
C
      NEWITR = (IWORK(CNVCOD).EQ.0)
      IF (IWORK(1)-2) 10, 40, 60
C
   60 DONE = .TRUE.
      GO TO 40
   70 CONTINUE
C
C     SET ERROR FLAGS, IF NECESSARY
C
      CALL NLERR(IWORK(ICNVCD), ISKULL)
C
C     FINISH COMPUTATIONS AND PRINT ANY DESIRED RESULTS
C
      CALL DCOPY(N, RESTS(NRESTS-N+1), 1, RES(1), 1)
      DO 75 I = 1, N
         PVT(I) = Y(I) - RES(I)
   75 CONTINUE
      SDPVI = IWORK(RSAVE)
      SDRESI = IWORK(QTR)
      VCVL = IWORK(COVMAT)
      IF (VCVL.GE.1) GO TO 80
C
      VCVL = IWORK(S)
      IF (IERR.NE.0) GO TO 80
      ISKULL(1) = 1
      ISKULL(7) = 1
      IERR = 7
C
   80 CONTINUE
C
      LVCVL = NPARE*(NPARE+1)/2
C
      RDI = IWORK(RD)
C
C     REPCK IS CALLED TO AVOID MODIFICATION OF NLS CODE.  FUTURE
C     REVISIONS OF NLS CODE SHOULD INCLUDE MODIFICATIONS NECESSARY
C     TO ELIMINATE NEED TO REPACK D FOR ARIMA CODE.
C
      CALL REPCK(D, NRESTS, NPAR, N)
      CALL AMEFIN(Y, WEIGHT, NNZW, WT, LWT, XM, N, M, IXM, IFIXD, PAR,
     +   NPAR, NPARE, RES, PAGE, WIDE, IPTOUT, NDIGIT, RWORK(RSSHLF),
     +   RSD, PVT, RWORK(SDPVI), RWORK(SDRESI), RWORK(RDI),
     +   RWORK(VCVL), LVCVL, D, NLHDR, IVCVPT, ISKULL, NRESTS)
C
      RETURN
C
      END
*DCOEF
      SUBROUTINE DCOEF (NDF, ND, IOD, NPARDF, PARDF, MBO, WORK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE EXPANDS THE DIFFERENCE FILTER SPECIFIED BY NDF,
C     IOD AND ND INTO PARDF.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DEVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  NOVEMBER 26, 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   MBO,NDF,NPARDF
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   PARDF(*),WORK(*)
      INTEGER
     +   IOD(*),ND(*)
C
C  LOCAL SCALARS
      INTEGER
     +   K,KK,L,NTIMES,NWORK1,NWORK2
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   NCHOSE
      EXTERNAL NCHOSE
C
C  EXTERNAL SUBROUTINES
      EXTERNAL MULTBP
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IOD(NDF)
C        THE ORDER OF EACH OF THE DIFFERENCE FACTORS.
C     INTEGER K
C        AN INDEX VARIABLE.
C     INTEGER KK
C        AN INDEX VARIABLE.
C     INTEGER L
C        AN INDEX VARIABLE.
C     INTEGER MBO
C        THE MAXIMUM BACK ORDER OPERATOR.
C     INTEGER ND(NDF)
C        THE NUMBER OF TIMES EACH DIFFERENCE FACTOR IS TO BE APPLIED.
C     INTEGER NDF
C        THE NUMBER OF DIFFERENCE FACTORS
C     INTEGER NPARDF
C        THE ORDER OF THE EXPANDED DIFFERENCE FILTER.
C     INTEGER NTIMES
C        THE NUMBER OF TIMES A GIVEN DIFFERENCE FACTOR IS TO BE APPLIED.
C     INTEGER NWORK1
C        THE NUMBER OF TERMS IN THE FIRST COLUMN OF WORK.
C     INTEGER NWORK2
C        THE NUMBER OF TERMS IN THE SECOND COLUMN OF WORK
C     DOUBLE PRECISION PARDF(MBO)
C        THE VECTOR CONTAINING THE DIFFERENCE FILTER PARAMETERS.
C     DOUBLE PRECISION WORK(MBO,2)
C        A WORK ARRAY NECESSARY TO EXPAND THE DIFFERENCE FILTER.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      NPARDF = 0
C
      DO 30 L = 1, NDF
         IF (ND(L).EQ.0) GO TO 30
         NTIMES = ND(L)
         NWORK1 = IOD(L) * ND(L)
         DO 10 K = 1, NWORK1
            WORK(K) = 0.0D0
   10    CONTINUE
         DO 20 K = 1, NTIMES
            KK = K * IOD(L)
            WORK(KK) = ((-1)**(K+1)) * NCHOSE(NTIMES, K)
   20    CONTINUE
         NWORK2 = NWORK1 + NPARDF
         CALL MULTBP (WORK(1), NWORK1, PARDF, NPARDF, WORK(MBO+1),
     +      NWORK2, MBO)
   30 CONTINUE
      RETURN
      END
*FITEXT
      SUBROUTINE FITEXT(RSS, YSS, EXACT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE CHECKS WHETHER THE FIT IS EXACT TO MACHINE
C     PRECISION.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  OCTOBER 3, 1983
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   RSS,YSS
      LOGICAL
     +   EXACT
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   FPLRS,RSSTST
C
C  EXTERNAL FUNCTIONS
CCCCC DOUBLE PRECISION
CCCCC+   D1MACH
CCCCC EXTERNAL D1MACH
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL EXACT
C        AN INDICATOR VALUE USED TO DESIGNATE WHETHER THE FIT
C        WAS EXACT TO MACHINE PRECISION (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION FPLRS
C        THE FLOATING POINT LARGEST RELATIVE SPACING.
C     DOUBLE PRECISION RSS
C        THE RESIDUAL SUM OF SQUARES.
C     DOUBLE PRECISION RSSTST
C        THE VALUE FOR TESTING WHETHER THE RESIDUAL SUM OF SQUARES
C        IS ZERO (TO WITHIN MACHINE PRECISION).
C     DOUBLE PRECISION YSS
C        THE SUM OF SQUARES OF THE DEPENDENT VARIABLE Y.
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      FPLRS = D1MACH(4)
C
C     TEST FOR EXACT FIT
C
      EXACT = .FALSE.
      RSSTST = RSS
      IF (YSS.GT.0.0D0) RSSTST = RSSTST / YSS
      RSSTST = SQRT(RSSTST)
      IF (RSSTST.LT.10.0D0*FPLRS) EXACT = .TRUE.
C
      RETURN
C
      END
*LMSTEP
      SUBROUTINE LMSTEP(D, G, IERR, IPIVOT, KA, P, QTR, R, STEP, V, W)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C
C  ***  COMPUTE LEVENBERG-MARQUARDT STEP USING MORE-HEBDEN TECHNIQUE  **
C  ***  NL2SOL VERSION 2.2.  ***
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IERR,KA,P
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   D(P),G(P),QTR(P),R(1),STEP(P),V(21),W(1)
      INTEGER
     +   IPIVOT(P)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   A,ADI,ALPHAK,B,D1,D2,DFAC,DFACSQ,DST,DTOL,EIGHT,HALF,LK,
     +   NEGONE,OLDPHI,ONE,P001,PHI,PHIMAX,PHIMIN,PSIFAC,RAD,SI,SJ,
     +   SQRTAK,T,THREE,TTOL,TWOPSI,UK,WL,ZERO
      INTEGER
     +   DGNORM,DST0,DSTNRM,DSTSAV,EPSLON,GTSTEP,I,I1,IP1,J1,K,
     +   KALIM,L,LK0,NREDUC,PHIPIN,PHMNFC,PHMXFC,PP1O2,PREDUC,RAD0,
     +   RADIUS,RES,RES0,RMAT,RMAT0,STPPAR,UK0
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DOTPRD,V2NORM
      EXTERNAL DOTPRD,V2NORM
C
C  EXTERNAL SUBROUTINES
      EXTERNAL LITVMU,LIVMUL,VCOPY
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MAX,MIN,SQRT
C
C  ***  PARAMETER DECLARATIONS  ***
C
C     INTEGER IERR, KA, P
C     INTEGER IPIVOT(P)
C     DOUBLE PRECISION D(P), G(P), QTR(P), R(1), STEP(P), V(21), W(1)
C     DIMENSION W(P*(P+5)/2 + 4)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  ***  PURPOSE  ***
C
C        GIVEN THE R MATRIX FROM THE QR DECOMPOSITION OF A JACOBIAN
C     MATRIX, J, AS WELL AS Q-TRANSPOSE TIMES THE CORRESPONDING
C     RESIDUAL VECTOR, RESID, THIS SUBROUTINE COMPUTES A LEVENBERG-
C     MARQUARDT STEP OF APPROXIMATE LENGTH V(RADIUS) BY THE MORE-
C     TECHNIQUE.
C
C  ***  PARAMETER DESCRIPTION  ***
C
C      D (IN)  = THE SCALE VECTOR.
C      G (IN)  = THE GRADIENT VECTOR (J**T)*R.
C   IERR (I/O) = RETURN CODE FROM QRFACT OR QRFGS -- 0 MEANS R HAS
C             FULL RANK.
C IPIVOT (I/O) = PERMUTATION ARRAY FROM QRFACT OR QRFGS, WHICH COMPUTE
C             QR DECOMPOSITIONS WITH COLUMN PIVOTING.
C     KA (I/O).  KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST CALL ON
C             LMSTEP FOR THE CURRENT R AND QTR.  ON OUTPUT KA CON-
C             TAINS THE NUMBER OF HEBDEN ITERATIONS NEEDED TO DETERMINE
C             STEP.  KA = 0 MEANS A GAUSS-NEWTON STEP.
C      P (IN)  = NUMBER OF PARAMETERS.
C    QTR (IN)  = (Q**T)*RESID = Q-TRANSPOSE TIMES THE RESIDUAL VECTOR.
C      R (IN)  = THE R MATRIX, STORED COMPACTLY BY COLUMNS.
C   STEP (OUT) = THE LEVENBERG-MARQUARDT STEP COMPUTED.
C      V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW.
C      W (I/O) = WORKSPACE OF LENGTH P*(P+5)/2 + 4.
C
C  ***  ENTRIES IN V  ***
C
C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G.
C V(DSTNRM) (I/O) = 2-NORM OF D*STEP.
C V(DST0)   (I/O) = 2-NORM OF GAUSS-NEWTON STEP (FOR NONSING. J).
C V(EPSLON) (IN) = MAX. REL. ERROR ALLOWED IN TWONORM(R)**2 MINUS
C             TWONORM(R - J*STEP)**2.  (SEE ALGORITHM NOTES BELOW.)
C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP.
C V(NREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED
C             FOR A GAUSS-NEWTON STEP.
C V(PHMNFC) (IN)  = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP
C             (MORE*S SIGMA).  THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE
C             BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS).
C V(PHMXFC) (IN)  (SEE V(PHMNFC).)
C V(PREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED
C             BY THE STEP RETURNED.
C V(RADIUS) (IN)  = RADIUS OF CURRENT (SCALED) TRUST REGION.
C V(RAD0)   (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL.
C V(STPPAR) (I/O) = MARQUARDT PARAMETER (OR ITS NEGATIVE IF THE SPECIAL
C             CASE MENTIONED BELOW IN THE ALGORITHM NOTES OCCURS).
C
C NOTE -- SEE DATA STATEMENT BELOW FOR VALUES OF ABOVE SUBSCRIPTS.
C
C  ***  USAGE NOTES  ***
C
C     IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF
C     V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT
C     WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS).  (THIS EXPLAINS
C     WHY MANY PARAMETERS ARE LISTED AS I/O).  ON AN INTIIAL CALL (ONE
C     WITH KA = -1), THE CALLER NEED ONLY HAVE INITIALIZED D, G, KA, P,
C     QTR, R, V(EPSLON), V(PHMNFC), V(PHMXFC), V(RADIUS), AND V(RAD0).
C
C  ***  APPLICATION AND USAGE RESTRICTIONS  ***
C
C     THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR LEAST-
C     SQUARES) PACKAGE (REF. 1).
C
C  ***  ALGORITHM NOTES  ***
C
C     THIS CODE IMPLEMENTS THE STEP COMPUTATION SCHEME DESCRIBED IN
C     REFS. 2 AND 4.  FAST GIVENS TRANSFORMATIONS (SEE REF. 3, PP. 60-
C     62) ARE USED TO COMPUTE STEP WITH A NONZERO MARQUARDT PARAMETER.
C        A SPECIAL CASE OCCURS IF J IS (NEARLY) SINGULAR AND V(RADIUS)
C     IS SUFFICIENTLY LARGE.  IN THIS CASE THE STEP RETURNED IS SUCH
C     THAT  TWONORM(R)**2 - TWONORM(R - J*STEP)**2  DIFFERS FROM ITS
C     OPTIMAL VALUE BY LESS THAN V(EPSLON) TIMES THIS OPTIMAL VALUE,
C     WHERE J AND R DENOTE THE ORIGINAL JACOBIAN AND RESIDUAL.  (SEE
C     REF. 2 FOR MORE DETAILS.)
C
C  ***  FUNCTIONS AND SUBROUTINES CALLED  ***
C
C DOTPRD - RETURNS INNER PRODUCT OF TWO VECTORS.
C LITVMU - APPLY INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX.
C LIVMUL - APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX.
C VCOPY  - COPIES ONE VECTOR TO ANOTHER.
C V2NORM - RETURNS 2-NORM OF A VECTOR.
C
C  ***  REFERENCES  ***
C
C 1.  DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1980), AN ADAPTIVE
C             NONLINEAR LEAST-SQUARES ALGORITHM, (SUBMITTED TO ACM
C             TRANS. MATH. SOFTWARE).
C 2.  GAY, D.M. (1979), COMPUTING OPTIMAL ELLIPTICALLY CONSTRAINED
C             STEPS, MRC TECH. SUMMARY REPORT NO. 2013, MATH RESEARCH
C             CENTER, UNIV. OF WISCONSIN-MADISON.
C 3.  LAWSON, C.L., AND HANSON, R.J. (1974), SOLVING LEAST SQUARES
C             PROBLEMS, PRENTICE-HALL, ENGLEWOOD CLIFFS, N.J.
C 4.  MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN-
C             TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES
C             IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER-
C             VERLAG, BERLIN AND NEW YORK.
C
C  ***  GENERAL  ***
C
C     CODED BY DAVID M. GAY.
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
C     MCS-7906671.
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  ***  LOCAL VARIABLES  ***
C
C     INTEGER DSTSAV, I, IP1, I1, J1, K, KALIM, L, LK0, PHIPIN,
C    1        PP1O2, RES, RES0, RMAT, RMAT0, UK0
C     DOUBLE PRECISION A, ADI, ALPHAK, B, DFACSQ, DST, DTOL, D1, D2,
C    1                 LK, OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD,
C    2                 SI, SJ, SQRTAK, T, TWOPSI, UK, WL
C
C     ***  CONSTANTS  ***
C     DOUBLE PRECISION DFAC, EIGHT, HALF, NEGONE, ONE, P001, THREE,
C    1                 TTOL, ZERO
C
C/
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
C     EXTERNAL DOTPRD, LITVMU, LIVMUL, VCOPY, V2NORM
C     DOUBLE PRECISION DOTPRD, V2NORM
C
C  ***  SUBSCRIPTS FOR V  ***
C
C     INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, NREDUC, PHMNFC,
C    1        PHMXFC, PREDUC, RADIUS, RAD0, STPPAR
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA DGNORM/1/, DSTNRM/2/, DST0/3/, EPSLON/19/,
     +     GTSTEP/4/, NREDUC/6/, PHMNFC/20/,
     +     PHMXFC/21/, PREDUC/7/, RADIUS/8/,
     +     RAD0/9/, STPPAR/5/
C
      DATA DFAC/256.0D0/, EIGHT/8.0D0/, HALF/0.5D0/, NEGONE/-1.0D0/,
     +     ONE/1.0D0/, P001/1.0D-3/, THREE/3.0D0/, TTOL/2.5D0/,
     +     ZERO/0.0D0/
C
C  ***  BODY  ***
C
C     ***  FOR USE IN RECOMPUTING STEP, THE FINAL VALUES OF LK AND UK,
C     ***  THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR NONSING. J)
C     ***  AND THE VALUE RETURNED AS V(DSTNRM) ARE STORED AT W(LK0),
C     ***  W(UK0), W(PHIPIN), AND W(DSTSAV) RESPECTIVELY.
      ALPHAK = 0.0D0
      PSIFAC = 0.0D0
      LK0 = P + 1
      PHIPIN = LK0 + 1
      UK0 = PHIPIN + 1
      DSTSAV = UK0 + 1
      RMAT0 = DSTSAV
C     ***  A COPY OF THE R-MATRIX FROM THE QR DECOMPOSITION OF J IS
C     ***  STORED IN W STARTING AT W(RMAT), AND A COPY OF THE RESIDUAL
C     ***  VECTOR IS STORED IN W STARTING AT W(RES).  THE LOOPS BELOW
C     ***  THAT UPDATE THE QR DECOMP. FOR A NONZERO MARQUARDT PARAMETER
C     ***  WORK ON THESE COPIES.
      RMAT = RMAT0 + 1
      PP1O2 = P * (P + 1) / 2
      RES0 = PP1O2 + RMAT0
      RES = RES0 + 1
      RAD = V(RADIUS)
      IF (RAD .GT. ZERO)
     +   PSIFAC = V(EPSLON)/((EIGHT*(V(PHMNFC) + ONE) + THREE) * RAD**2)
      PHIMAX = V(PHMXFC) * RAD
      PHIMIN = V(PHMNFC) * RAD
C     ***  DTOL, DFAC, AND DFACSQ ARE USED IN RESCALING THE FAST GIVENS
C     ***  REPRESENTATION OF THE UPDATED QR DECOMPOSITION.
      DTOL = ONE/DFAC
      DFACSQ = DFAC*DFAC
C     ***  OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY.  IF
C     ***  WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT.
      OLDPHI = ZERO
      LK = ZERO
      UK = ZERO
      KALIM = KA + 12
C
C  ***  START OR RESTART, DEPENDING ON KA  ***
C
      IF (KA) 10, 20, 370
C
C  ***  FRESH START -- COMPUTE V(NREDUC)  ***
C
 10   KA = 0
      KALIM = 12
      K = P
      IF (IERR .NE. 0) K = ABS(IERR) - 1
      V(NREDUC) = HALF*DOTPRD(K, QTR, QTR)
C
C  ***  SET UP TO TRY INITIAL GAUSS-NEWTON STEP  ***
C
 20   V(DST0) = NEGONE
      IF (IERR .NE. 0) GO TO 90
C
C  ***  COMPUTE GAUSS-NEWTON STEP  ***
C
C     ***  NOTE -- THE R-MATRIX IS STORED COMPACTLY BY COLUMNS IN
C     ***  R(1), R(2), R(3), ...  IT IS THE TRANSPOSE OF A
C     ***  LOWER TRIANGULAR MATRIX STORED COMPACTLY BY ROWS, AND WE
C     ***  TREAT IT AS SUCH WHEN USING LITVMU AND LIVMUL.
      CALL LITVMU(P, W, R, QTR)
C     ***  TEMPORARILY STORE PERMUTED -D*STEP IN STEP.
      DO 60 I = 1, P
         J1 = IPIVOT(I)
         STEP(I) = D(J1)*W(I)
 60      CONTINUE
      DST = V2NORM(P, STEP)
      V(DST0) = DST
      PHI = DST - RAD
      IF (PHI .LE. PHIMAX) GO TO 410
C     ***  IF THIS IS A RESTART, GO TO 110  ***
      IF (KA .GT. 0) GO TO 110
C
C  ***  GAUSS-NEWTON STEP WAS UNACCEPTABLE.  COMPUTE L0  ***
C
      DO 70 I = 1, P
         J1 = IPIVOT(I)
         STEP(I) = D(J1)*(STEP(I)/DST)
 70      CONTINUE
      CALL LIVMUL(P, STEP, R, STEP)
      T = ONE / V2NORM(P, STEP)
      W(PHIPIN) = (T/DST)*T
      LK = PHI*W(PHIPIN)
C
C  ***  COMPUTE U0  ***
C
 90   DO 100 I = 1, P
 100     W(I) = G(I)/D(I)
      V(DGNORM) = V2NORM(P, W)
      UK = V(DGNORM)/RAD
      IF (UK .LE. ZERO) GO TO 390
C
C     ***  ALPHAK WILL BE USED AS THE CURRENT MARQUARDT PARAMETER.  WE
C     ***  USE MORE*S SCHEME FOR INITIALIZING IT.
      ALPHAK = ABS(V(STPPAR)) * V(RAD0)/RAD
C
C
C  ***  TOP OF LOOP -- INCREMENT KA, COPY R TO RMAT, QTR TO RES  ***
C
 110  KA = KA + 1
      CALL VCOPY(PP1O2, W(RMAT), R)
      CALL VCOPY(P, W(RES), QTR)
C
C  ***  SAFEGUARD ALPHAK AND INITIALIZE FAST GIVENS SCALE VECTOR.  ***
C
      IF (ALPHAK .LE. ZERO .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK)
     +             ALPHAK = UK * MAX(P001, SQRT(LK/UK))
      SQRTAK = SQRT(ALPHAK)
      DO 120 I = 1, P
 120     W(I) = ONE
C
C  ***  ADD ALPHAK*D AND UPDATE QR DECOMP. USING FAST GIVENS TRANS.  ***
C
      DO 270 I = 1, P
C        ***  GENERATE, APPLY 1ST GIVENS TRANS. FOR ROW I OF ALPHAK*D.
C        ***  (USE STEP TO STORE TEMPORARY ROW)  ***
         L = I*(I+1)/2 + RMAT0
         WL = W(L)
         D2 = ONE
         D1 = W(I)
         J1 = IPIVOT(I)
         ADI = SQRTAK*D(J1)
         IF (ADI .GE. ABS(WL)) GO TO 150
 130     A = ADI/WL
         B = D2*A/D1
         T = A*B + ONE
         IF (T .GT. TTOL) GO TO 150
         W(I) = D1/T
         D2 = D2/T
         W(L) = T*WL
         A = -A
         DO 140 J1 = I, P
              L = L + J1
              STEP(J1) = A*W(L)
 140          CONTINUE
         GO TO 170
C
 150     B = WL/ADI
         A = D1*B/D2
         T = A*B + ONE
         IF (T .GT. TTOL) GO TO 130
         W(I) = D2/T
         D2 = D1/T
         W(L) = T*ADI
         DO 160 J1 = I, P
              L = L + J1
              WL = W(L)
              STEP(J1) = -WL
              W(L) = A*WL
 160          CONTINUE
C
 170     IF (I .EQ. P) GO TO 280
C
C        ***  NOW USE GIVENS TRANS. TO ZERO ELEMENTS OF TEMP. ROW  ***
C
         IP1 = I + 1
         DO 260 I1 = IP1, P
              L = I1*(I1+1)/2 + RMAT0
              WL = W(L)
              SI = STEP(I1-1)
              D1 = W(I1)
C
C             ***  RESCALE ROW I1 IF NECESSARY  ***
C
              IF (D1 .GE. DTOL) GO TO 190
                   D1 = D1*DFACSQ
                   WL = WL/DFAC
                   K = L
                   DO 180 J1 = I1, P
                        K = K + J1
                        W(K) = W(K)/DFAC
 180                    CONTINUE
C
C             ***  USE GIVENS TRANS. TO ZERO NEXT ELEMENT OF TEMP. ROW
C
 190          IF (ABS(SI) .GT. ABS(WL)) GO TO 220
              IF (SI .EQ. ZERO) GO TO 260
 200          A = SI/WL
              B = D2*A/D1
              T = A*B + ONE
              IF (T .GT. TTOL) GO TO 220
              W(L) = T*WL
              W(I1) = D1/T
              D2 = D2/T
              DO 210 J1 = I1, P
                   L = L + J1
                   WL = W(L)
                   SJ = STEP(J1)
                   W(L) = WL + B*SJ
                   STEP(J1) = SJ - A*WL
 210               CONTINUE
              GO TO 240
C
 220          B = WL/SI
              A = D1*B/D2
              T = A*B + ONE
              IF (T .GT. TTOL) GO TO 200
              W(I1) = D2/T
              D2 = D1/T
              W(L) = T*SI
              DO 230 J1 = I1, P
                   L = L + J1
                   WL = W(L)
                   SJ = STEP(J1)
                   W(L) = A*WL + SJ
                   STEP(J1) = B*SJ - WL
 230               CONTINUE
C
C             ***  RESCALE TEMP. ROW IF NECESSARY  ***
C
 240          IF (D2 .GE. DTOL) GO TO 260
                   D2 = D2*DFACSQ
                   DO 250 K = I1, P
 250                    STEP(K) = STEP(K)/DFAC
 260          CONTINUE
 270     CONTINUE
C
C  ***  COMPUTE STEP  ***
C
 280  CALL LITVMU(P, W(RES), W(RMAT), W(RES))
C     ***  RECOVER STEP AND STORE PERMUTED -D*STEP AT W(RES)  ***
      DO 290 I = 1, P
         J1 = IPIVOT(I)
         K = RES0 + I
         T = W(K)
         STEP(J1) = -T
         W(K) = T*D(J1)
 290     CONTINUE
      DST = V2NORM(P, W(RES))
      PHI = DST - RAD
      IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 430
      IF (OLDPHI .EQ. PHI) GO TO 430
      OLDPHI = PHI
C
C  ***  CHECK FOR (AND HANDLE) SPECIAL CASE  ***
C
      IF (PHI .GT. ZERO) GO TO 310
         IF (KA .GE. KALIM) GO TO 430
              TWOPSI = ALPHAK*DST*DST - DOTPRD(P, STEP, G)
              IF (ALPHAK .GE. TWOPSI*PSIFAC) GO TO 310
                   V(STPPAR) = -ALPHAK
                   GO TO 440
C
C  ***  UNACCEPTABLE STEP -- UPDATE LK, UK, ALPHAK, AND TRY AGAIN  ***
C
 300  IF (PHI .LT. ZERO) UK = MIN(UK, ALPHAK)
      GO TO 320
 310  IF (PHI .LT. ZERO) UK = ALPHAK
 320  DO 330 I = 1, P
         J1 = IPIVOT(I)
         K = RES0 + I
         STEP(I) = D(J1) * (W(K)/DST)
 330     CONTINUE
      CALL LIVMUL(P, STEP, W(RMAT), STEP)
      DO 340 I = 1, P
 340     STEP(I) = STEP(I) / SQRT(W(I))
      T = ONE / V2NORM(P, STEP)
      ALPHAK = ALPHAK + T*PHI*T/RAD
      LK = MAX(LK, ALPHAK)
      GO TO 110
C
C  ***  RESTART  ***
C
 370  LK = W(LK0)
      UK = W(UK0)
      IF (V(DST0) .GT. ZERO .AND. V(DST0) - RAD .LE. PHIMAX) GO TO 20
      ALPHAK = ABS(V(STPPAR))
      DST = W(DSTSAV)
      PHI = DST - RAD
      T = V(DGNORM)/RAD
      IF (RAD .GT. V(RAD0)) GO TO 380
C
C        ***  SMALLER RADIUS  ***
         UK = T
         IF (ALPHAK .LE. ZERO) LK = ZERO
         IF (V(DST0) .GT. ZERO) LK = MAX(LK, (V(DST0)-RAD)*W(PHIPIN))
         GO TO 300
C
C     ***  BIGGER RADIUS  ***
 380  IF (ALPHAK .LE. ZERO .OR. UK .GT. T) UK = T
      LK = ZERO
      IF (V(DST0) .GT. ZERO) LK = MAX(LK, (V(DST0)-RAD)*W(PHIPIN))
      GO TO 300
C
C  ***  SPECIAL CASE -- RAD .LE. 0 OR (G = 0 AND J IS SINGULAR)  ***
C
 390  V(STPPAR) = ZERO
      DST = ZERO
      LK = ZERO
      UK = ZERO
      V(GTSTEP) = ZERO
      V(PREDUC) = ZERO
      DO 400 I = 1, P
 400     STEP(I) = ZERO
      GO TO 450
C
C  ***  ACCEPTABLE GAUSS-NEWTON STEP -- RECOVER STEP FROM W  ***
C
 410  ALPHAK = ZERO
      DO 420 I = 1, P
         J1 = IPIVOT(I)
         STEP(J1) = -W(I)
 420     CONTINUE
C
C  ***  SAVE VALUES FOR USE IN A POSSIBLE RESTART  ***
C
 430  V(STPPAR) = ALPHAK
 440  V(GTSTEP) = DOTPRD(P, STEP, G)
      V(PREDUC) = HALF * (ALPHAK*DST*DST - V(GTSTEP))
 450  V(DSTNRM) = DST
      W(DSTSAV) = DST
      W(LK0) = LK
      W(UK0) = UK
      V(RAD0) = RAD
C
      RETURN
C
C  ***  LAST CARD OF LMSTEP FOLLOWS  ***
      END
*NLCMP
      SUBROUTINE NLCMP (Y, WEIGHT, WT, LWT, N, NPAR, NPARE,
     +   RES, D, RD, COND, VCVL, LVCVL, NNZW, IDF, RSSHLF, RSS, RSD,
     +   YSS, EXACT, PVT, SDPVT, SDREST, ISKULL)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES VARIOUS STATISTICS AND VALUES RETURNED
C     AND/OR PRINTED BY THE NLS FAMILY OF ROUTINES WHEN WEIGHTS ARE
C     INVOLVED.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  APRIL 2, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   COND,RSD,RSS,RSSHLF,YSS
      INTEGER
     +   IDF,LVCVL,LWT,N,NNZW,NPAR,NPARE
      LOGICAL
     +   EXACT,WEIGHT
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   D(N,NPAR),PVT(N),RD(N),RES(N),SDPVT(N),SDREST(N),VCVL(LVCVL),
     +   WT(LWT),Y(N)
      INTEGER
     +   ISKULL(10)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   FAC,FPLM,RVAR,SM,TJ,WTI,WTSUM,YWTSM,YWTYSM
      INTEGER
     +   I,J,JK,K
C
C  EXTERNAL FUNCTIONS
CCCCC DOUBLE PRECISION
CCCCC+   D1MACH
CCCCC EXTERNAL D1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL FITEXT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MAX,SQRT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION COND
C        THE CONDITION NUMBER OF D.
C     DOUBLE PRECISION D(N,NPAR)
C        THE FIRST DERIVATIVE OF THE MODEL (JACOBIAN).
C     LOGICAL EXACT
C        AN INDICATOR VALUE USED TO DESIGNATE WHETHER THE FIT
C        WAS EXACT TO MACHINE PRECISION (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION FAC
C        A FACTOR USED TO CORRECT FOR ZERO WEIGHTED OBSERVATIONS IN
C        THE VARIANCE COVARIANCE COMPUTATION.
C     DOUBLE PRECISION FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IDF
C        THE DEGREES OF FREEDOM IN THE FIT.
C     INTEGER IERR
C        THE VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .GE. 1, ERRORS WERE DETECTED.
C     INTEGER ISKULL(10)
C        AN ERROR MESSAGE INDICATOR VARIABLE.
C     INTEGER J
C        AN INDEX VARIABLE.
C     INTEGER JK
C        THE INDEX OF THE (J,K)TH ELEMENT OF THE VARIANCE-COVARIANCE
C        MATRIX.
C     INTEGER K
C        AN INDEX VARIABLE.
C     INTEGER LVCVL
C        THE DIMENSION OF VECTOR VCVL.
C     INTEGER LWT
C        THE DIMENSION OF VECTOR WT.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NNZW
C        THE NUMBER OF NON ZERO WEIGHTS.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     INTEGER NPARE
C        THE NUMBER OF PARAMETERS TO BE OPTIMIZED.
C     DOUBLE PRECISION PVT(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES.
C     DOUBLE PRECISION RD(N)
C        THE DIAGONAL ELEMENTS OF THE R MATRIX OF THE Q - R
C        FACTORIZATION OF D.
C     DOUBLE PRECISION RES(N)
C        THE RESIDUALS FROM THE FIT.
C     DOUBLE PRECISION RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     DOUBLE PRECISION RSS
C        THE RESIDUAL SUM OF SQUARES.
C     DOUBLE PRECISION RSSHLF
C        HALF THE RESIDUAL SUM OF SQUARES.
C     DOUBLE PRECISION RVAR
C        THE RESIDUAL VARIANCE.
C     DOUBLE PRECISION SDPVT(N)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     DOUBLE PRECISION SDREST(N)
C        THE STANDARDIZED RESIDUALS.
C     DOUBLE PRECISION SM
C        A VARIABLE USED FOR SUMMATION.
C     DOUBLE PRECISION TJ
C        ...
C     DOUBLE PRECISION VCVL(LVCVL)
C        THE LOWER HALF OF THE VARIANCE-COVARIANCE MATRIX, STORED
C        ROW WISE.
C     LOGICAL WEIGHT
C        THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO
C        BE PERFORMED (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION WT(LWT)
C        THE USER SUPPLIED WEIGHTS.
C     DOUBLE PRECISION WTI
C        THE ACTUAL WEIGHT USED FOR THE ITH OBSERVATION.
C     DOUBLE PRECISION WTSUM
C        THE SUM OF THE WEIGHTS.
C     DOUBLE PRECISION Y(N)
C        THE DEPENDENT VARIABLE.
C     DOUBLE PRECISION YSS
C        THE SUM OF THE SQUARES ABOUT THE MEAN Y VALUE.
C     DOUBLE PRECISION YWTSM
C        THE SUM OF THE VALUES Y(I)*WT(I), I=1,N.
C     DOUBLE PRECISION YWTYSM
C        THE SUM OF THE VALUES Y(I)*WT(I)*WT(I), I=1,N.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      FPLM = D1MACH(2)
C
C     COMPUTE RESIDUALS
C
      DO 10 I=1,N
         RES(I) = Y(I) - PVT(I)
   10 CONTINUE
C
C     COMPUTE VARIOUS STATISTICS
C
      IDF = NNZW - NPARE
      RSS = 2.0D0*RSSHLF
      RVAR = 0.0D0
      IF (IDF.GE.1) RVAR = RSS/IDF
      RSD = SQRT(RVAR)
      YWTSM = 0.0D0
      YWTYSM = 0.0D0
      WTSUM = 0.0D0
      DO 20 I=1,N
         WTI = 1.0D0
         IF (WEIGHT) WTI = WT(I)
         YWTSM = YWTSM + Y(I)*WTI
         YWTYSM = YWTYSM + Y(I)*WTI*Y(I)
         WTSUM = WTSUM + WTI
   20 CONTINUE
      YSS = MAX(YWTYSM-(YWTSM*YWTSM)/WTSUM,0.0D0)
C
      CALL FITEXT(RSS, YSS, EXACT)
C
      COND = FPLM
      IF (RD(NPARE).NE.0.0D0) COND = ABS(RD(1)/RD(NPARE))
C
      IF (IERR.NE.0) RETURN
C
C     CORRECT FOR DEGREES OF FREEDOM IF NECESSARY BECAUSE OF ZERO
C     WEIGHTED OBSERVATIONS.
C
      IF (N.EQ.NNZW) GO TO 40
C
      FAC = N-NPARE
      IF (IDF.GE.1) FAC = FAC/IDF
      DO 30 I=1,LVCVL
         VCVL(I) = VCVL(I)*FAC
   30 CONTINUE
C
   40 CONTINUE
C
C     IF THE RESIDUAL SUM OF SQUARES IS IDENTICALLY ZERO, THEN
C     NO FURTHER COMPUTATIONS ARE NECESSARY
C
      IF ((IDF.LE.0) .OR. EXACT) RETURN
C
C     IF THE STANDARD DEVIATIONS OF THE PREDICTED VALUES AND
C     STANDARDIZED RESIDUALS ARE NOT SAVED OR PRINTED, THEN NO
C     FURTHER COMPUTATIONS ARE NECESSARY.
C
C     COMPUTE THE STANDARD DEVIATIONS OF THE PREDICTED VALUES (SDPVT)
C
      DO 90 I=1,N
         SM = 0.0D0
         DO 60 J=1,NPARE
            TJ = 0.0D0
            DO 50 K=1,NPARE
               IF (J.GE.K) THEN
                  JK = J*(J-1)/2 + K
               ELSE
                  JK = K*(K-1)/2 + J
               END IF
               TJ = TJ + VCVL(JK)*D(I,K)
   50       CONTINUE
               SM = SM + D(I,J)*TJ
   60    CONTINUE
         IF (SM.LT.0.0D0) SM = 0.0D0
         SDPVT(I) = SQRT(SM)
C
         SDREST(I) = FPLM
         WTI = 1.0D0
         IF (WEIGHT) WTI = WT(I)
         IF (WTI.EQ.0.0D0) GO TO 90
C
         IF (RVAR/WTI-SM.LE.0.0D0) GO TO 70
         GO TO 80
C
C           THEN
C
   70    SDREST(I) = FPLM
         ISKULL(1) = 1
         ISKULL(4) = 1
         IERR = 4
         GO TO 90
C
C           ELSE
C
   80    SDREST(I) = RES(I)/SQRT(RVAR/WTI-SM)
C
C        END IF
C
   90 CONTINUE
C
      RETURN
C
      END
*REPCK
      SUBROUTINE REPCK(D, NRESTS, NPAR, N)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE MODIFIES D TO CONFORM TO N BY NPAR FORMAT REQUIRED
C     BY NLCMP.  FUTURE REVISIONS TO NLCMP SHOULD BE MADE TO ELIMINATE
C     THE NEED FOR THIS ROUTINE.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 2, 1985
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N,NPAR,NRESTS
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   D(NRESTS*NPAR)
C
C  LOCAL SCALARS
      INTEGER
     +   I,I1,I2,J
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      I1 = -N
      I2 = -N
      DO 10 J = 1, NPAR
        I1 = I1 + NRESTS
        I2 = I2 + N
        DO 5 I = 1, N
          D(I2+I) = D(I1+I)
    5   CONTINUE
   10 CONTINUE
      RETURN
      END
*UFPARM
      SUBROUTINE UFPARM
      RETURN
      END
*AMEOUT
      SUBROUTINE AMEOUT(Y, N, IFIXD,
     +   PAR, NPAR, NPARE, RES, IPTOUT, NDIGIT, PAGE, IDF, COND, RSS,
     +   RSD, YSS, EXACT, PVT, SDPVT, SDREST, VCVL, LVCVL, IVCVPT,
     +   ISKULL, AMEHDR, WIDE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE PRINTS THE FINAL SUMMARY OUTPUT FROM THE
C     ARIMA ESTIMATION SUBROUTINES.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 2, 1985
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   COND,RSD,RSS,YSS
      INTEGER
     +   IDF,IVCVPT,LVCVL,N,NDIGIT,NPAR,NPARE
      LOGICAL
     +   EXACT,PAGE,WIDE
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   PAR(*),PVT(*),RES(*),SDPVT(*),SDREST(*),VCVL(*),Y(*)
      INTEGER
     +   IFIXD(*),IPTOUT(*),ISKULL(10)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL AMEHDR
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR,IFLAG,MBO,MBOL,MSPECT,NFACT,NPARAR,NPARDF,NPARMA,
     +   NRESTS,PARAR,PARDF,PARMA,T,TEMP
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   FPLM
      INTEGER
     +   I,IAMHD,ISUBHD
C
C  LOCAL ARRAYS
      INTEGER
     +   ISTAK(12)
C
C  EXTERNAL FUNCTIONS
CCCCC DOUBLE PRECISION
CCCCC+   D1MACH
CCCCC EXTERNAL D1MACH
C
C  EXTERNAL SUBROUTINES
CCCCC EXTERNAL AMEPT1,AMEPT2,AMLST,MODSUM,NLSKL,VCVOTF
      EXTERNAL AMEPT1,AMLST,MODSUM,NLSKL,VCVOTF
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
      COMMON /MDLTSC/MSPECT,NFACT,PARDF,NPARDF,PARAR,NPARAR,PARMA,
     +   NPARMA,MBO,MBOL,T,TEMP,NRESTS,IFLAG
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),ISTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION COND
C        THE CONDITION NUMBER OF D.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     LOGICAL EXACT
C        AN INDICATOR VALUE USED TO DESIGNATE WHETHER THE FIT
C        WAS EXACT TO MACHINE PRECISION (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     EXTERNAL AMEHDR
C        THE ROUTINE USED TO PRINT THE HEADING
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IAMHD
C        THE INDICATOR VALUE USED TO DESIGNATE THE TYPE OF LIST
C        TO BE GENERATED
C        IF IAMHD=1, THE LIST IS FOR THE INITIAL SUMMARY OF THE
C                    ESTIMATION ROUTINES.
C        IF IAMHD=2, THE LIST IS FOR THE INITIAL REPORT OF THE
C                    FORECASTING ROUTINES.
C        IF IAMHD=3, THE LIST IS FOR THE FINAL REPORT OF THE
C                    ESTIMATION ROUTINES.
C     INTEGER IDF
C        THE DEGREES OF FREEDOM IN THE FIT.
C     INTEGER IERR
C        THE VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .GE. 1, ERRORS WERE DETECTED.
C     INTEGER IFIXD(NPAR)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE
C        PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED.
C        IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED.
C        IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IPTOUT(NDIGIT)
C        THE VARIABLE USED TO CONTROL PRINTED OUTPUT FOR EACH SECTION.
C     INTEGER ISKULL(10)
C        AN ERROR MESSAGE INDICATOR VARIABLE.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ISUBHD
C        AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED.
C     INTEGER IVCVPT
C        AN INDICATOR VALUE USED TO DESIGNATE WHICH FORM OF THE
C        VARIANCE COVARIANCE MATRIX (VCV) IS BEING PRINTED, WHERE
C        IVCVPT = 1 INDICATES THE VCV WAS COMPUTED AS
C                   INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN)
C        IVCVPT = 2 INDICATES THE VCV WAS COMPUTED AS
C                   INVERSE(HESSIAN)
C        IVCVPT = 3 INDICATES THE VCV WAS COMPUTED AS
C                   INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN
C                       *INVERSE(HESSIAN)
C     INTEGER LVCVL
C        THE DIMENSION OF VECTOR VCVL.
C     INTEGER MBO
C        THE MAXIMUM BACK ORDER OPERATOR.
C     INTEGER MBOL
C        THE MAXIMUM BACK ORDER ON THE LEFT
C     INTEGER MSPECT
C        THE STARTING LOCATION IN THE WORK SPACE FOR
C        THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NDIGIT
C        THE NUMBER OF DIGITS IN THE PRINT CONTROL VALUE.
C     INTEGER NFACT
C        THE NUMBER OF FACTORS IN THE MODEL
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     INTEGER NPARAR
C        THE NUMBER OF AUTOREGRESSIVE PARAMETERS
C     INTEGER NPARDF
C        THE ORDER OF THE EXPANDED DIFFERENCE FILTER.
C     INTEGER NPARE
C        THE NUMBER OF PARAMETERS TO BE OPTIMIZED.
C     INTEGER NPARMA
C        THE LENGTH OF THE VECTOR PARMA
C     INTEGER NRESTS
C        THE MAXIMUM NUMBER OF RESIDUALS TO BE COMPUTED.
C     LOGICAL PAGE
C        THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF
C        THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     INTEGER PARAR
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        THE AUTOREGRESSIVE PARAMETERS
C     INTEGER PARDF
C        THE STARTING LOCATION IN THE WORK SPACE FOR
C        THE VECTOR CONTAINING THE DIFFERENCE FILTER PARAMETERS
C     INTEGER PARMA
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        THE MOVING AVERAGE PARAMETERS
C     DOUBLE PRECISION PVT(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES.
C     DOUBLE PRECISION RES(N)
C        THE RESIDUALS FROM THE FIT.
C     DOUBLE PRECISION RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     DOUBLE PRECISION RSS
C        THE RESIDUAL SUM OF SQUARES.
C     DOUBLE PRECISION SDPVT(N)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     DOUBLE PRECISION SDREST(N)
C        THE STANDARDIZED RESIDUALS.
C     INTEGER T
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        A TEMPORARY WORK VECTOR.
C     INTEGER TEMP
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        A TEMPORARY WORK VECTOR
C     DOUBLE PRECISION VCVL(LVCVL)
C        THE LOWER HALF OF THE VARIANCE-COVARIANCE MATRIX, STORED
C        ROW WISE.
C     LOGICAL WIDE
C        THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD
C        BE FULL WIDTH (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION Y(N)
C        THE DEPENDENT VARIABLE.
C     DOUBLE PRECISION YSS
C        THE SUM OF THE SQUARES ABOUT THE MEAN Y VALUE.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      FPLM = D1MACH(2)
C
CCCCC CALL IPRINT(IPRT)
C
      IF ((IERR.GE.1) .AND. (IERR.NE.4)) GO TO 60
C
C     TEST FOR EXACT FIT
C
      IF ((IDF.LE.0) .OR. EXACT) GO TO 70
C
C     PRINT ERROR HEADING IF NECESSARY
C
      IF (IERR.EQ.4) CALL NLSKL(ISKULL, PAGE, WIDE, AMEHDR)
C
C     PRINT PRIMARY REPORT
C
      IF ((IERR.EQ.0) .AND. (IPTOUT(3).EQ.0)) GO TO 10
      ISUBHD = 0
      CALL AMEHDR(PAGE, WIDE, ISUBHD)
      CALL AMEPT1(N, Y, PVT, SDPVT, RES, SDREST, IPTOUT, NDIGIT)
C
C     PRINT STANDARDIZED RESIDUAL PLOTS
C
CCCCC USE DATAPLOT HIGH-QUALITY GRAPHICS INSTEAD OF THESE LINE
CCCCC PRINTER GRAPHICS!!!
   10 IF (IPTOUT(4).EQ.0) GO TO 20
      ISUBHD = 0
CCCCC CALL AMEHDR(PAGE, WIDE, ISUBHD)
C
CCCCC CALL AMEPT2 (RES, SDREST, N, RSS)
C
C     PRINT THE COVARIANCE AND CORRELATION MATRIX
C
   20 IF ((IERR.EQ.0) .AND. (IPTOUT(5).EQ.0)) RETURN
      ISUBHD = 0
      CALL AMEHDR(PAGE, WIDE, ISUBHD)
CCCCC CALL MODSUM(NFACT, ISTAK(MSPECT))
C
      IF ((IERR.EQ.0) .AND. (IPTOUT(5).LE.1)) GO TO 30
C
      CALL VCVOTF(NPARE, VCVL, LVCVL, .TRUE., NPAR, IFIXD, IVCVPT)
C
C     PRINT ANALYSIS SUMMARY
C
   30 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1000)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1001)
      CALL DPWRST('XXX','BUG ')
      IAMHD = 3
      CALL AMLST(IAMHD, PAR, NPAR, NFACT, ISTAK(MSPECT), N, VCVL, LVCVL,
     +   PAR, NPAR, PAR, NPAR, IFIXD, RSS, RSD, NPARDF, NPARE, IDF)
      WRITE (ICOUT,1050) COND
      CALL DPWRST('XXX','BUG ')
C
      IF (RSS.GT.YSS) THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT,1060)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT,1061)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT,1062)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT,1063)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
C
C     PRINT OUT ERROR HEADING
C
   60 CALL NLSKL(ISKULL, PAGE, WIDE, AMEHDR)
C
      IF (IERR.LE.2) RETURN
C
C     PRINT SECONDARY REPORT
C
   70 CONTINUE
      ISUBHD = 0
      CALL AMEHDR(PAGE, WIDE, ISUBHD)
      CALL MODSUM(NFACT, ISTAK(MSPECT))
      IF (IERR.NE.0) THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT,1080)
        CALL DPWRST('XXX','BUG ')
      ENDIF
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1000)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1001)
      CALL DPWRST('XXX','BUG ')
      IAMHD = 2
      CALL AMLST(IAMHD, PAR, NPAR, NFACT, ISTAK(MSPECT), N, VCVL, LVCVL,
     +   PAR, NPAR, PAR, NPAR, IFIXD, RSS, RSD, NPARDF, NPARE, IDF)
      IF (IERR.NE.3) THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT,1050) COND
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      IF ((IERR.EQ.0) .AND. (.NOT.EXACT) .AND. (IDF.LE.0)) THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT,1070)
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IF ((IERR.EQ.0) .AND. EXACT) THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT,1090)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT,1091)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      IF (IERR.NE.0) GO TO 100
C
      DO 90 I=1,N
         SDREST(I) = 0.0D0
         SDPVT(I) = 0.0D0
   90 CONTINUE
C
      RETURN
C
  100 CONTINUE
C
      DO 110 I=1,N
         SDREST(I) = FPLM
         SDPVT(I) = FPLM
  110 CONTINUE
C
C     PRINT OUT ERROR EXIT STATISTICS
C
      CALL AMEPT1(N, Y, PVT, SDPVT, RES, SDREST, IPTOUT, NDIGIT)
C
C     WIPE OUT SDREST VECTOR
C
      DO 120 I=1,N
         SDREST(I) = FPLM
  120 CONTINUE
C
C     WIPE OUT VCV MATRIX
C
      DO 140 I=1,LVCVL
         VCVL(I) = FPLM
  140 CONTINUE
C
      RETURN
C
C     FORMAT STATEMENTS
C
  999 FORMAT(1X)
 1000 FORMAT (' ESTIMATES FROM LEAST SQUARES FIT (* FOR FIXED ',
     +        'PARAMETER)')
 1001 FORMAT(1X, 56('#'))
 1050 FORMAT (' APPROXIMATE CONDITION NUMBER', 10X, G15.7)
 1060 FORMAT (
     +   ' THE RESIDUAL SUM OF SQUARES AFTER THE LEAST SQUARES',
     +   ' FIT IS GREATER THAN')
 1061 FORMAT (
     +   ' THE SUM OF SQUARES ABOUT THE MEAN ',
     +   'Y OBSERVATION.  THE MODEL IS LESS')
 1062 FORMAT (
     +   ' REPRESENTATIVE OF THE DATA THAN A SIMPLE AVERAGE.  DATA',
     +   ' AND MODEL SHOULD ')
 1063 FORMAT (
     +   ' BE CHECKED TO BE SURE THAT THEY ARE COMPATABLE.')
 1070 FORMAT (' THE DEGREES OF FREEDOM FOR THIS PROBLEM IS ZERO.',
     +   '  STATISTICAL ANALYSIS OF THE RESULTS IS NOT POSSIBLE.')
 1080 FORMAT (
     +    ' THE FOLLOWING SUMMARY SHOULD BE USED TO ANALYZE',
     +   ' THE ABOVE MENTIONED PROBLEMS.')
 1090 FORMAT (
     +   ' THE LEAST SQUARES FIT OF THE DATA TO THE MODEL IS',
     +   ' EXACT TO WITHIN MACHINE PRECISION.')
 1091 FORMAT (
     +   ' STATISTICAL ANALYSIS OF THE RESULTS IS NOT POSSIBLE.')
      END
*DFAULT
      SUBROUTINE DFAULT(IV, V)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C
C
C  VARIABLE DECLARATIONS
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   V(45)
      INTEGER
     +   IV(25)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   MACHEP,MEPCRT,ONE,SQTEPS,THREE
      INTEGER
     +   AFCTOL,COSMIN,COVPRT,COVREQ,D0INIT,DECFAC,DELTA0,DFAC,
     +   DINIT,DLTFDC,DLTFDJ,DTYPE,EPSLON,FUZZ,INCFAC,INITS,JTINIT,
     +   LMAX0,MXFCAL,MXITER,OUTLEV,PARPRT,PHMNFC,PHMXFC,PRUNIT,
     +   RDFCMN,RDFCMX,RFCTOL,RLIMIT,SOLPRT,STATPR,TUNER1,TUNER2,
     +   TUNER3,TUNER4,TUNER5,X0PRT,XCTOL,XFTOL
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   RMDCON
      INTEGER
     +   IMDCON
      EXTERNAL RMDCON,IMDCON
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX
C
C  ***  SUPPLY NL2SOL (VERSION 2.2) DEFAULT VALUES TO IV AND V  ***
C
C     INTEGER IV(25)
C     DOUBLE PRECISION V(45)
C/+
C     DOUBLE PRECISION MAX
C/
C     EXTERNAL IMDCON, RMDCON
C     INTEGER IMDCON
C     DOUBLE PRECISION RMDCON
C
C     DOUBLE PRECISION MACHEP, MEPCRT, ONE, SQTEPS, THREE
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
C     INTEGER AFCTOL, COSMIN, COVPRT, COVREQ, DECFAC, DELTA0, DFAC,
C    1        DINIT, DLTFDC, DLTFDJ, DTYPE, D0INIT, EPSLON, FUZZ,
C    2        INCFAC, INITS, JTINIT, LMAX0, MXFCAL, MXITER, OUTLEV,
C    3        PARPRT, PHMNFC, PHMXFC, PRUNIT, RDFCMN, RDFCMX,
C    4        RFCTOL, RLIMIT, SOLPRT, STATPR, TUNER1, TUNER2, TUNER3,
C    5        TUNER4, TUNER5, XCTOL, XFTOL, X0PRT
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA ONE/1.0D0/, THREE/3.0D0/
C
C  ***  IV SUBSCRIPT VALUES  ***
C
      DATA COVPRT/14/, COVREQ/15/, DTYPE/16/, INITS/25/,
     +     MXFCAL/17/, MXITER/18/, OUTLEV/19/,
     +     PARPRT/20/, PRUNIT/21/, SOLPRT/22/,
     +     STATPR/23/, X0PRT/24/
C
C  ***  V SUBSCRIPT VALUES  ***
C
      DATA AFCTOL/31/, COSMIN/43/, DECFAC/22/,
     +     DELTA0/44/, DFAC/41/, DINIT/38/, DLTFDC/40/,
     +     DLTFDJ/36/, D0INIT/37/, EPSLON/19/, FUZZ/45/,
     +     INCFAC/23/, JTINIT/39/, LMAX0/35/, PHMNFC/20/,
     +     PHMXFC/21/, RDFCMN/24/, RDFCMX/25/,
     +     RFCTOL/32/, RLIMIT/42/, TUNER1/26/,
     +     TUNER2/27/, TUNER3/28/, TUNER4/29/,
     +     TUNER5/30/, XCTOL/33/, XFTOL/34/
C
C-----------------------------------------------------------------------
C
      IV(1) = 12
      IV(COVPRT) = 1
      IV(COVREQ) = 1
      IV(DTYPE) = 1
      IV(INITS) = 0
      IV(MXFCAL) = 200
      IV(MXITER) = 150
      IV(OUTLEV) = 1
      IV(PARPRT) = 1
      IV(PRUNIT) = IMDCON(1)
      IV(SOLPRT) = 1
      IV(STATPR) = 1
      IV(X0PRT) = 1
C
      MACHEP = RMDCON(3)
      V(AFCTOL) = 1.0D-20
      IF (MACHEP .GT. 1.0D-10) V(AFCTOL) = MACHEP**2
      V(COSMIN) = MAX(1.0D-6, 1.0D2 * MACHEP)
      V(DECFAC) = 0.5D0
      SQTEPS = RMDCON(4)
      V(DELTA0) = SQTEPS
      V(DFAC) = 0.6D0
      V(DINIT) = 0.0D0
      MEPCRT = MACHEP ** (ONE/THREE)
      V(DLTFDC) = MEPCRT
      V(DLTFDJ) = SQTEPS
      V(D0INIT) = 1.0D0
      V(EPSLON) = 0.1D0
      V(FUZZ) = 1.5D0
      V(INCFAC) = 2.0D0
      V(JTINIT) = 1.0D-6
      V(LMAX0) = 100.0D0
      V(PHMNFC) = -0.1D0
      V(PHMXFC) = 0.1D0
      V(RDFCMN) = 0.1D0
      V(RDFCMX) = 4.0D0
      V(RFCTOL) = MAX(1.0D-10, MEPCRT**2)
      V(RLIMIT) = RMDCON(5)
      V(TUNER1) = 0.1D0
      V(TUNER2) = 1.0D-4
      V(TUNER3) = 0.75D0
      V(TUNER4) = 0.5D0
      V(TUNER5) = 0.75D0
      V(XCTOL) = SQTEPS
      V(XFTOL) = 1.0D2 * MACHEP
C
      RETURN
C  ***  LAST CARD OF DFAULT FOLLOWS  ***
      END
*FIXPRT
      SUBROUTINE FIXPRT(IFIX, FIXED)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE SETS THE CHARACTER ARRAY FIXED.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  APRIL 2, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IFIX
C
C  ARRAY ARGUMENTS
      CHARACTER
     +   FIXED(3)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C  LOCAL ARRAYS
      CHARACTER
     +   NO(3)*1,YES(3)*1
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     CHARACTER*1 FIXED(3)
C        THE CHARACTERS USED TO LABEL THE PARAMETERS FIXED OR NOT.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IFIX
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE
C        PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED.
C        IF IFIX.EQ.0, THEN FIXED WILL BE SET TO NO.
C        IF IFIX.NE.0, THEN FIXED WILL BE SET TO YES.
C     CHARACTER*1 NO(3)
C        THE CHARACTERS BLANK, N, AND O
C     CHARACTER*1 YES(3)
C        THE CHARACTERS Y, E, AND S
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA NO(1)/' '/, NO(2)/'N'/, NO(3)/'O'/
      DATA YES(1)/'Y'/, YES(2)/'E'/, YES(3)/'S'/
C
      IF (IFIX.NE.0) THEN
C
C     SET FIXED TO YES
C
         DO 10 I = 1, 3
            FIXED(I) = YES(I)
   10    CONTINUE
C
      ELSE
C
C     SET FIXED TO NO
C
         DO 20 I = 1, 3
            FIXED(I) = NO(I)
   20    CONTINUE
      END IF
C
      RETURN
C
      END
*LOPASS
      SUBROUTINE LOPASS (Y, N, FC, K, HLP, YF, NYF, IERR2)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE CARRIES OUT LOW-PASS FILTERING OF THE
C     SERIES.  THE FILTER IS THE K-TERM
C     LEAST SQUARES APPROXIMATION TO THE CUTOFF FILTER
C     WITH CUTOF FREQUENCY FC.  ITS TRANSFER FUNCTION
C     HAS A TRANSITION BAND OF WIDTH DELTA SURROUNDING FC,
C     WHERE DELTA = 4*PI/K.
C
C     WRITTEN BY  -  PETER BLOOMFIELD
C                    FOURIER ANALYSIS OF TIME SERIES- AN
C                       INTRODUCTION
C                    JOHN WILEY AND SONS, NEW YORK, 1976
C                    PAGE 149
C     ADAPTED FOR STARPAC BY  -  JANET R. DONALDSON
C                                STATISTICAL ENGINEERING DIVISION
C                                NATIONAL BUREAU OF STANDARDS
C                                BOULDER, COLORADO
C
C     CREATION DATE  -  NOVEMBER 26, 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   FC
      INTEGER
     +   K,N,NYF
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   HLP(*),Y(*),YF(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      LOGICAL
     +   ERR01,ERR02,ERR03,ERR04,ERR05,HEAD
C
C  LOCAL ARRAYS
      CHARACTER
     +   LFC(8)*1,LK(8)*1,LN(8)*1,NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
CCCCC EXTERNAL EISGE,EISII,ERIODD,ERSII,ERSLFS,FLTSL,IPRNT,LPFLT
      EXTERNAL EISGE,EISII,ERIODD,ERSII,ERSLFS,FLTSL,LPFLT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERR01, ERR02, ERR03, ERR04, ERR05
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     DOUBLE PRECISION FC
C        THE USER SUPPLIED CUTOFF FREQUENCY.
C     LOGICAL HEAD
C        A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED
C        (TRUE) OR NOT (FALSE).  IF A HEADING IS PRINTED, THE VALUE
C        OF HEAD WILL BE CHANGED TO FALSE.
C     DOUBLE PRECISION HLP(K)
C        THE ARRAY IN WHICH THE -IDEAL- HIGH PASS FILTER COEFFICIENTS
C        WILL BE RETURNED.
C     INTEGER IERR
C        THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED.
C     INTEGER IPRT
C        THE UNIT NUMBER USED FOR OUTPUT.
C     INTEGER K
C        THE NUMBER OF FILTER TERMS TO BE COMPUTED.
C     CHARACTER*1 LFC(8), LK(8), LN(8)
C        THE ARRAY CONTAINING THE NAMES OF THE VARIABLES FC, K AND N.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS IN THE SERIES Y.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NYF
C        THE NUMBER OF OBSERVATIONS IN THE FILTERED SERIES YF.
C     DOUBLE PRECISION Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES.
C     DOUBLE PRECISION YF(N)
C        THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     SET UP NAME ARRAYS
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'L',       'O',       'P',       'A',       'S',       'S'/
      DATA
     +  LFC(1), LFC(2), LFC(3), LFC(4), LFC(5), LFC(6), LFC(7), LFC(8)
     + /  'F',   'C',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
      DATA
     +  LK(1), LK(2), LK(3), LK(4), LK(5), LK(6), LK(7), LK(8)
     + /  'K',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
      DATA
     +  LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8)
     + /  'N',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      HEAD = .TRUE.
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL EISGE(NMSUB, LN, N, 3, 1, HEAD, ERR01, LN)
C
      CALL ERSII(NMSUB, LFC, FC, 0.0D0, 0.5D0, 2, HEAD, ERR02, LFC, LFC)
C
      CALL EISII(NMSUB, LK, K, 1, N, 2, HEAD, ERR03, LK, LK)
C
      CALL ERIODD(NMSUB, LK, K, 1, HEAD, ERR04)
C
      IF (ERR01 .OR. ERR02 .OR. ERR03 .OR. ERR04) GO TO 10
C
      CALL ERSLFS(NMSUB, FC, K, HEAD, ERR05)
C
      IF (.NOT. ERR05) GO TO 20
C
   10 CONTINUE
      IERR = 1
CCCCC CALL IPRNT (IPRT)
      WRITE(ICOUT,999)
  999 FORMAT(1X)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1000)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1003)
      CALL DPWRST('XXX','BUG ')
      IERR2=IERR
C
      RETURN
C
   20 CONTINUE
C
      CALL LPFLT (FC, K, HLP)
C
      CALL FLTSL (Y, N, K, HLP, YF, NYF)
C
      IERR2=IERR
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT(' THE CORRECT FORM OF THE CALL STATEMENT IS')
 1003 FORMAT('     CALL LOPASS (Y, N, FC, K, HLP, YF, NYF)')
      END
*NLDRVN
      SUBROUTINE NLDRVN (MDL, DRV, DONE, IFIXD, PAR, NPAR, XM, N, M,
     +   IXM, PVT, D, WEIGHT, WT, LWT, STPT, LSTPT, SCL, LSCL)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE NUMERICAL APPROXIMATIONS TO THE
C     DERIVATIVE MATRIX (JACOBIAN).
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  OCTOBER 3, 1983
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IXM,LSCL,LSTPT,LWT,M,N,NPAR
      LOGICAL
     +   DONE,WEIGHT
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   D(N,NPAR),PAR(NPAR),PVT(N),SCL(LSCL),STPT(LSTPT),WT(LWT),
     +   XM(IXM,M)
      INTEGER
     +   IFIXD(NPAR)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL DRV,MDL
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   PJ,STPJ,WTSQRT
      INTEGER
     +   I,J,JPK
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MAX,SIGN,SQRT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION D(N,NPAR)
C        THE FIRST DERIVATIVE OF THE MODEL (JACOBIAN).
C     EXTERNAL DRV
C        THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE
C        DERIVATIVE (JACOBIAN) MATRIX OF THE MODEL.
C     LOGICAL DONE
C        THE VARIABLE USED TO INDICATE WHETHER THIS IS THE FINAL
C        COMPUTATION OF THE JACOBIAN OR NOT.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IERR
C        THE VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .GE. 1, ERRORS WERE DETECTED.
C     INTEGER IFIXD(NPAR)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE
C        PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED.
C        IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED.
C        IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED.
C     INTEGER IXM
C        THE FIRST DIMENSION OF MATRIX XM.
C     INTEGER J
C        AN INDEX VARIABLE.
C     INTEGER JPK
C        AN INDEX VARIABLE.
C     INTEGER LSCL
C        THE DIMENSION OF VECTOR SCL.
C     INTEGER LSTPT
C        THE DIMENSION OF VECTOR STPT.
C     INTEGER LWT
C        THE DIMENSION OF VECTOR WT.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     EXTERNAL MDL
C        THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE
C        PREDICTED VALUES BASED ON THE CURRENT PARAMETER ESTIMATES.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     DOUBLE PRECISION PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     DOUBLE PRECISION PJ
C        A TEMPORARY LOCATION FOR STORAGE OF THE JTH PARAMETER.
C     DOUBLE PRECISION PVT(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES.
C     DOUBLE PRECISION SCL(LSCL)
C        THE SCALE VALUES.
C     DOUBLE PRECISION STPT(LSTPT)
C        THE STEP SIZE ARRAY.
C     DOUBLE PRECISION STPJ
C        THE JTH STEP SIZE.
C     LOGICAL WEIGHT
C        THE VARIABLE USED TO INDICATE WHETHER WEIGHTED ANALYSIS IS TO
C        BE PERFORMED (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION WT(LWT)
C        THE USER SUPPLIED WEIGHTS.
C     DOUBLE PRECISION WTSQRT
C        THE SQUARE ROOT OF THE USER SUPPLIED WEIGHTS.
C     DOUBLE PRECISION XM(IXM,M)
C        THE INDEPENDENT VARIABLE.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     COMPUTE FINITE-DIFFERENCE JACOBIAN OF THE OPTIMIZED PARAMETERS
C
      JPK = 0
C
      DO 20 J=1,NPAR
         IF (IFIXD(J).EQ.0) THEN
            JPK = JPK + 1
            PJ = PAR(J)
            IF (SCL(JPK).EQ.0.0D0) THEN
               IF (PAR(J).NE.0.0D0) THEN
                  STPJ = STPT(J)*SIGN(1.0D0,PAR(J))*ABS(PAR(J))
               ELSE
                  STPJ = STPT(J)
               END IF
            ELSE
               STPJ = STPT(J)*
     +                SIGN(1.0D0,PAR(J))*MAX(ABS(PAR(J)),1.0D0/
     +                ABS(SCL(JPK)))
            END IF
C
            STPJ = STPJ + PAR(J)
            STPJ = STPJ - PAR(J)
C
            PAR(J) = PJ + STPJ
            CALL MDL(PAR, NPAR, XM, N, M, IXM, D(1,J))
C
            DO 10 I=1,N
               WTSQRT = 1.0D0
               IF (WEIGHT .AND. (.NOT.DONE)) WTSQRT = SQRT(WT(I))
               D(I,JPK) = WTSQRT*(PVT(I)-D(I,J))/STPJ
   10       CONTINUE
C
            PAR(J) = PJ
         END IF
   20 CONTINUE
C
      RETURN
C
      END
*RMDCON
      DOUBLE PRECISION FUNCTION RMDCON(K)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   K
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   BIG,ETA,MACHEP,ONE001,PT999
C
C  EXTERNAL FUNCTIONS
CCCCC DOUBLE PRECISION
CCCCC+   D1MACH
CCCCC EXTERNAL D1MACH
C
C  INTRINSIC FUNCTIONS
      INTRINSIC DSQRT
C
C
C  ***  RETURN MACHINE DEPENDENT CONSTANTS USED BY NL2SOL  ***
C
C +++  COMMENTS BELOW CONTAIN DATA STATEMENTS FOR VARIOUS MACHINES.  +++
C +++  TO CONVERT TO ANOTHER MACHINE, PLACE A C IN COLUMN 1 OF THE   +++
C +++  DATA STATEMENT LINE(S) THAT CORRESPOND TO THE CURRENT MACHINE +++
C +++  AND REMOVE THE C FROM COLUMN 1 OF THE DATA STATEMENT LINE(S)  +++
C +++  THAT CORRESPOND TO THE NEW MACHINE.                           +++
C
C     INTEGER K
C
C  ***  THE CONSTANT RETURNED DEPENDS ON K...
C
C  ***        K = 1... SMALLEST POS. ETA SUCH THAT -ETA EXISTS.
C  ***        K = 2... SQUARE ROOT OF 1.001*ETA.
C  ***        K = 3... UNIT ROUNDOFF = SMALLEST POS. NO. MACHEP SUCH
C  ***                 THAT 1 + MACHEP .GT. 1 .AND. 1 - MACHEP .LT. 1.
C  ***        K = 4... SQUARE ROOT OF 0.999*MACHEP.
C  ***        K = 5... SQUARE ROOT OF 0.999*BIG (SEE K = 6).
C  ***        K = 6... LARGEST MACHINE NO. BIG SUCH THAT -BIG EXISTS.
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      DATA ONE001/1.001D0/, PT999/0.999D0/
C
      BIG = D1MACH(2)
      ETA = D1MACH(1)
      MACHEP = D1MACH(4)
C
C-------------------------------  BODY  --------------------------------
C
      GO TO (10, 20, 30, 40, 50, 60), K
C
 10   RMDCON = ETA
      GO TO 999
C
 20   RMDCON = DSQRT(ONE001*ETA)
      GO TO 999
C
 30   RMDCON = MACHEP
      GO TO 999
C
 40   RMDCON = DSQRT(PT999*MACHEP)
      GO TO 999
C
 50   RMDCON = DSQRT(PT999*BIG)
      GO TO 999
C
 60   RMDCON = BIG
C
 999  RETURN
C  ***  LAST CARD OF RMDCON FOLLOWS  ***
      END
*V2NORM
      DOUBLE PRECISION FUNCTION V2NORM(P, X)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C  ***  RETURN THE 2-NORM OF THE P-VECTOR X, TAKING  ***
C  ***  CARE TO AVOID THE MOST LIKELY UNDERFLOWS.    ***
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   P
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   X(*)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   ONE,R,SCALE,SQTETA,T,XI,ZERO
      INTEGER
     +   I,J
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   RMDCON
      EXTERNAL RMDCON
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,SQRT
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      DATA ONE/1.0D0/, SQTETA/0.0D0/, ZERO/0.0D0/
C
      IF (P .GT. 0) GO TO 10
         V2NORM = ZERO
         GO TO 999
 10   DO 20 I = 1, P
         IF (X(I) .NE. ZERO) GO TO 30
 20      CONTINUE
      V2NORM = ZERO
      GO TO 999
C
 30   SCALE = ABS(X(I))
      IF (I .LT. P) GO TO 40
         V2NORM = SCALE
         GO TO 999
 40   T = ONE
      IF (SQTETA .EQ. ZERO) SQTETA = RMDCON(2)
C
C     ***  SQTETA IS (SLIGHTLY LARGER THAN) THE SQUARE ROOT OF THE
C     ***  SMALLEST POSITIVE FLOATING POINT NUMBER ON THE MACHINE.
C     ***  THE TESTS INVOLVING SQTETA ARE DONE TO PREVENT UNDERFLOWS.
C
      J = I + 1
      DO 60 I = J, P
         XI = ABS(X(I))
         IF (XI .GT. SCALE) GO TO 50
              R = XI / SCALE
              IF (R .GT. SQTETA) T = T + R*R
              GO TO 60
 50           R = SCALE / XI
              IF (R .LE. SQTETA) R = ZERO
              T = ONE  +  T * R*R
         SCALE = XI
 60      CONTINUE
C
      V2NORM = SCALE * SQRT(T)
 999  RETURN
C  ***  LAST CARD OF V2NORM FOLLOWS  ***
      END
*AMEPT1
      SUBROUTINE AMEPT1(N, Y, PVT, SDPVT, RES, SDREST, IPTOUT, NDIGIT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBOUTINE PRINTS THE DATA SUMMARY FOR THE NONLINEAR
C     LEAST SQUARES SUBROUTINES.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 2, 1985
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N,NDIGIT
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   PVT(*),RES(*),SDPVT(*),SDREST(*),Y(*)
      INTEGER
     +   IPTOUT(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   FPLM
      INTEGER
     +   I,NMAX
C
C  EXTERNAL FUNCTIONS
CCCCC DOUBLE PRECISION
CCCCC+   D1MACH
CCCCC EXTERNAL D1MACH
C
C  EXTERNAL SUBROUTINES
      EXTERNAL OBSSM2
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX,MIN
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION FPLM
C        THE FLOATING POINT LARGEST MAGNITUDE.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IERR
C        THE VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .GE. 1, ERRORS WERE DETECTED.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IPTOUT(NDIGIT)
C        THE VARIABLE USED TO CONTROL PRINTED OUTPUT FOR EACH SECTION.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NDIGIT
C        THE NUMBER OF DIGITS IN THE PRINT CONTROL VALUE.
C     INTEGER NMAX
C        THE MAXIMUM NUMBER OF ROWS TO BE PRINTED.
C     DOUBLE PRECISION PVT(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES.
C     DOUBLE PRECISION RES(N)
C        THE RESIDUALS FROM THE FIT.
C     DOUBLE PRECISION SDPVT(N)
C        THE STANDARD DEVIATIONS OF THE PREDICTED VALUES.
C     DOUBLE PRECISION SDREST(N)
C        THE STANDARDIZED RESIDUALS.
C     DOUBLE PRECISION Y(N)
C        THE DEPENDENT VARIABLE.
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      FPLM = D1MACH(2)
C
CCCCC CALL IPRINT(IPRT)
C
CCCCC WRITE(IOUNI2,999)
CCCCC CALL DPWRST('XXX','BUG ')
CCCCC WRITE(IOUNI2,999)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE (IOUNI2,1100)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE (IOUNI2,1101)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE(IOUNI2,999)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE (IOUNI2,1000)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE (IOUNI2,1001)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE (IOUNI2, 1110)
CCCCC CALL DPWRST('XXX','BUG ')
C
      NMAX = N
      IF ((MAX(IPTOUT(3),1).EQ.1) .AND. (N.GE.45))
     +  NMAX = MIN(N,40)
C
C     PRINT OBSERVATION SUMMARY
C
      CALL OBSSM2(N, Y, PVT, SDPVT, RES, SDREST, 1, NMAX)
C
      IF (NMAX.GE.N) GO TO 200
C
      DO 195 I = 1, 3
         WRITE (IOUNI2, 1150)
  195 CONTINUE
C
C     PRINT LAST LINE OF OUTPUT
C
      CALL OBSSM2(N, Y, PVT, SDPVT, RES, SDREST, N, N)
C
  200 CONTINUE
C
      IF ((IERR.EQ.4)) THEN
        WRITE(IOUNI2,999)
CCCCC   CALL DPWRST('XXX','BUG ')
        WRITE(IOUNI2,999)
CCCCC   CALL DPWRST('XXX','BUG ')
        WRITE (IOUNI2, 1080)
CCCCC   CALL DPWRST('XXX','BUG ')
      ENDIF
      IF ((IERR.GT.0) .AND. (IERR.NE.4)) THEN
        WRITE(IOUNI2,999)
CCCCC   CALL DPWRST('XXX','BUG ')
        WRITE(IOUNI2,999)
CCCCC   CALL DPWRST('XXX','BUG ')
        WRITE (IOUNI2, 1090)
CCCCC   CALL DPWRST('XXX','BUG ')
        WRITE (IOUNI2, 1091)
CCCCC   CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
C
C     FORMAT STATEMENTS
C
  999 FORMAT(1X)
 1000 FORMAT (
     +   4X, 15X, '   -----PREDICTED  ----STD DEV OF', 16X,
     +   '   ---STD')
 1001 FORMAT (
     +   1X, 3HROW, '   -------SERIES  --------VALUE',
     +   '    ---PRED VALUE   -----RESIDUAL   --RES')
 1080 FORMAT (
     +   ' *  NC  -  VALUE NOT COMPUTED BECAUSE',
     +   ' THE STANDARD DEVIATION OF THE RESIDUAL IS ZERO.')
 1090 FORMAT (
     +   ' *  NC  -  VALUE NOT COMPUTED BECAUSE CONVERGENCE')
 1091 FORMAT (
     + 'PROBLEMS PREVENTED THE COVARIANCE MATRIX FROM BEING COMPUTED.')
 1100 FORMAT (' RESULTS FROM LEAST SQUARES FIT')
 1101 FORMAT ( 1X, 31('-'))
 1110 FORMAT (' ')
 1150 FORMAT (4X, '.', 4(14X, '.'), 7X, '.')
      END
*DOTPRD
      DOUBLE PRECISION FUNCTION DOTPRD(P, X, Y)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C  ***  RETURN THE INNER PRODUCT OF THE P-VECTORS X AND Y.  ***
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   P
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   X(*),Y(*)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   ONE,SQTETA,T,ZERO
      INTEGER
     +   I
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   RMDCON
      EXTERNAL RMDCON
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MAX
C
C     INTEGER P
C     DOUBLE PRECISION X(*), Y(*)
C
C     INTEGER I
C     DOUBLE PRECISION ONE, SQTETA, T, ZERO
C/+
C     DOUBLE PRECISION MAX, ABS
C/
C     EXTERNAL RMDCON
C     DOUBLE PRECISION RMDCON
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C  ***  RMDCON(2) RETURNS A MACHINE-DEPENDENT CONSTANT, SQTETA, WHICH
C  ***  IS SLIGHTLY LARGER THAN THE SMALLEST POSITIVE NUMBER THAT
C  ***  CAN BE SQUARED WITHOUT UNDERFLOWING.
C
      DATA ONE/1.0D0/, SQTETA/0.0D0/, ZERO/0.0D0/
C
      DOTPRD = ZERO
      IF (P .LE. 0) GO TO 999
      IF (SQTETA .EQ. ZERO) SQTETA = RMDCON(2)
      DO 20 I = 1, P
         T = MAX(ABS(X(I)), ABS(Y(I)))
         IF (T .GT. ONE) GO TO 10
         IF (T .LT. SQTETA) GO TO 20
         T = (X(I)/SQTETA)*Y(I)
         IF (ABS(T) .LT. SQTETA) GO TO 20
 10      DOTPRD = DOTPRD + X(I)*Y(I)
 20   CONTINUE
C
 999  RETURN
C  ***  LAST CARD OF DOTPRD FOLLOWS  ***
      END
*FLTSL
      SUBROUTINE FLTSL (Y, N, K, H, YF, NYF)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE FILTERS THE INPUT SERIES Y USING THE K TERMS
C     OF H, COPYING THE FILTERED SERIES INTO YF.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DEVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  NOVEMBER 26, 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   K,N,NYF
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   H(K),Y(N),YF(N)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   TEMP
      INTEGER
     +   I,I1,IHM,IHP,IKMID,IM,IP,J,KHALF,KMID
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION H(K)
C        THE ARRAY IN WHICH THE FILTER COEFFICIENTS ARE STORED.
C     INTEGER I, IHM, IHP, IKMID, IM, IP
C        INDEXING VARIABLES.
C     INTEGER J
C        AN INDEXING VARIABLE.
C     INTEGER K
C        THE NUMBER OF FILTER TERMS.
C     INTEGER KHALF, KMID
C        THE HALF LENGTH OF THE FILTER AND THE MIDPOINT OF THE FILTER.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS IN THE SERIES Y.
C     INTEGER NYF
C        THE NUMBER OF OBSERVATIONS IN THE FILTERED SERIES YF.
C     DOUBLE PRECISION TEMP
C        A TEMPORY STORAGE LOCATION.
C     DOUBLE PRECISION Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES.
C     DOUBLE PRECISION YF(N)
C        THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED.
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DO 10 I = 1, N
         YF(I) = Y(I)
   10 CONTINUE
C
      NYF = N - (K - 1)
C
      KHALF = (K - 1) / 2
C
      KMID = KHALF + 1
C
      DO 30 I = 1, NYF
         IKMID = I + KHALF
         TEMP = H(KMID) * YF(IKMID)
         DO 20 J = 1, KHALF
            IP = IKMID + J
            IHP = KMID + J
            IM = IKMID - J
            IHM = KMID - J
            TEMP = TEMP + H(IHP)*YF(IP) + H(IHM)*YF(IM)
   20    CONTINUE
         YF(I) = TEMP
   30 CONTINUE
C
      I1 = NYF + 1
C
      DO 40 I = I1, N
         YF(I) = 0.0D0
   40 CONTINUE
      RETURN
      END
*LPFLT
      SUBROUTINE LPFLT (FC, K, HLP)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE LOPASS FILTER COEFFICIENTS.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  NOVEMBER 26, 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   FC
      INTEGER
     +   K
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   HLP(K)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   ARG,CON,PI,SUM
      INTEGER
     +   I,IHM,IHP,KHALF,KMID
C
C  EXTERNAL SUBROUTINES
      EXTERNAL GETPI
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION ARG, CON
C        VARIABLES USED IN THE COMPUTATION OF THE LOW PASS FILTER
C        COEFFICIENTS.
C     DOUBLE PRECISION FC
C        THE CUTOFF FREQUENCY USED FOR THE LOW PASS FILTER.
C     DOUBLE PRECISION HLP(K)
C        THE ARRAY IN WHICH THE INPUT LOW PASS FILTER COEFFICIENTS
C        ARE STORED.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IHM, IHP
C        INDEX VARIABLES FOR SYMMETRIC LOCATIONS AROUND THE MIDPOINT
C        OF THE FILTER.
C     INTEGER K
C        THE NUMBER OF TERMS IN THE FILTER.
C     INTEGER KHALF
C        THE VALUE OF THE MIDPOINT OF K MINUS 1.
C     INTEGER KMID
C        THE MIDPOINT OF THE FILTER.
C     DOUBLE PRECISION PI
C        THE VALUE OF PI.
C     DOUBLE PRECISION SUM
C        A VALUE USED FOR SUMMING.
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      CALL GETPI(PI)
C
      KMID = (K + 1) / 2
C
      HLP(KMID) = 1.0D0
C
      IF (K .EQ. 1) RETURN
C
      HLP(KMID) = 2.0D0 * FC
      CON = 2.0D0 * PI / K
      SUM = HLP(KMID)
C
      KHALF = (K - 1) / 2
C
      DO 10 I = 1, KHALF
         ARG = I * CON
         IHP = KMID + I
         HLP(IHP) = SIN(I * FC * 2.0D0 * PI) * SIN(ARG) /
     +      (I * PI * ARG)
         IHM = KMID - I
         HLP(IHM) = HLP(IHP)
         SUM = SUM + HLP(IHM) + HLP(IHP)
   10 CONTINUE
      DO 20 I = 1, K
         HLP(I) = HLP(I) / SUM
   20 CONTINUE
      RETURN
      END
*NLERR
      SUBROUTINE NLERR (ICNVCD, ISKULL)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE SETS THE ERROR FLAG IERR BASED ON THE CONVERGENCE
C     CODE RETURNED BY NL2.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  APRIL 2, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   ICNVCD
C
C  ARRAY ARGUMENTS
      INTEGER
     +   ISKULL(10)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER ICNVCD
C        THE CONVERGENCE CODE FROM NL2.
C     INTEGER IERR
C        THE VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .GE. 1, ERRORS WERE DETECTED.
C     INTEGER ISKULL(10)
C        AN ERROR MESSAGE INDICATOR VARIABLE.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     INITIALIZE MESSAGE INDICATOR VARIABLE
C
      DO 5 I = 1, 10
         ISKULL(I) = 0
    5 CONTINUE
C
C     SET ERROR FLAG
C
      GO TO (10, 10, 20, 20, 20, 20, 40, 50, 60, 60, 10, 30, 10, 10,
     +   10), ICNVCD
C
C     BAD VALUE
C
   10 IERR = 1
      RETURN
C
C     ACCEPTABLE STOPPING CONDITION
C
   20 IERR = 0
      RETURN
C
C     INITIAL VARIANCE COMPUTATION OVERFLOWS
C
   30 IERR = 2
      ISKULL(2) = 1
      RETURN
C
C     SINGULAR CONVERGENCE
C
   40 IERR = 3
      ISKULL(3) = 1
      RETURN
C
C     FALSE CONVERGENCE
C
   50 IERR = 5
      ISKULL(5) = 1
      RETURN
C
C     ITERATION OR FUNCTION EVALUATION LIMIT
C
   60 IERR = 6
      ISKULL(6) = 1
      RETURN
C
      END
*RPTMUL
      SUBROUTINE RPTMUL(FUNC, IPIVOT, J, NN, P, RD, X, Y, Z)
C
C  ***  FUNC = 1... SET  Y = RMAT * (PERM**T) * X.
C  ***  FUNC = 2... SET  Y = PERM * (RMAT**T) * RMAT * (PERM**T) * X.
C  ***  FUNC = 3... SET  Y = PERM * (RMAT**T) X.
C
C
C  ***  PERM = MATRIX WHOSE I-TH COL. IS THE IPIVOT(I)-TH UNIT VECTOR.
C  ***  RMAT IS THE UPPER TRIANGULAR MATRIX WHOSE STRICT UPPER TRIANGLE
C  ***       IS STORED IN  J  AND WHOSE DIAGONAL IS STORED IN RD.
C  ***  Z IS A SCRATCH VECTOR.
C  ***  X AND Y MAY SHARE STORAGE.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   FUNC,NN,P
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   J(NN,P),RD(P),X(P),Y(P),Z(P)
      INTEGER
     +   IPIVOT(P)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   ZK
      INTEGER
     +   I,IM1,K,KM1
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DOTPRD
      EXTERNAL DOTPRD
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
C-----------------------------------------------------------------------
C
      IF (FUNC .GT. 2) GO TO 50
C
C  ***  FIRST SET  Z = (PERM**T) * X  ***
C
      DO 10 I = 1, P
         K = IPIVOT(I)
         Z(I) = X(K)
 10      CONTINUE
C
C  ***  NOW SET  Y = RMAT * Z  ***
C
      Y(1) = Z(1) * RD(1)
      IF (P .LE. 1) GO TO 40
      DO 30 K = 2, P
         KM1 = K - 1
         ZK = Z(K)
         DO 20 I = 1, KM1
 20           Y(I) = Y(I) + J(I,K)*ZK
         Y(K) = ZK*RD(K)
 30      CONTINUE
C
 40   IF (FUNC .LE. 1) GO TO 999
      GO TO 70
C
 50   DO 60 I = 1, P
 60      Y(I) = X(I)
C
C  ***  SET  Z = (RMAT**T) * Y  ***
C
 70   Z(1) = Y(1) * RD(1)
      IF (P .EQ. 1) GO TO 90
      DO 80 I = 2, P
         IM1 = I - 1
         Z(I) = Y(I)*RD(I) + DOTPRD(IM1, J(1,I), Y)
 80      CONTINUE
C
C  ***  NOW SET  Y = PERM * Z  ***
C
 90   DO 100 I = 1, P
         K = IPIVOT(I)
         Y(K) = Z(I)
 100     CONTINUE
C
 999  RETURN
C  ***  LAST CARD OF RPTMUL FOLLOWS  ***
      END
*VAXPY
      SUBROUTINE VAXPY(P, W, A, X, Y)
C
C  ***  SET W = A*X + Y  --  W, X, Y = P-VECTORS, A = SCALAR  ***
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   A
      INTEGER
     +   P
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   W(*),X(*),Y(*)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      DO 10 I = 1, P
 10      W(I) = A*X(I) + Y(I)
      RETURN
      END
*AMESTP
      SUBROUTINE AMESTP(XM, N, M, IXM, MDL, PAR, NPAR, STP,
     +   EXMPT, NETA, SCALE, LSCALE, NPRT, HDR, PAGE, WIDE, ISUBHD,
     +   HLFRPT, PRTFXD, IFIXED, LIFIXD, STPOUT, PVPAD)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE CONTROLS THE STEP SIZE SELECTION PROCESS.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  APRIL 2, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   EXMPT
      INTEGER
     +   ISUBHD,IXM,LIFIXD,LSCALE,M,N,NETA,NPAR,NPRT,PVPAD
      LOGICAL
     +   HLFRPT,PAGE,PRTFXD,WIDE
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   PAR(*),SCALE(*),STP(*),XM(IXM,*)
      INTEGER
     +   IFIXED(*)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL HDR,MDL,STPOUT
C
C  SCALARS IN COMMON
      DOUBLE PRECISION
     +   Q
      INTEGER
     +   IERR
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   ETA,EXM,FPLRS,SCL,TAU
      INTEGER
     +   CD,FD,FDLAST,FDSAVE,IFAILJ,IFIXD,IFP,ITEMP,J,MXFAIL,NALL0,
     +   NDD,NDGT1,NEXMPT,NFAIL,NFAILJ,PARTMP,PV,PVMCD,PVNEW,PVPCD,
     +   PVSTP,PVTEMP
      LOGICAL
     +   HEAD
C
C  LOCAL ARRAYS
      DOUBLE PRECISION
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
C
C  EXTERNAL FUNCTIONS
CCCCC DOUBLE PRECISION
CCCCC+   D1MACH
      INTEGER
     +   STKGET,STKST
CCCCC EXTERNAL D1MACH,STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL CPYVII,ETAMDL,SETIV,STKCLR,STPMN
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,INT,LOG10,MAX,MIN
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
      COMMON /NOTOPT/Q
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),ISTAK(1))
      EQUIVALENCE (DSTAK(1),RSTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER CD
C        THE STARTING LOCATION IN THE WORK AREA OF
C        THE CENTRAL DIFFERENCE QUOTIENT APPROXIMATION TO THE
C        DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER.
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     DOUBLE PRECISION ETA
C        THE RELATIVE NOISE IN THE MODEL.
C     DOUBLE PRECISION EXM
C        THE PROPORTION OF OBSERVATIONS ACTUALLY USED FOR WHICH THE
C        COMPUTED NUMERICAL DERIVATIVES WRT A GIVEN PARAMETER ARE
C        EXEMPTED FROM MEETING THE DERIVATIVE ACCEPTANCE CRITERIA.
C     DOUBLE PRECISION EXMPT
C        THE PROPORTION OF OBSERVATIONS FOR WHICH THE COMPUTED
C        NUMERICAL DERIVATIVES WRT A GIVEN PARAMETER ARE EXEMPTED
C        FROM MEETING THE DERIVATIVE ACCEPTANCE CRITERIA.
C     INTEGER FD
C        THE STARTING LOCATION IN THE WORK AREA OF
C        THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE
C        DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER.
C     INTEGER FDLAST
C        THE STARTING LOCATION IN THE WORK AREA OF
C        THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE
C        DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER
C        FOR THE LAST STEP SIZE TRIED.
C     INTEGER FDSAVE
C        THE STARTING LOCATION IN THE WORK AREA OF
C        THE FORWARD DIFFERENCE QUOTIENT APPROXIMATION TO THE
C        DERIVATIVE OF THE MODEL WITH RESPECT TO THE JTH PARAMETER
C        FOR THE BEST STEP SIZE TRIED SO FAR.
C     DOUBLE PRECISION FPLRS
C        THE FLOATING POINT LARGEST RELATIVE SPACING.
C     EXTERNAL HDR
C        THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING
C     LOGICAL HEAD
C        A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED
C        (TRUE) OR NOT (FALSE).  IF A HEADING IS PRINTED, THE VALUE
C        OF HEAD WILL BE CHANGED TO FALSE.
C     LOGICAL HLFRPT
C        THE VARIABLE WHICH INDICATES WHETHER THE DERIVATIVE
C        CHECKING ROUTINE HAS ALREADY PRINTED PART OF THE
C        INITIAL SUMMARY (TRUE) OR NOT (FALSE).
C     INTEGER IERR
C        THE VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .GE. 1, ERRORS WERE DETECTED.
C     INTEGER IFAILJ
C        THE STARTING LOCATION IN ISTAK FOR
C        THE ARRAY OF INDICATOR VARIABLES DESIGNATING WHETHER
C        THE SETP SIZE SELECTED WAS SATISFACOTRY FOR A GIVEN
C        OBSERVATION AND THE JTH PARAMETER.
C     INTEGER IFIXD
C        THE STARTING LOCATION IN /CSTAK/ OF VECTOR IFIXD CONTAINING
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE
C        PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED.
C        IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED.
C        IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED.
C     INTEGER IFIXED(LIFIXD)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE
C        PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED.
C        IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED.
C        IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED.
C     INTEGER IFP
C        AN INDICATOR FOR THE PRECISION OF THE STACK ALLOCATION TYPE,
C        WHERE IFP=3 INDICATES SINGLE AND IFP=4 INDICATES DOUBLE.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER ISUBHD
C        AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED.
C     INTEGER ITEMP
C        THE STARTING LOCATION IN ISTAK FOR
C        A TEMPORARY STORAGE VECTOR.
C     INTEGER IXM
C        THE FIRST DIMENSION OF MATRIX XM.
C     INTEGER J
C        AN INDEX VARIABLE.
C     INTEGER LIFIXD
C        THE DIMENSION OF VECTOR IFIXED.
C     INTEGER LSCALE
C        THE DIMENSION OF VECTOR SCALE.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     EXTERNAL MDL
C        THE NAME OF THE USER SUPPLIED SUBROUTINE WHICH COMPUTES THE
C        PREDICTED VALUES BASED ON THE CURRENT PARAMETER ESTIMATES.
C     INTEGER MXFAIL
C        THE MAXIMUM NUMBER OF FAILURES FOR ANY PARAMETER.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NALL0
C        NUMBER OF STACK ALLOCATIONS OUTSTANDING.
C     INTEGER NDD
C        THE NUMBER OF DECIMAL DIGITS CARRIED FOR A SINGLE
C        PRECISION DOUBLE PRECISION NUMBER.
C     INTEGER NDGT1
C        THE NUMBER OF RELIABLE DIGITS IN THE MODEL USED, EITHER
C        SET TO THE USER SUPPLIED VALUE OF NETA, OR COMPUTED
C        BY ETAMDL.
C     INTEGER NETA
C        THE NUMBER OF ACCURATE DIGITS IN THE MODEL RESULTS.
C     INTEGER NEXMPT
C        THE NUMBER OF OBSERVATIONS FOR WHICH A GIVEN STEP SIZE
C        DOES NOT HAVE TO BE SATISFACTORY AND THE SELECTED STEP
C        SIZE STILL BE CONSIDERED OK.
C     INTEGER NFAIL
C        THE NUMBER OF OBSERVATIONS FOR WHICH THE SELECTED STEP SIZE
C        FOR THE PARAMETER DOES NOT MEET THE CRITERIA.
C     INTEGER NFAILJ
C        THE NUMBER OF OBSERVATIONS FOR WHICH THE SELECTED STEP SIZE
C        FOR THE JTH PARAMETER DOES NOT MEET THE CRITERIA.
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     INTEGER NPRT
C        THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS
C        TO BE PROVIDED.
C     LOGICAL PAGE
C        THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF
C        THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     INTEGER PARTMP
C        THE STARTING LOCATION IN THE WORK AREA OF
C        THE MODIFIED MODEL PARAMETERS
C     LOGICAL PRTFXD
C        THE INDICATOR VALUE USED TO DESIGNATE WHETHER THE
C        OUTPUT IS TO INCLUDE INFORMATION ON WHETHER THE
C        PARAMETER IS FIXED (TRUE) OR NOT (FALSE).
C     INTEGER PV
C        THE STARTING LOCATION IN THE WORK AREA OF
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     INTEGER PVMCD
C        THE STARTING LOCATION IN THE WORK AREA OF
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C     INTEGER PVNEW
C        THE STARTING LOCATION IN THE WORK AREA OF
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C        FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J)+STPNEW.
C     INTEGER PVPAD
C       ADDITIONAL WORKSPACE NEEDED IN PV FOR THE EVALUATION OF THE
C       MODEL.
C     INTEGER PVPCD
C        THE STARTING LOCATION IN THE WORK AREA OF
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C        FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J)+STPCD.
C     INTEGER PVSTP
C        THE STARTING LOCATION IN THE WORK AREA OF
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
C        FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS PAR(J)+STP(J).
C     INTEGER PVTEMP
C        THE STARTING LOCATION IN THE WORK AREA OF
C        A TEMPORY STORAGE LOCATION FOR PREDICTED VALUES BEGINS.
C     DOUBLE PRECISION Q
C        A DUMMY VARIABLE WHICH IS USED, ALONG WITH COMMON NOTOPT (NO
C        OPTIMIZATION), TO COMPUTE THE STEP SIZE.
C     DOUBLE PRECISION RSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     DOUBLE PRECISION SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE PARAMETERS.
C     DOUBLE PRECISION SCL
C        THE ACTUAL TYPICAL SIZE USED.
C     DOUBLE PRECISION STP(NPAR)
C        THE SELECTED STEP SIZES.
C     EXTERNAL STPOUT
C        THE ROUTINE FOR PRINTING THE OUTPUT.
C     DOUBLE PRECISION TAU
C        THE AGREEMENT TOLERANCE.
C     LOGICAL WIDE
C        THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD
C        BE FULL WIDTH (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION XM(IXM,M)
C        THE INDEPENDENT VARIABLE.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      NALL0 = STKST(1)
C
      FPLRS = D1MACH(4)
      IFP = 4
C
C     SET PRINT CONTROLS
C
      HEAD = .TRUE.
C
C     SUBDIVIDE WORK AREA
C
      IFIXD = STKGET(NPAR, 2)
      ITEMP = STKGET(N, 2)
      IFAILJ = STKGET(N, 2)
      NFAIL = STKGET(NPAR, 2)
C
      CD = STKGET(N, IFP)
      FD = STKGET(N, IFP)
      FDLAST = STKGET(N, IFP)
      FDSAVE = STKGET(N, IFP)
      PV = STKGET(N+PVPAD, IFP)
      PVMCD = STKGET(N+PVPAD, IFP)
      PVNEW = STKGET(N+PVPAD, IFP)
      PVPCD = STKGET(N+PVPAD, IFP)
      PVSTP = STKGET(N+PVPAD, IFP)
      PVTEMP = STKGET(N+PVPAD, IFP)
C
      IF (IERR .EQ. 1) RETURN
C
      PARTMP = CD
C
C     SET UP IFIXD
C
      IF (IFIXED(1).LT.0) CALL SETIV(ISTAK(IFIXD), NPAR, 0)
      IF (IFIXED(1).GE.0) CALL CPYVII(NPAR, IFIXED, 1, ISTAK(IFIXD), 1)
C
C     SET PARAMETERS NECESSARY FOR THE COMPUTATIONS
C
      NDD = INT(-LOG10(FPLRS))
C
      IF ((NETA .GE. 2) .AND. (NETA .LE. NDD)) THEN
            ETA = 10.0D0 ** (-NETA)
            NDGT1 = NETA
      ELSE
            CALL ETAMDL(MDL, PAR, NPAR, XM, N, M, IXM, ETA, NDGT1,
     +         RSTAK(PARTMP), RSTAK(PVTEMP), 0)
      END IF
C
      TAU = MIN(ETA**0.25D0, 0.01D0)
C
      EXM = EXMPT
      IF ((EXM.LT.0.0D0) .OR. (EXM.GT.1.0D0)) EXM = 0.10D0
      NEXMPT = INT(EXM * N)
      IF (EXM .NE. 0.0D0) NEXMPT = MAX(NEXMPT, 1)
C
C     COMPUTE PREDICTED VALUES OF THE MODEL USING THE INPUT PARAMETER
C     ESTIMATES
C
      CALL MDL(PAR, NPAR, XM, N, M, IXM, RSTAK(PV))
C
      MXFAIL = 0
      NFAILJ = NFAIL
C
      DO 120 J = 1, NPAR
C
         IF (SCALE(1) .LE. 0.0D0) THEN
            IF (PAR(J) .EQ. 0.0D0) THEN
               SCL = 1.0D0
            ELSE
               SCL = ABS(PAR(J))
            END IF
         ELSE
            SCL = SCALE(J)
         END IF
C
         CALL STPMN(J, XM, N, M, IXM, MDL, PAR, NPAR, NEXMPT,
     +      ETA, TAU, SCL, STP(J), ISTAK(NFAILJ), ISTAK(IFAILJ),
     +      RSTAK(CD), ISTAK(ITEMP), RSTAK(FD), RSTAK(FDLAST),
     +      RSTAK(FDSAVE), RSTAK(PV), RSTAK(PVMCD), RSTAK(PVNEW),
     +      RSTAK(PVPCD), RSTAK(PVSTP), RSTAK(PVTEMP))
C
C     COMPUTE THE MAXIMUM NUMBER OF FAILURES FOR ANY PARAMETER
C
         MXFAIL = MAX(ISTAK(NFAILJ), MXFAIL)
C
C     PRINT RESULTS IF THEY ARE DESIRED
C
         IF ((NPRT.NE.0) .OR. (MXFAIL.GT.NEXMPT))
     +      CALL STPOUT(HEAD, N, EXM, NEXMPT, NDGT1, J, PAR, NPAR,
     +         STP, ISTAK(NFAIL), ISTAK(IFAILJ), SCALE,  LSCALE, HDR,
     +         PAGE, WIDE, ISUBHD, NPRT, PRTFXD, ISTAK(IFIXD))
C
         NFAILJ = NFAILJ + 1
C
  120 CONTINUE
C
      HLFRPT = .FALSE.
      IF ((NPRT.NE.0) .OR. (MXFAIL.GT.NEXMPT)) HLFRPT = .TRUE.
C
      IF (MXFAIL.GT.NEXMPT) IERR = 2
C
      CALL STKCLR(NALL0)
C
      RETURN
C
      END
*DRV
      SUBROUTINE DRV(PAR, NPAR, XM, N, M, IXM, D)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     DUMMY DERIVATIVE FUNCTION FOR NLS FAMILY
C
C     WRITTEN BY  -  LINDA L. MITCHELL
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 7, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IXM,M,N,NPAR
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   D(N,NPAR),PAR(NPAR),XM(IXM,M)
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION D(N,NPAR)
C        THE FIRST DERIVATIVE WITH RESPECT TO THE ITH PARAMETER
C     INTEGER IXM
C        ACTUAL FIRST DIMENSION OF XM
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLESC
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS
C     DOUBLE PRECISION PAR(NPAR)
C        MODEL PARAMETERS
C     DOUBLE PRECISION XM(IXM,M)
C        MODEL INDEPENDENT VARIABLE
C
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      RETURN
C
      END
*GETPI
      SUBROUTINE GETPI(PI)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE SETS THE VALUE OF PI.
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  NOVEMBER 21, 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   PI
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION PI
C        THE VALUE OF PI.
C
      PI = 3.141592653589793238462643383279D0
      RETURN
      END
*LSQRTZ
      SUBROUTINE LSQRTZ(N1, N, L, A, IRC)
C
C  ROUTINE RENAMED LSQRTZ FROM LSQRT FOR DATAPLOT TO
C  AVOID NAME CONFLICT WITH A PREVIOUSLY EXISTING ROUTINE.
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C  ***  COMPUTE ROWS N1 THROUGH N OF THE CHOLESKY FACTOR  L  OF
C  ***  A = L*(L**T),  WHERE  L  AND THE LOWER TRIANGLE OF  A  ARE BOTH
C  ***  STORED COMPACTLY BY ROWS (AND MAY OCCUPY THE SAME STORAGE).
C  ***  IRC = 0 MEANS ALL WENT WELL.  IRC = J MEANS THE LEADING
C  ***  PRINCIPAL  J X J  SUBMATRIX OF  A  IS NOT POSITIVE DEFINITE --
C  ***  AND  L(J*(J+1)/2)  CONTAINS THE (NONPOS.) REDUCED J-TH DIAGONAL.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IRC,N,N1
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   A(1),L(1)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   T,TD,ZERO
      INTEGER
     +   I,I0,IJ,IK,IM1,J,J0,JK,JM1,K
C
C  INTRINSIC FUNCTIONS
      INTRINSIC SQRT
C
C  ***  PARAMETERS  ***
C
C     INTEGER N1, N, IRC
C     DOUBLE PRECISION L(1), A(1)
C     DIMENSION L(N*(N+1)/2), A(N*(N+1)/2)
C
C  ***  LOCAL VARIABLES  ***
C
C     INTEGER I, IJ, IK, IM1, I0, J, JK, JM1, J0, K
C     DOUBLE PRECISION T, TD, ZERO
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C/
      DATA ZERO/0.0D0/
C
C  ***  BODY  ***
C
      I0 = N1 * (N1 - 1) / 2
      DO 50 I = N1, N
         TD = ZERO
         IF (I .EQ. 1) GO TO 40
         J0 = 0
         IM1 = I - 1
         DO 30 J = 1, IM1
              T = ZERO
              IF (J .EQ. 1) GO TO 20
              JM1 = J - 1
              DO 10 K = 1, JM1
                   IK = I0 + K
                   JK = J0 + K
                   T = T + L(IK)*L(JK)
 10                CONTINUE
 20           IJ = I0 + J
              J0 = J0 + J
              T = (A(IJ) - T) / L(J0)
              L(IJ) = T
              TD = TD + T*T
 30           CONTINUE
 40      I0 = I0 + I
         T = A(I0) - TD
         IF (T .LE. ZERO) GO TO 60
         L(I0) = SQRT(T)
 50      CONTINUE
C
      IRC = 0
      GO TO 999
C
 60   L(I0) = T
      IRC = I
C
 999  RETURN
C
C  ***  LAST CARD OF LSQRTZ  ***
      END
*NLINIT
      SUBROUTINE NLINIT (N, IFIXD, PAR, NPAR, PARE, NPARE, MIT,
     +   STOPSS, STOPP, SCALE, LSCALE, DELTA, IVAPRX, APRXDV, IVCVPT,
     +   IWORK, IIWORK, RWORK, IRWORK, SCL)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PERFORMS INITIALIZATION FOR THE NONLINEAR
C     LEAST SQUARES ROUTINES.
C
C     REFERENCES
C
C     DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1979), AN ADAPTIVE
C             NONLINEAR LEAST-SQUARES ALGORITHM, (BEING REVISED).
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  OCTOBER 3, 1983
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   DELTA,STOPP,STOPSS
      INTEGER
     +   IIWORK,IRWORK,IVAPRX,IVCVPT,LSCALE,MIT,N,NPAR,NPARE,SCL
      LOGICAL
     +   APRXDV
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   PAR(NPAR),PARE(NPAR),RWORK(IRWORK),SCALE(LSCALE)
      INTEGER
     +   IFIXD(NPAR),IWORK(IIWORK)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   AFCTOL,CNVCOD,COVPRT,COVREQ,DINIT,DTYPE,ISCL,J,LMAX0,
     +   MXFCAL,MXITER,NITER,OUTLEV,PRUNIT,RFCTOL,SCLJ,SOLPRT,
     +   STATPR,X0PRT,XCTOL
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   RMDCON
      EXTERNAL RMDCON
C
C  EXTERNAL SUBROUTINES
      EXTERNAL DFAULT,NLSPK
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,IABS,MAX
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER AFCTOL
C        THE LOCATION IN RWORK OF THE ABSOLUTE CONVERGENCE TOLERANCE.
C     LOGICAL APRXDV
C        THE VARIABLE USED TO INDICATE WHETHER NUMERICAL
C        APPROXIMATIONS TO THE DERIVATIVE WERE USED (TRUE) OR NOT
C        (FALSE).
C     INTEGER CNVCOD
C        A VALUE USED TO CONTROL THE PRINTING OF ITERATION REPORTS.
C     INTEGER COVPRT
C        THE LOCATION IN IWORK OF THE VARIABLE USED TO INDICATE WHETHER
C        THE COVARIANCE MATRIX IS TO BE PRINTED BY THE NL2 CODE, WHERE
C        IWORK(COVPRT) = 0 INDICATES IT IS NOT.
C     INTEGER COVREQ
C        THE LOCATION IN IWORK OF THE VARIABLE USED TO INDICATE HOW
C        THE COVARIANCE MATRIX IS TO BE COMPUTED BY THE NL2 CODE, WHERE
C        IWORK(COVREQ) = 3 INDICATES THE COVARIANCE MATRIX IS TO BE COMP
C        AS THE RESIDUAL VARIANCE TIMES THE INVERSE OF THE JACOBIAN MATR
C        TRANSPOSED TIMES THE JACOBIAN MATRIX .
C     DOUBLE PRECISION DELTA
C        THE MAXIMUM CHANGE ALLOWED IN THE MODEL PARAMETERS AT THE
C        FIRST ITERATION.
C     INTEGER DINIT
C        THE LOCATION IN IWORK OF THE VALUE USED TO INDICATE
C        WHETHER OR NOT USER SUPPLIED SCALE VALUES ARE TO BE
C        USED, WHERE THE (NL2) DEFAULT VALUE OF RWORK(DINIT) = 0.0D0
C        INIDCATES NO, AND THE VALUE RWORK(DINIT) = -1.0D0 INDICATES
C        YES.
C     INTEGER DTYPE
C        THE LOCATION IN IWORK OF THE VALUE INDICATING WHETHER THE
C        SCALE VALUES HAVE BEEN SUPPLIED BY THE USER (IWORK(DTYPE) .LE.
C        OR THE DEFAULT VALUES ARE TO BE USED (IWORK(DTYPE) .GT. 0).
C     INTEGER IERR
C        THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .GE. 1, ERRORS WERE DETECTED.
C     INTEGER IFIXD(NPAR)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE
C        PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED.
C        IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED.
C        IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED.
C     INTEGER IIWORK
C        THE DIMENSION OF THE INTEGER WORK VECTOR IWORK.
C     INTEGER IRWORK
C        THE DIMENSION OF THE DOUBLE PRECISION WORK VECTOR RWORK.
C     INTEGER ISCL
C        THE LOCATION IN IWORK INDICATING THE STARTING LOCATION IN
C         RWORK OF THE SCALE VECTOR.
C     INTEGER IVAPRX
C        AN INDICATOR VALUE USED TO DESIGNATE WHICH OPTION IS TO BE USED
C        TO COMPUTE THE VARIANCE COVARIANCE MATRIX (VCV), WHERE
C        IVAPRX LE 0 INDICATES THE THE DEFAULT OPTION WILL BE USED
C        IVAPRX EQ 1 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN)
C                    USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED
C                    DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE
C        IVAPRX EQ 2 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(HESSIAN)
C                    USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED
C                    DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE
C        IVAPRX EQ 3 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN
C                          *INVERSE(HESSIAN)
C                    USING BOTH THE MODEL SUBROUTINE THE USER SUPPLIED
C                    DERIVATIVE SUBROUTINE WHEN IT IS AVAILABLE
C        IVAPRX EQ 4 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN)
C                    USING ONLY THE MODEL SUBROUTINE
C        IVAPRX EQ 5 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(HESSIAN)
C                    USING ONLY THE MODEL SUBROUTINE
C        IVAPRX EQ 6 INDICATES THE VCV IS TO BE COMPUTED BY
C                       INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN
C                          *INVERSE(HESSIAN)
C                    USING ONLY THE MODEL SUBROUTINE
C        IVAPRX GE 7 INDICATES THE DEFAULT OPTION WILL BE USED
C     INTEGER IVCVPT
C        AN INDICATOR VALUE USED TO DESIGNATE WHICH FORM OF THE
C        VARIANCE COVARIANCE MATRIX (VCV) IS BEING PRINTED, WHERE
C        IVCVPT = 1 INDICATES THE VCV WAS COMPUTED AS
C                   INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN)
C        IVCVPT = 2 INDICATES THE VCV WAS COMPUTED AS
C                   INVERSE(HESSIAN)
C        IVCVPT = 3 INDICATES THE VCV WAS COMPUTED AS
C                   INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN
C                       *INVERSE(HESSIAN)
C     INTEGER IWORK(IIWORK)
C        THE INTEGER WORK SPACE VECTOR USED BY THE NL2 SUBROUTINES.
C     INTEGER J
C        THE INDEX OF THE PARAMETER BEING EXAMINED.
C     INTEGER LMAX0
C        THE LOCATION IN RWORK OF THE VALUE INDICATING THE
C        MAXIMUM CHANGE ALLOWED IN THE MODEL PARAMETERS AT THE
C        FIRST ITERATION.
C     INTEGER MIT
C        THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C     INTEGER MXFCAL
C        THE LOCATION IN IWORK OF THE VARIABLE DESIGNATING THE
C        MAXIMUM NUMBER OF FUNCTION CALLS ALLOWED, EXCLUDING
C        CALLS NECESSARY TO COMPUTE THE DERIVATIVES AND VARIANCE
C        COVARIANCE MATRIX.
C     INTEGER MXITER
C        THE LOCATION IN IWORK OF THE VARIABLE DESIGNATING THE
C        MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NITER
C        THE LOCATION IN IWORK OF THE NUMBER OF THE CURRENT ITERATION.
C     INTEGER NPAR
C        THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL.
C     INTEGER NPARE
C        THE NUMBER OF UNKNOWN PARAMETERS TO BE OPTIMIZED.
C     INTEGER OUTLEV
C        THE LOCATION IN IWORK OF THE PARAMETER USED TO CONTROL THE
C        PRINTING OF THE ITERATION REPORTS BY NL2.
C     DOUBLE PRECISION PAR(NPAR)
C        THE ARRAY IN WHICH THE CURRENT ESTIMATES OF THE UNKNOWN
C        PARAMETERS ARE STORED.
C     DOUBLE PRECISION PARE(NPAR)
C        THE CURRENT ESTIMATES OF THE UNKNOWN PARAMETERS, BUT ONLY
C        THOSE TO BE OPTIMIZED (NOT THOSE WHOSE VALUES ARE FIXED).
C     INTEGER PRUNIT
C        THE LOCATION IN IWORK OF THE PARAMETER USED TO CONTROL
C        THE PRINT UNIT USED BY NL2.  IWORK(PRUNIT) = 0 MEANS
C        DONT PRINT ANYTHING.
C     INTEGER RFCTOL
C        THE LOCATION IN RWORK OF THE RELATIVE FUNCTION CONVERGENCE
C        TOLERANCE.
C     DOUBLE PRECISION RWORK(IRWORK)
C        THE DOUBLE PRECISION WORK VECTOR USED BY THE NL2 SUBROUTINES.
C     DOUBLE PRECISION SCALE(LSCALE)
C        THE TYPICAL SIZE OF THE UNKNOWN PARAMETERS.
C     INTEGER SCL
C        THE INDEX IN RWORK OF THE 1ST VALUE OF THE USER SUPPLIED SCALE
C        VALUE.
C     INTEGER SCLJ
C        THE INDEX IN RWORK OF THE JTH VALUE OF THE USER SUPPLIED SCALE
C        VALUE.
C     INTEGER SOLPRT
C        THE LOCATION IN IWORK OF THE PARAMETER USED TO CONTROL PRINTING
C        BY NL2 OF THE FINAL SOLUTION.
C     INTEGER STATPR
C        THE LOCATION IN IWORK OF THE PARAMETER USED TO CONTROL PRINTING
C        BY NL2 OF SUMMARY STATISTICS.
C     DOUBLE PRECISION STOPP
C        THE STOPPING CRITERION FOR THE TEST BASED ON THE MAXIMUM SCALED
C        RELATIVE CHANGE IN THE ELEMENTS OF THE MODEL PARAMETER VECTOR
C     DOUBLE PRECISION STOPSS
C        THE STOPPING CRITERION FOR THE TEST BASED ON THE RATIO OF THE
C        PREDICTED DECREASE IN THE RESIDUAL SUM OF SQUARES (COMPUTED
C        BY STARPAC) TO THE CURRENT RESIDUAL SUM OF SQUARES ESTIMATE.
C     INTEGER XCTOL
C        THE LOCATION IN RSTAK/DSTAK OF THE P CONVERGENCE TOLERANCE.
C     INTEGER X0PRT
C         THE LOCATION IN IWORK OF THE PARAMETER USED TO CONTROL PRINTIN
C        BY NL2 OF THE INITIAL PARAMETER AND SCALE VALUES.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     IWORK SUBSCRIPT VALUES
C
      DATA CNVCOD /34/, COVPRT /14/, COVREQ /15/, DINIT /38/, DTYPE
     +   /16/, ISCL /27/, MXFCAL /17/, MXITER /18/,
     +   NITER /31/, OUTLEV /19/, PRUNIT /21/, SOLPRT /22/, STATPR
     +   /23/, X0PRT /24/
C
C     RWORK SUBSCRIPT VALUES
C
      DATA AFCTOL /31/, LMAX0 /35/, RFCTOL /32/, XCTOL /33/
C
C+++++++++++++++++++++++++++++++  BODY  ++++++++++++++++++++++++++++++++
C
C     PACK PARAMETERS INTO PARE
C
      CALL NLSPK(PAR, IFIXD, NPAR, PARE, NPAR)
C
C     SET NL2SOL DEFAULT VALUES
C
      CALL DFAULT(IWORK, RWORK)
C
C     SET NON NL2 DEFAULT VALUES
C
      IWORK(MXITER) = MIT
      IF (MIT.LE.0) IWORK(MXITER) = 21
C
      IWORK(MXFCAL) = 2*IWORK(MXITER)
C
C     SET STOPPING CRITERION
C
      RWORK(AFCTOL) = RMDCON(1)
      IF ((STOPSS.GE.RMDCON(3)) .AND. (STOPSS.LE.0.1)) RWORK(RFCTOL) =
     +   STOPSS
C
      IF ((STOPP.GE.0.0D0) .AND. (STOPP.LE.1.0D0))
     +   RWORK(XCTOL) = STOPP
C
C     SET SCALE VALUES
C
      SCL = 94 + 2*N + NPARE*(3*NPARE+31)/2
      IWORK(ISCL) = SCL
      IF (SCALE(1).GT.0.0D0) GO TO 40
C
      IWORK(DTYPE) = 1
C
C     INITIALIZE SCALE VALUES FOR FIRST ITERATION
C
      SCLJ = SCL - 1
      DO 30 J=1,NPAR
         IF (IFIXD(J).NE.0) GO TO 30
         SCLJ = SCLJ + 1
         IF (PAR(J).EQ.0.0D0) RWORK(SCLJ) = 1.0D0
         IF (PAR(J).NE.0.0D0) RWORK(SCLJ) = 1.0D0/ABS(PAR(J))
   30 CONTINUE
C
      GO TO 60
C
   40 IWORK(DTYPE) = 0
      RWORK(DINIT) = -1.0D0
      SCLJ = SCL - 1
      DO 50 J=1,NPAR
         IF (IFIXD(J).NE.0) GO TO 50
         SCLJ = SCLJ + 1
         RWORK(SCLJ) = 1.0D0/MAX(ABS(SCALE(J)),ABS(PAR(J)))
   50 CONTINUE
C
   60 IF (DELTA.LE.0.0D0) RWORK(LMAX0) = 100.0D0
      IF (DELTA.GT.0.0D0) RWORK(LMAX0) = DELTA
C
C     SET NL2 COVARIANCE COMPUTATION CONTROL PARAMETER
C
      IF ((IVAPRX.LE.1) .OR. (IVAPRX.EQ.4) .OR. (IVAPRX.GE.7))
     +   IWORK(COVREQ) = 3
      IF ((IVAPRX.EQ.2) .OR. (IVAPRX.EQ.5)) IWORK(COVREQ) = 2
      IF ((IVAPRX.EQ.3) .OR. (IVAPRX.EQ.6)) IWORK(COVREQ) = 1
      IF ((IVAPRX.GE.4) .AND. (IVAPRX.LE.6))
     +   IWORK(COVREQ) = -IWORK(COVREQ)
      IF (APRXDV) IWORK(COVREQ) = -IABS(IWORK(COVREQ))
      IF ((IVAPRX.LE.1) .OR. (IVAPRX.EQ.4) .OR. (IVAPRX.GE.7))
     +   IVCVPT = 1
      IF ((IVAPRX.EQ.2) .OR. (IVAPRX.EQ.5)) IVCVPT = 2
      IF ((IVAPRX.EQ.3) .OR. (IVAPRX.EQ.6)) IVCVPT = 3
C
C     INITIALIZE THE ITERATION COUNTER
C
      IWORK(NITER) = 0
C
C     SET NL2 PRINT CONTROL PARAMETERS
C
      IWORK(CNVCOD) = 0
      IWORK(COVPRT) = 0
      IWORK(OUTLEV) = 0
      IWORK(PRUNIT) = 0
      IWORK(SOLPRT) = 0
      IWORK(STATPR) = 0
      IWORK(X0PRT) = 0
C
      RETURN
C
      END
*SETIV
      SUBROUTINE SETIV(VECTOR, N, VALUE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE SETS THE FIRST N ELEMENTS OF AN INTEGER VECTOR
C
C     WRITTEN BY  -  JOHN E. KOONTZ
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 7, 1981
C        ADAPTED FROM SETRV, WRITTEN BY LINDA L. MITCHELL
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N,VALUE
C
C  ARRAY ARGUMENTS
      INTEGER
     +   VECTOR(N)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        *
C     INTEGER N
C        NUMBER OF ELEMENTS TO SET
C     INTEGER VALUE
C        VALUE TO WHICH THE ELEMENTS ARE TO BE SET
C     INTEGER VECTOR(N)
C        VECTOR WHOSE FIRST N ELEMENTS ARE TO BE SET.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DO 10 I=1,N
         VECTOR(I) = VALUE
   10 CONTINUE
C
      RETURN
C
      END
*VCOPY
      SUBROUTINE VCOPY(P, Y, X)
C
C  ***  SET Y = X, WHERE X AND Y ARE P-VECTORS  ***
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   P
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   X(*),Y(*)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      DO 10 I = 1, P
 10      Y(I) = X(I)
      RETURN
      END
*AMFCNT
      SUBROUTINE AMFCNT(Y, N, MSPEC, NFAC, PAR, NPAR, LDSTAK,
     +   NFCST, NFCSTO, IFCSTO, NPRT, FCST, IFCST, FCSTSD, NMSUB, SAVE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE CONTROLLING SUBROUTINE FOR FORECASTING USING
C     ARIMA MODELS.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 2, 1985
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IFCST,LDSTAK,N,NFAC,NFCST,NFCSTO,NPAR,NPRT
      LOGICAL
     +   SAVE
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   FCST(*),FCSTSD(*),PAR(*),Y(*)
      INTEGER
     +   IFCSTO(*),MSPEC(4,*)
      CHARACTER
     +   NMSUB(6)*1
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR,IFLAG,MBO,MBOL,MSPECT,NFACT,NPARAR,NPARDF,NPARMA,
     +   NRESTS,PARAR,PARDF,PARMA,T,TEMP
C
C  ARRAYS IN COMMON
      DOUBLE PRECISION DSTAK(12)
C
C  LOCAL SCALARS
      INTEGER
     +   F,FSD,IFP,IS,LDSMIN,NALL0,PV
      LOGICAL
     +   PAGE,WIDE
C
C  LOCAL ARRAYS
      DOUBLE PRECISION
     +   RSTAK(12)
      INTEGER
     +   ISTAK(12)
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   STKGET,STKST
      EXTERNAL STKGET,STKST
C
C  EXTERNAL SUBROUTINES
      EXTERNAL AMFER,AMFMN,BACKOP,CPYVII,LDSCMP,STKCLR,STKSET
C
C  COMMON BLOCKS
      COMMON /CSTAK/DSTAK
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
      COMMON /MDLTSC/MSPECT,NFACT,PARDF,NPARDF,PARAR,NPARAR,PARMA,
     +   NPARMA,MBO,MBOL,T,TEMP,NRESTS,IFLAG
C
C  EQUIVALENCES
      EQUIVALENCE (DSTAK(1),ISTAK(1))
      EQUIVALENCE (DSTAK(1),RSTAK(1))
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION DSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER F
C        THE STARTING LOCATION IN THE WORK VECTOR FOR
C        THE FORECASTS.
C     DOUBLE PRECISION FCST(IFCST,NFCSTO)
C        THE STORAGE ARRAY FOR THE FORECASTS.
C     DOUBLE PRECISION FCSTSD(NFCST)
C        THE STORAGE ARRAY FOR THE STANDARD DEVIATIONS OF THE FORECASTS.
C     INTEGER FSD
C        THE STARTING LOCATION IN THE WORK VECTOR FOR
C        THE STANDARD DEVIATIONS OF THE FORECASTS.
C     INTEGER IERR
C        THE VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .GE. 1, ERRORS WERE DETECTED.
C     INTEGER IFCST
C        THE FIRST DIMENSION OF THE ARRAY FCST.
C     INTEGER IFCSTO(NFCSTO)
C        THE INDICES OF THE ORIGINS FOR THE FORECASTS.
C     INTEGER IFP
C        AN INDICATOR FOR THE PRECISION OF THE STACK ALLOCATION TYPE,
C        WHERE IFP=3 INDICATES SINGLE AND IFP=4 INDICATES DOUBLE.
C     INTEGER IS
C        A VALUE USED TO DETERMINE THE AMOUNT OF WORK SPACE NEEDED
C        BASED ON WHETHER STEP SIZES ARE INPUT OR ARE TO BE CALCULATED.
C     INTEGER ISTAK(12)
C        THE INTEGER VERSION OF THE /CSTAK/ WORK AREA.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     INTEGER MBO
C        THE MAXIMUM BACK ORDER OPERATOR.
C     INTEGER MBOL
C        THE MAXIMUM BACK ORDER ON THE LEFT
C     INTEGER MSPEC(4,NFAC)
C        THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT
C     INTEGER MSPECT
C        THE STARTING LOCATION IN THE WORK SPACE FOR
C        THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NALL0
C        NUMBER OF STACK ALLOCATIONS OUTSTANDING.
C     INTEGER NFAC
C        THE NUMBER OF FACTORS IN THE MODEL
C     INTEGER NFACT
C        THE NUMBER OF FACTORS IN THE MODEL
C     INTEGER NFCST
C        THE NUMBER OF FORECASTS.
C     INTEGER NFCSTO
C        THE NUMBER OF THE ORIGINS.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE ROUTINE CALLING THE ERROR CHECKING ROUTINE
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     INTEGER NPARAR
C        THE NUMBER OF AUTOREGRESSIVE PARAMETERS
C     INTEGER NPARDF
C        THE ORDER OF THE EXPANDED DIFFERENCE FILTER.
C     INTEGER NPARMA
C        THE LENGTH OF THE VECTOR PARMA
C     INTEGER NPRT
C        THE PARAMETER USED TO INDICATE HOW MUCH PRINTED OUTPUT IS
C        TO BE PROVIDED.
C     LOGICAL PAGE
C        THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF
C        THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION PAR(NPAR)
C        THE CURRENT ESTIMATES OF THE PARAMETERS.
C     INTEGER PARAR
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        THE AUTOREGRESSIVE PARAMETERS
C     INTEGER PARDF
C        THE STARTING LOCATION IN THE WORK SPACE FOR
C        THE VECTOR CONTAINING THE DIFFERENCE FILTER PARAMETERS
C     INTEGER PARMA
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        THE MOVING AVERAGE PARAMETERS
C     INTEGER PV
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        THE PREDICTED VALUES
C     INTEGER NRESTS
C        THE MAXIMUM NUMBER OF RESIDUALS TO BE COMPUTED.
C     DOUBLE PRECISION RSTAK(12)
C        THE DOUBLE PRECISION VERSION OF THE /CSTAK/ WORK AREA.
C     LOGICAL SAVE
C        THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN
C        THE RESIDUALS AND PARAMETERS ARE TO BE SAVED (TRUE) OR NOT
C        (FALSE).
C     INTEGER T
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        A TEMPORARY WORK VECTOR.
C     INTEGER TEMP
C        THE STARTING LOCATION IN THE WORK ARRAY FOR
C        A TEMPORARY WORK VECTOR
C     LOGICAL WIDE
C        THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD
C        BE FULL WIDTH (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION Y(N)
C        THE DEPENDENT VARIABLE.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     SET VARIOUS PROGRAM VALUES
C
      WIDE = .TRUE.
      PAGE = .FALSE.
C
C     COMPUTE BACK OPERATORS
C
      CALL BACKOP(MSPEC, NFAC, NPARDF, MBOL, MBO, NPARMA, NPARAR)
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      IS = 0
C
      CALL LDSCMP(8, 0, 4*NFAC,
     +   0, 0, 0, 'D', 5*MBO + 2*NFCST + N + MBO + 101, LDSMIN)
C
      CALL AMFER(NMSUB, N, NPAR, LDSTAK, LDSMIN, SAVE, MSPEC, NFAC,
     +   IFCST, NFCST)
C
      IF (IERR.EQ.0) THEN
C
        CALL STKSET(LDSTAK, 4)
C
C       SUBDIVIDE WORKSPACE FOR STEP SIZES
C
        NALL0 = STKST(1)
C
        IFP = 4
C
        PARDF = STKGET(MBO, IFP)
        PARAR = STKGET(MBO, IFP)
        PARMA = STKGET(MBO, IFP)
        T = STKGET(2*MBO, IFP)
C
        TEMP = T + MBO
C
        NFACT = NFAC
        MSPECT = STKGET(4*NFAC, 2)
        F = STKGET(NFCST, IFP)
        FSD = STKGET(NFCST, IFP)
C
C       SET UP FOR MODEL
C
        NRESTS = MBO + 101 + N
        PV = STKGET(NRESTS, IFP)
C
        CALL CPYVII(NFAC, MSPEC(1,1), 4, ISTAK(MSPECT), 1)
        CALL CPYVII(NFAC, MSPEC(2,1), 4, ISTAK(MSPECT+NFAC), 1)
        CALL CPYVII(NFAC, MSPEC(3,1), 4, ISTAK(MSPECT+2*NFAC), 1)
        CALL CPYVII(NFAC, MSPEC(4,1), 4, ISTAK(MSPECT+3*NFAC), 1)
C
C       CALL MAIN ROUTINE FOR COMPUTING AND PRINTING FORECASTS
C
        CALL AMFMN (PAR, RSTAK(PV), Y, NPAR, N, NFAC, ISTAK(MSPECT),
     +    RSTAK(PARDF), NPARDF, RSTAK(T), RSTAK(TEMP), RSTAK(PARAR),
     +    RSTAK(PARMA), MBO, MBOL, N-NRESTS+1, N, NPRT, SAVE,
     +    NFCST, NFCSTO, IFCSTO, FCST, IFCST, FCSTSD, RSTAK(F),
     +    RSTAK(FSD), NPARAR, NPARMA)
      END IF
C
      CALL STKCLR(NALL0)
C
      RETURN
C
      END
*DUPDAT
      SUBROUTINE DUPDAT(D, IV, J, N, NN, P, V)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C  ***  UPDATE SCALE VECTOR D FOR NL2ITR (NL2SOL VERSION 2.2)  ***
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N,NN,P
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   D(P),J(NN,P),V(1)
      INTEGER
     +   IV(1)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   SII,T,VDFAC,ZERO
      INTEGER
     +   D0,DFAC,DTYPE,I,JTOL0,JTOLI,NITER,S,S1
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   V2NORM
      EXTERNAL V2NORM
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MAX,SQRT
C
C  ***  PARAMETER DECLARATIONS  ***
C
C     INTEGER IV(1), N, NN, P
C     DOUBLE PRECISION D(P), J(NN,P), V(1)
C     DIMENSION IV(*), V(*)
C
C  ***  LOCAL VARIABLES  ***
C
C     INTEGER D0, I, JTOLI, S1
C     DOUBLE PRECISION SII, T, VDFAC
C
C     ***  CONSTANTS  ***
C     DOUBLE PRECISION ZERO
C
C/
C  ***  EXTERNAL FUNCTION  ***
C
C     EXTERNAL V2NORM
C     DOUBLE PRECISION V2NORM
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
C     INTEGER DFAC, DTYPE, JTOL0, NITER, S
      DATA DFAC/41/, DTYPE/16/, JTOL0/86/, NITER/31/, S/53/
C
      DATA ZERO/0.0D0/
C
C-----------------------------------------------------------------------
C
      I = IV(DTYPE)
      IF (I .EQ. 1) GO TO 20
         IF (IV(NITER) .GT. 0) GO TO 999
C
 20   VDFAC = V(DFAC)
      D0 = JTOL0 + P
      S1 = IV(S) - 1
      DO 30 I = 1, P
         S1 = S1 + I
         SII = V(S1)
         T = V2NORM(N, J(1,I))
         IF (SII .GT. ZERO) T = SQRT(T*T + SII)
         JTOLI = JTOL0 + I
         D0 = D0 + 1
         IF (T .LT. V(JTOLI)) T = MAX(V(D0), V(JTOLI))
         D(I) = MAX(VDFAC*D(I), T)
 30      CONTINUE
C
 999  RETURN
C  ***  LAST CARD OF DUPDAT FOLLOWS  ***
      END
*GMEAN
      SUBROUTINE GMEAN(Y, N, YMEAN)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE COMPUTES THE GEOMETRIC MEAN OF A SERIES, ASSUMING
C     ALL VALUES IN Y ARE NON-ZERO.
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  APRIL 2, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   YMEAN
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   Y(N)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C  INTRINSIC FUNCTIONS
      INTRINSIC EXP,LOG
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        AN INDEX VARIABLE
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS IN THE SERIES
C     DOUBLE PRECISION Y(N)
C        THE VECTOR CONTAINING THE OBSERVED SERIES
C     DOUBLE PRECISION YMEAN
C        THE GEOMETRIC MEAN OF THE OBSERVED SERIES
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      YMEAN = 0.0D0
      DO 10 I = 1, N
         YMEAN = YMEAN + LOG(Y(I))
   10 CONTINUE
      YMEAN = EXP(YMEAN/N)
      RETURN
      END
*LSTVCF
      SUBROUTINE LSTVCF(N, VEC, LMASK, MASK)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE PRINTS THE FIRST N ELEMENTS OF THE VECTOR
C     VEC.  THE I TH ELEMENT OF VEC IS IDENTIFIED WITH THE INDEX
C     OF THE I TH ZERO ELEMENT OF MASK.
C
C     WRITTEN BY  -  JOHN E. KOONTZ
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  OCTOBER 3, 1983
C                       PATTERNED AFTER LSTVEC OF JUNE 7, 1982.
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   LMASK,N
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   VEC(N)
      INTEGER
     +   MASK(LMASK)
C
C  LOCAL SCALARS
      INTEGER
     +   I,IMASK,IMAX,IMIN,INDEX,J,JMAX,NPERL
C
C  LOCAL ARRAYS
      INTEGER
     +   INDW(10)
C
C  EXTERNAL FUNCTIONS
      INTEGER
     +   INPERL
      EXTERNAL INPERL
C
C  EXTERNAL SUBROUTINES
CCCCC EXTERNAL IPRINT
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MIN
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        AN INDEX VARIABLE
C     INTEGER IMASK
C        INDEX IN MASK.
C     INTEGER IMAX, IMIN
C        THE LARGEST AND SMALLEST INDICES IN VEC OF THE ELEMENTS TO BE
C        PRINTED.
C     INTEGER INDEX
C        THE INDEX OF THE VALUE TO BE PRINTED.
C     INTEGER INDW(10)
C        A WORK VECTOR FOR THE INDICES TO BE PRINTED FOR VEC.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER JMAX
C        INDEX IN INDW OF THE LARGEST INDEX TO BE PRINTED FOR VEC.
C     INTEGER LMASK
C        THE LENGTH OF MASK.  LMASK .GE. N.
C     INTEGER MASK(LMASK)
C        MASK VECTOR FOR VEC.  THE INDEX OF THE ITH ELEMENT OF MASK
C        EQUAL TO ZERO IS THE LABEL IN THE OUTPUT OF THE ITH ELEMENT
C        OF VEC.
C     INTEGER N
C        THE NUMBER OF VALUES TO BE PRINTED IN THE INPUT VECTOR.
C     INTEGER NPERL
C        THE NUMBER OF VALUES TO BE PRINTED PER LINE.
C     DOUBLE PRECISION VEC(N)
C        THE VECTOR OF VALUES TO BE PRINTED.
C
C
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC CALL IPRINT(IPRT)
C
      NPERL = INPERL(0)
C        NOTE - INPERL(0) IS ASSUMED TO BE AT MOST 10.0D0  IF GREATER,
C               INCREASE THE DIMENSION OF INDW.
C
C
      IMASK = 0
      DO 30 I = 1, N, NPERL
         IMIN = I
         IMAX = MIN(I+NPERL-1, N)
         JMAX = MIN(N - IMIN + 1, NPERL)
         DO 20 J = 1, JMAX
   10       IF (IMASK .GE. LMASK) GO TO 40
            IMASK = IMASK + 1
            IF (MASK(IMASK) .NE. 0) GO TO 10
            INDW(J) = IMASK
   20    CONTINUE
         WRITE(IOUNI3, 1010) (INDW(INDEX), INDEX = 1, JMAX)
CCCCC    CALL DPWRST('XXX','BUG ')
         WRITE(IOUNI3, 1020) (VEC(INDEX), INDEX = IMIN, IMAX)
CCCCC    CALL DPWRST('XXX','BUG ')
         WRITE(IOUNI3,999)
CCCCC    CALL DPWRST('XXX','BUG ')
   30 CONTINUE
C
      RETURN
C
   40 CONTINUE
      WRITE(IOUNI3,999)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE (IOUNI3, 1030)
CCCCC CALL DPWRST('XXX','BUG ')
      RETURN
C
C     FORMAT STATEMENTS
C
  999 FORMAT(1X)
 1010 FORMAT(10X, 'INDEX', I5, 6I15)
 1020 FORMAT(10X, 'VALUE', 7(1X, G14.7))
 1030 FORMAT (' ERROR IN STARPAC.  LSTVEC TRIED TO ACCESS MORE',
     +   ' ELEMENTS THAN EXIST IN MASK.')
C
      END
*NLITRP
      SUBROUTINE NLITRP(NLHDR, HEAD, PAGE, WIDE, IPTOUT, NPAR, NNZW,
     +   IWORK, IIWORK, RWORK, IRWORK, IFIXD, PARE, NPARE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE PRINTS THE ITERATION REPORTS FOR THE
C     NONLINEAR LEAST SQUARES REGRESSION SUBROUTINES.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  APRIL 2, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IIWORK,IPTOUT,IRWORK,NNZW,NPAR,NPARE
      LOGICAL
     +   HEAD,PAGE,WIDE
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   PARE(NPAR),RWORK(IRWORK)
      INTEGER
     +   IFIXD(NPAR),IWORK(IIWORK)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL NLHDR
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   RSD,RSS,RSSC,RSSPC
      INTEGER
     +   DST0,F,F0,FDIF,ICASE,ISUBHD,MXITER,NFCALL,NITER,
     +   NREDUC,PREDUC,RELDX,STPPAR
      CHARACTER
     +   LETTRN*1,LETTRY*1
C
C  LOCAL ARRAYS
      CHARACTER
     +   ISCHKD(2)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL LSTVCF
C
C  INTRINSIC FUNCTIONS
      INTRINSIC MOD,DBLE,SQRT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER DST0
C        THE LOCATION IN RWORK OF THE VALUE OF THE 2 NORM OF D TIMES
C        THE  NEWTON STEP.
C     INTEGER F
C        THE LOCATION IN RWORK OF THE VALUE OF HALF THE RESIDUAL
C        SUM OF SQUARES AT THE CURRENT PARAMETER VALUES.
C     INTEGER FDIF
C        THE LOCATION IN RWORK OF THE DIFFERENCE BETWEEN THE
C        RESIDUAL SUM OF SQUARES AT THE BEGINNING AND END OF THE
C        CURRENT ITERATION.
C     INTEGER F0
C        THE LOCATION IN RWORK OF THE VALUE OF HALF THE RESIDUAL
C        VARIANCE AT THE BEGINNING OF THE CURRENT ITERATION.
C     LOGICAL HEAD
C        THE VARIABLE USED TO INDICATE WHETHER A HEADING IS TO BE
C        PRINTED DURING A GIVEN CALL TO THE ITERATION REPORT (TRUE)
C        OR NOT (FALSE).
C     INTEGER ICASE
C        AN INDICATER VARIABLE USED TO DESIGNATE THE MESSAGE TO BE
C        PRINTED.
C     INTEGER IFIXD(NPAR)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE
C        PARAMETERS ARE TO BE OPTIMIZED OR ARE TO BE HELD FIXED.
C        IF IFIXED(I).NE.0, THEN PAR(I) WILL BE HELD FIXED.
C        IF IFIXED(I).EQ.0, THEN PAR(I) WILL BE OPTIMIZED.
C     INTEGER IIWORK
C        THE DIMENSION OF THE INTEGER WORK VECTOR IWORK.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IRWORK
C        THE DIMENSION OF THE DOUBLE PRECISION WORK VECTOR RWORK.
C     CHARACTER*1 ISCHKD(2)
C        THE INDICATOR USED TO DESIGNATE WHETHER THE
C        TEST VALUE WAS CHECKED FOR CONVERGENCE (Y) OR NOT (N).
C     INTEGER ISUBHD
C        AN INTEGER VALUE SPECIFYING SUBHEADINGS TO BE PRINTED.
C     INTEGER IWORK(IIWORK)
C        THE INTEGER WORK SPACE VECTOR USED BY THE NL2 SUBROUTINES.
C     CHARACTER*1 LETTRN, LETTRY
C        THE LETTERS N AND Y, RESPECTIVELY.
C     INTEGER MXITER
C        THE LOCATION IN IWORK OF THE VARIABLE DESIGNATING THE
C        MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C     INTEGER NFCALL
C        THE LOCATION IN IWORK OF THE NUMBER OF FUNCTION EVALUATIONS.
C     INTEGER NITER
C        THE LOCATION IN IWORK OF THE NUMBER OF THE CURRENT ITERATION.
C     EXTERNAL NLHDR
C        THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING.
C     INTEGER NPAR
C        THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL.
C     INTEGER NPARE
C        THE NUMBER OF UNKNOWN PARAMETERS TO BE OPTIMIZED.
C     INTEGER NNZW
C        THE NUMBER OF NON ZERO WEIGHTS.
C     INTEGER NREDUC
C        THE LOCATION IN RWORK OF THE VALUE USED TO CHECK IF THE
C        HESSIAN APPROXIMATION IS POSITIVE DEFINITE.  IF
C        IF RWORK(NREDUC) .EQ. 0, THE HESSIAN IS SINGULAR, OTHERWISE
C        IT IS NOT.
C     LOGICAL PAGE
C        THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF
C        THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE).
C     DOUBLE PRECISION PARE(NPAR)
C        THE CURRENT ESTIMATES OF THE UNKNOWN PARAMETERS, BUT ONLY
C        THOSE TO BE OPTIMIZED (NOT THOSE WHOSE VALUES ARE FIXED).
C     INTEGER PREDUC
C        THE LOCATION IN RWORK OF THE PREDICTED FUNCTION REDUCTION
C        FOR THE CURRENT STEP.
C     INTEGER RELDX
C        THE LOCATION IN RWORK OF THE SCALED RELATIVE CHANGE IN
C        THE PARAMETER VALUES CAUSED BY THE CURRENT ITERATION.
C     DOUBLE PRECISION RSD
C        THE RESIDUAL STANDARD DEVIATION.
C     DOUBLE PRECISION RSS
C        THE RESIDUAL SUM OF SQUARES.
C     DOUBLE PRECISION RSSC
C        THE CHANGE IN THE RESIDUAL SUM OF SQUARES CAUSED BY THIS
C        ITERATION.
C     DOUBLE PRECISION RSSPC
C        THE PREDICTED CHANGE IN THE RESIDUAL SUM OF SQUARES AT THIS
C        ITERATION.
C     DOUBLE PRECISION RWORK(IRWORK)
C        THE DOUBLE PRECISION WORK VECTOR USED BY THE NL2 SUBROUTINES.
C     INTEGER STPPAR
C        THE LOCATION IN RWORK OF THE MARQUARDT LAMBDA PARAMETER.
C     LOGICAL WIDE
C        THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD
C        BE FULL WIDTH (TRUE) OR NOT (FALSE).
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      DATA LETTRN /'N'/, LETTRY /'Y'/
C
C     IWORK SUBSCRIPT VALUES
C
      DATA MXITER /18/, NFCALL /6/, NITER /31/
C
C     RWORK SUBSCRIPT VALUES
C
      DATA DST0 /3/, F /10/, FDIF /11/, F0 /13/, NREDUC /6/, PREDUC
     +   /7/, RELDX /17/, STPPAR /5/
C
CCCCC CALL IPRINT(IPRT)
C
C
      IF (IWORK(1).EQ.10) GO TO 90
      IF ((IPTOUT.EQ.1) .AND. (IWORK(NITER).NE.1) .AND.
     +   (IWORK(NITER).NE.IWORK(MXITER)) .AND. (IWORK(1).LE.2)) RETURN
C
      ISUBHD = 0
      IF (HEAD) CALL NLHDR(PAGE, WIDE, ISUBHD)
      HEAD = .FALSE.
      IF (MOD(IWORK(NITER),4).EQ.0) HEAD = .TRUE.
C
      WRITE(IOUNI3,999)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE(IOUNI3,999)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE (IOUNI3,1000) IWORK(NITER)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE (IOUNI3,1001)
CCCCC CALL DPWRST('XXX','BUG ')
 1000 FORMAT (' ITERATION NUMBER', I5)
 1001 FORMAT (1X, 22('-'))
C
C     COMPUTE STATISTICS TO BE PRINTED
C
      RSS = 2.0D0*RWORK(F)
      RSD = SQRT(RSS)
      IF (NNZW-NPARE.GE.1) RSD = RSD/SQRT(DBLE(NNZW-NPARE))
C
      RSSC = 0.0D0
      IF (RWORK(F0).GT.0.0D0) RSSC = RWORK(FDIF)/RWORK(F0)
C
      RSSPC = 0.0D0
      IF (RWORK(F0).GT.0.0D0) RSSPC = RWORK(NREDUC)/RWORK(F0)
C
C     REFERENCE NL2 SUBROUTINE ASSESS, STATEMENT LABEL 300 TO 320
C
      ISCHKD(1) = LETTRN
      ISCHKD(2) = LETTRN
      IF (RWORK(FDIF).GT.2.0D0*RWORK(PREDUC)) GO TO 10
      IF (RWORK(DST0).LT.0.0D0) GO TO 10
      IF (RWORK(NREDUC).GE.0.0D0) ISCHKD(1) = LETTRY
      IF (RWORK(STPPAR).EQ.0.0D0) ISCHKD(2) = LETTRY
   10 CONTINUE
C
      WRITE (IOUNI3,1010)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE (IOUNI3,1011)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE (IOUNI3,1012)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE (IOUNI3,1013) IWORK(NFCALL), RSD, RSS, RSSC, RSSPC,
     +   ISCHKD(1), RWORK(RELDX), ISCHKD(2)
CCCCC CALL DPWRST('XXX','BUG ')
 1010 FORMAT (
     +   5X, 'MODEL', 53X, 'FORECASTED')
 1011 FORMAT (
     +   5X, 'CALLS', 9X, 'RSD',
     +   13X, 'RSS', 8X, 'REL CHNG RSS', 4X, 'REL CHNG RSS', 4X,
     +   'REL CHNG PAR')
 1012 FORMAT (
     +   62X, 'VALUE', 3X, 'CHKD', 4X, 'VALUE', 3X,
     +   'CHKD')
 1013 FORMAT (
     +   3X, I7, 3(2X, G14.4), 2(G12.4, 3X, A1))
      IF (NPARE.LT.NPAR) THEN
        WRITE(IOUNI3,999)
CCCCC   CALL DPWRST('XXX','BUG ')
        WRITE (IOUNI3,1020)
CCCCC   CALL DPWRST('XXX','BUG ')
      ENDIF
 1020 FORMAT (5X,' CURRENT PARAMETER VALUES', ' (ONLY UNFIXED PARA',
     +   'METERS ARE LISTED)')
      IF (NPARE.GE.NPAR) THEN
        WRITE(IOUNI3,999)
CCCCC   CALL DPWRST('XXX','BUG ')
        WRITE (IOUNI3,1150)
CCCCC   CALL DPWRST('XXX','BUG ')
      ENDIF
 1150 FORMAT (5X, ' CURRENT PARAMETER VALUES')
      CALL LSTVCF(NPARE, PARE, NPAR, IFIXD)
C
      IF (IWORK(1).LE.2) RETURN
C
C     PRINT FINAL ITERATION MESSAGE
C
      ICASE = IWORK(1) - 2
      GO TO (20, 30, 40, 50, 60, 70, 80, 90, 100, 140, 110, 120, 130),
     +   ICASE
C
C     ***** PARAMETER CONVERGENCE *****
C
   20 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1030)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     ***** RESIDUAL SUM OF SQUARES CONVERGENCE *****
C
   30 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1040)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     ***** PARAMETER AND RESIDUAL SUM OF SQUARES CONVERGENCE ****
C
   40 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1050)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     ***** RESIDUAL SUM OF SQUARES IS EXACTLY ZERO *****
C
   50 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1060)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     ***** SINGULAR CONVERGENCE *****
C
   60 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1070)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     ***** FALSE CONVERGENCE *****
C
   70 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1080)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     ***** LIMIT ON NUM. OF CALLS TO THE MODEL SUBROUTINE REACHED *****
C
   80 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1090)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     ***** ITERATION LIMIT REACHED *****
C
   90 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1100)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     ***** STOPX *****
C
  100 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1110)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     ***** INITIAL RESIDUAL SUM OF SQUARES OVERFLOWS *****
C
  110 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1120)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     ***** BAD PARAMETERS TO ASSESS *****
C
  120 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1130)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
C     ***** J COULD NOT BE COMPUTED *****
C
  130 CONTINUE
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1140)
      CALL DPWRST('XXX','BUG ')
      RETURN
C
  140 RETURN
C
C      FORMAT STATEMENTS
C
  999 FORMAT(1X)
 1030 FORMAT (' ##### PARAMETER CONVERGENCE #####')
 1040 FORMAT (' ##### RESIDUAL SUM OF SQUARES CONVERGENCE #####')
 1050 FORMAT (' ##### PARAMETER AND RESIDUAL SUM OF SQUARES',
     +   ' CONVERGENCE #####')
 1060 FORMAT (' ##### THE RESIDUAL SUM OF SQUARES IS EXACTLY ZERO',
     +   ' #####')
 1070 FORMAT (' ##### SINGULAR CONVERGENCE #####')
 1080 FORMAT (' ##### FALSE CONVERGENCE #####')
 1090 FORMAT (' ##### LIMIT ON NUMBER OF CALLS TO THE MODEL',
     +   ' SUBROUTINE REACHED #####')
 1100 FORMAT (' ##### ITERATION LIMIT REACHED #####')
 1110 FORMAT (' ##### STOPX #####')
 1120 FORMAT (' ##### INITIAL RESIDUAL SUM OF SQUARES OVERFLOWS ####',
     +   '#')
 1130 FORMAT (' ##### BAD PARAMETERS TO ASSESS #####')
 1140 FORMAT (' ##### DERIVATIVE MATRIX COULD NOT BE COMPUTED #####')
      END
*SETROW
      SUBROUTINE SETROW (NROW, XM, N, M, IXM, NROWU)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE SELECTS THE ROW USED BY THE DERIVATIVE CHECKING
C     PROCEDURE.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  OCTOBER 3, 1983
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IXM,M,N,NROW,NROWU
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   XM(IXM,M)
C
C  LOCAL SCALARS
      INTEGER
     +   I,J
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IXM
C        THE FIRST DIMENSION OF THE INDEPENDENT VARIABLE ARRAY XM.
C     INTEGER J
C        AN INDEX VARIABLE.
C     INTEGER M
C        THE NUMBER OF INDEPENDENT VARIABLES.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS OF DATA.
C     INTEGER NROW, NROWU
C        THE USER-SUPPLIED NUMBER OF THE ROW OF THE INDEPENDENT
C        VARIABLE ARRAY AT WHICH THE DERIVATIVE IS TO BE CHECKED,
C        AND THE NUMBER OF THE ROW ACTUALLY USED.
C     DOUBLE PRECISION XM(IXM,M)
C        THE INDEPENDENT VARIABLE MATRIX.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      NROWU = NROW
C
      IF ((NROWU.GE.1) .AND. (NROWU.LE.N)) RETURN
C
C     SELECT FIRST ROW OF INDEPENDENT VARIABLES WHICH CONTAINS NO ZEROS
C     IF THERE IS ONE, OTHERWISE FIRST ROW IS USED.
C
      DO 20 I = 1, N
         DO 10 J = 1, M
            IF (XM(I,J) .EQ. 0.0D0) GO TO 20
   10    CONTINUE
         NROWU = I
         RETURN
   20 CONTINUE
C
      NROWU = 1
C
      RETURN
      END
*VCVOTF
      SUBROUTINE VCVOTF(NPAR, VCV, LVCV, EST, LMASK, MASK, IVCVPT)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE PRINTS THE VARIANCE COVARIANCE MATRIX
C     STORED ROW WISE WHEN IT IS TO BE LABELLED ON THE BASIS OF A MASK.
C     IF EST IS TRUE, THE COVARIANCES ARE LISTED ABOVE THE
C     DIAGONAL, THE VARIANCES ON THE DIAGONAL, AND THE CORRELATION
C     COEFFICIENTS BELOW THE DIAGONAL.
C     IF EST IS FALSE, THE STANDARD DEVIATIONS ARE LISTED ON THE
C     DIAGONAL, AND THE CORRELATION COEFFICIENTS ARE BELOW THE
C     DIAGONAL.
C
C     WRITTEN BY  -  JOHN E. KOONTZ
C          STATISTICAL ENGINEERING DIVISION
C          NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  OCTOBER 3, 1983
C        BASED ON VCVOUT VERSION OF DECEMBER 29, 1982
C        WRITTEN BY JANET R. DONALDSON
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IVCVPT,LMASK,LVCV,NPAR
      LOGICAL
     +   EST
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   VCV(LVCV)
      INTEGER
     +   MASK(LMASK)
C
C  LOCAL SCALARS
      INTEGER
     +   CODE,I,II,MODE
C
C  EXTERNAL SUBROUTINES
      EXTERNAL MATPRF
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER CODE
C        IF 1 -SINGLE PRINTED, X ONLY (Y IS DUMMY ARG)
C           2 -DOUBLE PRINTED LINE, BOTH X AND Y
C     LOGICAL EST
C        AN INDICATOR USED TO DESIGNATE WHETHER THE VCV TO BE PRINTED
C        IS OF THE ESTIMATED PARAMETERS (TRUE) OR NOT (FALSE).
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER II
C        THE INDEX OF THE (I,I)TH ELEMENT OF THE VCV MATRIX
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER IVCVPT
C        AN INDICATOR VALUE USED TO DESIGNATE WHICH FORM OF THE
C        VARIANCE COVARIANCE MATRIX (VCV) IS BEING PRINTED, WHERE
C        IVCVPT = 1 INDICATES THE VCV WAS COMPUTED AS
C                   INVERSE(TRANSPOSE(JACOBIAN)*JACOBIAN)
C        IVCVPT = 2 INDICATES THE VCV WAS COMPUTED AS
C                   INVERSE(HESSIAN)
C        IVCVPT = 3 INDICATES THE VCV WAS COMPUTED AS
C                   INVERSE(HESSIAN)*TRANSPOSE(JACOBIAN)*JACOBIAN
C                       *INVERSE(HESSIAN)
C     INTEGER LMASK
C        THE LENGTH OF MASK.
C     INTEGER LVCV
C        THE LENGTH OF ARRAY VCV.
C     INTEGER MASK(LMASK)
C        MASK VECTOR FOR VCV.  THE INDEX OF THE ITH ELEMENT OF
C        MASK EQUAL TO ZERO IS THE LABEL IN THE OUTPUT OF VCV
C        OF THE ITH ROW AND ITH COLUMN.
C     INTEGER MODE
C        IF 0, LOWER TRIANGULAR PART PRINTED
C           1, LOWER TRIANGULAR PART IS PRINTED WITH
C              SQUARE ROOTS OF THE DIAGONAL
C           2, LOWER TRIANGLE PRINTED AS CORRELATION MATRIX
C              WITH SQUARE ROOTS ON THE DIAGONAL
C           3, FULL MATRIX PRINTED
C           4, FULL MATRIX PRINTED WITH CORRELATION MATRIX
C              PRINTED BELOW THE DIAGONAL
C     INTEGER NPAR
C        THE NUMBER OF UNKNOWN PARAMETERS IN THE MODEL.
C     DOUBLE PRECISION VCV(LVCV)
C        THE VARIANCE COVARIANCE MATRIX.
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C     COMMENCE BODY OF ROUTINE
C
CCCCC CALL IPRINT(IPRT)
C
      CODE = 1
C
C     DETERMINE WHETHER TO ISSUE NEGATIVE VARIANCE WARNING
C
      MODE = 0
      DO 30 I=1,NPAR
         II = I*(I-1)/2 + I
         IF (VCV(II).GT.0.0D0) GO TO 30
         IF (EST) GO TO 10
         WRITE(IOUNI4,999)
CCCCC    CALL DPWRST('XXX','BUG ')
         WRITE(IOUNI4,999)
CCCCC    CALL DPWRST('XXX','BUG ')
         WRITE(IOUNI4,999)
CCCCC    CALL DPWRST('XXX','BUG ')
         WRITE (IOUNI4,1000)
CCCCC    CALL DPWRST('XXX','BUG ')
         GO TO 20
C
   10    CONTINUE
         WRITE(IOUNI4,999)
CCCCC    CALL DPWRST('XXX','BUG ')
         WRITE (IOUNI4,1050)
CCCCC    CALL DPWRST('XXX','BUG ')
         WRITE (IOUNI4,1051)
CCCCC    CALL DPWRST('XXX','BUG ')
         IF (IVCVPT.EQ.1) THEN
           WRITE(IOUNI4,999)
CCCCC      CALL DPWRST('XXX','BUG ')
           WRITE (IOUNI4,1060)
CCCCC      CALL DPWRST('XXX','BUG ')
         ENDIF
         IF (IVCVPT.EQ.2) THEN
           WRITE(IOUNI4,999)
CCCCC      CALL DPWRST('XXX','BUG ')
           WRITE (IOUNI4,1070)
CCCCC      CALL DPWRST('XXX','BUG ')
         ENDIF
         IF (IVCVPT.EQ.3) THEN
           WRITE(IOUNI4,999)
CCCCC      CALL DPWRST('XXX','BUG ')
           WRITE (IOUNI4,1080)
CCCCC      CALL DPWRST('XXX','BUG ')
           WRITE (IOUNI4,1081)
CCCCC      CALL DPWRST('XXX','BUG ')
         ENDIF
   20    CONTINUE
         WRITE(IOUNI4,999)
CCCCC    CALL DPWRST('XXX','BUG ')
         WRITE (IOUNI4,1010)
CCCCC    CALL DPWRST('XXX','BUG ')
         WRITE (IOUNI4,1011)
CCCCC    CALL DPWRST('XXX','BUG ')
         GO TO 50
   30 CONTINUE
C
      IF (EST) GO TO 40
C
C     PRINT HEADING FOR CORRELATION ROUTINES
C
      WRITE(IOUNI4,999)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE (IOUNI4,1040)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE(IOUNI4,999)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE (IOUNI4,1030)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE (IOUNI4,1031)
CCCCC CALL DPWRST('XXX','BUG ')
      MODE = 2
      GO TO 50
C
   40 CONTINUE
C
C     PRINT HEADING FOR ESTIMATION ROUTINES
C
      WRITE(IOUNI4,999)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE(IOUNI4,999)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE(IOUNI4,999)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE (IOUNI4,1050)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE (IOUNI4,1051)
CCCCC CALL DPWRST('XXX','BUG ')
      IF (IVCVPT.EQ.1) THEN
        WRITE(IOUNI4,999)
CCCCC   CALL DPWRST('XXX','BUG ')
        WRITE (IOUNI4,1060)
CCCCC   CALL DPWRST('XXX','BUG ')
      ENDIF
      IF (IVCVPT.EQ.2) THEN
        WRITE(IOUNI4,999)
CCCCC   CALL DPWRST('XXX','BUG ')
        WRITE (IOUNI4,1070)
CCCCC   CALL DPWRST('XXX','BUG ')
      ENDIF
      IF (IVCVPT.EQ.3) THEN
        WRITE(IOUNI4,999)
CCCCC   CALL DPWRST('XXX','BUG ')
        WRITE (IOUNI4,1080)
CCCCC   CALL DPWRST('XXX','BUG ')
        WRITE (IOUNI4,1081)
CCCCC   CALL DPWRST('XXX','BUG ')
      ENDIF
      WRITE(IOUNI4,999)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE (IOUNI4,1020)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE (IOUNI4,1021)
CCCCC CALL DPWRST('XXX','BUG ')
      WRITE (IOUNI4,1022)
CCCCC CALL DPWRST('XXX','BUG ')
      MODE = 4
C
   50 CALL MATPRF(VCV, VCV, NPAR, MODE, CODE, LVCV, MASK, LMASK)
C
      RETURN
C
C     FORMAT STATEMENTS
C
  999 FORMAT(1X)
 1000 FORMAT (' COVARIANCE MATRIX')
 1010 FORMAT ('     NONPOSITIVE VARIANCES ENCOUNTERED.')
 1011 FORMAT(
     +   '     CORRELATION COEFFICIENTS CANNOT BE COMPUTED.')
 1020 FORMAT (
     +   4X, '- COVARIANCES ARE ABOVE THE DIAGONAL')
 1021 FORMAT (
     +   4X, '- VARIANCES ARE ON THE DIAGONAL')
 1022 FORMAT (
     +   4X, '- CORRELATION COEFFICIENTS ARE BELOW THE DIAGONAL')
 1030 FORMAT (
     +   4X, '- STANDARD DEVIATIONS ARE ON THE DIAGONAL')
 1031 FORMAT (
     +   4X, '- CORRELATION COEFFICIENTS ARE BELOW THE DIAGONAL')
 1040 FORMAT (' CORRELATION MATRIX')
 1050 FORMAT (
     +   ' VARIANCE-COVARIANCE AND CORRELATION MATRICES',
     +   ' OF THE ESTIMATED (UNFIXED) PARAMETERS')
 1051 FORMAT (
     +   1X, 82('-'))
 1060 FORMAT (
     +   4X, '- APPROXIMATION BASED ON ASSUMPTION THAT RESIDUALS ARE',
     +   ' SMALL')
 1070 FORMAT (
     +   4X, '- APPROXIMATION BASED ON ASYMPTOTIC MAXIMUM LIKELIH',
     +   'OOD THEORY')
 1080 FORMAT (
     +   4X,
     +   '- APPROXIMATION BASED ON ASSUMPTION THAT CONDITIONS',
     +   ' NECESSARY')
 1081 FORMAT (
     +   5X, ' FOR ASYMPTOTIC MAXIMUM LIKELIHOOD THEORY',
     +   ' MIGHT BE VIOLATED')
      END
*AMFER
      SUBROUTINE AMFER(NMSUB, N, NPAR, LDSTAK, LDSMIN,
     +  SAVE, MSPEC, NFAC, IFCST, NFCST)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS IS THE ERROR CHECKING ROUTINE FOR NONLINEAR LEAST SQUARES
C     ESTIMATION ROUTINES.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 2, 1985
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IFCST,LDSMIN,LDSTAK,N,NFAC,NFCST,NPAR
      LOGICAL
     +   SAVE
C
C  ARRAY ARGUMENTS
      INTEGER
     +   MSPEC(4,*)
      CHARACTER
     +   NMSUB(6)*1
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      INTEGER
     +   I,NP,NV
      LOGICAL
     +   HEAD
C
C  LOCAL ARRAYS
      LOGICAL
     +   ERROR(20)
      CHARACTER
     +   LIFCST(8)*1,LLDS(8)*1,LMSPEC(8)*1,LN(8)*1,LNFAC(8)*1,
     +   LNFCST(8)*1,LNPAR(8)*1,LONE(8)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EIAGE,EISEQ,EISGE
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERROR(20)
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     LOGICAL HEAD
C        THE VARIABLE USED TO INDICATE WHETHER A HEADING IS TO BE
C        PRINTED DURING A GIVEN CALL TO THE ITERATION REPORT (TRUE)
C        OR NOT (FALSE).
C     INTEGER IERR
C        THE VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .GE. 1, ERRORS WERE DETECTED.
C     INTEGER LDSMIN
C        THE MINIMUM LENGTH ALLOWED FOR THE ARRAY DSTAK.
C     INTEGER LDSTAK
C        THE LENGTH OF THE ARRAY DSTAK.
C     CHARACTER*1 LIFCST(8), LLDS(8), LMSPEC(8), LN(8), LNFAC(8),
C    *  LNPAR(8), LNFCST(8), LONE(8)
C        THE ARRAY(S) CONTAINING THE NAME(S) OF INPUT PARAMETER(S)
C        CHECKED FOR ERRORS.
C     INTEGER MSPEC(4,NFAC)
C        THE ARRAY CONTAINING THE VALUES OF P, D, Q, AND S FOR EACH FACT
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     INTEGER NFAC
C        THE NUMBER OF FACTORS IN THE MODEL
C     INTEGER NFCST
C        THE NUMBER OF FORECASTS.
C     CHARACTER*1 NMSUB(6)
C        THE NAME OF THE ROUTINE CALLING THE ERROR CHECKING ROUTINE
C     INTEGER NPAR
C        THE NUMBER OF PARAMETERS IN THE MODEL.
C     INTEGER NV
C        *
C     LOGICAL SAVE
C        THE VARIABLE USED TO INDICATE WHETHER ANY RESULTS OTHER THAN
C        THE RESIDUALS AND PARAMETERS ARE TO BE SAVED (TRUE) OR NOT
C        (FALSE).
C
C     SET UP NAME ARRAYS
C
      DATA LIFCST(1), LIFCST(2), LIFCST(3), LIFCST(4), LIFCST(5),
     +   LIFCST(6), LIFCST(7), LIFCST(8)
     +  /'I','F','C','S','T',' ',' ',' '/
      DATA LLDS(1), LLDS(2), LLDS(3), LLDS(4), LLDS(5), LLDS(6),
     +   LLDS(7), LLDS(8) /'L','D','S','T','A','K',' ',' '/
      DATA LMSPEC(1), LMSPEC(2), LMSPEC(3), LMSPEC(4), LMSPEC(5),
     +   LMSPEC(6), LMSPEC(7), LMSPEC(8)
     +  /'M','S','P','C',' ',' ',' ',' '/
      DATA LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8) /'N',
     +   ' ',' ',' ',' ',' ',' ',' '/
      DATA LNFAC(1), LNFAC(2), LNFAC(3), LNFAC(4), LNFAC(5),
     +   LNFAC(6), LNFAC(7), LNFAC(8) /'N','F','A','C',' ',' ',' ',' '/
      DATA LNFCST(1), LNFCST(2), LNFCST(3), LNFCST(4), LNFCST(5),
     +   LNFCST(6), LNFCST(7), LNFCST(8)
     +  /'N','F','C','S','T',' ',' ',' '/
      DATA LNPAR(1), LNPAR(2), LNPAR(3), LNPAR(4), LNPAR(5),
     +   LNPAR(6), LNPAR(7), LNPAR(8) /'N','P','A','R',' ',' ',' ',
     +   ' '/
      DATA LONE(1), LONE(2), LONE(3), LONE(4), LONE(5),
     +   LONE(6), LONE(7), LONE(8) /'1',' ',' ',' ',' ',' ',' ',' '/
C
C     ERROR CHECKING
C
      DO 10 I=1,20
         ERROR(I) = .FALSE.
   10 CONTINUE
C
      IERR = 0
      HEAD = .TRUE.
C
      CALL EISGE(NMSUB, LN, N, 1, 2, HEAD, ERROR(1), LONE)
C
      CALL EISGE(NMSUB, LNFAC, NFAC, 1, 2, HEAD, ERROR(2), LONE)
C
      IF (.NOT. ERROR(2))
     +  CALL EIAGE(NMSUB, LMSPEC, MSPEC, 4, NFAC, 4, 0, 0, HEAD, 1, NV,
     +  ERROR(3), LMSPEC)
C
      IF ((.NOT. ERROR(2)) .AND. (.NOT. ERROR(3))) THEN
        NP = 1
         DO 15 I = 1, NFAC
           NP = NP + MSPEC(1,I) + MSPEC(3,I)
   15   CONTINUE
        CALL EISEQ(NMSUB, LNPAR, NPAR, NP, 1, HEAD, ERROR(4), LNPAR)
      END IF
C
      IF ((.NOT.ERROR(1)) .AND. (.NOT.ERROR(2)) .AND. (.NOT.ERROR(3))
     +   .AND. (.NOT.ERROR(4)) .AND. (.NOT.ERROR(5)))
     +   CALL EISGE(NMSUB, LLDS, LDSTAK, LDSMIN, 9, HEAD, ERROR(6),
     +   LLDS)
C
      IF (SAVE)
     +   CALL EISGE(NMSUB, LIFCST, IFCST, NFCST, 3, HEAD, ERROR(15),
     +   LNFCST)
C
      DO 20 I=1,20
         IF (ERROR(I)) GO TO 30
   20 CONTINUE
      RETURN
C
   30 CONTINUE
      IERR = 1
      RETURN
C
      END
*EHDR
      SUBROUTINE EHDR(NMSUB, HEAD)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRINTS THE HEADING FOR THE ERROR CHECKING ROUTINES.
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  DECEMBER 29, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      LOGICAL
     +   HEAD
C
C  ARRAY ARGUMENTS
      CHARACTER
     +   NMSUB(6)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
C  EXTERNAL SUBROUTINES
CCCCC EXTERNAL IPRINT,VERSP
      EXTERNAL VERSP
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL HEAD
C        A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED
C        (TRUE) OR NOT (FALSE).  IF A HEADING IS PRINTED, THE VALUE
C        OF HEAD WILL BE CHANGED TO FALSE.
C     INTEGER I
C        AN INDEX ARGUMENT.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      IF (.NOT.HEAD) RETURN
C
CCCCC CALL IPRINT(IPRT)
C
      CALL VERSP(.FALSE.)
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
C
      WRITE(ICOUT,1010)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1011)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,1010)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1000) (NMSUB(I), I=1,6)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1001) 
      CALL DPWRST('XXX','BUG ')
      HEAD = .FALSE.
C
      RETURN
C
C     FORMAT STATEMENTS
C
  999 FORMAT(1X)
 1000 FORMAT (' ERROR CHECKING FOR SUBROUTINE ',6A1)
 1001 FORMAT (1X, 37('-'))
 1010 FORMAT ('+', 18('*'))
 1011 FORMAT (' * ERROR MESSAGES *')
C
      END
*GQTSTP
      SUBROUTINE GQTSTP(D, DIG, DIHDI, KA, L, P, STEP, V, W)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C  *** COMPUTE GOLDFELD-QUANDT-TROTTER STEP BY MORE-HEBDEN TECHNIQUE ***
C  ***  (NL2SOL VERSION 2.2)  ***
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   KA,P
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   D(P),DIG(P),DIHDI(1),L(1),STEP(P),V(21),W(1)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   AKI,AKK,ALPHAK,DELTA,DGXFAC,DST,EPSFAC,EPSO6,FOUR,HALF,KAPPA,
     +   LK,NEGONE,OLDPHI,ONE,P001,PHI,PHIMAX,PHIMIN,PSIFAC,RAD,ROOT,
     +   SI,SIX,SK,SW,T,T1,THREE,TWO,TWOPSI,UK,WI,ZERO
      INTEGER
     +   DGGDMX,DGNORM,DIAG,DIAG0,DST0,DSTNRM,DSTSAV,EMAX,EMIN,
     +   EPSLON,GTSTEP,I,IM1,INC,IRC,J,K,K1,KALIM,LK0,NREDUC,
     +   PHIPIN,PHMNFC,PHMXFC,PREDUC,Q,Q0,RAD0,RADIUS,STPPAR,UK0,X,
     +   X0
      LOGICAL
     +   RESTRT
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DOTPRD,LSVMIN,RMDCON,V2NORM
      EXTERNAL DOTPRD,LSVMIN,RMDCON,V2NORM
C
C  EXTERNAL SUBROUTINES
      EXTERNAL LITVMU,LIVMUL,LSQRTZ
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MAX,MIN,SQRT
C
C  ***  PARAMETER DECLARATIONS  ***
C
C     INTEGER KA, P
C     DOUBLE PRECISION D(P), DIG(P), DIHDI(1), L(1), V(21), STEP(P),
C    1                 W(1)
C     DIMENSION DIHDI(P*(P+1)/2), L(P*(P+1)/2), W(4*P+7)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  ***  PURPOSE  ***
C
C        GIVEN THE (COMPACTLY STORED) LOWER TRIANGLE OF A SCALED
C     HESSIAN (APPROXIMATION) AND A NONZERO SCALED GRADIENT VECTOR,
C     THIS SUBROUTINE COMPUTES A GOLDFELD-QUANDT-TROTTER STEP OF
C     APPROXIMATE LENGTH V(RADIUS) BY THE MORE-HEBDEN TECHNIQUE.  IN
C     OTHER WORDS, STEP IS COMPUTED TO (APPROXIMATELY) MINIMIZE
C     PSI(STEP) = (G**T)*STEP + 0.5*(STEP**T)*H*STEP  SUCH THAT THE
C     2-NORM OF D*STEP IS AT MOST (APPROXIMATELY) V(RADIUS), WHERE
C     G  IS THE GRADIENT,  H  IS THE HESSIAN, AND  D  IS A DIAGONAL
C     SCALE MATRIX WHOSE DIAGONAL IS STORED IN THE PARAMETER D.
C     (GQTSTP ASSUMES  DIG = D**-1 * G  AND  DIHDI = D**-1 * H * D**-1.)
C     IF G = 0, HOWEVER, STEP = 0 IS RETURNED (EVEN AT A SADDLE POINT).
C
C  ***  PARAMETER DESCRIPTION  ***
C
C     D (IN)  = THE SCALE VECTOR, I.E. THE DIAGONAL OF THE SCALE
C              MATRIX  D  MENTIONED ABOVE UNDER PURPOSE.
C   DIG (IN)  = THE SCALED GRADIENT VECTOR, D**-1 * G.  IF G = 0, THEN
C              STEP = 0  AND  V(STPPAR) = 0  ARE RETURNED.
C DIHDI (IN)  = LOWER TRIANGLE OF THE SCALED HESSIAN (APPROXIMATION),
C              I.E., D**-1 * H * D**-1, STORED COMPACTLY BY ROWS., I.E.,
C              IN THE ORDER (1,1), (2,1), (2,2), (3,1), (3,2), ETC.
C    KA (I/O) = THE NUMBER OF HEBDEN ITERATIONS (SO FAR) TAKEN TO DETER-
C              MINE STEP.  KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST
C              ATTEMPT TO DETERMINE STEP (FOR THE PRESENT DIG AND DIHDI)
C              -- KA IS INITIALIZED TO 0 IN THIS CASE.  OUTPUT WITH
C              KA = 0  (OR V(STPPAR) = 0)  MEANS  STEP = -(H**-1)*G.
C     L (I/O) = WORKSPACE OF LENGTH P*(P+1)/2 FOR CHOLESKY FACTORS.
C     P (IN)  = NUMBER OF PARAMETERS -- THE HESSIAN IS A  P X P  MATRIX.
C  STEP (I/O) = THE STEP COMPUTED.
C     V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW.
C     W (I/O) = WORKSPACE OF LENGTH 4*P + 6.
C
C  ***  ENTRIES IN V  ***
C
C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G.
C V(DSTNRM) (OUTPUT) = 2-NORM OF D*STEP.
C V(DST0)   (I/O) = 2-NORM OF D*(H**-1)*G (FOR POS. DEF. H ONLY), OR
C             OVERESTIMATE OF SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1).
C V(EPSLON) (IN)  = MAX. REL. ERROR ALLOWED FOR PSI(STEP).  FOR THE
C             STEP RETURNED, PSI(STEP) WILL EXCEED ITS OPTIMAL VALUE
C             BY LESS THAN -V(EPSLON)*PSI(STEP).  SUGGESTED VALUE = 0.1.
C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP.
C V(NREDUC) (OUT) = PSI(-(H**-1)*G) = PSI(NEWTON STEP)  (FOR POS. DEF.
C             H ONLY -- V(NREDUC) IS SET TO ZERO OTHERWISE).
C V(PHMNFC) (IN)  = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP
C             (MORE*S SIGMA).  THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE
C             BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS).
C V(PHMXFC) (IN)  (SEE V(PHMNFC).)
C             SUGGESTED VALUES -- V(PHMNFC) = -0.25, V(PHMXFC) = 0.5.
C V(PREDUC) (OUT) = PSI(STEP) = PREDICTED OBJ. FUNC. REDUCTION FOR STEP.
C V(RADIUS) (IN)  = RADIUS OF CURRENT (SCALED) TRUST REGION.
C V(RAD0)   (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL.
C V(STPPAR) (I/O) IS NORMALLY THE MARQUARDT PARAMETER, I.E. THE ALPHA
C             DESCRIBED BELOW UNDER ALGORITHM NOTES.  IF H + ALPHA*D**2
C             (SEE ALGORITHM NOTES) IS (NEARLY) SINGULAR, HOWEVER,
C             THEN V(STPPAR) = -ALPHA.
C
C  ***  USAGE NOTES  ***
C
C     IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF
C     V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT
C     WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS).  (THIS EXPLAINS
C     WHY STEP AND W ARE LISTED AS I/O).  ON AN INTIIAL CALL (ONE WITH
C     KA .LT. 0), STEP AND W NEED NOT BE INITIALIZED AND ONLY COMPO-
C     NENTS V(EPSLON), V(STPPAR), V(PHMNFC), V(PHMXFC), V(RADIUS), AND
C     V(RAD0) OF V MUST BE INITIALIZED.  TO COMPUTE STEP FROM A SADDLE
C     POINT (WHERE THE TRUE GRADIENT VANISHES AND H HAS A NEGATIVE
C     EIGENVALUE), A NONZERO G WITH SMALL COMPONENTS SHOULD BE PASSED.
C
C  ***  APPLICATION AND USAGE RESTRICTIONS  ***
C
C     THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR LEAST-
C     SQUARES) PACKAGE (REF. 1), BUT IT COULD BE USED IN SOLVING ANY
C     UNCONSTRAINED MINIMIZATION PROBLEM.
C
C  ***  ALGORITHM NOTES  ***
C
C        THE DESIRED G-Q-T STEP (REF. 2, 3, 4) SATISFIES
C     (H + ALPHA*D**2)*STEP = -G  FOR SOME NONNEGATIVE ALPHA SUCH THAT
C     H + ALPHA*D**2 IS POSITIVE SEMIDEFINITE.  ALPHA AND STEP ARE
C     COMPUTED BY A SCHEME ANALOGOUS TO THE ONE DESCRIBED IN REF. 5.
C     ESTIMATES OF THE SMALLEST AND LARGEST EIGENVALUES OF THE HESSIAN
C     ARE OBTAINED FROM THE GERSCHGORIN CIRCLE THEOREM ENHANCED BY A
C     SIMPLE FORM OF THE SCALING DESCRIBED IN REF. 6.  CASES IN WHICH
C     H + ALPHA*D**2 IS NEARLY (OR EXACTLY) SINGULAR ARE HANDLED BY
C     THE TECHNIQUE DISCUSSED IN REF. 2.  IN THESE CASES, A STEP OF
C     (EXACT) LENGTH V(RADIUS) IS RETURNED FOR WHICH PSI(STEP) EXCEEDS
C     ITS OPTIMAL VALUE BY LESS THAN -V(EPSLON)*PSI(STEP).
C
C  ***  FUNCTIONS AND SUBROUTINES CALLED  ***
C
C DOTPRD - RETURNS INNER PRODUCT OF TWO VECTORS.
C LITVMU - APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX.
C LIVMUL - APPLIES INVERSE OF COMPACT LOWER TRIANG. MATRIX.
C LSQRTZ  - FINDS CHOLESKY FACTOR (OF COMPACTLY STORED LOWER TRIANG.).
C LSVMIN - RETURNS APPROX. TO MIN. SING. VALUE OF LOWER TRIANG. MATRIX.
C RMDCON - RETURNS MACHINE-DEPENDENT CONSTANTS.
C V2NORM - RETURNS 2-NORM OF A VECTOR.
C
C  ***  REFERENCES  ***
C
C 1.  DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1980), AN ADAPTIVE
C             NONLINEAR LEAST-SQUARES ALGORITHM, (SUBMITTED TO ACM
C             TRANS. MATH. SOFTWARE).
C 2.  GAY, D.M. (1979), COMPUTING OPTIMAL ELLIPTICALLY CONSTRAINED
C             STEPS, MRC TECH. SUMMARY REPORT NO. 2013, MATH. RESEARCH
C             CENTER, UNIV. OF WISCONSIN-MADISON.
C 3.  GOLDFELD, S.M., QUANDT, R.E., AND TROTTER, H.F. (1966),
C             MAXIMIZATION BY QUADRATIC HILL-CLIMBING, ECONOMETRICA 34,
C             PP. 541-551.
C 4.  HEBDEN, M.D. (1973), AN ALGORITHM FOR MINIMIZATION USING EXACT
C             SECOND DERIVATIVES, REPORT T.P. 515, THEORETICAL PHYSICS
C             DIV., A.E.R.E. HARWELL, OXON., ENGLAND.
C 5.  MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN-
C             TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES
C             IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER-
C             VERLAG, BERLIN AND NEW YORK.
C 6.  VARGA, R.S. (1965), MINIMAL GERSCHGORIN SETS, PACIFIC J. MATH. 15,
C             PP. 719-729.
C
C  ***  GENERAL  ***
C
C     CODED BY DAVID M. GAY.
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
C     MCS-7906671.
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  ***  LOCAL VARIABLES  ***
C
C     LOGICAL RESTRT
C     INTEGER DGGDMX, DIAG, DIAG0, DSTSAV, EMAX, EMIN, I, IM1, INC, IRC,
C    1        J, K, KALIM, K1, LK0, PHIPIN, Q, Q0, UK0, X, X0
C     DOUBLE PRECISION ALPHAK, AKI, AKK, DELTA, DST, EPSO6, LK,
C    1                 OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD,
C    2                 ROOT, SI, SK, SW, T, TWOPSI, T1, UK, WI
C
C     ***  CONSTANTS  ***
C     DOUBLE PRECISION DGXFAC, EPSFAC, FOUR, HALF, KAPPA, NEGONE, ONE,
C    1                 P001, SIX, THREE, TWO, ZERO
C
C/
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
C     EXTERNAL DOTPRD, LITVMU, LIVMUL, LSQRTZ, LSVMIN, RMDCON, V2NORM
C     DOUBLE PRECISION DOTPRD, LSVMIN, RMDCON, V2NORM
C
C  ***  SUBSCRIPTS FOR V  ***
C
C     INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, STPPAR, NREDUC,
C    1        PHMNFC, PHMXFC, PREDUC, RADIUS, RAD0
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA DGNORM/1/, DSTNRM/2/, DST0/3/, EPSLON/19/,
     +     GTSTEP/4/, NREDUC/6/, PHMNFC/20/,
     +     PHMXFC/21/, PREDUC/7/, RADIUS/8/,
     +     RAD0/9/, STPPAR/5/
C
      DATA DGXFAC/0.0D0/, EPSFAC/50.0D0/, FOUR/4.0D0/, HALF/0.5D0/,
     +     KAPPA/2.0D0/, NEGONE/-1.0D0/, ONE/1.0D0/, P001/1.0D-3/,
     +     SIX/6.0D0/, THREE/3.0D0/, TWO/2.0D0/, ZERO/0.0D0/
C
C  ***  BODY  ***
C
C     ***  STORE LARGEST ABS. ENTRY IN (D**-1)*H*(D**-1) AT W(DGGDMX).
      DGGDMX = P + 1
C     ***  STORE GERSCHGORIN OVER- AND UNDERESTIMATES OF THE LARGEST
C     ***  AND SMALLEST EIGENVALUES OF (D**-1)*H*(D**-1) AT W(EMAX)
C     ***  AND W(EMIN) RESPECTIVELY.
      EMAX = DGGDMX + 1
      EMIN = EMAX + 1
C     ***  FOR USE IN RECOMPUTING STEP, THE FINAL VALUES OF LK, UK, DST,
C     ***  AND THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR POS. DEF.
C     ***  H) ARE STORED IN W(LK0), W(UK0), W(DSTSAV), AND W(PHIPIN)
C     ***  RESPECTIVELY.
      UK = 0.0D0
      PHI = 0.0D0
      DST = 0.0D0
      ALPHAK = 0.0D0
      LK0 = EMIN + 1
      PHIPIN = LK0 + 1
      UK0 = PHIPIN + 1
      DSTSAV = UK0 + 1
C     ***  STORE DIAG OF (D**-1)*H*(D**-1) IN W(DIAG),...,W(DIAG0+P).
      DIAG0 = DSTSAV
      DIAG = DIAG0 + 1
C     ***  STORE -D*STEP IN W(Q),...,W(Q0+P).
      Q0 = DIAG0 + P
      Q = Q0 + 1
      RAD = V(RADIUS)
C     ***  PHITOL = MAX. ERROR ALLOWED IN DST = V(DSTNRM) = 2-NORM OF
C     ***  D*STEP.
      PHIMAX = V(PHMXFC) * RAD
      PHIMIN = V(PHMNFC) * RAD
C     ***  EPSO6 AND PSIFAC ARE USED IN CHECKING FOR THE SPECIAL CASE
C     ***  OF (NEARLY) SINGULAR H + ALPHA*D**2 (SEE REF. 2).
      PSIFAC = TWO * V(EPSLON) / (THREE * (FOUR * (V(PHMNFC) + ONE) *
     +                       (KAPPA + ONE)  +  KAPPA  +  TWO) * RAD**2)
C     ***  OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY.  IF
C     ***  WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT.
      OLDPHI = ZERO
      EPSO6 = V(EPSLON)/SIX
      IRC = 0
      RESTRT = .FALSE.
      KALIM = KA + 50
C
C  ***  START OR RESTART, DEPENDING ON KA  ***
C
      IF (KA .GE. 0) GO TO 310
C
C  ***  FRESH START  ***
C
      K = 0
      UK = NEGONE
      KA = 0
      KALIM = 50
C
C     ***  STORE DIAG(DIHDI) IN W(DIAG0+1),...,W(DIAG0+P)  ***
C
      J = 0
      DO 20 I = 1, P
         J = J + I
         K1 = DIAG0 + I
         W(K1) = DIHDI(J)
 20      CONTINUE
C
C     ***  DETERMINE W(DGGDMX), THE LARGEST ELEMENT OF DIHDI  ***
C
      T1 = ZERO
      J = P * (P + 1) / 2
      DO 30 I = 1, J
         T = ABS(DIHDI(I))
         IF (T1 .LT. T) T1 = T
 30      CONTINUE
      W(DGGDMX) = T1
C
C  ***  TRY ALPHA = 0  ***
C
 40   CALL LSQRTZ(1, P, L, DIHDI, IRC)
      IF (IRC .EQ. 0) GO TO 60
C        ***  INDEF. H -- UNDERESTIMATE SMALLEST EIGENVALUE, USE THIS
C        ***  ESTIMATE TO INITIALIZE LOWER BOUND LK ON ALPHA.
         J = IRC*(IRC+1)/2
         T = L(J)
         L(J) = ONE
         DO 50 I = 1, IRC
 50           W(I) = ZERO
         W(IRC) = ONE
         CALL LITVMU(IRC, W, L, W)
         T1 = V2NORM(IRC, W)
         LK = -T / T1 / T1
         V(DST0) = -LK
         IF (RESTRT) GO TO 210
         V(NREDUC) = ZERO
         GO TO 70
C
C     ***  POSITIVE DEFINITE H -- COMPUTE UNMODIFIED NEWTON STEP.  ***
 60   LK = ZERO
      CALL LIVMUL(P, W(Q), L, DIG)
      V(NREDUC) = HALF * DOTPRD(P, W(Q), W(Q))
      CALL LITVMU(P, W(Q), L, W(Q))
      DST = V2NORM(P, W(Q))
      V(DST0) = DST
      PHI = DST - RAD
      IF (PHI .LE. PHIMAX) GO TO 280
      IF (RESTRT) GO TO 210
C
C  ***  PREPARE TO COMPUTE GERSCHGORIN ESTIMATES OF LARGEST (AND
C  ***  SMALLEST) EIGENVALUES.  ***
C
 70   V(DGNORM) = V2NORM(P, DIG)
      IF (V(DGNORM) .EQ. ZERO) GO TO 450
      K = 0
      DO 100 I = 1, P
         WI = ZERO
         IF (I .EQ. 1) GO TO 90
         IM1 = I - 1
         DO 80 J = 1, IM1
              K = K + 1
              T = ABS(DIHDI(K))
              WI = WI + T
              W(J) = W(J) + T
 80           CONTINUE
 90      W(I) = WI
         K = K + 1
 100     CONTINUE
C
C  ***  (UNDER-)ESTIMATE SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1)  ***
C
      K = 1
      T1 = W(DIAG) - W(1)
      IF (P .LE. 1) GO TO 120
      DO 110 I = 2, P
         J = DIAG0 + I
         T = W(J) - W(I)
         IF (T .GE. T1) GO TO 110
              T1 = T
              K = I
 110     CONTINUE
C
 120  SK = W(K)
      J = DIAG0 + K
      AKK = W(J)
      K1 = K*(K-1)/2 + 1
      INC = 1
      T = ZERO
      DO 150 I = 1, P
         IF (I .EQ. K) GO TO 130
         AKI = ABS(DIHDI(K1))
         SI = W(I)
         J = DIAG0 + I
         T1 = HALF * (AKK - W(J) + SI - AKI)
         T1 = T1 + SQRT(T1*T1 + SK*AKI)
         IF (T .LT. T1) T = T1
         IF (I .LT. K) GO TO 140
 130     INC = I
 140     K1 = K1 + INC
 150     CONTINUE
C
      W(EMIN) = AKK - T
      UK = V(DGNORM)/RAD - W(EMIN)
C
C  ***  COMPUTE GERSCHGORIN (OVER-)ESTIMATE OF LARGEST EIGENVALUE  ***
C
      K = 1
      T1 = W(DIAG) + W(1)
      IF (P .LE. 1) GO TO 170
      DO 160 I = 2, P
         J = DIAG0 + I
         T = W(J) + W(I)
         IF (T .LE. T1) GO TO 160
              T1 = T
              K = I
 160     CONTINUE
C
 170  SK = W(K)
      J = DIAG0 + K
      AKK = W(J)
      K1 = K*(K-1)/2 + 1
      INC = 1
      T = ZERO
      DO 200 I = 1, P
         IF (I .EQ. K) GO TO 180
         AKI = ABS(DIHDI(K1))
         SI = W(I)
         J = DIAG0 + I
         T1 = HALF * (W(J) + SI - AKI - AKK)
         T1 = T1 + SQRT(T1*T1 + SK*AKI)
         IF (T .LT. T1) T = T1
         IF (I .LT. K) GO TO 190
 180     INC = I
 190     K1 = K1 + INC
 200     CONTINUE
C
      W(EMAX) = AKK + T
      LK = MAX(LK, V(DGNORM)/RAD - W(EMAX))
C
C     ***  ALPHAK = CURRENT VALUE OF ALPHA (SEE ALG. NOTES ABOVE).  WE
C     ***  USE MORE*S SCHEME FOR INITIALIZING IT.
      ALPHAK = ABS(V(STPPAR)) * V(RAD0)/RAD
C
      IF (IRC .NE. 0) GO TO 210
C
C  ***  COMPUTE L0 FOR POSITIVE DEFINITE H  ***
C
      CALL LIVMUL(P, W, L, W(Q))
      T = V2NORM(P, W)
      W(PHIPIN) = DST / T / T
      LK = MAX(LK, PHI*W(PHIPIN))
C
C  ***  SAFEGUARD ALPHAK AND ADD ALPHAK*I TO (D**-1)*H*(D**-1)  ***
C
 210  KA = KA + 1
      IF (-V(DST0) .GE. ALPHAK .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK)
     +                      ALPHAK = UK * MAX(P001, SQRT(LK/UK))
      K = 0
      DO 220 I = 1, P
         K = K + I
         J = DIAG0 + I
         DIHDI(K) = W(J) + ALPHAK
 220     CONTINUE
C
C  ***  TRY COMPUTING CHOLESKY DECOMPOSITION  ***
C
      CALL LSQRTZ(1, P, L, DIHDI, IRC)
      IF (IRC .EQ. 0) GO TO 250
C
C  ***  (D**-1)*H*(D**-1) + ALPHAK*I  IS INDEFINITE -- OVERESTIMATE
C  ***  SMALLEST EIGENVALUE FOR USE IN UPDATING LK  ***
C
      J = (IRC*(IRC+1))/2
      T = L(J)
      L(J) = ONE
      DO 230 I = 1, IRC
 230     W(I) = ZERO
      W(IRC) = ONE
      CALL LITVMU(IRC, W, L, W)
      T1 = V2NORM(IRC, W)
      LK = ALPHAK - T/T1/T1
      V(DST0) = -LK
      GO TO 210
C
C  ***  ALPHAK MAKES (D**-1)*H*(D**-1) POSITIVE DEFINITE.
C  ***  COMPUTE Q = -D*STEP, CHECK FOR CONVERGENCE.  ***
C
 250  CALL LIVMUL(P, W(Q), L, DIG)
      CALL LITVMU(P, W(Q), L, W(Q))
      DST = V2NORM(P, W(Q))
      PHI = DST - RAD
      IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 290
      IF (PHI .EQ. OLDPHI) GO TO 290
      OLDPHI = PHI
      IF (PHI .GT. ZERO) GO TO 260
C        ***  CHECK FOR THE SPECIAL CASE OF  H + ALPHA*D**2  (NEARLY)
C        ***  SINGULAR.  DELTA IS .GE. THE SMALLEST EIGENVALUE OF
C        ***  (D**-1)*H*(D**-1) + ALPHAK*I.
         IF (V(DST0) .GT. ZERO) GO TO 260
         DELTA = ALPHAK + V(DST0)
         TWOPSI = ALPHAK*DST*DST + DOTPRD(P, DIG, W(Q))
         IF (DELTA .LT. PSIFAC*TWOPSI) GO TO 270
C
C  ***  UNACCEPTABLE ALPHAK -- UPDATE LK, UK, ALPHAK  ***
C
 260  IF (KA .GE. KALIM) GO TO 290
      CALL LIVMUL(P, W, L, W(Q))
      T1 = V2NORM(P, W)
C     ***  THE FOLLOWING MIN IS NECESSARY BECAUSE OF RESTARTS  ***
      IF (PHI .LT. ZERO) UK = MIN(UK, ALPHAK)
      ALPHAK = ALPHAK  +  (PHI/T1) * (DST/T1) * (DST/RAD)
      LK = MAX(LK, ALPHAK)
      GO TO 210
C
C  ***  DECIDE HOW TO HANDLE (NEARLY) SINGULAR H + ALPHA*D**2  ***
C
C     ***  IF NOT YET AVAILABLE, OBTAIN MACHINE DEPENDENT VALUE DGXFAC.
 270  IF (DGXFAC .EQ. ZERO) DGXFAC = EPSFAC * RMDCON(3)
C
C     ***  NOW DECIDE.  ***
      IF (DELTA .GT. DGXFAC*W(DGGDMX)) GO TO 350
C        ***  DELTA IS SO SMALL WE CANNOT HANDLE THE SPECIAL CASE IN
C        ***  THE AVAILABLE ARITHMETIC.  ACCEPT STEP AS IT IS.
         GO TO 290
C
C  ***  ACCEPTABLE STEP ON FIRST TRY  ***
C
 280  ALPHAK = ZERO
C
C  ***  SUCCESSFUL STEP IN GENERAL.  COMPUTE STEP = -(D**-1)*Q  ***
C
 290  DO 300 I = 1, P
         J = Q0 + I
         STEP(I) = -W(J)/D(I)
 300     CONTINUE
      V(GTSTEP) = -DOTPRD(P, DIG, W(Q))
      V(PREDUC) = HALF * (ABS(ALPHAK)*DST*DST - V(GTSTEP))
      GO TO 430
C
C
C  ***  RESTART WITH NEW RADIUS  ***
C
 310  IF (V(DST0) .LE. ZERO .OR. V(DST0) - RAD .GT. PHIMAX) GO TO 330
C
C     ***  PREPARE TO RETURN NEWTON STEP  ***
C
         RESTRT = .TRUE.
         KA = KA + 1
         K = 0
         DO 320 I = 1, P
              K = K + I
              J = DIAG0 + I
              DIHDI(K) = W(J)
 320          CONTINUE
         UK = NEGONE
         GO TO 40
C
 330  IF (KA .EQ. 0) GO TO 60
C
      DST = W(DSTSAV)
      ALPHAK = ABS(V(STPPAR))
      PHI = DST - RAD
      T = V(DGNORM)/RAD
      IF (RAD .GT. V(RAD0)) GO TO 340
C
C        ***  SMALLER RADIUS  ***
         UK = T - W(EMIN)
         LK = ZERO
         IF (ALPHAK .GT. ZERO) LK = W(LK0)
         LK = MAX(LK, T - W(EMAX))
         IF (V(DST0) .GT. ZERO) LK = MAX(LK, (V(DST0)-RAD)*W(PHIPIN))
         GO TO 260
C
C     ***  BIGGER RADIUS  ***
 340  UK = T - W(EMIN)
      IF (ALPHAK .GT. ZERO) UK = MIN(UK, W(UK0))
      LK = MAX(ZERO, -V(DST0), T - W(EMAX))
      IF (V(DST0) .GT. ZERO) LK = MAX(LK, (V(DST0)-RAD)*W(PHIPIN))
      GO TO 260
C
C  ***  HANDLE (NEARLY) SINGULAR H + ALPHA*D**2  ***
C
C     ***  NEGATE ALPHAK TO INDICATE SPECIAL CASE  ***
 350  ALPHAK = -ALPHAK
C     ***  ALLOCATE STORAGE FOR SCRATCH VECTOR X  ***
      X0 = Q0 + P
      X = X0 + 1
C
C  ***  USE INVERSE POWER METHOD WITH START FROM LSVMIN TO OBTAIN
C  ***  APPROXIMATE EIGENVECTOR CORRESPONDING TO SMALLEST EIGENVALUE
C  ***  OF (D**-1)*H*(D**-1).
C
      DELTA = KAPPA*DELTA
      T = LSVMIN(P, L, W(X), W)
C
      K = 0
C     ***  NORMALIZE W  ***
 360  DO 370 I = 1, P
 370     W(I) = T*W(I)
C     ***  COMPLETE CURRENT INV. POWER ITER. -- REPLACE W BY (L**-T)*W.
      CALL LITVMU(P, W, L, W)
      T1 = ONE/V2NORM(P, W)
      T = T1*T
      IF (T .LE. DELTA) GO TO 390
      IF (K .GT. 30) GO TO 290
      K = K + 1
C     ***  START NEXT INV. POWER ITER. BY STORING NORMALIZED W IN X.
      DO 380 I = 1, P
         J = X0 + I
         W(J) = T1*W(I)
 380     CONTINUE
C     ***  COMPUTE W = (L**-1)*X.
      CALL LIVMUL(P, W, L, W(X))
      T = ONE/V2NORM(P, W)
      GO TO 360
C
 390  DO 400 I = 1, P
 400     W(I) = T1*W(I)
C
C  ***  NOW W IS THE DESIRED APPROXIMATE (UNIT) EIGENVECTOR AND
C  ***  T*X = ((D**-1)*H*(D**-1) + ALPHAK*I)*W.
C
      SW = DOTPRD(P, W(Q), W)
      T1 = (RAD + DST) * (RAD - DST)
      ROOT = SQRT(SW*SW + T1)
      IF (SW .LT. ZERO) ROOT = -ROOT
      SI = T1 / (SW + ROOT)
C     ***  ACCEPT CURRENT STEP IF ADDING SI*W WOULD LEAD TO A
C     ***  FURTHER RELATIVE REDUCTION IN PSI OF LESS THAN V(EPSLON)/3.
      V(PREDUC) = HALF*TWOPSI
      T1 = ZERO
      T = SI*(ALPHAK*SW - HALF*SI*(ALPHAK + T*DOTPRD(P,W(X),W)))
      IF (T .LT. EPSO6*TWOPSI) GO TO 410
         V(PREDUC) = V(PREDUC) + T
         DST = RAD
         T1 = -SI
 410  DO 420 I = 1, P
         J = Q0 + I
         W(J) = T1*W(I) - W(J)
         STEP(I) = W(J) / D(I)
 420     CONTINUE
      V(GTSTEP) = DOTPRD(P, DIG, W(Q))
C
C  ***  SAVE VALUES FOR USE IN A POSSIBLE RESTART  ***
C
 430  V(DSTNRM) = DST
      V(STPPAR) = ALPHAK
      W(LK0) = LK
      W(UK0) = UK
      V(RAD0) = RAD
      W(DSTSAV) = DST
C
C     ***  RESTORE DIAGONAL OF DIHDI  ***
C
      J = 0
      DO 440 I = 1, P
         J = J + I
         K = DIAG0 + I
         DIHDI(J) = W(K)
 440     CONTINUE
      GO TO 999
C
C  ***  SPECIAL CASE -- G = 0  ***
C
 450  V(STPPAR) = ZERO
      V(PREDUC) = ZERO
      V(DSTNRM) = ZERO
      V(GTSTEP) = ZERO
      DO 460 I = 1, P
 460     STEP(I) = ZERO
C
 999  RETURN
C
C  ***  LAST CARD OF GQTSTP FOLLOWS  ***
      END
*LSVMIN
      DOUBLE PRECISION FUNCTION LSVMIN(P, L, X, Y)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C  ***  ESTIMATE SMALLEST SING. VALUE OF PACKED LOWER TRIANG. MATRIX L
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   P
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   L(1),X(P),Y(P)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   B,HALF,ONE,PSJ,R9973,SMINUS,SPLUS,T,XMINUS,XPLUS,ZERO
      INTEGER
     +   I,II,IX,J,J0,JI,JJ,JJJ,JM1,PPLUS1
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   V2NORM
      EXTERNAL V2NORM
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MOD
C
C  ***  PARAMETER DECLARATIONS  ***
C
C     INTEGER P
C     DOUBLE PRECISION L(1), X(P), Y(P)
C     DIMENSION L(P*(P+1)/2)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  ***  PURPOSE  ***
C
C     THIS FUNCTION RETURNS A GOOD OVER-ESTIMATE OF THE SMALLEST
C     SINGULAR VALUE OF THE PACKED LOWER TRIANGULAR MATRIX L.
C
C  ***  PARAMETER DESCRIPTION  ***
C
C  P (IN)  = THE ORDER OF L.  L IS A  P X P  LOWER TRIANGULAR MATRIX.
C  L (IN)  = ARRAY HOLDING THE ELEMENTS OF  L  IN ROW ORDER, I.E.
C             L(1,1), L(2,1), L(2,2), L(3,1), L(3,2), L(3,3), ETC.
C  X (OUT) IF LSVMIN RETURNS A POSITIVE VALUE, THEN X IS A NORMALIZED
C             APPROXIMATE LEFT SINGULAR VECTOR CORRESPONDING TO THE
C             SMALLEST SINGULAR VALUE.  THIS APPROXIMATION MAY BE VERY
C             CRUDE.  IF LSVMIN RETURNS ZERO, THEN SOME COMPONENTS OF X
C             ARE ZERO AND THE REST RETAIN THEIR INPUT VALUES.
C  Y (OUT) IF LSVMIN RETURNS A POSITIVE VALUE, THEN Y = (L**-1)*X IS AN
C             UNNORMALIZED APPROXIMATE RIGHT SINGULAR VECTOR CORRESPOND-
C             ING TO THE SMALLEST SINGULAR VALUE.  THIS APPROXIMATION
C             MAY BE CRUDE.  IF LSVMIN RETURNS ZERO, THEN Y RETAINS ITS
C             INPUT VALUE.  THE CALLER MAY PASS THE SAME VECTOR FOR X
C             AND Y (NONSTANDARD FORTRAN USAGE), IN WHICH CASE Y OVER-
C             WRITES X (FOR NONZERO LSVMIN RETURNS).
C
C  ***  APPLICATION AND USAGE RESTRICTIONS  ***
C
C     THERE ARE NO USAGE RESTRICTIONS.
C
C  ***  ALGORITHM NOTES  ***
C
C     THE ALGORITHM IS BASED ON (1), WITH THE ADDITIONAL PROVISION THAT
C     LSVMIN = 0 IS RETURNED IF THE SMALLEST DIAGONAL ELEMENT OF L
C     (IN MAGNITUDE) IS NOT MORE THAN THE UNIT ROUNDOFF TIMES THE
C     LARGEST.  THE ALGORITHM USES A RANDOM NUMBER GENERATOR PROPOSED
C     IN (4), WHICH PASSES THE SPECTRAL TEST WITH FLYING COLORS -- SEE
C     (2) AND (3).
C
C  ***  SUBROUTINES AND FUNCTIONS CALLED  ***
C
C        V2NORM - FUNCTION, RETURNS THE 2-NORM OF A VECTOR.
C
C  ***  REFERENCES  ***
C
C     (1) CLINE, A., MOLER, C., STEWART, G., AND WILKINSON, J.H.(1977),
C         AN ESTIMATE FOR THE CONDITION NUMBER OF A MATRIX, REPORT
C         TM-310, APPLIED MATH. DIV., ARGONNE NATIONAL LABORATORY.
C
C     (2) HOAGLIN, D.C. (1976), THEORETICAL PROPERTIES OF CONGRUENTIAL
C         RANDOM-NUMBER GENERATORS --  AN EMPIRICAL VIEW,
C         MEMORANDUM NS-340, DEPT. OF STATISTICS, HARVARD UNIV.
C
C     (3) KNUTH, D.E. (1969), THE ART OF COMPUTER PROGRAMMING, VOL. 2
C         (SEMINUMERICAL ALGORITHMS), ADDISON-WESLEY, READING, MASS.
C
C     (4) SMITH, C.S. (1971), MULTIPLICATIVE PSEUDO-RANDOM NUMBER
C         GENERATORS WITH PRIME MODULUS, J. ASSOC. COMPUT. MACH. 18,
C         PP. 586-593.
C
C  ***  HISTORY  ***
C
C     DESIGNED AND CODED BY DAVID M GAY (WINTER 1977/SUMMER 1978).
C
C  ***  GENERAL  ***
C
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989.
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C  ***  LOCAL VARIABLES  ***
C
C     INTEGER I, II, IX, J, JI, JJ, JJJ, JM1, J0, PPLUS1
C     DOUBLE PRECISION B, PSJ, SMINUS, SPLUS, T, XMINUS, XPLUS
C
C  ***  CONSTANTS  ***
C
C     DOUBLE PRECISION HALF, ONE, R9973, ZERO
C
C/
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
C     EXTERNAL V2NORM
C     DOUBLE PRECISION V2NORM
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA IX/2/
      DATA HALF/0.5D0/, ONE/1.0D0/, R9973/9973.0D0/, ZERO/0.0D0/
C
C  ***  BODY  ***
C
C  ***  FIRST CHECK WHETHER TO RETURN LSVMIN = 0 AND INITIALIZE X  ***
C
      II = 0
      DO 10 I = 1, P
         X(I) = ZERO
         II = II + I
         IF (L(II) .EQ. ZERO) GO TO 300
 10      CONTINUE
      IF (MOD(IX, 9973) .EQ. 0) IX = 2
      PPLUS1 = P + 1
C
C  ***  SOLVE (L**T)*X = B, WHERE THE COMPONENTS OF B HAVE RANDOMLY
C  ***  CHOSEN MAGNITUDES IN (.5,1) WITH SIGNS CHOSEN TO MAKE X LARGE.
C
C     DO J = P TO 1 BY -1...
      DO 100 JJJ = 1, P
         J = PPLUS1 - JJJ
C       ***  DETERMINE X(J) IN THIS ITERATION. NOTE FOR I = 1,2,...,J
C       ***  THAT X(I) HOLDS THE CURRENT PARTIAL SUM FOR ROW I.
         IX = MOD(3432*IX, 9973)
         B = HALF*(ONE + IX/R9973)
         XPLUS = (B - X(J))
         XMINUS = (-B - X(J))
         SPLUS = ABS(XPLUS)
         SMINUS = ABS(XMINUS)
         JM1 = J - 1
         J0 = J*JM1/2
         JJ = J0 + J
         XPLUS = XPLUS/L(JJ)
         XMINUS = XMINUS/L(JJ)
         IF (JM1 .EQ. 0) GO TO 30
         DO 20 I = 1, JM1
              JI = J0 + I
              SPLUS = SPLUS + ABS(X(I) + L(JI)*XPLUS)
              SMINUS = SMINUS + ABS(X(I) + L(JI)*XMINUS)
 20           CONTINUE
 30      IF (SMINUS .GT. SPLUS) XPLUS = XMINUS
         X(J) = XPLUS
C       ***  UPDATE PARTIAL SUMS  ***
         IF (JM1 .EQ. 0) GO TO 100
         DO 40 I = 1, JM1
              JI = J0 + I
              X(I) = X(I) + L(JI)*XPLUS
 40           CONTINUE
 100     CONTINUE
C
C  ***  NORMALIZE X  ***
C
      T = ONE/V2NORM(P, X)
      DO 110 I = 1, P
 110     X(I) = T*X(I)
C
C  ***  SOLVE L*Y = X AND RETURN SVMIN = 1/TWONORM(Y)  ***
C
      DO 200 J = 1, P
         PSJ = ZERO
         JM1 = J - 1
         J0 = J*JM1/2
         IF (JM1 .EQ. 0) GO TO 130
         DO 120 I = 1, JM1
              JI = J0 + I
              PSJ = PSJ + L(JI)*Y(I)
 120          CONTINUE
 130     JJ = J0 + J
         Y(J) = (X(J) - PSJ)/L(JJ)
 200     CONTINUE
C
      LSVMIN = ONE/V2NORM(P, Y)
      GO TO 999
C
 300  LSVMIN = ZERO
 999  RETURN
C  ***  LAST CARD OF LSVMIN FOLLOWS  ***
      END
*NLSKL
      SUBROUTINE NLSKL(ISKULL, PAGE, WIDE, NLHDR)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRINTS A HEADING AND WARNING MESSAGES FOR
C     SERIOUS ERRORS DETECTED BY THE NONLINEAR LEAST SQUARES ROUTINES.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  APRIL 2, 1981
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      LOGICAL
     +   PAGE,WIDE
C
C  ARRAY ARGUMENTS
      INTEGER
     +   ISKULL(10)
C
C  SUBROUTINE ARGUMENTS
      EXTERNAL NLHDR
C
C  LOCAL SCALARS
      INTEGER
     +   ISUBHD
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C  EXTERNAL SUBROUTINES
CCCCC EXTERNAL IPRINT
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     EXTERNAL NLHDR
C        THE NAME OF THE ROUTINE WHICH PRODUCES THE HEADING.
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER ISKULL(10)
C        AN ERROR MESSAGE INDICATOR VARIABLE.
C     INTEGER ISUBHD
C        AN INTEGER VALUE SPECIFYING SUBHEADINGS TO BE PRINTED.
C     LOGICAL PAGE
C        THE VARIABLE USED TO INDICATE WHETHER OR NOT THE OUTPUT
C        IS TO BEGIN ON A NEW PAGE.
C     LOGICAL WIDE
C        THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD
C        BE FULL WIDTH (TRUE) OR NOT (FALSE).
C
CCCCC CALL IPRINT(IPRT)
C
      ISUBHD = 0
      CALL NLHDR(PAGE, WIDE, ISUBHD)
C
      IF (WIDE) THEN
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE (ICOUT,1010)
         CALL DPWRST('XXX','BUG ')
         WRITE (ICOUT,1011)
         CALL DPWRST('XXX','BUG ')
         WRITE (ICOUT,1012)
         CALL DPWRST('XXX','BUG ')
         WRITE (ICOUT,1013)
         CALL DPWRST('XXX','BUG ')
         WRITE (ICOUT,1014)
         CALL DPWRST('XXX','BUG ')
         WRITE (ICOUT,1020)
         CALL DPWRST('XXX','BUG ')
         WRITE (ICOUT,1021)
         CALL DPWRST('XXX','BUG ')
         WRITE (ICOUT,1022)
         CALL DPWRST('XXX','BUG ')
         WRITE (ICOUT,1023)
         CALL DPWRST('XXX','BUG ')
         WRITE (ICOUT,1024)
         CALL DPWRST('XXX','BUG ')
C        WRITE (ICOUT,1030)
C        WRITE (ICOUT,1040)
C        WRITE (ICOUT,1050)
CCCCC    WRITE (ICOUT,1000)
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
         WRITE(ICOUT,999)
         CALL DPWRST('XXX','BUG ')
      END IF
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT,1060)
      CALL DPWRST('XXX','BUG ')
C
C     VCV COMPUTATION NOT COMPLETED
C
      IF (ISKULL(7).NE.0) THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT,1120)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C     MAXIMUM NUMBER OF ITERATIONS REACHED BEFORE CONVERGENCE
C
      IF (ISKULL(6).NE.0) THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT,1100)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C     FALSE CONVERGENCE
C
      IF (ISKULL(5).NE.0) THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT,1090)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C     MEANINGLESS VCV MATRIX
C
      IF (ISKULL(4).NE.0) THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT,1080)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C     PROBLEM IS COMPUTATIONALLY SINGULAR
C
      IF (ISKULL(3).NE.0) THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT,1070)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
C     INITIAL RESIDUAL SUM OF SQUARES COMPUTATION OVERFLOWED
C
      IF (ISKULL(2).NE.0) THEN
        WRITE(ICOUT,999)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT,1110)
        CALL DPWRST('XXX','BUG ')
      ENDIF
C
      RETURN
C
C     FORMAT STATEMENTS
C
  999 FORMAT(1X)
c1000 FORMAT (///)
 1010 FORMAT (
     +   '  W      W     AA     RRRRRRR   N      N    IIII',
     +   '    N      N    GGG')
 1011 FORMAT (
     +   '  W      W    A  A    R     RR ',
     +   ' NN     N     II     NN     N   G    G')
 1012 FORMAT (
     +   '  W      W  ',
     +   '  A  A    R      R  N N    N     II     N N    N  G')
 1013 FORMAT (
     +   '  WW    WW   AA  AA   R     RR  N  N   N     II     N  N   ',
     +   'N  G')
 1014 FORMAT (
     +   '   W    W    AAAAAA   RRRRRRR   N  NN  N     II',
     +   '     N  NN  N  G  GGGGG')
 1020 FORMAT (
     +   '   W WW W    A    A   R R       N   N  N     II  ',
     +   '   N   N  N  G      G')
 1021 FORMAT (
     +   '   W WW W    A    A   R  R   ',
     +   '   N    N N     II     N    N N  G      G')
 1022 FORMAT (
     +   '    W  W ',
     +   '   AA    AA  R   R     N     NN     II     N     NN   G    ',
     +   'GG')
 1023 FORMAT (
     +   '    W  W    A      A  R    R    N      N    IIII ',
     +   '   N      N    GGGG G')
 1024 FORMAT (1X)
C1010 FORMAT (/30X, 48H  W      W     AA     RRRRRRR   N      N    IIII,
C    *   19H    N      N    GGG/30X, 31H  W      W    A  A    R     RR ,
C    *   38H NN     N     II     NN     N   G    G/30X, 12H  W      W  ,
C    *   51H  A  A    R      R  N N    N     II     N N    N  G/30X,
C    *   59H  WW    WW   AA  AA   R     RR  N  N   N     II     N  N   ,
C    *   4HN  G/30X, 47H   W    W    AAAAAA   RRRRRRR   N  NN  N     II,
C    *   23H     N  NN  N  G  GGGGG)
C1020 FORMAT (30X, 49H   W WW W    A    A   R R       N   N  N     II  ,
C    *   21H   N   N  N  G      G/30X, 29H   W WW W    A    A   R  R   ,
C    *   41H   N    N N     II     N    N N  G      G/30X, 9H    W  W ,
C    *   59H   AA    AA  R   R     N     NN     II     N     NN   G    ,
C    *   2HGG/30X, 49H    W  W    A      A  R    R    N      N    IIII ,
C    *   21H   N      N    GGGG G/)
C1030 FORMAT (1(34X, 3HXXX, 58X, 3HXXX/), 31X, 6('X'), 58X, 6('X')/31X,
C    *   7('X'), 56X, 7('X')/31X, 9('X'), 52X, 9('X')/36X, 5('X'), 17X,
C    *   '(', 14('-'), ')', 17X, 5('X')/38X, 5('X'), 14X, 2H((, 14X,
C    *   2H)), 14X, 5('X')/40X, 5('X'), 10X, 2H((, 18X, 2H)), 10X,
C    *   5('X')/41X, 5('X'), 8X, 2H((, 20X, 2H)), 8X, 5('X')/43X,
C    *   5('X'), 5X, 2H((, 22X, 2H)), 5X, 5('X')/44X, 5('X'), 3X, 2H((,
C    *   24X, 2H)), 3X, 5('X'))
C1040 FORMAT (46X, 7HXXXXX (, 26X, 7H) XXXXX/48X,
C    *   5HXXX((, 7X, 2HOO, 8X, 2HOO, 7X, 5H))XXX/49X, 3HXX(, 7X,
C    *   4HO  O, 6X, 4HO  O, 7X, 3H)XX/50X, 2HX(, 7X, 4HO  O, 6X,
C    *   4HO  O, 7X, 2H)X/51X, '(', 8X, 2HOO, 8X, 2HOO, 8X, ')'/2(51X,
C    *   '(', 28X, ')'/), 51X, '(', 11X, 6HOO  OO, 11X, ')'/51X, 2H((,
C    *   10X, 6HOO  OO, 10X, 2H))/52X, 2H((, 24X, 2H))/53X, '(', 24X,
C    *   ')'/54X, '(', 22X, ')')
C1050 FORMAT (55X, 4H(--(, 14X, 4H)--)/59X, '(', 12X, ')'/58X,
C    *   3HX((, 10X, 3H))X/56X, 5HXXXX(, 10X, 5H)XXXX/54X, 9HXXXXX (II,
C    *   15HIIIIIIII) XXXXX/53X, 5('X'), 2X, 12H(IIIIIIIIII), 2X, 5('X')
C    *   /51X, 5('X'), 4X, '(', 10X, ')', 4X, 5('X')/49X, 5('X'), 6X,
C    *   2H((, 8X, 2H)), 6X, 5('X')/48X, 5('X'), 8X, 10H(--------), 8X,
C    *   5('X')/46X, 5('X'), 30X, 5('X')/44X, 5('X'), 34X, 5('X')/43X,
C    *   5('X'), 36X, 5('X')/41X, 5('X'), 40X, 5('X')/40X, 4HXXXX, 44X,
C    *   4HXXXX/38X, 5('X'), 46X, 5('X')/36X, 5('X'), 50X, 5('X')/31X,
C    *   9('X'), 52X, 9('X')/31X, 7('X'), 56X, 7('X')/31X, 6('X'), 58X,
C    *   6('X')/1(34X, 3HXXX, 58X, 3HXXX))
 1060 FORMAT (' **  ERROR SUMMARY  **')
 1070 FORMAT (' THIS MODEL AND DATA ARE COMPUTATIONALLY SINGULAR.',
     +   ' CHECK YOUR INPUT FOR ERRORS.')
 1080 FORMAT (
     +   ' AT LEAST ONE OF THE STANDARDIZED RESIDUALS COULD',
     +   ' NOT BE COMPUTED BECAUSE THE STANDARD DEVIATION OF THE ')
 1081 FORMAT (
     +   'RESIDUAL WAS ZERO.  THE VALIDITY OF THE COVARIANCE MATRIX',
     +   ' IS QUESTIONABLE.')
 1090 FORMAT (
     +   ' THE ITERATIONS DO NOT APPEAR TO BE CONVERGING',
     +   ' TO A MINIMUM (FALSE CONVERGENCE), INDICATING THAT THE')
 1091 FORMAT (
     +   ' CONVERGENCE CRITERIA STOPSS AND STOPP MAY BE TOO ',
     +   'SMALL FOR THE ACCURACY OF THE MODEL AND DERIVATIVES,')
 1092 FORMAT (
     +   'THAT THERE IS AN ERROR IN THE DERIVATIVE MATRIX, OR',
     +   ' THAT THE MODEL IS DISCONTINUOUS NEAR THE CURRENT COEF',
     +   'FICIENT ESTIMATES.')
 1100 FORMAT (' PROGRAM DID NOT CONVERGE IN THE NUMBER OF ITERATIONS',
     +   ' OR NUMBER OF MODEL SUBROUTINE CALLS ALLOWED.')
 1110 FORMAT (' THE RESIDUAL SUM OF SQUARES COULD NOT BE COMPUTED',
     +   ' USING THE STARTING MODEL COEFFICIENT VALUES.')
 1120 FORMAT (' THE VARIANCE-COVARIANCE MATRIX COULD NOT BE',
     +   ' COMPUTED AT THE SOLUTION.')
      END
*SLUPDT
      SUBROUTINE SLUPDT(A, COSMIN, P, SIZE, STEP, U, W, WCHMTD, WSCALE,
     +                  Y)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C
C  ***  UPDATE SYMMETRIC  A  SO THAT  A * STEP = Y  ***
C  ***  (LOWER TRIANGLE OF  A  STORED ROWWISE       ***
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   COSMIN,SIZE,WSCALE
      INTEGER
     +   P
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   A(1),STEP(P),U(P),W(P),WCHMTD(P),Y(P)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   DENMIN,HALF,ONE,SDOTWM,T,UI,WI,ZERO
      INTEGER
     +   I,J,K
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DOTPRD,V2NORM
      EXTERNAL DOTPRD,V2NORM
C
C  EXTERNAL SUBROUTINES
      EXTERNAL SLVMUL
C
C  INTRINSIC FUNCTIONS
      INTRINSIC ABS,MIN
C
C  ***  PARAMETER DECLARATIONS  ***
C
C     INTEGER P
C     DOUBLE PRECISION A(1), COSMIN, SIZE, STEP(P), U(P), W(P),
C    1                 WCHMTD(P), WSCALE, Y(P)
C     DIMENSION A(P*(P+1)/2)
C
C  ***  LOCAL VARIABLES  ***
C
C     INTEGER I, J, K
C     DOUBLE PRECISION DENMIN, SDOTWM, T, UI, WI
C
C     ***  CONSTANTS  ***
C     DOUBLE PRECISION HALF, ONE, ZERO
C
C/
C  ***  EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
C     EXTERNAL DOTPRD, SLVMUL, V2NORM
C     DOUBLE PRECISION DOTPRD, V2NORM
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA HALF/0.5D0/, ONE/1.0D0/, ZERO/0.0D0/
C
C-----------------------------------------------------------------------
C
      SDOTWM = DOTPRD(P, STEP, WCHMTD)
      DENMIN = COSMIN * V2NORM(P,STEP) * V2NORM(P,WCHMTD)
      WSCALE = ONE
      IF (DENMIN .NE. ZERO) WSCALE = MIN(ONE, ABS(SDOTWM/DENMIN))
      T = ZERO
      IF (SDOTWM .NE. ZERO) T = WSCALE / SDOTWM
      DO 10 I = 1, P
 10      W(I) = T * WCHMTD(I)
      CALL SLVMUL(P, U, A, STEP)
      T = HALF * (SIZE * DOTPRD(P, STEP, U)  -  DOTPRD(P, STEP, Y))
      DO 20 I = 1, P
 20      U(I) = T*W(I) + Y(I) - SIZE*U(I)
C
C  ***  SET  A = A + U*(W**T) + W*(U**T)  ***
C
      K = 1
      DO 40 I = 1, P
         UI = U(I)
         WI = W(I)
         DO 30 J = 1, I
              A(K) = SIZE*A(K) + UI*W(J) + WI*U(J)
              K = K + 1
 30           CONTINUE
 40      CONTINUE
C
      RETURN
C  ***  LAST CARD OF SLUPDT FOLLOWS  ***
      END
*VERSP
      SUBROUTINE VERSP (WIDE)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PRINTS THE VERSION NUMBER.
C
C     FOR DATAPLOT, MAKE THIS A NULL ROUTINE
C
C     WRITTEN BY - JANET R. DONALDSON
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  OCTOBER 4, 1983
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      LOGICAL
     +   WIDE
C
C  LOCAL SCALARS
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IPRT
C        THE UNIT NUMBER OF THE DEVICE USED FOR PRINTED OUTPUT.
C     LOGICAL WIDE
C        THE MAXIMUM NUMBER OF COLUMNS THE PRINTED OUTPUT CAN USE.
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC CALL IPRINT(IPRT)
C
CCCCC IF (WIDE) THEN
CCCCC    WRITE(IPRT, 1000)
CCCCC ELSE
CCCCC    WRITE(IPRT, 1010)
CCCCC END IF
C
      RETURN
C
C     FORMAT STATEMENTS
C
C1000 FORMAT (105X, 'STARPAC 2.08D (03/15/90)')
C1010 FORMAT (54X, 'STARPAC 2.08D (03/15/90)')
      END
*AMFHDR
      SUBROUTINE AMFHDR(PAGE, WIDE, ISUBHD)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE PRINTS THE PAGE HEADINGS FOR THE NONLINEAR
C     LEAST SQUARES ESTIMATION ROUTINES FOR ARIMA MODELS THAT USE
C     NUMERICAL APPROXIMATIONS TO THE DERIVATIVES.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  AUGUST 1, 1985
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   ISUBHD
      LOGICAL
     +   PAGE,WIDE
C
C  LOCAL SCALARS
CCCCC INTEGER
CCCCC+   IPRT
C
C  EXTERNAL SUBROUTINES
      EXTERNAL VERSP
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     INTEGER IPRT
C        THE UNIT NUMBER FOR PRINTED OUTPUT.
C     INTEGER ISUBHD
C        AN INDICATOR VALUE SPECIFYING SUBHEADINGS TO BE PRINTED.
C     LOGICAL PAGE
C        THE VARIABLE USED TO INDICATE WHETHER A GIVEN SECTION OF
C        THE OUTPUT IS TO BEGIN ON A NEW PAGE (TRUE) OR NOT (FALSE).
C     LOGICAL WIDE
C        THE VARIABLE USED TO INDICATE WHETHER THE HEADING SHOULD
C        BE FULL WIDTH (TRUE) OR NOT (FALSE).
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
CCCCC CALL IPRINT(IPRT)
      IF (PAGE) THEN
        WRITE (ICOUT, 1020)
        CALL DPWRST('XXX','BUG ')
      ENDIF
      CALL VERSP(WIDE)
      IF (PAGE) THEN
        WRITE (ICOUT,1000)
        CALL DPWRST('XXX','BUG ')
      ENDIF
      IF (.NOT.PAGE) THEN
        WRITE (ICOUT,1010)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT,1011)
        CALL DPWRST('XXX','BUG ')
        WRITE (ICOUT,1012)
        CALL DPWRST('XXX','BUG ')
      ENDIF
      PAGE = .TRUE.
C
      IF (ISUBHD.EQ.0) RETURN
C
      GO TO (10), ISUBHD
C
   10 CONTINUE
      WRITE (ICOUT, 1020)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1020)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1030)
      CALL DPWRST('XXX','BUG ')
C
      RETURN
C
C     FORMAT STATEMENTS FOR PAGE HEADINGS
C
 1000 FORMAT ('+ARIMA FORECASTING, CONTINUED')
 1010 FORMAT (
     +  '+', 23('*'))
 1011 FORMAT (
     +  ' *  ARIMA FORECASTING  *')
 1012 FORMAT (
     +  1X, 23('*'))
 1020 FORMAT ('1')
 1030 FORMAT (' MODEL SUMMARY')
 1031 FORMAT (' -------------')
      END
*EIAGE
      SUBROUTINE EIAGE (NMSUB, NMVAR, YM, N, M, IYM, YMMN, NVMX,
     +   HEAD, MSGTYP, NV, ERROR, NMMIN)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE CHECKS TO ENSURE THAT NO VALUES, OR ONLY A MAXIMUM
C     OF NVMX, ARE NOT GREATER THAN A SPECIFIED LOWER BOUND YMMN,
C     WITH NAME NMMIN.   THE CHECKING OPTION IS SPECIFIED
C     WITH MSGTYP.  IF AN ERROR IS FOUND, THE ERROR IS PRINTED AND
C     AN ERROR FLAG AND THE NUMBER OF VIOLATINS ARE RETURNED.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  JUNE 10, 1982
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   IYM,M,MSGTYP,N,NV,NVMX,YMMN
      LOGICAL
     +   ERROR,HEAD
C
C  ARRAY ARGUMENTS
      INTEGER
     +   YM(*)
      CHARACTER
     +   NMMIN(8)*1,NMSUB(6)*1,NMVAR(8)*1
C
C  LOCAL SCALARS
      INTEGER
     +   I,J
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EIAGEP
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERROR
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     LOGICAL HEAD
C        A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED
C        (TRUE) OR NOT (FALSE).  IF A HEADING IS PRINTED, THE VALUE
C        OF HEAD WILL BE CHANGED TO FALSE.
C     INTEGER I
C        AN INDEX VARIABLE.
C     INTEGER IYM
C        THE FIRST DIMENSION OF THE ARRAY YM.
C     INTEGER J
C        AN INDEXING VARIABLE.
C     INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN YM.
C     INTEGER MSGTYP
C        THE INDICATOR ARGUMENT FOR THE TYPE OF MESSAGE.
C        IF (MSGTYP.GE.3) THE MESSAGE PRINTED WILL USE NMMIN
C        OTHERWISE IT WILL USE YMMN.
C        IF (MSGTYP = 1 OR 3) NO VIOLATIONS ARE ALLOWED.
C        IF (MSGTYP = 2 OR 4) THE NUMBER OF VIOLATIONS MUST
C                             BE LESS THAN   NVMX   .
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C     CHARACTER*1 NMMIN(8)
C        THE NAME OF THE ARGUMENT SPECIFYING THE MINIMUM.
C     CHARACTER*1 NMSUB(6)
C        THE CHARACTERS OF THE CALLING ROUTINES NAME.
C     CHARACTER*1 NMVAR(8)
C        THE CHARACTERS OF THE PARAMETERS NAME.
C     INTEGER NV
C        THE NUMBER OF VIOLATIONS FOUND.
C     INTEGER NVMX
C        THE LARGEST NUMBER OF VIOLATIONS ALLOWED.
C     INTEGER YM(IYM,M)
C        THE ARRAY BEING TESTED.
C     INTEGER YMMN
C        THE MINIMUM ACCEPTABLE VALUE.
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      ERROR = .FALSE.
C
      IF ((N.LE.0) .OR. (M.LE.0)) RETURN
C
C     CHECK FOR VIOLATIONS
C
      NV = 0
      DO 5 I = 1, N
         DO 1 J = 1, M
            IF (YM(I+(J-1)*IYM) .LT. YMMN) NV = NV + 1
    1    CONTINUE
    5 CONTINUE
C
      IF (NV .LE. NVMX) RETURN
C
C     VIOLATIONS FOUND
C
      ERROR = .TRUE.
C
      CALL EIAGEP (NMSUB, NMVAR, YMMN, NVMX, HEAD, MSGTYP, NV,
     +   NMMIN)
C
      RETURN
C
      END
*HIPASS
      SUBROUTINE HIPASS (Y, N, FC, K, HHP, YF, NYF, IERR2)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS SUBROUTINE CARRIES OUT HI-PASS FILTERING OF THE
C     SERIES.  THE FILTER IS THE K-TERM
C     LEAST SQUARES APPROXIMATION TO THE CUTOFF FILTER
C     WITH CUTOF FREQUENCY FC.  ITS TRANSFER FUNCTION
C     HAS A TRANSITION BAND OF WIDTH DELTA SURROUNDING FC,
C     WHERE DELTA = 4*PI/K.
C
C     WRITTEN BY  -  JANET R. DONALDSON
C                    STATISTICAL ENGINEERING DIVISION
C                    NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  NOVEMBER 26, 1980
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   FC
      INTEGER
     +   K,N,NYF
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   HHP(*),Y(*),YF(*)
C
C  SCALARS IN COMMON
      INTEGER
     +   IERR
C
C  LOCAL SCALARS
      LOGICAL
     +   ERR01,ERR02,ERR03,ERR04,ERR05,HEAD
C
C  LOCAL ARRAYS
      CHARACTER
     +   LFC(8)*1,LK(8)*1,LN(8)*1,NMSUB(6)*1
C
C  EXTERNAL SUBROUTINES
      EXTERNAL EISGE,EISII,ERIODD,ERSII,ERSLFS,FLTSL,HPFLT,LPFLT
C
C  COMMON BLOCKS
      COMMON /ERRCHK/IERR,IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     LOGICAL ERR01, ERR02, ERR03, ERR04, ERR05
C        VALUE(S) INDICATING WHETHER AN ERROR WAS DETECTED (TRUE) OR NOT
C        (FALSE).
C     DOUBLE PRECISION FC
C        THE USER SUPPLIED CUTOFF FREQUENCY.
C     LOGICAL HEAD
C        A FLAG INDICATING WHETHER THE HEADING SHOULD BE PRINTED
C        (TRUE) OR NOT (FALSE).  IF A HEADING IS PRINTED, THE VALUE
C        OF HEAD WILL BE CHANGED TO FALSE.
C     DOUBLE PRECISION HHP(K)
C        THE ARRAY IN WHICH THE -IDEAL- HIGH PASS FILTER COEFFICIENTS
C        WILL BE RETURNED.
C     INTEGER IERR
C        THE INTEGER VALUE RETURNED BY THIS ROUTINE DESIGNATING
C        WHETHER ANY ERRORS WERE DETECTED IN THE PARAMETER LIST.
C        IF IERR .EQ. 0, NO ERRORS WERE DETECTED.
C        IF IERR .EQ. 1, ERRORS HAVE BEEN DETECTED.
C     INTEGER IPRT
C        THE UNIT NUMBER USED FOR OUTPUT.
C     INTEGER K
C        THE NUMBER OF FILTER TERMS TO BE COMPUTED.
C     CHARACTER*1 LFC(8), LK(8), LN(8)
C        THE ARRAYS CONTAINING THE NAMES OF THE VARIABLES FC, K AND N.
C     INTEGER N
C        THE NUMBER OF OBSERVATIONS IN THE SERIES Y.
C     CHARACTER*1 NMSUB(6)
C        THE ARRAY CONTAINING THE NAME OF THIS SUBROUTINE.
C     INTEGER NYF
C        THE NUMBER OF OBSERVATIONS IN THE FILTERED SERIES YF.
C     DOUBLE PRECISION Y(N)
C        THE VECTOR CONTAINING THE OBSERVED TIME SERIES.
C     DOUBLE PRECISION YF(N)
C        THE VECTOR IN WHICH THE FILTERED SERIES IS RETURNED.
C
C     SET UP NAME ARRAYS
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      DATA
     +  NMSUB(1),  NMSUB(2),  NMSUB(3),  NMSUB(4),  NMSUB(5),  NMSUB(6)
     + /     'H',       'I',       'P',       'A',       'S',       'S'/
      DATA
     +  LFC(1), LFC(2), LFC(3), LFC(4), LFC(5), LFC(6), LFC(7), LFC(8)
     + /  'F',   'C',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
      DATA
     +  LK(1), LK(2), LK(3), LK(4), LK(5), LK(6), LK(7), LK(8)
     + /  'K',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
      DATA
     +  LN(1), LN(2), LN(3), LN(4), LN(5), LN(6), LN(7), LN(8)
     + /  'N',   ' ',   ' ',   ' ',   ' ',   ' ',   ' ',   ' '/
C
C     SET UP FOR ERROR CHECKING
C
      IERR = 0
      HEAD = .TRUE.
C
C     CALL ERROR CHECKING ROUTINES
C
      CALL EISGE(NMSUB, LN, N, 3, 1, HEAD, ERR01, LN)
C
      CALL ERSII(NMSUB, LFC, FC, 0.0D0,
     +           0.5D0, 2, HEAD, ERR02, LFC, LFC)
C
      CALL EISII(NMSUB, LK, K, 1, N, 2, HEAD, ERR03, LK, LK)
C
      CALL ERIODD(NMSUB, LK, K, 1, HEAD, ERR04)
      IF (ERR01 .OR. ERR02 .OR. ERR03 .OR. ERR04) GO TO 10
C
      CALL ERSLFS(NMSUB, FC, K, HEAD, ERR05)
C
      IF (ERR05) GO TO 10
      GO TO 20
C
   10 CONTINUE
      IERR = 1
C
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1000)
      CALL DPWRST('XXX','BUG ')
      WRITE(ICOUT,999)
      CALL DPWRST('XXX','BUG ')
      WRITE (ICOUT, 1001)
      CALL DPWRST('XXX','BUG ')
      IERR2=IERR
      RETURN
C
   20 CONTINUE
C
      CALL LPFLT (FC, K, HHP)
C
      CALL HPFLT (HHP, K, HHP)
C
      CALL FLTSL (Y, N, K, HHP, YF, NYF)
C
      IERR2=IERR
      RETURN
C
C     FORMAT STATEMENTS
C
  999 FORMAT(1X)
 1000 FORMAT (
     +   ' THE CORRECT FORM OF THE CALL STATEMENT IS')
 1001 FORMAT (
     +   '       CALL HIPASS (Y, N, FC, K, HHP, YF, NYF)')
      END
*LTSQAR
      SUBROUTINE LTSQAR(N, A, L)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C
C  ***  SET A TO LOWER TRIANGLE OF (L**T) * L  ***
C
C  ***  L = N X N LOWER TRIANG. MATRIX STORED ROWWISE.  ***
C  ***  A IS ALSO STORED ROWWISE AND MAY SHARE STORAGE WITH L.  ***
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   N
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   A(*),L(*)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   LII,LJ
      INTEGER
     +   I,I1,II,IIM1,J,K,M
C
C     INTEGER N
C     DOUBLE PRECISION A(1), L(1)
C     DIMENSION A(N*(N+1)/2), L(N*(N+1)/2)
C
C     INTEGER I, II, IIM1, I1, J, K, M
C     DOUBLE PRECISION LII, LJ
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      II = 0
      DO 50 I = 1, N
         I1 = II + 1
         II = II + I
         M = 1
         IF (I .EQ. 1) GO TO 30
         IIM1 = II - 1
         DO 20 J = I1, IIM1
              LJ = L(J)
              DO 10 K = I1, J
                   A(M) = A(M) + LJ*L(K)
                   M = M + 1
 10                CONTINUE
 20           CONTINUE
 30      LII = L(II)
         DO 40 J = I1, II
 40           A(J) = LII * L(J)
 50      CONTINUE
C
      RETURN
C  ***  LAST CARD OF LTSQAR FOLLOWS  ***
      END
*NLSPK
      SUBROUTINE NLSPK(PAR, MASK, NPAR, PPAR, NPPAR)
C
C     LATEST REVISION  -  03/15/90  (JRD)
C
C     THIS ROUTINE PACKS A VECTOR PAR INTO A VECTOR PPAR, BY
C     OMITTING FROM THE PACKED VERSION THOSE ELEMENTS OF THE
C     UNPACKED VERSION CORRESPONDING TO ELEMENTS OF MASK WHICH
C     HAVE THE VALUE 1.  OTHER ELEMENTS OF MASK SHOULD BE ZERO.
C
C     WRITTEN BY - JOHN E. KOONTZ
C                  STATISTICAL ENGINEERING DIVISION
C                  NATIONAL BUREAU OF STANDARDS, BOULDER, COLORADO
C
C     CREATION DATE  -  OCTOBER 3, 1983
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   NPAR,NPPAR
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   PAR(NPAR),PPAR(NPPAR)
      INTEGER
     +   MASK(NPAR)
C
C  LOCAL SCALARS
      INTEGER
     +   I,IPPAR
C
C     VARIABLE DEFINITIONS (ALPHABETICALLY)
C
C     DOUBLE PRECISION PAR(NPAR)
C        INPUT PARAMETER.  THE UNPACKED VECTOR.
C     INTEGER I
C        LOOP PARAMETER.
C     INTEGER IPPAR
C        CURRENT ELEMENT OF PPAR.  RANGES FROM 0 (ON INITIALIZATION)
C        TO NPPAR.
C     INTEGER MASK(NPAR)
C        INPUT PARAMETER.  THE MASK GOVERNING THE PACKING OF PAR.
C        ELEMENTS OF MASK ARE 1 IF THE CORRESPONDING ELEMENT OF PAR
C        IS TO BE ELIMINATED IN PPAR, 0 IF IT IS TO BE INCLUDED.
C     INTEGER NPAR
C        INPUT PARAMETER.  THE LENGTH OF PAR.
C     INTEGER NPPAR
C        INPUT PARAMETER.  THE LENGTH OF PPAR.
C     DOUBLE PRECISION PPAR(NPPAR)
C        OUTPUT PARAMETER.  THE PACKED VERSION OF PAR.  SEE INITIAL
C        DESCRIPTION.
C
C     COMMENCE BODY OF ROUTINE
C
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
      IPPAR = 0
      DO 10 I=1,NPAR
         IF (MASK(I).NE.0) GO TO 10
         IPPAR = IPPAR + 1
         PPAR(IPPAR) = PAR(I)
   10 CONTINUE
      RETURN
      END
*SLVMUL
      SUBROUTINE SLVMUL(P, Y, S, X)
C
C  ***  SET  Y = S * X,  S = P X P SYMMETRIC MATRIX.  ***
C  ***  LOWER TRIANGLE OF  S  STORED ROWWISE.         ***
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      INTEGER
     +   P
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   S(1),X(P),Y(P)
C
C  LOCAL SCALARS
      DOUBLE PRECISION
     +   XI
      INTEGER
     +   I,IM1,J,K
C
C  EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DOTPRD
      EXTERNAL DOTPRD
C
C  ***  PARAMETER DECLARATIONS  ***
C
C     INTEGER P
C     DOUBLE PRECISION S(1), X(P), Y(P)
C     DIMENSION S(P*(P+1)/2)
C
C  ***  LOCAL VARIABLES  ***
C
C     INTEGER I, IM1, J, K
C     DOUBLE PRECISION XI
C
C  ***  EXTERNAL FUNCTION  ***
C
C     EXTERNAL DOTPRD
C     DOUBLE PRECISION DOTPRD
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C-----------------------------------------------------------------------
C
      J = 1
      DO 10 I = 1, P
         Y(I) = DOTPRD(I, S(J), X)
         J = J + I
 10      CONTINUE
C
      IF (P .LE. 1) GO TO 999
      J = 1
      DO 40 I = 2, P
         XI = X(I)
         IM1 = I - 1
         J = J + 1
         DO 30 K = 1, IM1
              Y(K) = Y(K) + S(J)*XI
              J = J + 1
 30           CONTINUE
 40      CONTINUE
C
 999  RETURN
C  ***  LAST CARD OF SLVMUL FOLLOWS  ***
      END
*VSCOPY
      SUBROUTINE VSCOPY(P, Y, S)
C
C  ***  SET P-VECTOR Y TO SCALAR S  ***
C
C
C  VARIABLE DECLARATIONS
C
C  SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   S
      INTEGER
     +   P
C
C  ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   Y(*)
C
C  LOCAL SCALARS
      INTEGER
     +   I
C
      INCLUDE 'DPCOMC.INC'
      CHARACTER*4 IFEEDB
      CHARACTER*4 IPRINT
      CHARACTER*240 ICOUT
C
      COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW
      COMMON /PRINT/IFEEDB,IPRINT
      COMMON /TEXTOU/ICOUT,NCOUT,ILOUT
C
C
      DO 10 I = 1, P
 10      Y(I) = S
      RETURN
      END
